{-# 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,
resolveSchemaType,
schemaTypeVToTypeQ,
schemaVToTypeQ,
)
import Data.Aeson.Schema.Type (
Schema' (..),
SchemaType' (..),
SchemaTypeV,
SchemaV,
showSchemaTypeV,
toSchemaObjectV,
)
unwrap :: QuasiQuoter
unwrap :: QuasiQuoter
unwrap =
QuasiQuoter
{ quoteExp :: String -> Q Exp
quoteExp = forall a. HasCallStack => String -> a
error String
"Cannot use `unwrap` for Exp"
, quoteDec :: String -> Q [Dec]
quoteDec = forall a. HasCallStack => String -> a
error String
"Cannot use `unwrap` for Dec"
, quoteType :: String -> Q Type
quoteType = forall (m :: * -> *). MonadFail m => String -> m UnwrapSchema
parseUnwrapSchema forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> UnwrapSchema -> Q Type
generateUnwrapSchema
, quotePat :: String -> Q Pat
quotePat = forall a. HasCallStack => String -> a
error String
"Cannot use `unwrap` for Pat"
}
generateUnwrapSchema :: UnwrapSchema -> TypeQ
generateUnwrapSchema :: UnwrapSchema -> Q Type
generateUnwrapSchema UnwrapSchema{String
GetterOps
$sel:getterOps:UnwrapSchema :: UnwrapSchema -> GetterOps
$sel:startSchema:UnwrapSchema :: UnwrapSchema -> String
getterOps :: GetterOps
startSchema :: String
..} = String -> Q SchemaV
reifySchema String
startSchema forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GetterOps -> SchemaV -> Q Type
unwrapSchema GetterOps
getterOps
unwrapSchema :: GetterOps -> SchemaV -> TypeQ
unwrapSchema :: GetterOps -> SchemaV -> Q Type
unwrapSchema = FunctorHandler -> GetterOps -> SchemaV -> Q Type
unwrapSchemaUsing FunctorHandler
StripFunctors
unwrapSchemaUsing :: FunctorHandler -> GetterOps -> SchemaV -> TypeQ
unwrapSchemaUsing :: FunctorHandler -> GetterOps -> SchemaV -> Q Type
unwrapSchemaUsing FunctorHandler
functorHandler GetterOps
getterOps = UnwrapSchemaResult -> Q Type
toResultTypeQ forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a b c. (a -> b -> c) -> b -> a -> c
flip SchemaTypeV -> [GetterOperation] -> Q UnwrapSchemaResult
go (forall a. NonEmpty a -> [a]
NonEmpty.toList GetterOps
getterOps) forall b c a. (b -> c) -> (a -> b) -> a -> c
. SchemaV -> SchemaTypeV
toSchemaObjectV
where
toResultTypeQ :: UnwrapSchemaResult -> TypeQ
toResultTypeQ :: UnwrapSchemaResult -> Q Type
toResultTypeQ = \case
SchemaResult (SchemaObject SchemaObjectMap' String NameLike
pairs) -> [t|Object $(schemaVToTypeQ (Schema pairs))|]
SchemaResult SchemaTypeV
schemaType -> [t|SchemaResult $(schemaTypeVToTypeQ schemaType)|]
SchemaResultList UnwrapSchemaResult
schemaResult -> forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT forall (m :: * -> *). Quote m => m Type
listT (UnwrapSchemaResult -> Q Type
toResultTypeQ UnwrapSchemaResult
schemaResult)
SchemaResultTuple [UnwrapSchemaResult]
schemaResults -> forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Int -> m Type
tupleT forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [UnwrapSchemaResult]
schemaResults) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map UnwrapSchemaResult -> Q Type
toResultTypeQ [UnwrapSchemaResult]
schemaResults
SchemaResultWrapped Type
functorTy UnwrapSchemaResult
schemaResult ->
let handleFunctor :: Type -> Type
handleFunctor Type
ty =
case FunctorHandler
functorHandler of
FunctorHandler
ApplyFunctors -> Type -> Type -> Type
AppT Type
functorTy Type
ty
FunctorHandler
StripFunctors -> Type
ty
in Type -> Type
handleFunctor forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnwrapSchemaResult -> Q Type
toResultTypeQ UnwrapSchemaResult
schemaResult
go :: SchemaTypeV -> [GetterOperation] -> Q UnwrapSchemaResult
go :: SchemaTypeV -> [GetterOperation] -> Q UnwrapSchemaResult
go SchemaTypeV
schemaType [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ SchemaTypeV -> UnwrapSchemaResult
SchemaResult SchemaTypeV
schemaType
go SchemaTypeV
schemaType' (GetterOperation
op : [GetterOperation]
ops) = do
SchemaTypeV
schemaType <- SchemaTypeV -> Q SchemaTypeV
resolveSchemaType SchemaTypeV
schemaType'
let invalid :: String -> m a
invalid String
message = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
message forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ SchemaTypeV -> String
showSchemaTypeV SchemaTypeV
schemaType
wrapMaybe :: UnwrapSchemaResult -> UnwrapSchemaResult
wrapMaybe = Type -> UnwrapSchemaResult -> UnwrapSchemaResult
SchemaResultWrapped (Name -> Type
ConT ''Maybe)
wrapList :: UnwrapSchemaResult -> UnwrapSchemaResult
wrapList = Type -> UnwrapSchemaResult -> UnwrapSchemaResult
SchemaResultWrapped Type
ListT
case GetterOperation
op of
GetterKey String
key ->
case SchemaTypeV
schemaType of
SchemaObject SchemaObjectMap' String NameLike
pairs ->
case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
key forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first SchemaKeyV -> String
fromSchemaKeyV) SchemaObjectMap' String NameLike
pairs of
Just SchemaTypeV
inner -> SchemaTypeV -> [GetterOperation] -> Q UnwrapSchemaResult
go SchemaTypeV
inner [GetterOperation]
ops
Maybe SchemaTypeV
Nothing -> forall {m :: * -> *} {a}. MonadFail m => String -> m a
invalid forall a b. (a -> b) -> a -> b
$ String
"Key '" forall a. [a] -> [a] -> [a]
++ String
key forall a. [a] -> [a] -> [a]
++ String
"' does not exist in schema"
SchemaTypeV
_ -> forall {m :: * -> *} {a}. MonadFail m => String -> m a
invalid forall a b. (a -> b) -> a -> b
$ String
"Cannot get key '" forall a. [a] -> [a] -> [a]
++ String
key forall a. [a] -> [a] -> [a]
++ String
"' in schema"
GetterOperation
GetterBang ->
case SchemaTypeV
schemaType of
SchemaMaybe SchemaTypeV
inner -> SchemaTypeV -> [GetterOperation] -> Q UnwrapSchemaResult
go SchemaTypeV
inner [GetterOperation]
ops
SchemaTry SchemaTypeV
inner -> SchemaTypeV -> [GetterOperation] -> Q UnwrapSchemaResult
go SchemaTypeV
inner [GetterOperation]
ops
SchemaTypeV
_ -> forall {m :: * -> *} {a}. MonadFail m => String -> m a
invalid String
"Cannot use `!` operator on schema"
GetterOperation
GetterMapMaybe ->
case SchemaTypeV
schemaType of
SchemaMaybe SchemaTypeV
inner -> UnwrapSchemaResult -> UnwrapSchemaResult
wrapMaybe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SchemaTypeV -> [GetterOperation] -> Q UnwrapSchemaResult
go SchemaTypeV
inner [GetterOperation]
ops
SchemaTry SchemaTypeV
inner -> UnwrapSchemaResult -> UnwrapSchemaResult
wrapMaybe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SchemaTypeV -> [GetterOperation] -> Q UnwrapSchemaResult
go SchemaTypeV
inner [GetterOperation]
ops
SchemaTypeV
_ -> forall {m :: * -> *} {a}. MonadFail m => String -> m a
invalid String
"Cannot use `?` operator on schema"
GetterOperation
GetterMapList ->
case SchemaTypeV
schemaType of
SchemaList SchemaTypeV
inner -> UnwrapSchemaResult -> UnwrapSchemaResult
wrapList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SchemaTypeV -> [GetterOperation] -> Q UnwrapSchemaResult
go SchemaTypeV
inner [GetterOperation]
ops
SchemaTypeV
_ -> forall {m :: * -> *} {a}. MonadFail m => String -> m a
invalid String
"Cannot use `[]` operator on schema"
GetterBranch Int
branch ->
case SchemaTypeV
schemaType of
SchemaUnion [SchemaTypeV]
schemas ->
if Int
branch forall a. Ord a => a -> a -> Bool
< forall (t :: * -> *) a. Foldable t => t a -> Int
length [SchemaTypeV]
schemas
then SchemaTypeV -> [GetterOperation] -> Q UnwrapSchemaResult
go ([SchemaTypeV]
schemas forall a. [a] -> Int -> a
!! Int
branch) [GetterOperation]
ops
else forall {m :: * -> *} {a}. MonadFail m => String -> m a
invalid String
"Branch out of bounds for schema"
SchemaTypeV
_ -> forall {m :: * -> *} {a}. MonadFail m => String -> m a
invalid String
"Cannot use `@` operator on schema"
GetterList NonEmpty GetterOps
elemOps ->
case SchemaTypeV
schemaType of
SchemaObject SchemaObjectMap' String NameLike
_ -> do
NonEmpty UnwrapSchemaResult
elemSchemas <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (SchemaTypeV -> [GetterOperation] -> Q UnwrapSchemaResult
go SchemaTypeV
schemaType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> [a]
NonEmpty.toList) NonEmpty GetterOps
elemOps
let elemSchema :: UnwrapSchemaResult
elemSchema = forall a. NonEmpty a -> a
NonEmpty.head NonEmpty UnwrapSchemaResult
elemSchemas
if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
== UnwrapSchemaResult
elemSchema) NonEmpty UnwrapSchemaResult
elemSchemas
then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ UnwrapSchemaResult -> UnwrapSchemaResult
SchemaResultList UnwrapSchemaResult
elemSchema
else forall {m :: * -> *} {a}. MonadFail m => String -> m a
invalid String
"List contains different types in schema"
SchemaTypeV
_ -> forall {m :: * -> *} {a}. MonadFail m => String -> m a
invalid String
"Cannot get keys in schema"
GetterTuple NonEmpty GetterOps
elemOps ->
case SchemaTypeV
schemaType of
SchemaObject SchemaObjectMap' String NameLike
_ -> [UnwrapSchemaResult] -> UnwrapSchemaResult
SchemaResultTuple forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SchemaTypeV -> [GetterOperation] -> Q UnwrapSchemaResult
go SchemaTypeV
schemaType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> [a]
NonEmpty.toList) (forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty GetterOps
elemOps)
SchemaTypeV
_ -> forall {m :: * -> *} {a}. MonadFail m => String -> m a
invalid String
"Cannot get keys in schema"
data UnwrapSchemaResult
= SchemaResult SchemaTypeV
| SchemaResultList UnwrapSchemaResult
| SchemaResultTuple [UnwrapSchemaResult]
|
SchemaResultWrapped Type UnwrapSchemaResult
deriving (UnwrapSchemaResult -> UnwrapSchemaResult -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnwrapSchemaResult -> UnwrapSchemaResult -> Bool
$c/= :: UnwrapSchemaResult -> UnwrapSchemaResult -> Bool
== :: UnwrapSchemaResult -> UnwrapSchemaResult -> Bool
$c== :: UnwrapSchemaResult -> UnwrapSchemaResult -> Bool
Eq)
data FunctorHandler
=
ApplyFunctors
|
StripFunctors