{-# 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.Client.Internal.TH
  ( matchWith,
    decodeObjectE,
    mkFieldsE,
    destructRecord,
    failExp,
    isTypeDeclared,
    hasInstance,
  )
where

import Data.Foldable (foldr1)
import Data.Morpheus.Client.Internal.Types (ClientTypeDefinition (..), TypeNameTH (..))
import Data.Morpheus.CodeGen.Internal.TH
  ( camelCaseFieldName,
    camelCaseTypeName,
    toCon,
    toName,
    toString,
    toVar,
    v',
    vars,
  )
import Data.Morpheus.Types.Internal.AST
  ( FieldDefinition (..),
    TypeName,
    isNullable,
  )
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 :: (Bool -> Name) -> TypeName -> [FieldDefinition cat s] -> ExpQ
decodeObjectE :: forall (cat :: TypeCategory) (s :: Stage).
(Bool -> Name) -> TypeName -> [FieldDefinition cat s] -> Q Exp
decodeObjectE Bool -> Name
_ TypeName
conName [] = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [|pure|] (forall a b. ToCon a b => a -> b
toCon TypeName
conName)
decodeObjectE Bool -> Name
funName TypeName
conName [FieldDefinition cat s]
fields =
  forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
uInfixE
    (forall a b. ToCon a b => a -> b
toCon TypeName
conName)
    [|(<$>)|]
    (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 (forall (cat :: TypeCategory) (s :: Stage).
(Bool -> Name) -> FieldDefinition cat s -> Q Exp
defField Bool -> Name
funName) [FieldDefinition cat s]
fields)

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

defField :: (Bool -> Name) -> FieldDefinition cat s -> ExpQ
defField :: forall (cat :: TypeCategory) (s :: Stage).
(Bool -> Name) -> FieldDefinition cat s -> Q Exp
defField Bool -> Name
f field :: FieldDefinition cat s
field@FieldDefinition {FieldName
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName :: 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
f (forall a. Nullable a => a -> Bool
isNullable FieldDefinition cat s
field)) (forall a b. ToString a b => a -> b
toString FieldName
fieldName)

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

--  input : mkFieldWith 'mkValue (FieldDefinition { fieldName = "field1", ..})
--  expression: mkValue "field1"  field1
mkEntryWith ::
  TypeName ->
  Name ->
  FieldDefinition cat s ->
  Exp
mkEntryWith :: forall (cat :: TypeCategory) (s :: Stage).
TypeName -> Name -> FieldDefinition cat s -> Exp
mkEntryWith TypeName
conName Name
f FieldDefinition {FieldName
fieldName :: FieldName
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> 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 TypeName
conName FieldName
fieldName)

-- |
-- input:
-- >>>
-- WAS WAS destructRecord "User" ["name","id"]
-- >>>
--
-- expression:
-- >>>
-- WAS WAS (User name id)
-- >>>
destructRecord :: TypeName -> [FieldDefinition cat s] -> PatQ
destructRecord :: forall (cat :: TypeCategory) (s :: Stage).
TypeName -> [FieldDefinition cat s] -> PatQ
destructRecord TypeName
conName [FieldDefinition cat s]
fields = forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP (forall a. ToName a => a -> Name
toName TypeName
conName) (forall a b. ToVar a b => [a] -> [b]
vars [FieldName]
names)
  where
    names :: [FieldName]
names = forall a b. (a -> b) -> [a] -> [b]
map (TypeName -> FieldName -> FieldName
camelCaseFieldName TypeName
conName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName) [FieldDefinition cat s]
fields

isTypeDeclared :: ClientTypeDefinition -> Q Bool
isTypeDeclared :: ClientTypeDefinition -> Q Bool
isTypeDeclared ClientTypeDefinition
clientDef = do
  let name :: Name
name = ClientTypeDefinition -> Name
mkTypeName ClientTypeDefinition
clientDef
  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 -> ClientTypeDefinition -> Q Bool
hasInstance :: Name -> ClientTypeDefinition -> Q Bool
hasInstance Name
typeClass ClientTypeDefinition
clientDef = do
  Name -> [Type] -> Q Bool
isInstance Name
typeClass [Name -> Type
ConT (ClientTypeDefinition -> Name
mkTypeName ClientTypeDefinition
clientDef)]

mkTypeName :: ClientTypeDefinition -> Name
mkTypeName :: ClientTypeDefinition -> Name
mkTypeName ClientTypeDefinition {clientTypeName :: ClientTypeDefinition -> TypeNameTH
clientTypeName = TypeNameTH [FieldName]
namespace TypeName
typeName} =
  TypeName -> Name
toType TypeName
typeName
  where
    toType :: TypeName -> Name
toType = forall a. ToName a => a -> Name
toName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: NAME). [Name t] -> TypeName -> TypeName
camelCaseTypeName [FieldName]
namespace