{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Client.CodeGen.AST
  ( AesonField,
    ClientDeclaration (..),
    ClientMethod (..),
    ClientPreDeclaration (..),
    DERIVING_MODE (..),
    MValue (..),
    RequestTypeDefinition (..),
    UnionPat (..),
    ClientTypeDefinition (..),
  )
where

import Data.Aeson (parseJSON)
import Data.Foldable (foldr1)
import Data.Morpheus.Client.CodeGen.Internal
  ( withObject,
    withUnion,
  )
import Data.Morpheus.CodeGen.Internal.AST
  ( CodeGenConstructor (..),
    CodeGenType,
    CodeGenTypeName,
    PrintableValue (..),
    TypeClassInstance,
    printTHName,
  )
import Data.Morpheus.CodeGen.TH
  ( PrintExp (..),
    ToName (toName),
    toCon,
    toString,
    toVar,
    v',
  )
import Data.Morpheus.Types.Internal.AST (FieldName, OperationType, TypeKind, TypeName, unpackName)
import Language.Haskell.TH
import Prettyprinter
  ( Doc,
    Pretty (..),
    indent,
    line,
    space,
    vsep,
    (<+>),
  )
import Relude hiding (lift, show, toString)
import Prelude (show)

data DERIVING_MODE = SCALAR_MODE | ENUM_MODE | TYPE_MODE

data ClientDeclaration
  = InstanceDeclaration DERIVING_MODE (TypeClassInstance ClientMethod)
  | ClientTypeDeclaration CodeGenType

data ClientPreDeclaration
  = ToJSONClass DERIVING_MODE CodeGenType
  | FromJSONClass DERIVING_MODE CodeGenType
  | FromJSONUnionClass CodeGenTypeName [(UnionPat, (CodeGenTypeName, Maybe String))]
  | FromJSONObjectClass CodeGenTypeName CodeGenConstructor
  | RequestTypeClass RequestTypeDefinition
  | ClientType CodeGenType

data ClientTypeDefinition = ClientTypeDefinition
  { ClientTypeDefinition -> CodeGenTypeName
clientTypeName :: CodeGenTypeName,
    ClientTypeDefinition -> [CodeGenConstructor]
clientCons :: [CodeGenConstructor],
    ClientTypeDefinition -> TypeKind
clientKind :: TypeKind
  }
  deriving (Int -> ClientTypeDefinition -> ShowS
[ClientTypeDefinition] -> ShowS
ClientTypeDefinition -> String
(Int -> ClientTypeDefinition -> ShowS)
-> (ClientTypeDefinition -> String)
-> ([ClientTypeDefinition] -> ShowS)
-> Show ClientTypeDefinition
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ClientTypeDefinition -> ShowS
showsPrec :: Int -> ClientTypeDefinition -> ShowS
$cshow :: ClientTypeDefinition -> String
show :: ClientTypeDefinition -> String
$cshowList :: [ClientTypeDefinition] -> ShowS
showList :: [ClientTypeDefinition] -> ShowS
Show)

data RequestTypeDefinition = RequestTypeDefinition
  { RequestTypeDefinition -> TypeName
requestName :: TypeName,
    RequestTypeDefinition -> TypeName
requestArgs :: TypeName,
    RequestTypeDefinition -> OperationType
requestType :: OperationType,
    RequestTypeDefinition -> String
requestQuery :: String
  }
  deriving (Int -> RequestTypeDefinition -> ShowS
[RequestTypeDefinition] -> ShowS
RequestTypeDefinition -> String
(Int -> RequestTypeDefinition -> ShowS)
-> (RequestTypeDefinition -> String)
-> ([RequestTypeDefinition] -> ShowS)
-> Show RequestTypeDefinition
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RequestTypeDefinition -> ShowS
showsPrec :: Int -> RequestTypeDefinition -> ShowS
$cshow :: RequestTypeDefinition -> String
show :: RequestTypeDefinition -> String
$cshowList :: [RequestTypeDefinition] -> ShowS
showList :: [RequestTypeDefinition] -> ShowS
Show)

instance Pretty ClientDeclaration where
  pretty :: forall ann. ClientDeclaration -> Doc ann
pretty (ClientTypeDeclaration CodeGenType
def) = CodeGenType -> Doc ann
forall ann. CodeGenType -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty CodeGenType
def
  pretty (InstanceDeclaration DERIVING_MODE
_ TypeClassInstance ClientMethod
def) = TypeClassInstance ClientMethod -> Doc ann
forall ann. TypeClassInstance ClientMethod -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty TypeClassInstance ClientMethod
def

data ClientMethod
  = PrintableMethod PrintableValue
  | FunctionNameMethod Name
  | MatchMethod ValueMatch
  | ToJSONObjectMethod Name [(FieldName, Name, Name)]
  | FromJSONObjectMethod TypeName [AesonField]
  | FromJSONUnionMethod [([UnionPat], (Name, Maybe Name))]

type AesonField = (Name, Name, FieldName)

instance Pretty ClientMethod where
  pretty :: forall ann. ClientMethod -> Doc ann
pretty (FunctionNameMethod Name
x) = Doc ann
forall ann. Doc ann
space Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Name -> Doc ann
forall ann. Name -> Doc ann
printTHName Name
x
  pretty (PrintableMethod PrintableValue
x) = Doc ann
forall ann. Doc ann
space Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> PrintableValue -> Doc ann
forall ann. PrintableValue -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty PrintableValue
x
  pretty (MatchMethod ValueMatch
x) = Doc ann
forall ann. Doc ann
space Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> ValueMatch -> Doc ann
forall n. ValueMatch -> Doc n
printMatchDoc ValueMatch
x
  pretty (ToJSONObjectMethod Name
name [(FieldName, Name, Name)]
fields) = 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 (Name -> Doc ann
forall ann. Name -> Doc ann
printTHName Name
name 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 (t :: * -> *) ann. Foldable t => t (Doc ann) -> Doc ann
list (((FieldName, Name, Name) -> Doc ann)
-> [(FieldName, Name, Name)] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (FieldName, Name, Name) -> Doc ann
forall {a} {ann}. Show a => (a, Name, Name) -> Doc ann
mkEntry [(FieldName, Name, Name)]
fields)))
    where
      mkEntry :: (a, Name, Name) -> Doc ann
