content: {-# LANGUAGE GADTs #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE RankNTypes #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE NoImplicitPrelude #-}
  
  module Data.Morpheus.CodeGen.Internal.AST
    ( CodeGenConstructor (..),
      CodeGenField (..),
      CodeGenType (..),
      CodeGenTypeName (..),
      DerivingClass (..),
      FIELD_TYPE_WRAPPER (..),
      TypeValue (..),
      fromTypeName,
      getFullName,
      ModuleDefinition (..),
      TypeClassInstance (..),
      AssociatedType (..),
      MethodArgument (..),
      printTHName,
      PrintableValue (..),
    )
  where
  
  import qualified Data.HashMap.Lazy as HM
  import Data.Morpheus.CodeGen.Internal.Name (camelCaseTypeName)
  import Data.Morpheus.CodeGen.Printer
  import Data.Morpheus.Types.Internal.AST
    ( DirectiveLocation,
      FieldName,
      TypeName,
      TypeRef,
      TypeWrapper,
      unpackName,
    )
  import qualified Data.Set as S
  import qualified Data.Text as T
  import Language.Haskell.TH.Syntax (Lift)
  import qualified Language.Haskell.TH.Syntax as TH
  import Prettyprinter
    ( Doc,
      Pretty (..),
      comma,
      enclose,
      hsep,
      indent,
      line,
      list,
      nest,
      pretty,
      punctuate,
      space,
      tupled,
      vsep,
      (<+>),
    )
  import Relude hiding (Show, optional, print, show)
  import Prelude (Show (..))
  
  data DerivingClass
    = SHOW
    | GENERIC
    | CLASS_EQ
    deriving (Show)
  
  instance Pretty DerivingClass where
    pretty SHOW = "Show"
    pretty GENERIC = "Generic"
    pretty CLASS_EQ = "Eq"
  
  data TypeValue
    = TypeValueObject TypeName [(FieldName, TypeValue)]
    | TypeValueNumber Double
    | TypeValueString Text
    | TypeValueBool Bool
    | TypeValueList [TypeValue]
    | TypedValueMaybe (Maybe TypeValue)
    | PrintableTypeValue PrintableValue
    deriving (Show)
  
  renderField :: (FieldName, TypeValue) -> Doc n
  renderField (fName, fValue) = pretty (unpackName fName :: Text) <+> "=" <+> pretty fValue
  
  instance Pretty TypeValue where
    pretty (TypeValueObject name xs) =
      pretty (unpackName name :: Text)
        <+> "{"
        <> vsep (punctuate "," (map renderField xs))
        <> "}"
    pretty (TypeValueNumber x) = pretty x
    pretty (TypeValueString x) = pretty (show x :: String)
    pretty (TypeValueBool x) = pretty x
    pretty (TypedValueMaybe (Just x)) = "Just" <+> pretty x
    pretty (TypedValueMaybe Nothing) = "Nothing"
    pretty (TypeValueList xs) = prettyList xs
    pretty (PrintableTypeValue x) = pretty x
  
  data CodeGenType = CodeGenType
    { cgTypeName :: CodeGenTypeName,
      cgConstructors :: [CodeGenConstructor],
      cgDerivations :: [DerivingClass]
    }
    deriving (Show)
  
  isNewType :: CodeGenType -> Bool
  isNewType CodeGenType {cgConstructors = [CodeGenConstructor {constructorFields = [_]}]} = True
  isNewType _ = False
  
  instance Pretty CodeGenType where
    pretty t@CodeGenType {..} =
      (if isNewType t then "newtype" else "data")
        <+> ignore (print cgTypeName)
        <> renderConstructors cgConstructors
        <> line
        <> indent 2 (renderDeriving cgDerivations)
        <> line
      where
        renderConstructors [cons] = (" =" <+>) $ print' cons
        renderConstructors conses = nest 2 . (line <>) . vsep . prefixVariants $ map print' conses
        prefixVariants (x : xs) = "=" <+> x : map ("|" <+>) xs
        prefixVariants [] = []
  
  renderDeriving :: [DerivingClass] -> Doc n
  renderDeriving = ("deriving" <+>) . tupled . map pretty
  
  data CodeGenConstructor = CodeGenConstructor
    { constructorName :: CodeGenTypeName,
      constructorFields :: [CodeGenField]
    }
    deriving (Show)
  
  instance Printer CodeGenConstructor where
    print CodeGenConstructor {constructorFields = [CodeGenField {fieldName = "_", ..}], ..} =
      pack (print' constructorName <+> unpack (foldr renderWrapper (print fieldType) wrappers))
    print CodeGenConstructor {constructorFields = [], ..} =
      print constructorName
    print CodeGenConstructor {..} = do
      let fields = map (unpack . print) constructorFields
      pack (print' constructorName <> renderSet fields)
      where
        renderSet = nest 2 . enclose "\n{ " "\n}" . nest 2 . vsep . punctuate comma
  
  data CodeGenField = CodeGenField
    { fieldName :: FieldName,
      fieldType :: TypeName,
      wrappers :: [FIELD_TYPE_WRAPPER],
      fieldIsNullable :: Bool
    }
    deriving (Show)
  
  instance Printer CodeGenField where
    print CodeGenField {..} = infix' (print fieldName) "::" (foldr renderWrapper (print fieldType) wrappers)
  
  data FIELD_TYPE_WRAPPER
    = MONAD
    | SUBSCRIPTION TH.Name
    | PARAMETRIZED
    | ARG TypeName
    | TAGGED_ARG TH.Name FieldName TypeRef
    | GQL_WRAPPER TypeWrapper
    deriving (Show)
  
  renderWrapper :: FIELD_TYPE_WRAPPER -> HSDoc n -> HSDoc n
  renderWrapper PARAMETRIZED = (.<> "m")
  renderWrapper MONAD = ("m" .<>)
  renderWrapper SUBSCRIPTION {} = id
  renderWrapper (GQL_WRAPPER typeWrappers) = wrapped typeWrappers
  renderWrapper (ARG name) = infix' (print name) "->"
  renderWrapper (TAGGED_ARG _ name typeRef) = infix' (apply "Arg" [print (show name :: String), print typeRef]) "->"
  
  data CodeGenTypeName = CodeGenTypeName
    { namespace :: [FieldName],
      typeParameters :: [Text],
      typename :: TypeName
    }
    deriving (Show)
  
  getFullName :: CodeGenTypeName -> TypeName
  getFullName CodeGenTypeName {..} = camelCaseTypeName namespace typename
  
  fromTypeName :: TypeName -> CodeGenTypeName
  fromTypeName = CodeGenTypeName [] []
  
  instance Printer CodeGenTypeName where
    print cgName =
      HSDoc (not $ null (typeParameters cgName))
        $ parametrizedType
          (unpackName (getFullName cgName))
          (typeParameters cgName)
  
  parametrizedType :: Text -> [Text] -> Doc ann
  parametrizedType tName typeParameters = hsep $ map pretty $ tName : typeParameters
  
  data ModuleDefinition dec = ModuleDefinition
    { moduleName :: Text,
      imports :: [(Text, [Text])],
      extensions :: [Text],
      types :: [dec]
    }
  
  instance (Pretty dec) => Pretty (ModuleDefinition dec) where
    pretty ModuleDefinition {..} =
      vsep
        (map renderExtension (sort extensions))
        <> line
        <> line
        <> "module"
        <+> pretty moduleName
        <+> "where"
        <> line
        <> line
        <> vsep (map renderImport $ organizeImports imports)
        <> line
        <> line
        <> vsep (filter notEmpty $ map pretty types)
  
  notEmpty :: Doc a -> Bool
  notEmpty x = not $ null (show x :: String)
  
  renderExtension :: Text -> Doc ann
  renderExtension txt
    | T.isPrefixOf "{-#" txt = pretty txt
    | otherwise = "{-#" <+> "LANGUAGE" <+> pretty txt <+> "#-}"
  
  organizeImports :: [(Text, [Text])] -> [(Text, [Text])]
  organizeImports xs = sortWith fst $ HM.toList $ fmap (sort . toList) (groupImports xs)
  
  groupImports :: [(Text, [Text])] -> HashMap Text (Set Text)
  groupImports = foldr insertImport mempty
  
  insertImport :: (Text, [Text]) -> HashMap Text (Set Text) -> HashMap Text (Set Text)
  insertImport (moduleName, names) = HM.alter f moduleName
    where
      f x = Just (S.fromList names <> fromMaybe mempty x)
  
  renderImport :: (Text, [Text]) -> Doc ann
  renderImport (src, ls) = "import" <+> pretty src <> renderImportList ls
  
  renderImportList :: [Text] -> Doc ann
  renderImportList ["*"] = ""
  renderImportList xs = space <> tupled (map pretty xs)
  
  data TypeClassInstance body = TypeClassInstance
    { typeClassName :: TH.Name,
      typeClassContext :: [(TH.Name, TH.Name)],
      typeClassTarget :: CodeGenTypeName,
      assoc :: [(TH.Name, AssociatedType)],
      typeClassMethods :: [(TH.Name, MethodArgument, body)]
    }
    deriving (Show)
  
  instance (Pretty a) => Pretty (TypeClassInstance a) where
    pretty TypeClassInstance {..} =
      "instance"
        <> optional renderTypeableConstraints (typeParameters typeClassTarget)
        <+> printTHName typeClassName
        <+> typeHead
        <+> "where"
        <> line
        <> indent 2 (vsep (map renderAssoc assoc <> map renderMethodD typeClassMethods))
        <> line
      where
        typeHead = unpack (print typeClassTarget)
        renderAssoc (name, a) = "type" <+> printTHName name <+> typeHead <+> "=" <+> pretty a
        renderMethodD (name, args, method) = printTHName name <+> pretty args <> "=" <> pretty method
  
  renderTypeableConstraints :: [Text] -> Doc n
  renderTypeableConstraints xs = tupled (map (("Typeable" <+>) . pretty) xs) <+> "=>"
  
  data AssociatedType
    = AssociatedTypeName TH.Name
    | AssociatedLocations [DirectiveLocation]
    deriving (Show)
  
  printTHName :: TH.Name -> Doc ann
  printTHName = ignore . print
  
  printPromotedLocation :: DirectiveLocation -> Doc ann
  printPromotedLocation = ("'" <>) . ignore . print
  
  instance Pretty AssociatedType where
    pretty (AssociatedTypeName x) = printTHName x
    pretty (AssociatedLocations x) = list $ map printPromotedLocation x
  
  data MethodArgument
    = NoArgument
    | ProxyArgument
    | DestructArgument TH.Name [TH.Name]
    deriving (Show)
  
  instance Pretty MethodArgument where
    pretty NoArgument = ""
    pretty ProxyArgument = "_ "
    pretty (DestructArgument x xs) = unpack (print x .<> pack (hsep $ map printTHName xs)) <> " "
  
  data PrintableValue where
    PrintableValue :: forall a. (Show a, Lift a) => a -> PrintableValue
  
  instance Show PrintableValue where
    show (PrintableValue a) = show a
  
  instance Pretty PrintableValue where
    pretty (PrintableValue x) = pretty (show x)
  