{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.CodeGen.Internal.TH
( _',
apply,
applyCons,
applyVars,
declareTypeRef,
funDSimple,
camelCaseFieldName,
camelCaseTypeName,
toCon,
toVar,
ToName (..),
toString,
typeInstanceDec,
v',
vars,
wrappedType,
)
where
import Data.Morpheus.CodeGen.Internal.Name
( camelCaseFieldName,
camelCaseTypeName,
toHaskellName,
toHaskellTypeName,
)
import Data.Morpheus.Types.Internal.AST
( FieldName,
TypeName,
TypeRef (..),
TypeWrapper (..),
unpackName,
)
import qualified Data.Text as T
import Language.Haskell.TH
import Relude hiding
( ToString (..),
Type,
)
_' :: PatQ
_' :: PatQ
_' = Name -> PatQ
forall a b. ToVar a b => a -> b
toVar (String -> Name
mkName String
"_")
v' :: ToVar Name a => a
v' :: a
v' = Name -> a
forall a b. ToVar a b => a -> b
toVar (String -> Name
mkName String
"v")
wrappedType :: TypeWrapper -> Type -> Type
wrappedType :: TypeWrapper -> Type -> Type
wrappedType (TypeList TypeWrapper
xs Bool
nonNull) = Bool -> Type -> Type
withNonNull Bool
nonNull (Type -> Type) -> (Type -> Type) -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
withList (Type -> Type) -> (Type -> Type) -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeWrapper -> Type -> Type
wrappedType TypeWrapper
xs
wrappedType (BaseType Bool
nonNull) = Bool -> Type -> Type
withNonNull Bool
nonNull
{-# INLINE wrappedType #-}
declareTypeRef :: (TypeName -> Type) -> TypeRef -> Type
declareTypeRef :: (TypeName -> Type) -> TypeRef -> Type
declareTypeRef TypeName -> Type
f TypeRef {TypeName
typeConName :: TypeRef -> TypeName
typeConName :: TypeName
typeConName, TypeWrapper
typeWrappers :: TypeRef -> TypeWrapper
typeWrappers :: TypeWrapper
typeWrappers} =
TypeWrapper -> Type -> Type
wrappedType TypeWrapper
typeWrappers (TypeName -> Type
f TypeName
typeConName)
{-# INLINE declareTypeRef #-}
withList :: Type -> Type
withList :: Type -> Type
withList = Type -> Type -> Type
AppT (Name -> Type
ConT ''[])
withNonNull :: Bool -> Type -> Type
withNonNull :: Bool -> Type -> Type
withNonNull Bool
True = Type -> Type
forall a. a -> a
id
withNonNull Bool
False = Type -> Type -> Type
AppT (Name -> Type
ConT ''Maybe)
{-# INLINE withNonNull #-}
cons :: ToCon a b => [a] -> [b]
cons :: [a] -> [b]
cons = (a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map a -> b
forall a b. ToCon a b => a -> b
toCon
vars :: ToVar a b => [a] -> [b]
vars :: [a] -> [b]
vars = (a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map a -> b
forall a b. ToVar a b => a -> b
toVar
class ToName a where
toName :: a -> Name
instance ToName String where
toName :: String -> Name
toName = String -> Name
mkName
instance ToName Name where
toName :: Name -> Name
toName = Name -> Name
forall a. a -> a
id
instance ToName Text where
toName :: Text -> Name
toName = String -> Name
forall a. ToName a => a -> Name
toName (String -> Name) -> (Text -> String) -> Text -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
instance ToName TypeName where
toName :: TypeName -> Name
toName = Text -> Name
forall a. ToName a => a -> Name
toName (Text -> Name) -> (TypeName -> Text) -> TypeName -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> Text
toHaskellTypeName
instance ToName FieldName where
toName :: FieldName -> Name
toName = String -> Name
mkName (String -> Name) -> (FieldName -> String) -> FieldName -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> String
toHaskellName
class ToString a b where
toString :: a -> b
instance ToString a b => ToString a (Q b) where
toString :: a -> Q b
toString = b -> Q b
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> Q b) -> (a -> b) -> a -> Q b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
forall a b. ToString a b => a -> b
toString
instance ToString TypeName Lit where
toString :: TypeName -> Lit
toString = String -> Lit
stringL (String -> Lit) -> (TypeName -> String) -> TypeName -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String) -> (TypeName -> Text) -> TypeName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> Text
forall a (t :: NAME). NamePacking a => Name t -> a
unpackName
instance ToString TypeName Pat where
toString :: TypeName -> Pat
toString = Lit -> Pat
LitP (Lit -> Pat) -> (TypeName -> Lit) -> TypeName -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> Lit
forall a b. ToString a b => a -> b
toString
instance ToString FieldName Lit where
toString :: FieldName -> Lit
toString = String -> Lit
stringL (String -> Lit) -> (FieldName -> String) -> FieldName -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String) -> (FieldName -> Text) -> FieldName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> Text
forall a (t :: NAME). NamePacking a => Name t -> a
unpackName
instance ToString TypeName Exp where
toString :: TypeName -> Exp
toString = Lit -> Exp
LitE (Lit -> Exp) -> (TypeName -> Lit) -> TypeName -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> Lit
forall a b. ToString a b => a -> b
toString
instance ToString FieldName Exp where
toString :: FieldName -> Exp
toString = Lit -> Exp
LitE (Lit -> Exp) -> (FieldName -> Lit) -> FieldName -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> Lit
forall a b. ToString a b => a -> b
toString
class ToCon a b where
toCon :: a -> b
instance ToCon a b => ToCon a (Q b) where
toCon :: a -> Q b
toCon = b -> Q b
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> Q b) -> (a -> b) -> a -> Q b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
forall a b. ToCon a b => a -> b
toCon
instance (ToName a) => ToCon a Type where
toCon :: a -> Type
toCon = Name -> Type
ConT (Name -> Type) -> (a -> Name) -> a -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Name
forall a. ToName a => a -> Name
toName
instance (ToName a) => ToCon a Exp where
toCon :: a -> Exp
toCon = Name -> Exp
ConE (Name -> Exp) -> (a -> Name) -> a -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Name
forall a. ToName a => a -> Name
toName
class ToVar a b where
toVar :: a -> b
instance ToVar a b => ToVar a (Q b) where
toVar :: a -> Q b
toVar = b -> Q b
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> Q b) -> (a -> b) -> a -> Q b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
forall a b. ToVar a b => a -> b
toVar
instance (ToName a) => ToVar a Type where
toVar :: a -> Type
toVar = Name -> Type
VarT (Name -> Type) -> (a -> Name) -> a -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Name
forall a. ToName a => a -> Name
toName
instance (ToName a) => ToVar a Exp where
toVar :: a -> Exp
toVar = Name -> Exp
VarE (Name -> Exp) -> (a -> Name) -> a -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Name
forall a. ToName a => a -> Name
toName
instance (ToName a) => ToVar a Pat where
toVar :: a -> Pat
toVar = Name -> Pat
VarP (Name -> Pat) -> (a -> Name) -> a -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Name
forall a. ToName a => a -> Name
toName
class Apply a where
apply :: ToCon i a => i -> [a] -> a
instance Apply TypeQ where
apply :: i -> [TypeQ] -> TypeQ
apply = (TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' TypeQ -> TypeQ -> TypeQ
appT (TypeQ -> [TypeQ] -> TypeQ)
-> (i -> TypeQ) -> i -> [TypeQ] -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> TypeQ
forall a b. ToCon a b => a -> b
toCon
instance Apply Type where
apply :: i -> [Type] -> Type
apply = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
AppT (Type -> [Type] -> Type) -> (i -> Type) -> i -> [Type] -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> Type
forall a b. ToCon a b => a -> b
toCon
instance Apply Exp where
apply :: i -> [Exp] -> Exp
apply = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Exp -> Exp -> Exp
AppE (Exp -> [Exp] -> Exp) -> (i -> Exp) -> i -> [Exp] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> Exp
forall a b. ToCon a b => a -> b
toCon
instance Apply ExpQ where
apply :: i -> [ExpQ] -> ExpQ
apply = (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ExpQ -> ExpQ -> ExpQ
appE (ExpQ -> [ExpQ] -> ExpQ) -> (i -> ExpQ) -> i -> [ExpQ] -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> ExpQ
forall a b. ToCon a b => a -> b
toCon
applyVars ::
( ToName con,
ToName var,
Apply res,
ToCon con res,
ToVar var res
) =>
con ->
[var] ->
res
applyVars :: con -> [var] -> res
applyVars con
name [var]
li = con -> [res] -> res
forall a i. (Apply a, ToCon i a) => i -> [a] -> a
apply con
name ([var] -> [res]
forall a b. ToVar a b => [a] -> [b]
vars [var]
li)
applyCons :: (ToName con, ToName cons) => con -> [cons] -> Q Type
applyCons :: con -> [cons] -> TypeQ
applyCons con
name [cons]
li = con -> [TypeQ] -> TypeQ
forall a i. (Apply a, ToCon i a) => i -> [a] -> a
apply con
name ([cons] -> [TypeQ]
forall a b. ToCon a b => [a] -> [b]
cons [cons]
li)
funDSimple :: Name -> [PatQ] -> ExpQ -> DecQ
funDSimple :: Name -> [PatQ] -> ExpQ -> DecQ
funDSimple Name
name [PatQ]
args ExpQ
body = Name -> [ClauseQ] -> DecQ
funD Name
name [[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [PatQ]
args (ExpQ -> BodyQ
normalB ExpQ
body) []]
#if MIN_VERSION_template_haskell(2,15,0)
typeInstanceDec :: Name -> Type -> Type -> Dec
typeInstanceDec :: Name -> Type -> Type -> Dec
typeInstanceDec Name
typeFamily Type
arg Type
res = TySynEqn -> Dec
TySynInstD (Maybe [TyVarBndr] -> Type -> Type -> TySynEqn
TySynEqn Maybe [TyVarBndr]
forall a. Maybe a
Nothing (Type -> Type -> Type
AppT (Name -> Type
ConT Name
typeFamily) Type
arg) Type
res)
#else
typeInstanceDec :: Name -> Type -> Type -> Dec
typeInstanceDec typeFamily arg res = TySynInstD typeFamily (TySynEqn [arg] res)
#endif