mkEntry (a
n, Name
o, Name
v) = a -> Doc ann
forall a ann. Show a => a -> Doc ann
prettyLit a
n Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Name -> Doc ann
forall ann. Name -> Doc ann
printTHName Name
o Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Name -> Doc ann
forall ann. Name -> Doc ann
printTHName Name
v
  pretty (FromJSONObjectMethod TypeName
name [AesonField]
xs) = Doc ann -> Doc ann
withBody (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ (Name, [AesonField]) -> Doc ann
forall n. (Name, [AesonField]) -> Doc n
printObjectDoc (TypeName -> Name
forall a. ToName a => a -> Name
toName TypeName
name, [AesonField]
xs)
    where
      withBody :: Doc ann -> Doc ann
withBody Doc ann
body = 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
"withObject" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> TypeName -> Doc ann
forall a ann. Show a => a -> Doc ann
prettyLit TypeName
name Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"(\\v ->" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
body Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
")"
  pretty (FromJSONUnionMethod [([UnionPat], (Name, Maybe Name))]
xs) = 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
"withUnion" 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 (t :: * -> *) ann. Foldable t => t (Doc ann) -> Doc ann
tuple [Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
1 ([(Doc ann, Doc ann)] -> Doc ann
forall n. [(Doc n, Doc n)] -> Doc n
matchDoc ([(Doc ann, Doc ann)] -> Doc ann)
-> [(Doc ann, Doc ann)] -> Doc ann
forall a b. (a -> b) -> a -> b
$ (([UnionPat], (Name, Maybe Name)) -> (Doc ann, Doc ann))
-> [([UnionPat], (Name, Maybe Name))] -> [(Doc ann, Doc ann)]
forall a b. (a -> b) -> [a] -> [b]
map ([UnionPat], (Name, Maybe Name)) -> (Doc ann, Doc ann)
forall {ann} {n}.
([UnionPat], (Name, Maybe Name)) -> (Doc ann, Doc n)
toMatch [([UnionPat], (Name, Maybe Name))]
xs) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line]))
    where
      toMatch :: ([UnionPat], (Name, Maybe Name)) -> (Doc ann, Doc n)
