{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Client.CodeGen.TH
  ( deriveIfNotDefined,
    declareIfNotDeclared,
  )
where

import Data.Morpheus.CodeGen.Internal.AST
  ( CodeGenType (..),
    CodeGenTypeName (..),
    TypeClassInstance (..),
    getFullName,
  )
import Data.Morpheus.CodeGen.TH (toName)
import Language.Haskell.TH
import Relude

isTypeDeclared :: CodeGenTypeName -> Q Bool
isTypeDeclared :: CodeGenTypeName -> Q Bool
isTypeDeclared CodeGenTypeName
name = Maybe Name -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Name -> Bool) -> Q (Maybe Name) -> Q Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q (Maybe Name)
lookupTypeName (TypeName -> String
forall a. ToString a => a -> String
toString (TypeName -> String) -> TypeName -> String
forall a b. (a -> b) -> a -> b
$ CodeGenTypeName -> TypeName
getFullName CodeGenTypeName
name)

isInstanceDefined :: Name -> CodeGenTypeName -> Q Bool
isInstanceDefined :: Name -> CodeGenTypeName -> Q Bool
isInstanceDefined Name
typeClass CodeGenTypeName
tName = do
  Bool
exists <- CodeGenTypeName -> Q Bool
isTypeDeclared CodeGenTypeName
tName
  if Bool
exists
    then Name -> [Type] -> Q Bool
isInstance Name
typeClass [Name -> Type
ConT (CodeGenTypeName -> Name
forall a. ToName a => a -> Name
toName CodeGenTypeName
tName)]
    else Bool -> Q Bool
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

deriveIfNotDefined :: (TypeClassInstance a -> Q Dec) -> TypeClassInstance a -> Q [Dec]
deriveIfNotDefined :: forall a.
(TypeClassInstance a -> Q Dec) -> TypeClassInstance a -> Q [Dec]
deriveIfNotDefined TypeClassInstance a -> Q Dec
f TypeClassInstance a
dec = do
  Bool
exists <- Name -> CodeGenTypeName -> Q Bool
isInstanceDefined (TypeClassInstance a -> Name
forall body. TypeClassInstance body -> Name
typeClassName TypeClassInstance a
dec) (TypeClassInstance a -> CodeGenTypeName
forall body. TypeClassInstance body -> CodeGenTypeName
typeClassTarget TypeClassInstance a
dec)
  (TypeClassInstance a -> Q Dec) -> [TypeClassInstance a] -> Q [Dec]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse TypeClassInstance a -> Q Dec
f [TypeClassInstance a
dec | Bool -> Bool
not Bool
exists]

declareIfNotDeclared :: (CodeGenType -> Q a) -> CodeGenType -> Q [a]
declareIfNotDeclared :: forall a. (CodeGenType -> Q a) -> CodeGenType -> Q [a]
declareIfNotDeclared CodeGenType -> Q a
f CodeGenType
codeGenType = do
  Bool
exists <- CodeGenTypeName -> Q Bool
isTypeDeclared (CodeGenType -> CodeGenTypeName
cgTypeName CodeGenType
codeGenType)
  (CodeGenType -> Q a) -> [CodeGenType] -> Q [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse CodeGenType -> Q a
f [CodeGenType
codeGenType | Bool -> Bool
not Bool
exists]