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

module Data.Morpheus.Client.Internal.TH
  ( matchWith,
    decodeObjectE,
    mkFieldsE,
    failExp,
    deriveIfNotDefined,
    declareIfNotDeclared,
  )
where

import Data.Aeson ((.:))
import Data.Aeson.Types ((.:?))
import Data.Foldable (foldr1)
import Data.Morpheus.CodeGen.Internal.AST
  ( CodeGenConstructor (..),
    CodeGenField (..),
    CodeGenType (cgTypeName),
    CodeGenTypeName (..),
    getFullName,
  )
import Data.Morpheus.CodeGen.TH
  ( toCon,
    toName,
    toString,
    toVar,
    v',
  )
import Data.Morpheus.CodeGen.Utils
  ( camelCaseFieldName,
  )
import Language.Haskell.TH
import Relude hiding (toString)

matchWith ::
  Maybe (PatQ, ExpQ) ->
  (t -> (PatQ, ExpQ)) ->
  [t] ->
  ExpQ
matchWith :: forall t.
Maybe (PatQ, Q Exp) -> (t -> (PatQ, Q Exp)) -> [t] -> Q Exp
matchWith Maybe (PatQ, Q Exp)
fbexp t -> (PatQ, Q Exp)
f [t]
xs = forall (m :: * -> *). Quote m => [m Match] -> m Exp
lamCaseE (forall a b. (a -> b) -> [a] -> [b]
map t -> Q Match
buildMatch [t]
xs forall a. Semigroup a => a -> a -> a
<> forall {m :: * -> *}. Quote m => Maybe (m Pat, m Exp) -> [m Match]
fallback Maybe (PatQ, Q Exp)
fbexp)
  where
    fallback :: Maybe (m Pat, m Exp) -> [m Match]
fallback (Just (m Pat
pat, m Exp
fb)) = [forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match m Pat
pat (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB m Exp
fb) []]
    fallback Maybe (m Pat, m Exp)
_ = []
    buildMatch :: t -> Q Match
buildMatch t
x = forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match PatQ
pat (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body) []
      where
        (PatQ
pat, Q Exp
body) = t -> (PatQ, Q Exp)
f t
x

failExp :: ExpQ
failExp :: Q Exp
failExp =
  forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
    (forall a b. ToVar a b => a -> b
toVar 'fail)
    ( forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
uInfixE
        (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [|show|] forall a. ToVar Name a => a
v')
        [|(<>)|]
        (forall (m :: * -> *). Quote m => String -> m Exp
stringE String
" is Not Valid Union Constructor")
    )

decodeObjectE :: CodeGenConstructor -> ExpQ
decodeObjectE :: CodeGenConstructor -> Q Exp
decodeObjectE CodeGenConstructor {[CodeGenField]
CodeGenTypeName
constructorName :: CodeGenConstructor -> CodeGenTypeName
constructorFields :: CodeGenConstructor -> [CodeGenField]
constructorFields :: [CodeGenField]
constructorName :: CodeGenTypeName
..}
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CodeGenField]
constructorFields = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [|pure|] (forall a b. ToCon a b => a -> b
toCon CodeGenTypeName
constructorName)
  | Bool
otherwise =
      forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
uInfixE
        (forall a b. ToCon a b => a -> b
toCon CodeGenTypeName
constructorName)
        [|(<$>)|]
        (forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Q Exp -> Q Exp -> Q Exp
withApplicative forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map CodeGenField -> Q Exp
defField [CodeGenField]
constructorFields)

defField :: CodeGenField -> ExpQ
defField :: CodeGenField -> Q Exp
defField CodeGenField {Bool
[FIELD_TYPE_WRAPPER]
FieldName
TypeName
fieldName :: CodeGenField -> FieldName
fieldType :: CodeGenField -> TypeName
wrappers :: CodeGenField -> [FIELD_TYPE_WRAPPER]
fieldIsNullable :: CodeGenField -> Bool
fieldIsNullable :: Bool
wrappers :: [FIELD_TYPE_WRAPPER]
fieldType :: TypeName
fieldName :: FieldName
..} = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
uInfixE forall a. ToVar Name a => a
v' (forall (m :: * -> *). Quote m => Name -> m Exp
varE forall a b. (a -> b) -> a -> b
$ Bool -> Name
bindField Bool
fieldIsNullable) (forall a b. ToString a b => a -> b
toString FieldName
fieldName)

bindField :: Bool -> Name
bindField :: Bool -> Name
bindField Bool
nullable
  | Bool
nullable = '(.:?)
  | Bool
