{-# 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
(Int -> DerivingClass -> ShowS)
-> (DerivingClass -> String)
-> ([DerivingClass] -> ShowS)
-> Show DerivingClass
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DerivingClass -> ShowS
showsPrec :: Int -> DerivingClass -> ShowS
$cshow :: DerivingClass -> String
show :: DerivingClass -> String
$cshowList :: [DerivingClass] -> ShowS
showList :: [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
(Int -> TypeValue -> ShowS)
-> (TypeValue -> String)
-> ([TypeValue] -> ShowS)
-> Show TypeValue
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TypeValue -> ShowS
showsPrec :: Int -> TypeValue -> ShowS
$cshow :: TypeValue -> String
show :: TypeValue -> String
$cshowList :: [TypeValue] -> ShowS
showList :: [TypeValue] -> ShowS
Show)

renderField :: (FieldName, TypeValue) -> Doc n
renderField :: forall n. (FieldName, TypeValue) -> Doc n
renderField (FieldName
fName, TypeValue
fValue) = Text -> Doc n
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (FieldName -> Text
forall a (t :: NAME). NamePacking a => Name t -> a
forall (t :: NAME). Name t -> Text
unpackName FieldName
fName :: Text) Doc n -> Doc n -> Doc n
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc n
"=" Doc n -> Doc n -> Doc n
forall ann. Doc ann -> Doc ann -> Doc ann
<+> TypeValue -> Doc n
forall a ann. Pretty a => a -> Doc ann
forall ann. TypeValue -> Doc ann
pretty TypeValue
fValue

instance Pretty TypeValue where
  pretty :: forall ann. TypeValue -> Doc ann
pretty (TypeValueObject TypeName
name [(FieldName, TypeValue)]
xs) =
    Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (TypeName -> Text
forall a (t :: NAME). NamePacking a => Name t -> a
forall (t :: NAME). Name t -> Text
unpackName TypeName
name :: Text)
      Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"{"
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep (Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
"," (((FieldName, TypeValue) -> Doc ann)
-> [(FieldName, TypeValue)] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (FieldName, TypeValue) -> Doc ann
forall n. (FieldName, TypeValue) -> Doc n
renderField [(FieldName, TypeValue)]
xs))
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"}"
  pretty (TypeValueNumber Double
x) = Double -> Doc ann
forall ann. Double -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Double
x
  pretty (TypeValueString Text
x) = String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> String
forall a. Show a => a -> String
show Text
x :: String)
  pretty (TypeValueBool Bool
x) = Bool -> Doc ann
forall ann. Bool -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Bool
x
  pretty (TypedValueMaybe (Just TypeValue
x)) = Doc ann
"Just" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> TypeValue -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. TypeValue -> Doc ann
pretty TypeValue
x
  pretty (TypedValueMaybe Maybe TypeValue
Nothing) = Doc ann
"Nothing"
  pretty (TypeValueList [TypeValue]
xs) = [TypeValue] -> Doc ann
forall ann. [TypeValue] -> Doc ann
forall a ann. Pretty a => [a] -> Doc ann
prettyList [TypeValue]
xs
  pretty (PrintableTypeValue PrintableValue
x) = PrintableValue -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. PrintableValue -> 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
(Int -> CodeGenType -> ShowS)
-> (CodeGenType -> String)
-> ([CodeGenType] -> ShowS)
-> Show CodeGenType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CodeGenType -> ShowS
showsPrec :: Int -> CodeGenType -> ShowS
$cshow :: CodeGenType -> String
show :: CodeGenType -> String
$cshowList :: [CodeGenType] -> ShowS
showList :: [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
cgTypeName :: CodeGenType -> CodeGenTypeName
cgConstructors :: CodeGenType -> [CodeGenConstructor]
cgDerivations :: CodeGenType -> [DerivingClass]
cgTypeName :: CodeGenTypeName
cgConstructors :: [CodeGenConstructor]
cgDerivations :: [DerivingClass]
..} =
    (if CodeGenType -> Bool
isNewType CodeGenType
t then Doc ann
"newtype" else Doc ann
"data")
      Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> HSDoc ann -> Doc ann
