{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.CodeGen.Internal.AST ( CodeGenConstructor (..), CodeGenField (..), CodeGenType (..), CodeGenTypeName (..), DerivingClass (..), FIELD_TYPE_WRAPPER (..), TypeValue (..), fromTypeName, getFullName, ) where import Data.Morpheus.CodeGen.Internal.Name (camelCaseTypeName) import Data.Morpheus.CodeGen.Printer import Data.Morpheus.Types.Internal.AST ( FieldName, TypeName, TypeRef, TypeWrapper, unpackName, ) import qualified Language.Haskell.TH.Syntax as TH import Prettyprinter ( Doc, Pretty (..), comma, enclose, hsep, indent, line, nest, pretty, punctuate, tupled, vsep, (<+>), ) import Relude hiding (print) data DerivingClass = SHOW | GENERIC | CLASS_EQ deriving (Int -> DerivingClass -> ShowS [DerivingClass] -> ShowS DerivingClass -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [DerivingClass] -> ShowS $cshowList :: [DerivingClass] -> ShowS show :: DerivingClass -> String $cshow :: DerivingClass -> String showsPrec :: Int -> DerivingClass -> ShowS $cshowsPrec :: Int -> DerivingClass -> ShowS Show) instance Pretty DerivingClass where pretty :: forall ann. DerivingClass -> Doc ann pretty DerivingClass SHOW = Doc ann "Show" pretty DerivingClass GENERIC = Doc ann "Generic" pretty DerivingClass CLASS_EQ = Doc ann "Eq" data TypeValue = TypeValueObject TypeName [(FieldName, TypeValue)] | TypeValueNumber Double | TypeValueString Text | TypeValueBool Bool | TypeValueList [TypeValue] | TypedValueMaybe (Maybe TypeValue) deriving (Int -> TypeValue -> ShowS [TypeValue] -> ShowS TypeValue -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [TypeValue] -> ShowS $cshowList :: [TypeValue] -> ShowS show :: TypeValue -> String $cshow :: TypeValue -> String showsPrec :: Int -> TypeValue -> ShowS $cshowsPrec :: Int -> TypeValue -> ShowS Show) renderField :: (FieldName, TypeValue) -> Doc n renderField :: forall n. (FieldName, TypeValue) -> Doc n renderField (FieldName fName, TypeValue fValue) = forall a ann. Pretty a => a -> Doc ann pretty (forall a (t :: NAME). NamePacking a => Name t -> a unpackName FieldName fName :: Text) forall a. Semigroup a => a -> a -> a <> Doc n "=" forall ann. Doc ann -> Doc ann -> Doc ann <+> forall a ann. Pretty a => a -> Doc ann pretty TypeValue fValue instance Pretty TypeValue where pretty :: forall ann. TypeValue -> Doc ann pretty (TypeValueObject TypeName name [(FieldName, TypeValue)] xs) = forall a ann. Pretty a => a -> Doc ann pretty (forall a (t :: NAME). NamePacking a => Name t -> a unpackName TypeName name :: Text) forall ann. Doc ann -> Doc ann -> Doc ann <+> Doc ann "{" forall ann. Doc ann -> Doc ann -> Doc ann <+> forall ann. [Doc ann] -> Doc ann vsep (forall ann. Doc ann -> [Doc ann] -> [Doc ann] punctuate Doc ann "," (forall a b. (a -> b) -> [a] -> [b] map forall n. (FieldName, TypeValue) -> Doc n renderField [(FieldName, TypeValue)] xs)) forall ann. Doc ann -> Doc ann -> Doc ann <+> Doc ann "}" pretty (TypeValueNumber Double x) = forall a ann. Pretty a => a -> Doc ann pretty Double x pretty (TypeValueString Text x) = forall a ann. Pretty a => a -> Doc ann pretty (forall b a. (Show a, IsString b) => a -> b show Text x :: String) pretty (TypeValueBool Bool x) = forall a ann. Pretty a => a -> Doc ann pretty Bool x pretty (TypedValueMaybe (Just TypeValue x)) = Doc ann "Just" forall ann. Doc ann -> Doc ann -> Doc ann <+> forall a ann. Pretty a => a -> Doc ann pretty TypeValue x pretty (TypedValueMaybe Maybe TypeValue Nothing) = Doc ann "Nothing" pretty (TypeValueList [TypeValue] xs) = forall a ann. Pretty a => [a] -> Doc ann prettyList [TypeValue] xs data CodeGenType = CodeGenType { CodeGenType -> CodeGenTypeName cgTypeName :: CodeGenTypeName, CodeGenType -> [CodeGenConstructor] cgConstructors :: [CodeGenConstructor], CodeGenType -> [DerivingClass] cgDerivations :: [DerivingClass] } deriving (Int -> CodeGenType -> ShowS [CodeGenType] -> ShowS CodeGenType -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [CodeGenType] -> ShowS $cshowList :: [CodeGenType] -> ShowS show :: CodeGenType -> String $cshow :: CodeGenType -> String showsPrec :: Int -> CodeGenType -> ShowS $cshowsPrec :: Int -> CodeGenType -> ShowS Show) instance Pretty CodeGenType where pretty :: forall ann. CodeGenType -> Doc ann pretty CodeGenType {[CodeGenConstructor] [DerivingClass] CodeGenTypeName cgDerivations :: [DerivingClass] cgConstructors :: [CodeGenConstructor] cgTypeName :: CodeGenTypeName cgDerivations :: CodeGenType -> [DerivingClass] cgConstructors :: CodeGenType -> [CodeGenConstructor] cgTypeName :: CodeGenType -> CodeGenTypeName ..} = Doc ann "data" forall ann. Doc ann -> Doc ann -> Doc ann <+> forall n. HSDoc n -> Doc n ignore (forall a ann. Printer a => a -> HSDoc ann print CodeGenTypeName cgTypeName) forall a. Semigroup a => a -> a -> a <> forall {a} {ann}. Printer a => [a] -> Doc ann renderConstructors [CodeGenConstructor] cgConstructors forall a. Semigroup a => a -> a -> a <> forall ann. Doc ann line forall a. Semigroup a => a -> a -> a <> forall ann. Int -> Doc ann -> Doc ann indent Int 2 (forall ann. [DerivingClass] -> Doc ann renderDeriving [DerivingClass] cgDerivations) forall a. Semigroup a => a -> a -> a <> forall ann. Doc ann line where renderConstructors :: [a] -> Doc ann renderConstructors [a cons] = (Doc ann " =" forall ann. Doc ann -> Doc ann -> Doc ann <+>) forall a b. (a -> b) -> a -> b $ forall a n. Printer a => a -> Doc n print' a cons renderConstructors [a] conses = forall ann. Int -> Doc ann -> Doc ann nest Int 2 forall b c a. (b -> c) -> (a -> b) -> a -> c . (forall ann. Doc ann line forall a. Semigroup a => a -> a -> a <>) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall ann. [Doc ann] -> Doc ann vsep forall b c a. (b -> c) -> (a -> b) -> a -> c . forall {ann}. [Doc ann] -> [Doc ann] prefixVariants forall a b. (a -> b) -> a -> b $ forall a b. (a -> b) -> [a] -> [b] map forall a n. Printer a => a -> Doc n print' [a] conses prefixVariants :: [Doc ann] -> [Doc ann] prefixVariants (Doc ann x : [Doc ann] xs) = Doc ann "=" forall ann. Doc ann -> Doc ann -> Doc ann <+> Doc ann x forall a. a -> [a] -> [a] : forall a b. (a -> b) -> [a] -> [b] map (Doc ann "|" forall ann. Doc ann -> Doc ann -> Doc ann <+>) [Doc ann] xs prefixVariants [] = [] renderDeriving :: [DerivingClass] -> Doc n renderDeriving :: forall ann. [DerivingClass] -> Doc ann renderDeriving = (Doc n "deriving" forall ann. Doc ann -> Doc ann -> Doc ann <+>) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall ann. [Doc ann] -> Doc ann tupled forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map forall a ann. Pretty a => a -> Doc ann pretty data CodeGenConstructor = CodeGenConstructor { CodeGenConstructor -> CodeGenTypeName constructorName :: CodeGenTypeName, CodeGenConstructor -> [CodeGenField] constructorFields :: [CodeGenField] } deriving (Int -> CodeGenConstructor -> ShowS [CodeGenConstructor] -> ShowS CodeGenConstructor -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [CodeGenConstructor] -> ShowS $cshowList :: [CodeGenConstructor] -> ShowS show :: CodeGenConstructor -> String $cshow :: CodeGenConstructor -> String showsPrec :: Int -> CodeGenConstructor -> ShowS $cshowsPrec :: Int -> CodeGenConstructor -> ShowS Show) instance Printer CodeGenConstructor where print :: forall ann. CodeGenConstructor -> HSDoc ann print CodeGenConstructor {constructorFields :: CodeGenConstructor -> [CodeGenField] constructorFields = [], CodeGenTypeName constructorName :: CodeGenTypeName constructorName :: CodeGenConstructor -> CodeGenTypeName ..} = forall a ann. Printer a => a -> HSDoc ann print CodeGenTypeName constructorName print CodeGenConstructor {[CodeGenField] CodeGenTypeName constructorFields :: [CodeGenField] constructorName :: CodeGenTypeName constructorFields :: CodeGenConstructor -> [CodeGenField] constructorName :: CodeGenConstructor -> CodeGenTypeName ..} = do let fields :: [Doc n] fields = forall a b. (a -> b) -> [a] -> [b] map (forall n. HSDoc n -> Doc n unpack forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a ann. Printer a => a -> HSDoc ann print) [CodeGenField] constructorFields forall n. Doc n -> HSDoc n pack (forall a n. Printer a => a -> Doc n print' CodeGenTypeName constructorName forall a. Semigroup a => a -> a -> a <> forall ann. [Doc ann] -> Doc ann renderSet forall {n}. [Doc n] fields) where renderSet :: [Doc ann] -> Doc ann renderSet = forall ann. Int -> Doc ann -> Doc ann nest Int 2 forall b c a. (b -> c) -> (a -> b) -> a -> c . forall ann. Doc ann -> Doc ann -> Doc ann -> Doc ann enclose Doc ann "\n{ " Doc ann "\n}" forall b c a. (b -> c) -> (a -> b) -> a -> c . forall ann. Int -> Doc ann -> Doc ann nest Int 2 forall b c a. (b -> c) -> (a -> b) -> a -> c . forall ann. [Doc ann] -> Doc ann vsep forall b c a. (b -> c) -> (a -> b) -> a -> c . forall ann. Doc ann -> [Doc ann] -> [Doc ann] punctuate forall ann. Doc ann comma data CodeGenField = CodeGenField { CodeGenField -> FieldName fieldName :: FieldName, CodeGenField -> TypeName fieldType :: TypeName, CodeGenField -> [FIELD_TYPE_WRAPPER] wrappers :: [FIELD_TYPE_WRAPPER], CodeGenField -> Bool fieldIsNullable :: Bool } deriving (Int -> CodeGenField -> ShowS [CodeGenField] -> ShowS CodeGenField -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [CodeGenField] -> ShowS $cshowList :: [CodeGenField] -> ShowS show :: CodeGenField -> String $cshow :: CodeGenField -> String showsPrec :: Int -> CodeGenField -> ShowS $cshowsPrec :: Int -> CodeGenField -> ShowS Show) instance Printer CodeGenField where print :: forall ann. CodeGenField -> HSDoc ann print CodeGenField {Bool [FIELD_TYPE_WRAPPER] FieldName TypeName fieldIsNullable :: Bool wrappers :: [FIELD_TYPE_WRAPPER] fieldType :: TypeName fieldName :: FieldName fieldIsNullable :: CodeGenField -> Bool wrappers :: CodeGenField -> [FIELD_TYPE_WRAPPER] fieldType :: CodeGenField -> TypeName fieldName :: CodeGenField -> FieldName ..} = forall n. HSDoc n -> HSDoc n -> HSDoc n -> HSDoc n infix' (forall a ann. Printer a => a -> HSDoc ann print FieldName fieldName) HSDoc ann "::" (forall (t :: * -> *) a b. Foldable t => (a -> b -> b) -> b -> t a -> b foldr forall n. FIELD_TYPE_WRAPPER -> HSDoc n -> HSDoc n renderWrapper (forall a ann. Printer a => a -> HSDoc ann print TypeName fieldType) [FIELD_TYPE_WRAPPER] wrappers) data FIELD_TYPE_WRAPPER = MONAD | SUBSCRIPTION TH.Name | PARAMETRIZED | ARG TypeName | TAGGED_ARG TH.Name FieldName TypeRef | GQL_WRAPPER TypeWrapper deriving (Int -> FIELD_TYPE_WRAPPER -> ShowS [FIELD_TYPE_WRAPPER] -> ShowS FIELD_TYPE_WRAPPER -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [FIELD_TYPE_WRAPPER] -> ShowS $cshowList :: [FIELD_TYPE_WRAPPER] -> ShowS show :: FIELD_TYPE_WRAPPER -> String $cshow :: FIELD_TYPE_WRAPPER -> String showsPrec :: Int -> FIELD_TYPE_WRAPPER -> ShowS $cshowsPrec :: Int -> FIELD_TYPE_WRAPPER -> ShowS Show) renderWrapper :: FIELD_TYPE_WRAPPER -> HSDoc n -> HSDoc n renderWrapper :: forall n. FIELD_TYPE_WRAPPER -> HSDoc n -> HSDoc n renderWrapper FIELD_TYPE_WRAPPER PARAMETRIZED = (forall n. HSDoc n -> HSDoc n -> HSDoc n .<> HSDoc n "m") renderWrapper FIELD_TYPE_WRAPPER MONAD = (HSDoc n "m" forall n. HSDoc n -> HSDoc n -> HSDoc n .<>) renderWrapper SUBSCRIPTION {} = forall a. a -> a id renderWrapper (GQL_WRAPPER TypeWrapper typeWrappers) = forall n. TypeWrapper -> HSDoc n -> HSDoc n wrapped TypeWrapper typeWrappers renderWrapper (ARG TypeName name) = forall n. HSDoc n -> HSDoc n -> HSDoc n -> HSDoc n infix' (forall a ann. Printer a => a -> HSDoc ann print TypeName name) HSDoc n "->" renderWrapper (TAGGED_ARG Name _ FieldName name TypeRef typeRef) = forall n. HSDoc n -> HSDoc n -> HSDoc n -> HSDoc n infix' (forall (t :: NAME) n. Name t -> [HSDoc n] -> HSDoc n apply Name Any "Arg" [forall a ann. Printer a => a -> HSDoc ann print (forall b a. (Show a, IsString b) => a -> b show FieldName name :: String), forall a ann. Printer a => a -> HSDoc ann print TypeRef typeRef]) HSDoc n "->" data CodeGenTypeName = CodeGenTypeName { CodeGenTypeName -> [FieldName] namespace :: [FieldName], CodeGenTypeName -> [Text] typeParameters :: [Text], CodeGenTypeName -> TypeName typename :: TypeName } deriving (Int -> CodeGenTypeName -> ShowS [CodeGenTypeName] -> ShowS CodeGenTypeName -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [CodeGenTypeName] -> ShowS $cshowList :: [CodeGenTypeName] -> ShowS show :: CodeGenTypeName -> String $cshow :: CodeGenTypeName -> String showsPrec :: Int -> CodeGenTypeName -> ShowS $cshowsPrec :: Int -> CodeGenTypeName -> ShowS Show) getFullName :: CodeGenTypeName -> TypeName getFullName :: CodeGenTypeName -> TypeName getFullName CodeGenTypeName {[Text] [FieldName] TypeName typename :: TypeName typeParameters :: [Text] namespace :: [FieldName] typename :: CodeGenTypeName -> TypeName typeParameters :: CodeGenTypeName -> [Text] namespace :: CodeGenTypeName -> [FieldName] ..} = forall (t :: NAME). [Name t] -> TypeName -> TypeName camelCaseTypeName [FieldName] namespace TypeName typename fromTypeName :: TypeName -> CodeGenTypeName fromTypeName :: TypeName -> CodeGenTypeName fromTypeName = [FieldName] -> [Text] -> TypeName -> CodeGenTypeName CodeGenTypeName [] [] instance Printer CodeGenTypeName where print :: forall ann. CodeGenTypeName -> HSDoc ann print CodeGenTypeName cgName = forall n. Bool -> Doc n -> HSDoc n HSDoc (Bool -> Bool not forall a b. (a -> b) -> a -> b $ forall (t :: * -> *) a. Foldable t => t a -> Bool null (CodeGenTypeName -> [Text] typeParameters CodeGenTypeName cgName)) forall a b. (a -> b) -> a -> b $ forall ann. Text -> [Text] -> Doc ann parametrizedType (forall a (t :: NAME). NamePacking a => Name t -> a unpackName (CodeGenTypeName -> TypeName getFullName CodeGenTypeName cgName)) (CodeGenTypeName -> [Text] typeParameters CodeGenTypeName cgName) parametrizedType :: Text -> [Text] -> Doc ann parametrizedType :: forall ann. Text -> [Text] -> Doc ann parametrizedType Text tName [Text] typeParameters = forall ann. [Doc ann] -> Doc ann hsep forall a b. (a -> b) -> a -> b $ forall a b. (a -> b) -> [a] -> [b] map forall a ann. Pretty a => a -> Doc ann pretty forall a b. (a -> b) -> a -> b $ Text tName forall a. a -> [a] -> [a] : [Text] typeParameters