{-# LANGUAGE OverloadedStrings #-} {-# 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, ) where 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 Language.Haskell.TH.Syntax as TH import Prettyprinter ( Doc, Pretty (..), comma, enclose, hsep, indent, line, list, nest, pretty, punctuate, tupled, vsep, (<+>), ) import Relude hiding (optional, 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) isNewType :: CodeGenType -> Bool isNewType :: CodeGenType -> Bool isNewType CodeGenType {cgConstructors :: CodeGenType -> [CodeGenConstructor] cgConstructors = [CodeGenConstructor {constructorFields :: CodeGenConstructor -> [CodeGenField] constructorFields = [CodeGenField _]}]} = Bool True isNewType CodeGenType _ = Bool False instance Pretty CodeGenType where pretty :: forall ann. CodeGenType -> Doc ann pretty t :: CodeGenType t@CodeGenType {[CodeGenConstructor] [DerivingClass] CodeGenTypeName cgDerivations :: [DerivingClass] cgConstructors :: [CodeGenConstructor] cgTypeName :: CodeGenTypeName cgDerivations :: CodeGenType -> [DerivingClass] cgConstructors :: CodeGenType -> [CodeGenConstructor] cgTypeName :: CodeGenType -> CodeGenTypeName ..} = (if CodeGenType -> Bool isNewType CodeGenType t then Doc ann "newtype" else 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 constructorName :: CodeGenConstructor -> CodeGenTypeName constructorFields :: CodeGenConstructor -> [CodeGenField] ..} = 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 data ModuleDefinition dec = ModuleDefinition { forall dec. ModuleDefinition dec -> Text moduleName :: Text, forall dec. ModuleDefinition dec -> [(Text, [Text])] imports :: [(Text, [Text])], forall dec. ModuleDefinition dec -> [Text] extensions :: [Text], forall dec. ModuleDefinition dec -> [dec] types :: [dec] } instance Pretty dec => Pretty (ModuleDefinition dec) where pretty :: forall ann. ModuleDefinition dec -> Doc ann pretty ModuleDefinition {[dec] [(Text, [Text])] [Text] Text types :: [dec] extensions :: [Text] imports :: [(Text, [Text])] moduleName :: Text types :: forall dec. ModuleDefinition dec -> [dec] extensions :: forall dec. ModuleDefinition dec -> [Text] imports :: forall dec. ModuleDefinition dec -> [(Text, [Text])] moduleName :: forall dec. ModuleDefinition dec -> Text ..} = forall ann. [Doc ann] -> Doc ann vsep (forall a b. (a -> b) -> [a] -> [b] map forall ann. Text -> Doc ann renderExtension [Text] extensions) forall a. Semigroup a => a -> a -> a <> Doc ann "{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}" forall a. Semigroup a => a -> a -> a <> forall ann. Doc ann line forall a. Semigroup a => a -> a -> a <> forall ann. Doc ann line forall a. Semigroup a => a -> a -> a <> Doc ann "{-# HLINT ignore \"Use camelCase\" #-}" forall a. Semigroup a => a -> a -> a <> forall ann. Doc ann line forall a. Semigroup a => a -> a -> a <> forall ann. Doc ann line forall a. Semigroup a => a -> a -> a <> Doc ann "module" forall ann. Doc ann -> Doc ann -> Doc ann <+> forall a ann. Pretty a => a -> Doc ann pretty Text moduleName forall ann. Doc ann -> Doc ann -> Doc ann <+> Doc ann "where" forall a. Semigroup a => a -> a -> a <> forall ann. Doc ann line forall a. Semigroup a => a -> a -> a <> forall ann. Doc ann line forall a. Semigroup a => a -> a -> a <> forall ann. [Doc ann] -> Doc ann vsep (forall a b. (a -> b) -> [a] -> [b] map forall ann. (Text, [Text]) -> Doc ann renderImport [(Text, [Text])] imports) forall a. Semigroup a => a -> a -> a <> forall ann. Doc ann line forall a. Semigroup a => a -> a -> a <> forall ann. Doc ann line forall a. Semigroup a => a -> a -> a <> forall ann. [Doc ann] -> Doc ann vsep (forall a b. (a -> b) -> [a] -> [b] map forall a ann. Pretty a => a -> Doc ann pretty [dec] types) renderExtension :: Text -> Doc ann renderExtension :: forall ann. Text -> Doc ann renderExtension Text name = Doc ann "{-#" forall ann. Doc ann -> Doc ann -> Doc ann <+> Doc ann "LANGUAGE" forall ann. Doc ann -> Doc ann -> Doc ann <+> forall a ann. Pretty a => a -> Doc ann pretty Text name forall ann. Doc ann -> Doc ann -> Doc ann <+> Doc ann "#-}" renderImport :: (Text, [Text]) -> Doc ann renderImport :: forall ann. (Text, [Text]) -> Doc ann renderImport (Text src, [Text] ls) = Doc ann "import" forall ann. Doc ann -> Doc ann -> Doc ann <+> forall a ann. Pretty a => a -> Doc ann pretty Text src forall a. Semigroup a => a -> a -> a <> forall ann. [Text] -> Doc ann renderImportList [Text] ls renderImportList :: [Text] -> Doc ann renderImportList :: forall ann. [Text] -> Doc ann renderImportList [Text "*"] = Doc ann "" renderImportList [Text] xs = forall ann. [Doc ann] -> Doc ann tupled (forall a b. (a -> b) -> [a] -> [b] map forall a ann. Pretty a => a -> Doc ann pretty [Text] xs) data TypeClassInstance body = TypeClassInstance { forall body. TypeClassInstance body -> Name typeClassName :: TH.Name, forall body. TypeClassInstance body -> [(Name, Name)] typeClassContext :: [(TH.Name, TH.Name)], forall body. TypeClassInstance body -> CodeGenTypeName typeClassTarget :: CodeGenTypeName, forall body. TypeClassInstance body -> [(Name, AssociatedType)] assoc :: [(TH.Name, AssociatedType)], forall body. TypeClassInstance body -> [(Name, MethodArgument, body)] typeClassMethods :: [(TH.Name, MethodArgument, body)] } deriving (Int -> TypeClassInstance body -> ShowS forall body. Show body => Int -> TypeClassInstance body -> ShowS forall body. Show body => [TypeClassInstance body] -> ShowS forall body. Show body => TypeClassInstance body -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [TypeClassInstance body] -> ShowS $cshowList :: forall body. Show body => [TypeClassInstance body] -> ShowS show :: TypeClassInstance body -> String $cshow :: forall body. Show body => TypeClassInstance body -> String showsPrec :: Int -> TypeClassInstance body -> ShowS $cshowsPrec :: forall body. Show body => Int -> TypeClassInstance body -> ShowS Show) instance Pretty a => Pretty (TypeClassInstance a) where pretty :: forall ann. TypeClassInstance a -> Doc ann pretty TypeClassInstance {[(Name, Name)] [(Name, AssociatedType)] [(Name, MethodArgument, a)] Name CodeGenTypeName typeClassMethods :: [(Name, MethodArgument, a)] assoc :: [(Name, AssociatedType)] typeClassTarget :: CodeGenTypeName typeClassContext :: [(Name, Name)] typeClassName :: Name typeClassMethods :: forall body. TypeClassInstance body -> [(Name, MethodArgument, body)] assoc :: forall body. TypeClassInstance body -> [(Name, AssociatedType)] typeClassTarget :: forall body. TypeClassInstance body -> CodeGenTypeName typeClassContext :: forall body. TypeClassInstance body -> [(Name, Name)] typeClassName :: forall body. TypeClassInstance body -> Name ..} = Doc ann "instance" forall a. Semigroup a => a -> a -> a <> forall a n. ([a] -> Doc n) -> [a] -> Doc n optional forall ann. [Text] -> Doc ann renderTypeableConstraints (CodeGenTypeName -> [Text] typeParameters CodeGenTypeName typeClassTarget) forall ann. Doc ann -> Doc ann -> Doc ann <+> forall ann. Name -> Doc ann printTHName Name typeClassName forall ann. Doc ann -> Doc ann -> Doc ann <+> forall ann. Doc ann typeHead forall ann. Doc ann -> Doc ann -> Doc ann <+> Doc ann "where" 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. [Doc ann] -> Doc ann vsep (forall a b. (a -> b) -> [a] -> [b] map forall {a} {ann}. Pretty a => (Name, a) -> Doc ann renderAssoc [(Name, AssociatedType)] assoc forall a. Semigroup a => a -> a -> a <> forall a b. (a -> b) -> [a] -> [b] map forall {a} {a} {ann}. (Pretty a, Pretty a) => (Name, a, a) -> Doc ann renderMethodD [(Name, MethodArgument, a)] typeClassMethods)) where typeHead :: Doc n typeHead = forall n. HSDoc n -> Doc n unpack (forall a ann. Printer a => a -> HSDoc ann print CodeGenTypeName typeClassTarget) renderAssoc :: (Name, a) -> Doc ann renderAssoc (Name name, a a) = Doc ann "type" forall ann. Doc ann -> Doc ann -> Doc ann <+> forall ann. Name -> Doc ann printTHName Name name forall ann. Doc ann -> Doc ann -> Doc ann <+> forall ann. Doc ann typeHead forall ann. Doc ann -> Doc ann -> Doc ann <+> Doc ann "=" forall ann. Doc ann -> Doc ann -> Doc ann <+> forall a ann. Pretty a => a -> Doc ann pretty a a renderMethodD :: (Name, a, a) -> Doc ann renderMethodD (Name name, a args, a method) = forall ann. Name -> Doc ann printTHName Name name forall ann. Doc ann -> Doc ann -> Doc ann <+> forall a ann. Pretty a => a -> Doc ann pretty a args forall ann. Doc ann -> Doc ann -> Doc ann <+> Doc ann "=" forall ann. Doc ann -> Doc ann -> Doc ann <+> forall a ann. Pretty a => a -> Doc ann pretty a method renderTypeableConstraints :: [Text] -> Doc n renderTypeableConstraints :: forall ann. [Text] -> Doc ann renderTypeableConstraints [Text] xs = forall ann. [Doc ann] -> Doc ann tupled (forall a b. (a -> b) -> [a] -> [b] map ((Doc n "Typeable" forall ann. Doc ann -> Doc ann -> Doc ann <+>) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a ann. Pretty a => a -> Doc ann pretty) [Text] xs) forall ann. Doc ann -> Doc ann -> Doc ann <+> Doc n "=>" data AssociatedType = AssociatedTypeName TH.Name | AssociatedLocations [DirectiveLocation] deriving (Int -> AssociatedType -> ShowS [AssociatedType] -> ShowS AssociatedType -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [AssociatedType] -> ShowS $cshowList :: [AssociatedType] -> ShowS show :: AssociatedType -> String $cshow :: AssociatedType -> String showsPrec :: Int -> AssociatedType -> ShowS $cshowsPrec :: Int -> AssociatedType -> ShowS Show) printTHName :: TH.Name -> Doc ann printTHName :: forall ann. Name -> Doc ann printTHName = forall n. HSDoc n -> Doc n ignore forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a ann. Printer a => a -> HSDoc ann print printPromotedLocation :: DirectiveLocation -> Doc ann printPromotedLocation :: forall ann. DirectiveLocation -> Doc ann printPromotedLocation = (Doc ann "'" forall a. Semigroup a => a -> a -> a <>) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall n. HSDoc n -> Doc n ignore forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a ann. Printer a => a -> HSDoc ann print instance Pretty AssociatedType where pretty :: forall ann. AssociatedType -> Doc ann pretty (AssociatedTypeName Name x) = forall ann. Name -> Doc ann printTHName Name x pretty (AssociatedLocations [DirectiveLocation] x) = forall ann. [Doc ann] -> Doc ann list forall a b. (a -> b) -> a -> b $ forall a b. (a -> b) -> [a] -> [b] map forall ann. DirectiveLocation -> Doc ann printPromotedLocation [DirectiveLocation] x data MethodArgument = NoArgument | ProxyArgument | DestructArgument TH.Name [TH.Name] deriving (Int -> MethodArgument -> ShowS [MethodArgument] -> ShowS MethodArgument -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [MethodArgument] -> ShowS $cshowList :: [MethodArgument] -> ShowS show :: MethodArgument -> String $cshow :: MethodArgument -> String showsPrec :: Int -> MethodArgument -> ShowS $cshowsPrec :: Int -> MethodArgument -> ShowS Show) instance Pretty MethodArgument where pretty :: forall ann. MethodArgument -> Doc ann pretty MethodArgument NoArgument = Doc ann "" pretty MethodArgument ProxyArgument = Doc ann "_" pretty (DestructArgument Name x [Name] xs) = forall n. HSDoc n -> Doc n unpack (forall a ann. Printer a => a -> HSDoc ann print Name x forall n. HSDoc n -> HSDoc n -> HSDoc n .<> forall n. Doc n -> HSDoc n pack (forall ann. [Doc ann] -> Doc ann hsep forall a b. (a -> b) -> a -> b $ forall a b. (a -> b) -> [a] -> [b] map forall ann. Name -> Doc ann printTHName [Name] xs))