{-# 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
_' = forall a b. ToVar a b => a -> b
toVar (String -> Name
mkName String
"_")

v' :: ToVar Name a => a
v' :: forall a. ToVar Name a => a
v' = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
withList 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 = 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 :: forall a b. ToCon a b => [a] -> [b]
cons = forall a b. (a -> b) -> [a] -> [b]
map forall a b. ToCon a b => a -> b
toCon

vars :: ToVar a b => [a] -> [b]
vars :: forall a b. ToVar a b => [a] -> [b]
vars = forall a b. (a -> b) -> [a] -> [b]
map 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 = forall a. a -> a
id

instance ToName Text where
  toName :: Text -> Name
toName = forall a. ToName a => a -> Name
toName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

instance ToName TypeName where
  toName :: TypeName -> Name
toName = forall a. ToName a => a -> Name
toName forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> Text
toHaskellTypeName

instance ToName FieldName where
  toName :: FieldName -> Name
toName = String -> Name
mkName 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ToString a b => a -> b
toString

instance ToString TypeName Lit where
  toString :: TypeName -> Lit
toString = String -> Lit
stringL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (t :: NAME). NamePacking a => Name t -> a
unpackName

instance ToString TypeName Pat where
  toString :: TypeName -> Pat
toString = Lit -> Pat
LitP forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ToString a b => a -> b
toString

instance ToString FieldName Lit where
  toString :: FieldName -> Lit
toString = String -> Lit
stringL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (t :: NAME). NamePacking a => Name t -> a
unpackName

instance ToString TypeName Exp where
  toString :: TypeName -> Exp
toString = Lit -> Exp
LitE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ToString a b => a -> b
toString

instance ToString FieldName Exp where
  toString :: FieldName -> Exp
toString = Lit -> Exp
LitE forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ToCon a b => a -> b
toCon

instance (ToName a) => ToCon a Type where
  toCon :: a -> Type
toCon = Name -> Type
ConT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToName a => a -> Name
toName

instance (ToName a) => ToCon a Exp where
  toCon :: a -> Exp
toCon = Name -> Exp
ConE forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ToVar a b => a -> b
toVar

instance (ToName a) => ToVar a Type where
  toVar :: a -> Type
toVar = Name -> Type
VarT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToName a => a -> Name
toName

instance (ToName a) => ToVar a Exp where
  toVar :: a -> Exp
toVar = Name -> Exp
VarE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToName a => a -> Name
toName

instance (ToName a) => ToVar a Pat where
  toVar :: a -> Pat
toVar = Name -> Pat
VarP forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToName a => a -> Name
toName

class Apply a where
  apply :: ToCon i a => i -> [a] -> a

instance Apply TypeQ where
  apply :: forall i. ToCon i TypeQ => i -> [TypeQ] -> TypeQ
apply = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ToCon a b => a -> b
toCon

instance Apply Type where
  apply :: forall i. ToCon i Type => i -> [Type] -> Type
apply = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
AppT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ToCon a b => a -> b
toCon

instance Apply Exp where
  apply :: forall i. ToCon i Exp => i -> [Exp] -> Exp
apply = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Exp -> Exp -> Exp
AppE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ToCon a b => a -> b
toCon

instance Apply ExpQ where
  apply :: forall i. ToCon i ExpQ => i -> [ExpQ] -> ExpQ
apply = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall con var res.
(ToName con, ToName var, Apply res, ToCon con res,
 ToVar var res) =>
con -> [var] -> res
applyVars con
name [var]
li = forall a i. (Apply a, ToCon i a) => i -> [a] -> a
apply con
name (forall a b. ToVar a b => [a] -> [b]
vars [var]
li)

applyCons :: (ToName con, ToName cons) => con -> [cons] -> Q Type
applyCons :: forall con cons.
(ToName con, ToName cons) =>
con -> [cons] -> TypeQ
applyCons con
name [cons]
li = forall a i. (Apply a, ToCon i a) => i -> [a] -> a
apply con
name (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 = forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
name [forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [PatQ]
args (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB ExpQ
body) []]

#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 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