{-# 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) []]
]