toMatch ([UnionPat]
pat, (Name, Maybe Name)
expr) = ([Doc ann] -> Doc ann
forall (t :: * -> *) ann. Foldable t => t (Doc ann) -> Doc ann
tuple ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ (UnionPat -> Doc ann) -> [UnionPat] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map UnionPat -> Doc ann
forall {ann}. UnionPat -> Doc ann
mapP [UnionPat]
pat, (Name, Maybe Name) -> Doc n
forall n. (Name, Maybe Name) -> Doc n
printVariantDoc (Name, Maybe Name)
expr)
      mapP :: UnionPat -> Doc ann
mapP (UString TypeName
v) = TypeName -> Doc ann
forall a ann. Show a => a -> Doc ann
prettyLit TypeName
v
      mapP (UVar String
v) = String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
v

list :: Foldable t => t (Doc ann) -> Doc ann
list :: forall (t :: * -> *) ann. Foldable t => t (Doc ann) -> Doc ann
list t (Doc ann)
xs = Doc ann
"[" 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
1 ((Doc ann -> Doc ann -> Doc ann) -> t (Doc ann) -> Doc ann
forall a. (a -> a -> a) -> t a -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\Doc ann
a Doc ann
b -> Doc ann
a 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
<> Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
b) t (Doc ann)
xs) 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
"]"

tuple :: Foldable t => t (Doc ann) -> Doc ann
tuple :: forall (t :: * -> *) ann. Foldable t => t (Doc ann) -> Doc ann
tuple t (Doc ann)
ls = Doc ann
"(" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> (Doc ann -> Doc ann -> Doc ann) -> t (Doc ann) -> Doc ann
forall a. (a -> a -> a) -> t a -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\Doc ann
a Doc ann
b -> Doc ann
a Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"," Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
b) t (Doc ann)
ls Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
")"

instance PrintExp ClientMethod where
  printExp :: ClientMethod -> Q Exp
printExp (FunctionNameMethod Name
v) = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
v
  printExp (PrintableMethod PrintableValue
v) = PrintableValue -> Q Exp
forall a. PrintExp a => a -> Q Exp
printExp PrintableValue
v
  printExp (MatchMethod ValueMatch
p) = ValueMatch -> Q Exp
printMatchExp ValueMatch
p
  printExp (ToJSONObjectMethod Name
name [(FieldName, Name, Name)]
fields) = Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
name) ([Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ ((FieldName, Name, Name) -> Q Exp)
-> [(FieldName, Name, Name)] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (FieldName, Name, Name) -> Q Exp
forall {m :: * -> *} {a} {a} {a}.
(Quote m, ToString a (m Exp), ToVar a (m Exp), ToVar a (m Exp)) =>
(a, a, a) -> m Exp
mkEntry [(FieldName, Name, Name)]
fields)
    where
      mkEntry :: (a, a, a) -> m Exp
mkEntry (a
n, a
o, a
v) = m Exp -> m Exp -> m Exp -> m Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
uInfixE (a -> m Exp
forall a b. ToString a b => a -> b
toString a
n) (a -> m Exp
forall a b. ToVar a b => a -> b
toVar a
o) (a -> m Exp
forall a b. ToVar a b => a -> b
toVar a
v)
  printExp (FromJSONObjectMethod TypeName
name [AesonField]
fields) = Q Exp -> Q Exp
withBody (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Name, [AesonField]) -> Q Exp
printObjectExp (TypeName -> Name
forall a. ToName a => a -> Name
toName TypeName
name, [AesonField]
fields)
    where
      withBody :: Q Exp -> Q Exp
withBody Q Exp
body = Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall a b. ToVar a b => a -> b
toVar 'withObject) (TypeName -> Q Exp
forall a b. ToString a b => a -> b
toString TypeName
name)) ([PatQ] -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [PatQ
forall a. ToVar Name a => a
v'] Q Exp
body)
  printExp (FromJSONUnionMethod [([UnionPat], (Name, Maybe Name))]
matches) = Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall a b. ToVar a b => a -> b
toVar 'withUnion) ([(PatQ, Q Exp)] -> Q Exp
matchExp ([(PatQ, Q Exp)] -> Q Exp) -> [(PatQ, Q Exp)] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (([UnionPat], (Name, Maybe Name)) -> (PatQ, Q Exp))
-> [([UnionPat], (Name, Maybe Name))] -> [(PatQ, Q Exp)]
forall a b. (a -> b) -> [a] -> [b]
map ([UnionPat], (Name, Maybe Name)) -> (PatQ, Q Exp)
forall {m :: * -> *}.
(Quote m, ToString TypeName (m Pat), ToVar String (m Pat)) =>
([UnionPat], (Name, Maybe Name)) -> (m Pat, Q Exp)
toMatch [([UnionPat], (Name, Maybe Name))]
matches)
    where
      toMatch :: ([UnionPat], (Name, Maybe Name)) -> (m Pat, Q Exp)