forall n. HSDoc n -> Doc n
ignore (CodeGenTypeName -> HSDoc ann
forall a ann. Printer a => a -> HSDoc ann
forall ann. CodeGenTypeName -> HSDoc ann
print CodeGenTypeName
cgTypeName)
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [CodeGenConstructor] -> Doc ann
forall {a} {ann}. Printer a => [a] -> Doc ann
renderConstructors [CodeGenConstructor]
cgConstructors
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 ([DerivingClass] -> Doc ann
forall ann. [DerivingClass] -> Doc ann
renderDeriving [DerivingClass]
cgDerivations)
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line
    where
      renderConstructors :: [a] -> Doc ann
renderConstructors [a
cons] = (Doc ann
" =" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+>) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ a -> Doc ann
forall a n. Printer a => a -> Doc n
print' a
cons
      renderConstructors [a]
conses = Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann)
-> ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<>) (Doc ann -> Doc ann)
-> ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann)
-> ([Doc ann] -> [Doc ann]) -> [Doc ann] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc ann] -> [Doc ann]
forall {ann}. [Doc ann] -> [Doc ann]
prefixVariants ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ (a -> Doc ann) -> [a] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map a -> Doc ann
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
"=" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
x Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: (Doc ann -> Doc ann) -> [Doc ann] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (Doc ann
"|" Doc ann -> Doc ann -> 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" Doc n -> Doc n -> Doc n
forall ann. Doc ann -> Doc ann -> Doc ann
<+>) (Doc n -> Doc n)
-> ([DerivingClass] -> Doc n) -> [DerivingClass] -> Doc n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc n] -> Doc n
forall ann. [Doc ann] -> Doc ann
tupled ([Doc n] -> Doc n)
-> ([DerivingClass] -> [Doc n]) -> [DerivingClass] -> Doc n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DerivingClass -> Doc n) -> [DerivingClass] -> [Doc n]
forall a b. (a -> b) -> [a] -> [b]
map DerivingClass -> Doc n
forall a ann. Pretty a => a -> Doc ann
forall ann. DerivingClass -> Doc ann
pretty

data CodeGenConstructor = CodeGenConstructor
  { CodeGenConstructor -> CodeGenTypeName
constructorName :: CodeGenTypeName,
    CodeGenConstructor -> [CodeGenField]
constructorFields :: [CodeGenField]
  }
  deriving (Int -> CodeGenConstructor -> ShowS
[CodeGenConstructor] -> ShowS
CodeGenConstructor -> String
(Int -> CodeGenConstructor -> ShowS)
-> (CodeGenConstructor -> String)
-> ([CodeGenConstructor] -> ShowS)
-> Show CodeGenConstructor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CodeGenConstructor -> ShowS
showsPrec :: Int -> CodeGenConstructor -> ShowS
$cshow :: CodeGenConstructor -> String
show :: CodeGenConstructor -> String
$cshowList :: [CodeGenConstructor] -> ShowS
showList :: [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
fieldType :: TypeName
wrappers :: [FIELD_TYPE_WRAPPER]
fieldIsNullable :: Bool
fieldType :: CodeGenField -> TypeName
wrappers :: CodeGenField -> [FIELD_TYPE_WRAPPER]
fieldIsNullable :: CodeGenField -> Bool
..}], CodeGenTypeName
constructorName :: CodeGenConstructor -> CodeGenTypeName
constructorName :: CodeGenTypeName
..} =
    Doc ann -> HSDoc ann
