{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Data.Aeson.Schema.TH.Unwrap where
import Control.Monad ((>=>))
import Data.Bifunctor (first)
import qualified Data.List.NonEmpty as NonEmpty
import Language.Haskell.TH
import Language.Haskell.TH.Quote (QuasiQuoter(..))
import Data.Aeson.Schema.Internal (Object, SchemaResult)
import Data.Aeson.Schema.Key (fromSchemaKeyV)
import Data.Aeson.Schema.TH.Parse
(GetterOperation(..), GetterOps, UnwrapSchema(..), parseUnwrapSchema)
import Data.Aeson.Schema.TH.Utils
(reifySchema, schemaTypeVToTypeQ, schemaVToTypeQ)
import Data.Aeson.Schema.Type
( Schema'(..)
, SchemaType'(..)
, SchemaTypeV
, SchemaV
, showSchemaTypeV
, toSchemaObjectV
)
unwrap :: QuasiQuoter
unwrap = QuasiQuoter
{ quoteExp = error "Cannot use `unwrap` for Exp"
, quoteDec = error "Cannot use `unwrap` for Dec"
, quoteType = parseUnwrapSchema >=> generateUnwrapSchema
, quotePat = error "Cannot use `unwrap` for Pat"
}
generateUnwrapSchema :: UnwrapSchema -> TypeQ
generateUnwrapSchema UnwrapSchema{..} = reifySchema startSchema >>= unwrapSchema getterOps
unwrapSchema :: GetterOps -> SchemaV -> TypeQ
unwrapSchema = unwrapSchemaUsing StripFunctors
unwrapSchemaUsing :: FunctorHandler -> GetterOps -> SchemaV -> TypeQ
unwrapSchemaUsing functorHandler getterOps = either fail toResultTypeQ . flip go (NonEmpty.toList getterOps) . toSchemaObjectV
where
toResultTypeQ :: UnwrapSchemaResult -> TypeQ
toResultTypeQ = \case
SchemaResult (SchemaObject pairs) -> [t| Object $(schemaVToTypeQ (Schema pairs)) |]
SchemaResult schemaType -> [t| SchemaResult $(schemaTypeVToTypeQ schemaType) |]
SchemaResultList schemaResult -> appT listT (toResultTypeQ schemaResult)
SchemaResultTuple schemaResults -> foldl appT (tupleT $ length schemaResults) $ map toResultTypeQ schemaResults
SchemaResultWrapped functorTy schemaResult ->
let handleFunctor ty =
case functorHandler of
ApplyFunctors -> AppT functorTy ty
StripFunctors -> ty
in handleFunctor <$> toResultTypeQ schemaResult
go :: SchemaTypeV -> [GetterOperation] -> Either String UnwrapSchemaResult
go schemaType [] = pure $ SchemaResult schemaType
go schemaType (op:ops) =
let invalid message = Left $ message ++ ": " ++ showSchemaTypeV schemaType
wrapMaybe = SchemaResultWrapped (ConT ''Maybe)
wrapList = SchemaResultWrapped ListT
in case op of
GetterKey key ->
case schemaType of
SchemaObject pairs ->
case lookup key $ map (first fromSchemaKeyV) pairs of
Just inner -> go inner ops
Nothing -> invalid $ "Key '" ++ key ++ "' does not exist in schema"
_ -> invalid $ "Cannot get key '" ++ key ++ "' in schema"
GetterBang ->
case schemaType of
SchemaMaybe inner -> go inner ops
SchemaTry inner -> go inner ops
_ -> invalid "Cannot use `!` operator on schema"
GetterMapMaybe ->
case schemaType of
SchemaMaybe inner -> wrapMaybe <$> go inner ops
SchemaTry inner -> wrapMaybe <$> go inner ops
_ -> invalid "Cannot use `?` operator on schema"
GetterMapList ->
case schemaType of
SchemaList inner -> wrapList <$> go inner ops
_ -> invalid "Cannot use `[]` operator on schema"
GetterBranch branch ->
case schemaType of
SchemaUnion schemas ->
if branch < length schemas
then go (schemas !! branch) ops
else invalid "Branch out of bounds for schema"
_ -> invalid "Cannot use `@` operator on schema"
GetterList elemOps ->
case schemaType of
SchemaObject _ -> do
elemSchemas <- traverse (go schemaType . NonEmpty.toList) elemOps
let elemSchema = NonEmpty.head elemSchemas
if all (== elemSchema) elemSchemas
then pure $ SchemaResultList elemSchema
else invalid "List contains different types in schema"
_ -> invalid "Cannot get keys in schema"
GetterTuple elemOps ->
case schemaType of
SchemaObject _ -> SchemaResultTuple <$> mapM (go schemaType . NonEmpty.toList) (NonEmpty.toList elemOps)
_ -> invalid "Cannot get keys in schema"
data UnwrapSchemaResult
= SchemaResult SchemaTypeV
| SchemaResultList UnwrapSchemaResult
| SchemaResultTuple [UnwrapSchemaResult]
| SchemaResultWrapped Type UnwrapSchemaResult
deriving (Eq)
data FunctorHandler
= ApplyFunctors
| StripFunctors