toMatch ([UnionPat]
pat, (Name, Maybe Name)
expr) = ([m Pat] -> m Pat
forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP ([m Pat] -> m Pat) -> [m Pat] -> m Pat
forall a b. (a -> b) -> a -> b
$ (UnionPat -> m Pat) -> [UnionPat] -> [m Pat]
forall a b. (a -> b) -> [a] -> [b]
map UnionPat -> m Pat
forall {b}. (ToString TypeName b, ToVar String b) => UnionPat -> b
mapP [UnionPat]
pat, (Name, Maybe Name) -> Q Exp
printVariantExp (Name, Maybe Name)
expr)
      --
      mapP :: UnionPat -> b
mapP (UString TypeName
v) = TypeName -> b
forall a b. ToString a b => a -> b
toString TypeName
v
      mapP (UVar String
v) = String -> b
forall a b. ToVar a b => a -> b
toVar String
v

printVariantExp :: (Name, Maybe Name) -> ExpQ
printVariantExp :: (Name, Maybe Name) -> Q Exp
printVariantExp (Name
con, Just Name
x) = Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
uInfixE (Name -> Q Exp
forall a b. ToCon a b => a -> b
toCon Name
con) [|(<$>)|] (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall a b. ToVar a b => a -> b
toVar 'parseJSON) (Name -> Q Exp
forall a b. ToVar a b => a -> b
toVar Name
x))
printVariantExp (Name
con, Maybe Name
Nothing) = Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [|pure|] (Name -> Q Exp
forall a b. ToCon a b => a -> b
toCon Name
con)

printVariantDoc :: (Name, Maybe Name) -> Doc n
printVariantDoc :: forall n. (Name, Maybe Name) -> Doc n
printVariantDoc (Name
con, Just Name
x) = Name -> Doc n
forall ann. Name -> Doc ann
printTHName Name
con 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
<+> Doc n
"parseJSON" Doc n -> Doc n -> Doc n
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Name -> Doc n
forall ann. Name -> Doc ann
printTHName Name
x
printVariantDoc (Name
con, Maybe Name
Nothing) = Doc n
"pure" Doc n -> Doc n -> Doc n
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Name -> Doc n
forall ann. Name -> Doc ann
printTHName Name
con

printObjectExp :: (Name, [AesonField]) -> ExpQ
printObjectExp :: (Name, [AesonField]) -> Q Exp
printObjectExp (Name
con, [AesonField]
fields)
  | [AesonField] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AesonField]
fields = Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [|pure|] (Name -> Q Exp
forall a b. ToCon a b => a -> b
toCon Name
con)
  | Bool
otherwise = Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
uInfixE (Name -> Q Exp
forall a b. ToCon a b => a -> b
toCon Name
con) [|(<$>)|] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\Q Exp
x -> Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
uInfixE Q Exp
x [|(<*>)|]) ((AesonField -> Q Exp) -> [AesonField] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map AesonField -> Q Exp
printFieldExp [AesonField]
fields)

