{-# 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 (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)
  | PrintableTypeValue PrintableValue
  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 ann. Doc ann -> Doc ann -> Doc ann
<+> 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 a. Semigroup a => a -> a -> a
<> 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 a. Semigroup a => a -> a -> a
<> 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 a. Show a => a -> String
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
  pretty (PrintableTypeValue PrintableValue
x) = forall a ann. Pretty a => a -> Doc ann
pretty PrintableValue
x

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 = [CodeGenField {fieldName :: CodeGenField -> FieldName
fieldName = FieldName
"_", Bool
[FIELD_TYPE_WRAPPER]
TypeName
fieldIsNullable :: CodeGenField -> Bool
wrappers :: CodeGenField -> [FIELD_TYPE_WRAPPER]
fieldType :: CodeGenField -> TypeName
fieldIsNullable :: Bool
wrappers :: [FIELD_TYPE_WRAPPER]
fieldType :: TypeName
..}], CodeGenTypeName
constructorName :: CodeGenTypeName
constructorName :: CodeGenConstructor -> CodeGenTypeName
..} =
    forall n. Doc n -> HSDoc n
pack (forall a n. Printer a => a -> Doc n
print' CodeGenTypeName
constructorName forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall n. HSDoc n -> Doc n
unpack (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))
  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 ann]
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 [Doc ann]
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 a. Show a => a -> String
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 (forall a. Ord a => [a] -> [a]
sort [Text]
extensions))
      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 forall a b. (a -> b) -> a -> b
$ [(Text, [Text])] -> [(Text, [Text])]
organizeImports [(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. (a -> Bool) -> [a] -> [a]
filter forall a. Doc a -> Bool
notEmpty forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a ann. Pretty a => a -> Doc ann
pretty [dec]
types)

notEmpty :: Doc a -> Bool
notEmpty :: forall a. Doc a -> Bool
notEmpty Doc a
x = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall a. Show a => a -> String
show Doc a
x :: String)

renderExtension :: Text -> Doc ann
renderExtension :: forall ann. Text -> Doc ann
renderExtension Text
txt
  | Text -> Text -> Bool
T.isPrefixOf Text
"{-#" Text
txt = forall a ann. Pretty a => a -> Doc ann
pretty Text
txt
  | Bool
otherwise = 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
txt forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"#-}"

organizeImports :: [(Text, [Text])] -> [(Text, [Text])]
organizeImports :: [(Text, [Text])] -> [(Text, [Text])]
organizeImports [(Text, [Text])]
xs = forall b a. Ord b => (a -> b) -> [a] -> [a]
sortWith forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall k v. HashMap k v -> [(k, v)]
HM.toList forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Ord a => [a] -> [a]
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList) ([(Text, [Text])] -> HashMap Text (Set Text)
groupImports [(Text, [Text])]
xs)

groupImports :: [(Text, [Text])] -> HashMap Text (Set Text)
groupImports :: [(Text, [Text])] -> HashMap Text (Set Text)
groupImports = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Text, [Text])
-> HashMap Text (Set Text) -> HashMap Text (Set Text)
insertImport forall a. Monoid a => a
mempty

insertImport :: (Text, [Text]) -> HashMap Text (Set Text) -> HashMap Text (Set Text)
insertImport :: (Text, [Text])
-> HashMap Text (Set Text) -> HashMap Text (Set Text)
insertImport (Text
moduleName, [Text]
names) = forall k v.
(Eq k, Hashable k) =>
(Maybe v -> Maybe v) -> k -> HashMap k v -> HashMap k v
HM.alter Maybe (Set Text) -> Maybe (Set Text)
f Text
moduleName
  where
    f :: Maybe (Set Text) -> Maybe (Set Text)
f Maybe (Set Text)
x = forall a. a -> Maybe a
Just (forall a. Ord a => [a] -> Set a
S.fromList [Text]
names forall a. Semigroup a => a -> a -> a
<> forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty Maybe (Set Text)
x)

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
space forall a. Semigroup a => a -> a -> a
<> 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
<+> 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 (Name, AssociatedType) -> 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))
        forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
line
    where
      typeHead :: Doc ann
typeHead = forall n. HSDoc n -> Doc n
unpack (forall a ann. Printer a => a -> HSDoc ann
print CodeGenTypeName
typeClassTarget)
      renderAssoc :: (Name, AssociatedType) -> Doc ann
renderAssoc (Name
name, AssociatedType
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
<+> 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 AssociatedType
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 a. Semigroup a => a -> a -> a
<> Doc ann
"=" forall a. Semigroup a => a -> a -> a
<> 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)) forall a. Semigroup a => a -> a -> a
<> Doc ann
" "

data PrintableValue where
  PrintableValue :: forall a. (Show a, Lift a) => a -> PrintableValue

instance Show PrintableValue where
  show :: PrintableValue -> String
show (PrintableValue a
a) = forall a. Show a => a -> String
show a
a

instance Pretty PrintableValue where
  pretty :: forall ann. PrintableValue -> Doc ann
pretty (PrintableValue a
x) = forall a ann. Pretty a => a -> Doc ann
pretty (forall a. Show a => a -> String
show a
x)