forall n. Doc n -> HSDoc n
pack (CodeGenTypeName -> Doc ann
forall a n. Printer a => a -> Doc n
print' CodeGenTypeName
constructorName Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> HSDoc ann -> Doc ann
forall n. HSDoc n -> Doc n
unpack ((FIELD_TYPE_WRAPPER -> HSDoc ann -> HSDoc ann)
-> HSDoc ann -> [FIELD_TYPE_WRAPPER] -> HSDoc ann
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr FIELD_TYPE_WRAPPER -> HSDoc ann -> HSDoc ann
forall n. FIELD_TYPE_WRAPPER -> HSDoc n -> HSDoc n
renderWrapper (TypeName -> HSDoc ann
forall ann. TypeName -> HSDoc ann
forall a ann. Printer a => a -> HSDoc ann
print TypeName
fieldType) [FIELD_TYPE_WRAPPER]
wrappers))
  print CodeGenConstructor {constructorFields :: CodeGenConstructor -> [CodeGenField]
constructorFields = [], CodeGenTypeName
constructorName :: CodeGenConstructor -> CodeGenTypeName
constructorName :: CodeGenTypeName
..} =
    CodeGenTypeName -> HSDoc ann
forall a ann. Printer a => a -> HSDoc ann
forall ann. CodeGenTypeName -> HSDoc ann
print CodeGenTypeName
constructorName
  print CodeGenConstructor {[CodeGenField]
CodeGenTypeName
constructorFields :: CodeGenConstructor -> [CodeGenField]
constructorName :: CodeGenConstructor -> CodeGenTypeName
constructorName :: CodeGenTypeName
constructorFields :: [CodeGenField]
..} = do
    let fields :: [Doc ann]
fields = (CodeGenField -> Doc ann) -> [CodeGenField] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (HSDoc ann -> Doc ann
forall n. HSDoc n -> Doc n
unpack (HSDoc ann -> Doc ann)
-> (CodeGenField -> HSDoc ann) -> CodeGenField -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CodeGenField -> HSDoc ann
forall a ann. Printer a => a -> HSDoc ann
forall ann. CodeGenField -> HSDoc ann
print) [CodeGenField]
constructorFields
    Doc ann -> HSDoc ann
forall n. Doc n -> HSDoc n
pack (CodeGenTypeName -> Doc ann
forall a n. Printer a => a -> Doc n
print' CodeGenTypeName
constructorName Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
renderSet [Doc ann]
fields)
    where
      renderSet :: [Doc ann] -> Doc ann
renderSet = Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann)
-> ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc ann -> Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann -> Doc ann
enclose Doc ann
"\n{ " Doc ann
"\n}" (Doc ann -> Doc ann)
-> ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann)
-> ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann)
-> ([Doc ann] -> [Doc ann]) -> [Doc ann] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
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
(Int -> CodeGenField -> ShowS)
-> (CodeGenField -> String)
-> ([CodeGenField] -> ShowS)
-> Show CodeGenField
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CodeGenField -> ShowS
showsPrec :: Int -> CodeGenField -> ShowS
$cshow :: CodeGenField -> String
show :: CodeGenField -> String
$cshowList :: [CodeGenField] -> ShowS
showList :: [CodeGenField] -> ShowS
Show)

instance Printer CodeGenField where
  print :: forall ann. CodeGenField -> HSDoc ann