printObjectDoc :: (Name, [AesonField]) -> Doc n
printObjectDoc :: forall n. (Name, [AesonField]) -> Doc n
printObjectDoc (Name
name, [AesonField]
fields)
  | [AesonField] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AesonField]
fields = Doc n
"pure" Doc n -> Doc n -> Doc n
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Name -> Doc n
forall ann. Name -> Doc ann
printTHName Name
name
  | Bool
otherwise = Name -> Doc n
forall ann. Name -> Doc ann
printTHName Name
name 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
<+> (Doc n -> Doc n -> Doc n) -> [Doc n] -> Doc n
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\Doc n
a Doc n
b -> Doc n
a 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
<+> Doc n
b) ((AesonField -> Doc n) -> [AesonField] -> [Doc n]
forall a b. (a -> b) -> [a] -> [b]
map AesonField -> Doc n
forall n. AesonField -> Doc n
printFieldDoc [AesonField]
fields)

printFieldExp :: AesonField -> ExpQ
printFieldExp :: AesonField -> Q Exp
printFieldExp (Name
v, Name
o, FieldName
str) = Q Exp -> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
uInfixE (Name -> Q Exp
forall a b. ToVar a b => a -> b
toVar Name
v) (Name -> Q Exp
forall a b. ToVar a b => a -> b
toVar Name
o) (FieldName -> Q Exp
forall a b. ToString a b => a -> b
toString FieldName
str)

printFieldDoc :: AesonField -> Doc n
printFieldDoc :: forall n. AesonField -> Doc n
printFieldDoc (Name
v, Name
o, FieldName
l) = Name -> Doc n
forall ann. Name -> Doc ann
printTHName Name
v Doc n -> Doc n -> Doc n
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Name -> Doc n
forall ann. Name -> Doc ann
printTHName Name
o Doc n -> Doc n -> Doc n
forall ann. Doc ann -> Doc ann -> Doc ann
<+> FieldName -> Doc n
forall a ann. Show a => a -> Doc ann
prettyLit FieldName
l

prettyLit :: Show a => a -> Doc ann
prettyLit :: forall a ann. Show a => a -> Doc ann
prettyLit a
a = 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
a)

prettyName :: TypeName -> Doc ann
prettyName :: forall ann. TypeName -> Doc ann
prettyName TypeName
a = 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
a :: Text)

data UnionPat
  = UString TypeName
  | UVar String

data MValue
  = MFrom TypeName TypeName
  | MTo TypeName TypeName
  | MFunction String Name

type ValueMatch = [MValue]

printMatchDoc :: ValueMatch -> Doc n
printMatchDoc :: forall n. ValueMatch -> Doc n
printMatchDoc = [(Doc n, Doc n)] -> Doc n
forall n. [(Doc n, Doc n)] -> Doc n
matchDoc ([(Doc n, Doc n)] -> Doc n)
-> (ValueMatch -> [(Doc n, Doc n)]) -> ValueMatch -> Doc n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MValue -> (Doc n, Doc n)) -> ValueMatch -> [(Doc n, Doc n)]
forall a b. (a -> b) -> [a] -> [b]
map MValue -> (Doc n, Doc n)
forall {ann} {ann}. MValue -> (Doc ann, Doc ann)
buildMatch
  where
    buildMatch :: MValue -> (Doc ann, Doc ann)
buildMatch (MFrom TypeName
a TypeName
b) = (TypeName -> Doc ann
forall a ann. Show a => a -> Doc ann
prettyLit TypeName
a, Doc ann
"pure" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> TypeName -> Doc ann
forall ann. TypeName -> Doc ann
prettyName TypeName
b)
    buildMatch (MTo TypeName
a TypeName
b) = (TypeName -> Doc ann
forall ann. TypeName -> Doc ann
prettyName TypeName
a, TypeName -> Doc ann
forall a ann. Show a => a -> Doc ann
prettyLit TypeName
b)
    buildMatch (MFunction String
v Name
name) = (String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
v, 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
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
v)