otherwise = '(.:)

withApplicative :: ExpQ -> ExpQ -> ExpQ
withApplicative :: Q Exp -> Q Exp -> Q Exp
withApplicative Q Exp
x = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
uInfixE Q Exp
x [|(<*>)|]

-- | 'mkFieldsE'
--
--  input :
--  >>>
--       mkFieldsE 'mkValue [FieldDefinition { fieldName = \"field1" ,..} ,..]
--  >>>
--
--  expression :
--  >>>
--    [ mkValue \"field1\" field1,
--    ..
--    ]
-- >>>
mkFieldsE :: CodeGenTypeName -> Name -> [CodeGenField] -> Exp
mkFieldsE :: CodeGenTypeName -> Name -> [CodeGenField] -> Exp
mkFieldsE CodeGenTypeName
conName Name
name = [Exp] -> Exp
ListE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (CodeGenTypeName -> Name -> CodeGenField -> Exp
mkEntryWith CodeGenTypeName
conName Name
name)

--  input : mkFieldWith 'mkValue (FieldDefinition { fieldName = "field1", ..})
--  expression: mkValue "field1"  field1
mkEntryWith ::
  CodeGenTypeName ->
  Name ->
  CodeGenField ->
  Exp
mkEntryWith :: CodeGenTypeName -> Name -> CodeGenField -> Exp
mkEntryWith CodeGenTypeName
conName Name
f CodeGenField {FieldName
fieldName :: FieldName
fieldName :: CodeGenField -> FieldName
fieldName} =
  Exp -> Exp -> Exp
AppE
    (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
f) (forall a b. ToString a b => a -> b
toString FieldName
fieldName))
    (forall a b. ToVar a b => a -> b
toVar forall a b. (a -> b) -> a -> b
$ TypeName -> FieldName -> FieldName
camelCaseFieldName (CodeGenTypeName -> TypeName
getFullName CodeGenTypeName
conName) FieldName
fieldName)

isTypeDeclared :: CodeGenTypeName -> Q Bool
isTypeDeclared :: CodeGenTypeName -> Q Bool
isTypeDeclared CodeGenTypeName
clientTypeName = do
  let name :: Name
name = forall a. ToName a => a -> Name
toName CodeGenTypeName
clientTypeName
  Maybe Name
m <- String -> Q (Maybe Name)
lookupTypeName (forall b a. (Show a, IsString b) => a -> b
show Name
name)
  case Maybe Name
m of
    Maybe Name
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Maybe Name
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

hasInstance :: Name -> CodeGenType -> Q Bool
hasInstance :: Name -> CodeGenType -> Q Bool
hasInstance Name
typeClass CodeGenType
clientDef = Name -> [Type] -> Q Bool
isInstance Name
typeClass [Name -> Type
ConT (forall a. ToName a => a -> Name
toName (CodeGenType -> CodeGenTypeName
cgTypeName CodeGenType
clientDef))]

deriveIfNotDefined :: (CodeGenType -> Q Dec) -> Name -> CodeGenType -> Q [Dec]
deriveIfNotDefined :: (CodeGenType -> Q Dec) -> Name -> CodeGenType -> Q [Dec]
deriveIfNotDefined CodeGenType -> Q Dec
derivation Name
typeClass CodeGenType
clientDef = do
  Bool
exists <- CodeGenTypeName -> Q Bool
isTypeDeclared (CodeGenType -> CodeGenTypeName
cgTypeName CodeGenType
clientDef)
  if Bool
exists
    then do
      Bool
has <- Name -> CodeGenType -> Q Bool
hasInstance Name
typeClass CodeGenType
clientDef
      if Bool
has
        then forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        else Q [Dec]
mkDerivation
    else Q [Dec]
mkDerivation
  where
    mkDerivation :: Q [Dec]
    mkDerivation :: Q [Dec]
mkDerivation = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CodeGenType -> Q Dec
derivation CodeGenType
clientDef

declareIfNotDeclared :: (CodeGenType -> a) -> CodeGenType -> Q [a]
declareIfNotDeclared :: forall a. (CodeGenType -> a) -> CodeGenType -> Q [a]
declareIfNotDeclared CodeGenType -> a
f CodeGenType
c = do
  Bool
exists <- CodeGenTypeName -> Q Bool
isTypeDeclared (CodeGenType -> CodeGenTypeName
cgTypeName CodeGenType
c)
  if Bool
exists
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    else forall (f :: * -> *) a. Applicative f => a -> f a
pure [CodeGenType -> a
f CodeGenType
c]