{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Internal.TH
  ( _',
    apply,
    applyCons,
    applyVars,
    decArgs,
    declareTypeRef,
    funDProxy,
    funDSimple,
    infoTyVars,
    isEnum,
    m',
    nameSpaceField,
    nameSpaceType,
    toCon,
    toConE,
    toConT,
    toVar,
    ToName (..),
    toString,
    toVarE,
    toVarT,
    tyConArgs,
    typeInstanceDec,
    v',
    cat',
    _2',
    o',
    e',
    vars,
  )
where

import Data.Foldable (foldl)
import Data.Morpheus.Internal.Utils
  ( capitalize,
    nameSpaceField,
    nameSpaceType,
  )
import Data.Morpheus.Types.Internal.AST
  ( FieldName (..),
    TypeKind (..),
    TypeName (..),
    TypeRef (..),
    TypeWrapper (..),
    convertToHaskellName,
    isEnum,
    isOutputObject,
    readName,
  )
import Data.Text (unpack)
import Language.Haskell.TH
import Relude hiding (ToString (..), Type)

m' :: Type
m' :: Type
m' = Name -> Type
VarT (String -> Name
mkName String
"m")

o' :: Type
o' :: Type
o' = Name -> Type
VarT (String -> Name
mkName String
"o")

e' :: Type
e' :: Type
e' = Name -> Type
VarT (String -> Name
mkName String
"event")

_' :: PatQ
_' :: PatQ
_' = Name -> PatQ
forall a b. ToVar a b => a -> b
toVar (String -> Name
mkName String
"_")

_2' :: PatQ
_2' :: PatQ
_2' = Name -> PatQ
forall a b. ToVar a b => a -> b
toVar (String -> Name
mkName String
"_2")

v' :: ToVar Name a => a
v' :: a
v' = Name -> a
forall a b. ToVar a b => a -> b
toVar (String -> Name
mkName String
"v")

cat' :: Type
cat' :: Type
cat' = Name -> Type
VarT (String -> Name
mkName String
"cat")

declareTypeRef :: TypeRef -> Type
declareTypeRef :: TypeRef -> Type
declareTypeRef TypeRef {TypeName
typeConName :: TypeRef -> TypeName
typeConName :: TypeName
typeConName, [TypeWrapper]
typeWrappers :: TypeRef -> [TypeWrapper]
typeWrappers :: [TypeWrapper]
typeWrappers, Maybe String
typeArgs :: TypeRef -> Maybe String
typeArgs :: Maybe String
typeArgs} =
  [TypeWrapper] -> Type
wrappedT
    [TypeWrapper]
typeWrappers
  where
    wrappedT :: [TypeWrapper] -> Type
    wrappedT :: [TypeWrapper] -> Type
wrappedT (TypeWrapper
TypeList : [TypeWrapper]
xs) = Type -> Type -> Type
AppT (Name -> Type
ConT ''[]) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ [TypeWrapper] -> Type
wrappedT [TypeWrapper]
xs
    wrappedT (TypeWrapper
TypeMaybe : [TypeWrapper]
xs) = Type -> Type -> Type
AppT (Name -> Type
ConT ''Maybe) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ [TypeWrapper] -> Type
wrappedT [TypeWrapper]
xs
    wrappedT [] = Maybe String -> Type
decType Maybe String
typeArgs
    --------------------------------------------
    decType :: Maybe String -> Type
    decType :: Maybe String -> Type
decType (Just String
par) = TypeName -> [Type] -> Type
forall a i. (Apply a, ToCon i a) => i -> [a] -> a
apply TypeName
typeConName [String -> Type
forall a b. ToVar a b => a -> b
toVar String
par]
    decType Maybe String
_ = TypeName -> Type
forall a b. ToCon a b => a -> b
toCon TypeName
typeConName

tyConArgs :: TypeKind -> [String]
tyConArgs :: TypeKind -> [String]
tyConArgs TypeKind
kindD
  | TypeKind -> Bool
isOutputObject TypeKind
kindD Bool -> Bool -> Bool
|| TypeKind
kindD TypeKind -> TypeKind -> Bool
forall a. Eq a => a -> a -> Bool
== TypeKind
KindUnion = [String
"m"]
  | Bool
otherwise = []

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 TypeName where
  toName :: TypeName -> Name
toName = String -> Name
mkName (String -> Name) -> (TypeName -> String) -> TypeName -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack (Text -> String) -> (TypeName -> Text) -> TypeName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
capitalize (Text -> Text) -> (TypeName -> Text) -> TypeName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> Text
readTypeName

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
. Text -> String
unpack (Text -> String) -> (FieldName -> Text) -> FieldName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> Text
readName (FieldName -> Text)
-> (FieldName -> FieldName) -> FieldName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> FieldName
convertToHaskellName

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
unpack (Text -> String) -> (TypeName -> Text) -> TypeName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> Text
readTypeName

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 (FieldName Text
x) = String -> Lit
stringL (Text -> String
unpack Text
x)

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)

funDProxy :: [(Name, ExpQ)] -> [DecQ]
funDProxy :: [(Name, ExpQ)] -> [DecQ]
funDProxy = ((Name, ExpQ) -> DecQ) -> [(Name, ExpQ)] -> [DecQ]
forall a b. (a -> b) -> [a] -> [b]
map (Name, ExpQ) -> DecQ
fun
  where
    fun :: (Name, ExpQ) -> DecQ
fun (Name
name, ExpQ
body) = Name -> [PatQ] -> ExpQ -> DecQ
funDSimple Name
name [PatQ
_'] ExpQ
body

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) []]

infoTyVars :: Info -> [TyVarBndr]
infoTyVars :: Info -> [TyVarBndr]
infoTyVars (TyConI Dec
x) = Dec -> [TyVarBndr]
decArgs Dec
x
infoTyVars Info
_ = []

decArgs :: Dec -> [TyVarBndr]
decArgs :: Dec -> [TyVarBndr]
decArgs (DataD [Type]
_ Name
_ [TyVarBndr]
args Maybe Type
_ [Con]
_ [DerivClause]
_) = [TyVarBndr]
args
decArgs (NewtypeD [Type]
_ Name
_ [TyVarBndr]
args Maybe Type
_ Con
_ [DerivClause]
_) = [TyVarBndr]
args
decArgs (TySynD Name
_ [TyVarBndr]
args Type
_) = [TyVarBndr]
args
decArgs Dec
_ = []

toConT :: ToName a => a -> Q Type
toConT :: a -> TypeQ
toConT = Name -> TypeQ
conT (Name -> TypeQ) -> (a -> Name) -> a -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Name
forall a. ToName a => a -> Name
toName

toVarT :: ToVar a TypeQ => a -> TypeQ
toVarT :: a -> TypeQ
toVarT = a -> TypeQ
forall a b. ToVar a b => a -> b
toVar

toVarE :: ToVar a Exp => a -> ExpQ
toVarE :: a -> ExpQ
toVarE = a -> ExpQ
forall a b. ToVar a b => a -> b
toVar

toConE :: ToCon a Exp => a -> ExpQ
toConE :: a -> ExpQ
toConE = a -> ExpQ
forall a b. ToCon a b => a -> b
toCon

#if MIN_VERSION_template_haskell(2,15,0)
-- fix breaking changes
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