{-# 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,
  )
where

import Data.Foldable (foldr1)
import Data.Morpheus.CodeGen.Internal.TH
  ( camelCaseFieldName,
    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 :: Maybe (PatQ, ExpQ) -> (t -> (PatQ, ExpQ)) -> [t] -> ExpQ
matchWith Maybe (PatQ, ExpQ)
fbexp t -> (PatQ, ExpQ)
f [t]
xs = [MatchQ] -> ExpQ
lamCaseE ((t -> MatchQ) -> [t] -> [MatchQ]
forall a b. (a -> b) -> [a] -> [b]
map t -> MatchQ
buildMatch [t]
xs [MatchQ] -> [MatchQ] -> [MatchQ]
forall a. Semigroup a => a -> a -> a
<> Maybe (PatQ, ExpQ) -> [MatchQ]
fallback Maybe (PatQ, ExpQ)
fbexp)
  where
    fallback :: Maybe (PatQ, ExpQ) -> [MatchQ]
fallback (Just (PatQ
pat, ExpQ
fb)) = [PatQ -> BodyQ -> [DecQ] -> MatchQ
match PatQ
pat (ExpQ -> BodyQ
normalB ExpQ
fb) []]
    fallback Maybe (PatQ, ExpQ)
_ = []
    buildMatch :: t -> MatchQ
buildMatch t
x = PatQ -> BodyQ -> [DecQ] -> MatchQ
match PatQ
pat (ExpQ -> BodyQ
normalB ExpQ
body) []
      where
        (PatQ
pat, ExpQ
body) = t -> (PatQ, ExpQ)
f t
x

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

decodeObjectE :: (Bool -> Name) -> TypeName -> [FieldDefinition cat s] -> ExpQ
decodeObjectE :: (Bool -> Name) -> TypeName -> [FieldDefinition cat s] -> ExpQ
decodeObjectE Bool -> Name
_ TypeName
conName [] = ExpQ -> ExpQ -> ExpQ
appE [|pure|] (TypeName -> ExpQ
forall a b. ToCon a b => a -> b
toCon TypeName
conName)
decodeObjectE Bool -> Name
funName TypeName
conName [FieldDefinition cat s]
fields =
  ExpQ -> ExpQ -> ExpQ -> ExpQ
uInfixE
    (TypeName -> ExpQ
forall a b. ToCon a b => a -> b
toCon TypeName
conName)
    [|(<$>)|]
    ((ExpQ -> ExpQ -> ExpQ) -> [ExpQ] -> ExpQ
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 ExpQ -> ExpQ -> ExpQ
withApplicative ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ (FieldDefinition cat s -> ExpQ)
-> [FieldDefinition cat s] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map ((Bool -> Name) -> FieldDefinition cat s -> ExpQ
forall (cat :: TypeCategory) (s :: Stage).
(Bool -> Name) -> FieldDefinition cat s -> ExpQ
defField Bool -> Name
funName) [FieldDefinition cat s]
fields)

withApplicative :: ExpQ -> ExpQ -> ExpQ
withApplicative :: ExpQ -> ExpQ -> ExpQ
withApplicative ExpQ
x = ExpQ -> ExpQ -> ExpQ -> ExpQ
uInfixE ExpQ
x [|(<*>)|]

defField :: (Bool -> Name) -> FieldDefinition cat s -> ExpQ
defField :: (Bool -> Name) -> FieldDefinition cat s -> ExpQ
defField Bool -> Name
f field :: FieldDefinition cat s
field@FieldDefinition {FieldName
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName :: FieldName
fieldName} = ExpQ -> ExpQ -> ExpQ -> ExpQ
uInfixE ExpQ
forall a. ToVar Name a => a
v' (Name -> ExpQ
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ Bool -> Name
f (FieldDefinition cat s -> Bool
forall a. Nullable a => a -> Bool
isNullable FieldDefinition cat s
field)) (FieldName -> ExpQ
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 :: TypeName -> Name -> [FieldDefinition cat s] -> Exp
mkFieldsE TypeName
conName Name
name = [Exp] -> Exp
ListE ([Exp] -> Exp)
-> ([FieldDefinition cat s] -> [Exp])
-> [FieldDefinition cat s]
-> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldDefinition cat s -> Exp) -> [FieldDefinition cat s] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (TypeName -> Name -> FieldDefinition cat s -> Exp
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 :: 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) (FieldName -> Exp
forall a b. ToString a b => a -> b
toString FieldName
fieldName))
    (FieldName -> Exp
forall a b. ToVar a b => a -> b
toVar (FieldName -> Exp) -> FieldName -> Exp
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 :: TypeName -> [FieldDefinition cat s] -> PatQ
destructRecord TypeName
conName [FieldDefinition cat s]
fields = Name -> [PatQ] -> PatQ
conP (TypeName -> Name
forall a. ToName a => a -> Name
toName TypeName
conName) ([FieldName] -> [PatQ]
forall a b. ToVar a b => [a] -> [b]
vars [FieldName]
names)
  where
    names :: [FieldName]
names = (FieldDefinition cat s -> FieldName)
-> [FieldDefinition cat s] -> [FieldName]
forall a b. (a -> b) -> [a] -> [b]
map (TypeName -> FieldName -> FieldName
camelCaseFieldName TypeName
conName (FieldName -> FieldName)
-> (FieldDefinition cat s -> FieldName)
-> FieldDefinition cat s
-> FieldName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDefinition cat s -> FieldName
forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName) [FieldDefinition cat s]
fields