{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Data.Aeson.Schema.TH.Getter where
import Control.Monad (unless)
import Data.Aeson.Schema.Internal (Object)
import Data.Maybe (isNothing)
import Language.Haskell.TH
import Data.Aeson.Schema.TH.Get (generateGetterExp)
import Data.Aeson.Schema.TH.Parse (GetterExp (..), parseGetterExp)
import Data.Aeson.Schema.TH.Unwrap (
FunctorHandler (..),
unwrapSchema,
unwrapSchemaUsing,
)
import Data.Aeson.Schema.TH.Utils (loadSchema, lookupSchema, schemaVToTypeQ)
import Data.Aeson.Schema.Utils.NameLike (NameLike (..))
mkGetter :: String -> String -> Name -> String -> DecsQ
mkGetter :: String -> String -> Name -> String -> DecsQ
mkGetter String
unwrapName String
funcName Name
startSchemaName String
ops = do
getterExp :: GetterExp
getterExp@GetterExp{Maybe String
GetterOps
$sel:getterOps:GetterExp :: GetterExp -> GetterOps
$sel:start:GetterExp :: GetterExp -> Maybe String
getterOps :: GetterOps
start :: Maybe String
..} <- String -> Q GetterExp
forall (m :: * -> *). MonadFail m => String -> m GetterExp
parseGetterExp String
ops
Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe String -> Bool
forall a. Maybe a -> Bool
isNothing Maybe String
start) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
String -> Q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String
"Getter expression should start with '.': " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ops
SchemaV
startSchema <- NameLike -> Q ReifiedSchema
lookupSchema (Name -> NameLike
NameTH Name
startSchemaName) Q ReifiedSchema -> (ReifiedSchema -> Q SchemaV) -> Q SchemaV
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ReifiedSchema -> Q SchemaV
loadSchema
let unwrapResult :: TypeQ
unwrapResult = GetterOps -> SchemaV -> TypeQ
unwrapSchema GetterOps
getterOps SchemaV
startSchema
funcResult :: TypeQ
funcResult = FunctorHandler -> GetterOps -> SchemaV -> TypeQ
unwrapSchemaUsing FunctorHandler
ApplyFunctors GetterOps
getterOps SchemaV
startSchema
getterFunc :: ExpQ
getterFunc = GetterExp -> ExpQ
generateGetterExp GetterExp
getterExp
unwrapName' :: Name
unwrapName' = String -> Name
mkName String
unwrapName
funcName' :: Name
funcName' = String -> Name
mkName String
funcName
[Q Dec] -> DecsQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
[ Name -> [TyVarBndr] -> TypeQ -> Q Dec
tySynD Name
unwrapName' [] TypeQ
unwrapResult
, Name -> TypeQ -> Q Dec
sigD Name
funcName' [t|Object $(schemaVToTypeQ startSchema) -> $funcResult|]
, Name -> [ClauseQ] -> Q Dec
funD Name
funcName' [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB ExpQ
getterFunc) []]
]