printMatchExp :: ValueMatch -> ExpQ
printMatchExp :: ValueMatch -> Q Exp
printMatchExp = [(PatQ, Q Exp)] -> Q Exp
matchExp ([(PatQ, Q Exp)] -> Q Exp)
-> (ValueMatch -> [(PatQ, Q Exp)]) -> ValueMatch -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MValue -> (PatQ, Q Exp)) -> ValueMatch -> [(PatQ, Q Exp)]
forall a b. (a -> b) -> [a] -> [b]
map MValue -> (PatQ, Q Exp)
forall {m :: * -> *} {a}.
(Quote m, ToCon TypeName a, ToCon TypeName (m Exp),
 ToString TypeName a, ToString TypeName (m Exp), ToVar String a,
 ToVar Name (m Exp)) =>
MValue -> (a, m Exp)
buildMatch
  where
    buildMatch :: MValue -> (a, m Exp)
buildMatch (MFrom TypeName
a TypeName
b) = (TypeName -> a
forall a b. ToString a b => a -> b
toString TypeName
a, m Exp -> m Exp -> m Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> m Exp
forall a b. ToVar a b => a -> b
toVar 'pure) (TypeName -> m Exp
forall a b. ToCon a b => a -> b
toCon TypeName
b))
    buildMatch (MTo TypeName
a TypeName
b) = (TypeName -> a
forall a b. ToCon a b => a -> b
toCon TypeName
a, TypeName -> m Exp
forall a b. ToString a b => a -> b
toString TypeName
b)
    buildMatch (MFunction String
v Name
name) = (String -> a
forall a b. ToVar a b => a -> b
toVar String
v, m Exp -> m Exp -> m Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
name) m Exp
forall a. ToVar Name a => a
v')

matchExp :: [(PatQ, ExpQ)] -> ExpQ
matchExp :: [(PatQ, Q Exp)] -> Q Exp
matchExp [(PatQ, Q Exp)]
xs = [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => [m Match] -> m Exp
lamCaseE (((PatQ, Q Exp) -> Q Match) -> [(PatQ, Q Exp)] -> [Q Match]
forall a b. (a -> b) -> [a] -> [b]
map (PatQ, Q Exp) -> Q Match
forall {m :: * -> *}. Quote m => (m Pat, m Exp) -> m Match
buildMatch [(PatQ, Q Exp)]
xs)
  where
    buildMatch :: (m Pat, m Exp) -> m Match
buildMatch (m Pat
pat, m Exp
fb) = m Pat -> m Body -> [m Dec] -> m Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match m Pat
pat (m Exp -> m Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB m Exp
fb) []

matchDoc :: [(Doc n, Doc n)] -> Doc n
matchDoc :: forall n. [(Doc n, Doc n)] -> Doc n
matchDoc = ((Doc n
"\\case" Doc n -> Doc n -> Doc n
forall a. Semigroup a => a -> a -> a
<> Doc n
forall ann. Doc ann
line) Doc n -> Doc n -> Doc n
forall a. Semigroup a => a -> a -> a
<>) (Doc n -> Doc n)
-> ([(Doc n, Doc n)] -> Doc n) -> [(Doc n, Doc n)] -> Doc n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Doc n -> Doc n
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc n -> Doc n)
-> ([(Doc n, Doc n)] -> Doc n) -> [(Doc n, Doc n)] -> Doc n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc n] -> Doc n
forall ann. [Doc ann] -> Doc ann
vsep ([Doc n] -> Doc n)
-> ([(Doc n, Doc n)] -> [Doc n]) -> [(Doc n, Doc n)] -> Doc n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Doc n, Doc n) -> Doc n) -> [(Doc n, Doc n)] -> [Doc n]
forall a b. (a -> b) -> [a] -> [b]
map (Doc n, Doc n) -> Doc n
forall {ann}. (Doc ann, Doc ann) -> Doc ann
buildMatch
  where
    buildMatch :: (Doc ann, Doc ann) -> Doc ann
buildMatch (Doc ann
pat, Doc ann
fb) = Doc ann
pat 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
<+> Doc ann
fb