print CodeGenField {Bool
[FIELD_TYPE_WRAPPER]
TypeName
FieldName
fieldName :: CodeGenField -> FieldName
fieldType :: CodeGenField -> TypeName
wrappers :: CodeGenField -> [FIELD_TYPE_WRAPPER]
fieldIsNullable :: CodeGenField -> Bool
fieldName :: FieldName
fieldType :: TypeName
wrappers :: [FIELD_TYPE_WRAPPER]
fieldIsNullable :: Bool
..} = HSDoc ann -> HSDoc ann -> HSDoc ann -> HSDoc ann
forall n. HSDoc n -> HSDoc n -> HSDoc n -> HSDoc n
infix' (FieldName -> HSDoc ann
forall ann. FieldName -> HSDoc ann
forall a ann. Printer a => a -> HSDoc ann
print FieldName
fieldName) HSDoc ann
"::" ((FIELD_TYPE_WRAPPER -> HSDoc ann -> HSDoc ann)
-> HSDoc ann -> [FIELD_TYPE_WRAPPER] -> HSDoc ann
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr FIELD_TYPE_WRAPPER -> HSDoc ann -> HSDoc ann
forall n. FIELD_TYPE_WRAPPER -> HSDoc n -> HSDoc n
renderWrapper (TypeName -> HSDoc ann
forall ann. TypeName -> HSDoc ann
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
(Int -> FIELD_TYPE_WRAPPER -> ShowS)
-> (FIELD_TYPE_WRAPPER -> String)
-> ([FIELD_TYPE_WRAPPER] -> ShowS)
-> Show FIELD_TYPE_WRAPPER
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FIELD_TYPE_WRAPPER -> ShowS
showsPrec :: Int -> FIELD_TYPE_WRAPPER -> ShowS
$cshow :: FIELD_TYPE_WRAPPER -> String
show :: FIELD_TYPE_WRAPPER -> String
$cshowList :: [FIELD_TYPE_WRAPPER] -> ShowS
showList :: [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 = (HSDoc n -> HSDoc n -> HSDoc n
forall n. HSDoc n -> HSDoc n -> HSDoc n
.<> HSDoc n
"m")
renderWrapper FIELD_TYPE_WRAPPER
MONAD = (HSDoc n
"m" HSDoc n -> HSDoc n -> HSDoc n
forall n. HSDoc n -> HSDoc n -> HSDoc n
.<>)
renderWrapper SUBSCRIPTION {} = HSDoc n -> HSDoc n
forall a. a -> a
id
renderWrapper (GQL_WRAPPER TypeWrapper
typeWrappers) = TypeWrapper -> HSDoc n -> HSDoc n
forall n. TypeWrapper -> HSDoc n -> HSDoc n
wrapped TypeWrapper
typeWrappers
renderWrapper (ARG TypeName
name) = HSDoc n -> HSDoc n -> HSDoc n -> HSDoc n
forall n. HSDoc n -> HSDoc n -> HSDoc n -> HSDoc n
infix' (TypeName -> HSDoc n
forall ann. TypeName -> HSDoc ann
forall a ann. Printer a => a -> HSDoc ann
print TypeName
name) HSDoc n
"->"
renderWrapper (TAGGED_ARG Name
_ FieldName
name TypeRef
typeRef) = HSDoc n -> HSDoc n -> HSDoc n -> HSDoc n
forall n. HSDoc n -> HSDoc n -> HSDoc n -> HSDoc n
infix' (Name Any -> [HSDoc n] -> HSDoc n
forall (t :: NAME) n. Name t -> [HSDoc n] -> HSDoc n
apply Name Any
"Arg" [String -> HSDoc n
forall ann. String -> HSDoc ann
forall a ann. Printer a => a -> HSDoc ann
print (FieldName -> String
forall a. Show a => a -> String
show FieldName
name :: String), TypeRef -> HSDoc n
forall ann. TypeRef -> HSDoc ann
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
(Int -> CodeGenTypeName -> ShowS)
-> (CodeGenTypeName -> String)
-> ([CodeGenTypeName] -> ShowS)
-> Show CodeGenTypeName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CodeGenTypeName -> ShowS
showsPrec :: Int -> CodeGenTypeName -> ShowS
$cshow :: CodeGenTypeName -> String
show :: CodeGenTypeName -> String
$cshowList :: [CodeGenTypeName] -> ShowS
showList :: [CodeGenTypeName] -> ShowS
Show)

getFullName :: CodeGenTypeName -> TypeName
getFullName :: CodeGenTypeName -> TypeName
getFullName CodeGenTypeName {[Text]
[FieldName]
TypeName
namespace :: CodeGenTypeName -> [FieldName]
typeParameters :: CodeGenTypeName -> [Text]
typename :: CodeGenTypeName -> TypeName
namespace :: [FieldName]
typeParameters :: [Text]
typename :: TypeName
..} = [FieldName] -> TypeName -> TypeName
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 =
    Bool -> Doc ann -> HSDoc ann
forall n. Bool -> Doc n -> HSDoc n
HSDoc (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (CodeGenTypeName -> [Text]
typeParameters CodeGenTypeName
cgName)) (Doc ann -> HSDoc ann) -> Doc ann -> HSDoc ann
forall a b. (a -> b) -> a -> b
$
      Text -> [Text] -> Doc ann
forall ann. Text -> [Text] -> Doc ann
parametrizedType
        (TypeName -> Text
forall a (t :: NAME). NamePacking a => Name t -> a
forall (t :: NAME). Name t -> Text
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 = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ (Text -> Doc ann) -> [Text] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ([Text] -> [Doc ann]) -> [Text] -> [Doc ann]
forall a b. (a -> b) -> a -> b
$ Text
tName Text -> [Text] -> [Text]
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
moduleName :: forall dec. ModuleDefinition dec -> Text
imports :: forall dec. ModuleDefinition dec -> [(Text, [Text])]
extensions :: forall dec. ModuleDefinition dec -> [Text]
types :: forall dec. ModuleDefinition dec -> [dec]
moduleName :: Text
imports :: [(Text, [Text])]
extensions :: [Text]
types :: [dec]
..} =
    [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
      ((Text -> Doc ann) -> [Text] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Doc ann
forall ann. Text -> Doc ann
renderExtension ([Text] -> [Text]
forall a. Ord a => [a] -> [a]
sort [Text]
extensions))
      Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line
      Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line
      Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"module"
      Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
moduleName
      Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"where"
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep (((Text, [Text]) -> Doc ann) -> [(Text, [Text])] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (Text, [Text]) -> Doc ann
forall ann. (Text, [Text]) -> Doc ann
renderImport ([(Text, [Text])] -> [Doc ann]) -> [(Text, [Text])] -> [Doc ann]
forall a b. (a -> b) -> a -> b
$ [(Text, [Text])] -> [(Text, [Text])]
organizeImports [(Text, [Text])]
imports)
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ((Doc ann -> Bool) -> [Doc ann] -> [Doc ann]
forall a. (a -> Bool) -> [a] -> [a]
filter Doc ann -> Bool
forall a. Doc a -> Bool
notEmpty ([Doc ann] -> [Doc ann]) -> [Doc ann] -> [Doc ann]
forall a b. (a -> b) -> a -> b
$ (dec -> Doc ann) -> [dec] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map dec -> Doc ann
forall ann. dec -> Doc ann
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 (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Doc a -> String
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 = Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
txt
  | Bool
otherwise = Doc ann
"{-#" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"LANGUAGE" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
txt Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"#-}"

organizeImports :: [(Text, [Text])] -> [(Text, [Text])]
organizeImports :: [(Text, [Text])] -> [(Text, [Text])]
organizeImports [(Text, [Text])]
xs = ((Text, [Text]) -> Text) -> [(Text, [Text])] -> [(Text, [Text])]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortWith (Text, [Text]) -> Text
forall a b. (a, b) -> a
fst ([(Text, [Text])] -> [(Text, [Text])])
-> [(Text, [Text])] -> [(Text, [Text])]
forall a b. (a -> b) -> a -> b
$ HashMap Text [Text] -> [(Text, [Text])]
forall k v. HashMap k v -> [(k, v)]
HM.toList (HashMap Text [Text] -> [(Text, [Text])])
-> HashMap Text [Text] -> [(Text, [Text])]
forall a b. (a -> b) -> a -> b
$ (Set Text -> [Text])
-> HashMap Text (Set Text) -> HashMap Text [Text]
forall a b. (a -> b) -> HashMap Text a -> HashMap Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Text] -> [Text]
forall a. Ord a => [a] -> [a]
sort ([Text] -> [Text]) -> (Set Text -> [Text]) -> Set Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Text -> [Text]
forall a. Set a -> [a]
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 = ((Text, [Text])
 -> HashMap Text (Set Text) -> HashMap Text (Set Text))
-> HashMap Text (Set Text)
-> [(Text, [Text])]
-> HashMap Text (Set Text)
forall a b. (a -> b -> b) -> b -> [a] -> b
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 HashMap Text (Set Text)
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) = (Maybe (Set Text) -> Maybe (Set Text))
-> Text -> HashMap Text (Set Text) -> HashMap Text (Set Text)
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 = Set Text -> Maybe (Set Text)
forall a. a -> Maybe a
Just ([Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList [Text]
names Set Text -> Set Text -> Set Text
forall a. Semigroup a => a -> a -> a
<> Set Text -> Maybe (Set Text) -> Set Text
forall a. a -> Maybe a -> a
fromMaybe Set Text
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" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
src Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Text] -> Doc ann
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 = Doc ann
forall ann. Doc ann
space Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
tupled ((Text -> Doc ann) -> [Text] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Doc ann
forall ann. Text -> Doc ann
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
[TypeClassInstance body] -> ShowS
TypeClassInstance body -> String
(Int -> TypeClassInstance body -> ShowS)
-> (TypeClassInstance body -> String)
-> ([TypeClassInstance body] -> ShowS)
-> Show (TypeClassInstance body)
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
$cshowsPrec :: forall body. Show body => Int -> TypeClassInstance body -> ShowS
showsPrec :: Int -> TypeClassInstance body -> ShowS
$cshow :: forall body. Show body => TypeClassInstance body -> String
show :: TypeClassInstance body -> String
$cshowList :: forall body. Show body => [TypeClassInstance body] -> ShowS
showList :: [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
typeClassName :: forall body. TypeClassInstance body -> Name
typeClassContext :: forall body. TypeClassInstance body -> [(Name, Name)]
typeClassTarget :: forall body. TypeClassInstance body -> CodeGenTypeName
assoc :: forall body. TypeClassInstance body -> [(Name, AssociatedType)]
typeClassMethods :: forall body.
TypeClassInstance body -> [(Name, MethodArgument, body)]
typeClassName :: Name
typeClassContext :: [(Name, Name)]
typeClassTarget :: CodeGenTypeName
assoc :: [(Name, AssociatedType)]
typeClassMethods :: [(Name, MethodArgument, a)]
..} =
    Doc ann
"instance"
      Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> ([Text] -> Doc ann) -> [Text] -> Doc ann
forall a n. ([a] -> Doc n) -> [a] -> Doc n
optional [Text] -> Doc ann
forall ann. [Text] -> Doc ann
renderTypeableConstraints (CodeGenTypeName -> [Text]
typeParameters CodeGenTypeName
typeClassTarget)
      Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Name -> Doc ann
forall ann. Name -> Doc ann
printTHName Name
typeClassName
      Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
typeHead
      Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"where"
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 ([Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep (((Name, AssociatedType) -> Doc ann)
-> [(Name, AssociatedType)] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (Name, AssociatedType) -> Doc ann
renderAssoc [(Name, AssociatedType)]
assoc [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. Semigroup a => a -> a -> a
<> ((Name, MethodArgument, a) -> Doc ann)
-> [(Name, MethodArgument, a)] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (Name, MethodArgument, a) -> Doc ann
forall {a} {a} {ann}.
(Pretty a, Pretty a) =>
(Name, a, a) -> Doc ann
renderMethodD [(Name, MethodArgument, a)]
typeClassMethods))
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line
    where
      typeHead :: Doc ann
typeHead = HSDoc ann -> Doc ann
forall n. HSDoc n -> Doc n
unpack (CodeGenTypeName -> HSDoc ann
forall a ann. Printer a => a -> HSDoc ann
forall ann. CodeGenTypeName -> HSDoc ann
print CodeGenTypeName
typeClassTarget)
      renderAssoc :: (Name, AssociatedType) -> Doc ann
renderAssoc (Name
name, AssociatedType
a) = Doc ann
"type" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Name -> Doc ann
forall ann. Name -> Doc ann
printTHName Name
name Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
typeHead Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"=" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> AssociatedType -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. AssociatedType -> Doc ann
pretty AssociatedType
a
      renderMethodD :: (Name, a, a) -> Doc ann
renderMethodD (Name
name, a
args, a
method) = Name -> Doc ann
forall ann. Name -> Doc ann
printTHName Name
name Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> a -> Doc ann
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
args Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"=" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> a -> Doc ann
forall ann. a -> 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 = [Doc n] -> Doc n
forall ann. [Doc ann] -> Doc ann
tupled ((Text -> Doc n) -> [Text] -> [Doc n]
forall a b. (a -> b) -> [a] -> [b]
map ((Doc n
"Typeable" Doc n -> Doc n -> Doc n
forall ann. Doc ann -> Doc ann -> Doc ann
<+>) (Doc n -> Doc n) -> (Text -> Doc n) -> Text -> Doc n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Doc n
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty) [Text]
xs) Doc n -> Doc n -> Doc n
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
(Int -> AssociatedType -> ShowS)
-> (AssociatedType -> String)
-> ([AssociatedType] -> ShowS)
-> Show AssociatedType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AssociatedType -> ShowS
showsPrec :: Int -> AssociatedType -> ShowS
$cshow :: AssociatedType -> String
show :: AssociatedType -> String
$cshowList :: [AssociatedType] -> ShowS
showList :: [AssociatedType] -> ShowS
Show)

printTHName :: TH.Name -> Doc ann
printTHName :: forall ann. Name -> Doc ann
printTHName = HSDoc ann -> Doc ann
forall n. HSDoc n -> Doc n
ignore (HSDoc ann -> Doc ann) -> (Name -> HSDoc ann) -> Name -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> HSDoc ann
forall ann. Name -> HSDoc ann
forall a ann. Printer a => a -> HSDoc ann
print

printPromotedLocation :: DirectiveLocation -> Doc ann
printPromotedLocation :: forall ann. DirectiveLocation -> Doc ann
printPromotedLocation = (Doc ann
"'" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<>) (Doc ann -> Doc ann)
-> (DirectiveLocation -> Doc ann) -> DirectiveLocation -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HSDoc ann -> Doc ann
forall n. HSDoc n -> Doc n
ignore (HSDoc ann -> Doc ann)
-> (DirectiveLocation -> HSDoc ann) -> DirectiveLocation -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DirectiveLocation -> HSDoc ann
forall ann. DirectiveLocation -> HSDoc ann
forall a ann. Printer a => a -> HSDoc ann
print

instance Pretty AssociatedType where
  pretty :: forall ann. AssociatedType -> Doc ann
pretty (AssociatedTypeName Name
x) = Name -> Doc ann
forall ann. Name -> Doc ann
printTHName Name
x
  pretty (AssociatedLocations [DirectiveLocation]
x) = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
list ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ (DirectiveLocation -> Doc ann) -> [DirectiveLocation] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map DirectiveLocation -> Doc ann
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
(Int -> MethodArgument -> ShowS)
-> (MethodArgument -> String)
-> ([MethodArgument] -> ShowS)
-> Show MethodArgument
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MethodArgument -> ShowS
showsPrec :: Int -> MethodArgument -> ShowS
$cshow :: MethodArgument -> String
show :: MethodArgument -> String
$cshowList :: [MethodArgument] -> ShowS
showList :: [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) = HSDoc ann -> Doc ann
forall n. HSDoc n -> Doc n
unpack (Name -> HSDoc ann
forall ann. Name -> HSDoc ann
forall a ann. Printer a => a -> HSDoc ann
print Name
x HSDoc ann -> HSDoc ann -> HSDoc ann
forall n. HSDoc n -> HSDoc n -> HSDoc n
.<> Doc ann -> HSDoc ann
forall n. Doc n -> HSDoc n
pack ([Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ (Name -> Doc ann) -> [Name] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Doc ann
forall ann. Name -> Doc ann
printTHName [Name]
xs)) Doc ann -> Doc ann -> Doc ann
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) = a -> String
forall a. Show a => a -> String
show a
a

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