{-# 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 :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
{ quoteExp :: String -> Q Exp
quoteExp = String -> String -> Q Exp
forall a. HasCallStack => String -> a
error String
"Cannot use `unwrap` for Exp"
, quoteDec :: String -> Q [Dec]
quoteDec = String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"Cannot use `unwrap` for Dec"
, quoteType :: String -> Q Type
quoteType = String -> Q UnwrapSchema
forall (m :: * -> *). MonadFail m => String -> m UnwrapSchema
parseUnwrapSchema (String -> Q UnwrapSchema)
-> (UnwrapSchema -> Q Type) -> String -> Q Type
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 = String -> String -> Q Pat
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 Q SchemaV -> (SchemaV -> Q Type) -> Q Type
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 (UnwrapSchemaResult -> Q Type)
-> (SchemaV -> Q UnwrapSchemaResult) -> SchemaV -> Q Type
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (SchemaTypeV -> [GetterOperation] -> Q UnwrapSchemaResult)
-> [GetterOperation] -> SchemaTypeV -> Q UnwrapSchemaResult
forall a b c. (a -> b -> c) -> b -> a -> c
flip SchemaTypeV -> [GetterOperation] -> Q UnwrapSchemaResult
go (GetterOps -> [GetterOperation]
forall a. NonEmpty a -> [a]
NonEmpty.toList GetterOps
getterOps) (SchemaTypeV -> Q UnwrapSchemaResult)
-> (SchemaV -> SchemaTypeV) -> SchemaV -> Q UnwrapSchemaResult
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 -> Q Type -> Q Type -> Q Type
appT Q Type
listT (UnwrapSchemaResult -> Q Type
toResultTypeQ UnwrapSchemaResult
schemaResult)
SchemaResultTuple [UnwrapSchemaResult]
schemaResults -> (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
appT (Int -> Q Type
tupleT (Int -> Q Type) -> Int -> Q Type
forall a b. (a -> b) -> a -> b
$ [UnwrapSchemaResult] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [UnwrapSchemaResult]
schemaResults) ([Q Type] -> Q Type) -> [Q Type] -> Q Type
forall a b. (a -> b) -> a -> b
$ (UnwrapSchemaResult -> Q Type) -> [UnwrapSchemaResult] -> [Q Type]
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 (Type -> Type) -> Q Type -> Q Type
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 [] = UnwrapSchemaResult -> Q UnwrapSchemaResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UnwrapSchemaResult -> Q UnwrapSchemaResult)
-> UnwrapSchemaResult -> Q UnwrapSchemaResult
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 = String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ String
message String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> 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 String -> [(String, SchemaTypeV)] -> Maybe SchemaTypeV
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
key ([(String, SchemaTypeV)] -> Maybe SchemaTypeV)
-> [(String, SchemaTypeV)] -> Maybe SchemaTypeV
forall a b. (a -> b) -> a -> b
$ ((SchemaKeyV, SchemaTypeV) -> (String, SchemaTypeV))
-> SchemaObjectMap' String NameLike -> [(String, SchemaTypeV)]
forall a b. (a -> b) -> [a] -> [b]
map ((SchemaKeyV -> String)
-> (SchemaKeyV, SchemaTypeV) -> (String, SchemaTypeV)
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 -> String -> Q UnwrapSchemaResult
forall (m :: * -> *) a. MonadFail m => String -> m a
invalid (String -> Q UnwrapSchemaResult) -> String -> Q UnwrapSchemaResult
forall a b. (a -> b) -> a -> b
$ String
"Key '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
key String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' does not exist in schema"
SchemaTypeV
_ -> String -> Q UnwrapSchemaResult
forall (m :: * -> *) a. MonadFail m => String -> m a
invalid (String -> Q UnwrapSchemaResult) -> String -> Q UnwrapSchemaResult
forall a b. (a -> b) -> a -> b
$ String
"Cannot get key '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
key String -> String -> String
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
_ -> String -> Q UnwrapSchemaResult
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 (UnwrapSchemaResult -> UnwrapSchemaResult)
-> Q UnwrapSchemaResult -> Q UnwrapSchemaResult
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 (UnwrapSchemaResult -> UnwrapSchemaResult)
-> Q UnwrapSchemaResult -> Q UnwrapSchemaResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SchemaTypeV -> [GetterOperation] -> Q UnwrapSchemaResult
go SchemaTypeV
inner [GetterOperation]
ops
SchemaTypeV
_ -> String -> Q UnwrapSchemaResult
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 (UnwrapSchemaResult -> UnwrapSchemaResult)
-> Q UnwrapSchemaResult -> Q UnwrapSchemaResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SchemaTypeV -> [GetterOperation] -> Q UnwrapSchemaResult
go SchemaTypeV
inner [GetterOperation]
ops
SchemaTypeV
_ -> String -> Q UnwrapSchemaResult
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [SchemaTypeV] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SchemaTypeV]
schemas
then SchemaTypeV -> [GetterOperation] -> Q UnwrapSchemaResult
go ([SchemaTypeV]
schemas [SchemaTypeV] -> Int -> SchemaTypeV
forall a. [a] -> Int -> a
!! Int
branch) [GetterOperation]
ops
else String -> Q UnwrapSchemaResult
forall (m :: * -> *) a. MonadFail m => String -> m a
invalid String
"Branch out of bounds for schema"
SchemaTypeV
_ -> String -> Q UnwrapSchemaResult
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 <- (GetterOps -> Q UnwrapSchemaResult)
-> NonEmpty GetterOps -> Q (NonEmpty UnwrapSchemaResult)
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 ([GetterOperation] -> Q UnwrapSchemaResult)
-> (GetterOps -> [GetterOperation])
-> GetterOps
-> Q UnwrapSchemaResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GetterOps -> [GetterOperation]
forall a. NonEmpty a -> [a]
NonEmpty.toList) NonEmpty GetterOps
elemOps
let elemSchema :: UnwrapSchemaResult
elemSchema = NonEmpty UnwrapSchemaResult -> UnwrapSchemaResult
forall a. NonEmpty a -> a
NonEmpty.head NonEmpty UnwrapSchemaResult
elemSchemas
if (UnwrapSchemaResult -> Bool) -> NonEmpty UnwrapSchemaResult -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (UnwrapSchemaResult -> UnwrapSchemaResult -> Bool
forall a. Eq a => a -> a -> Bool
== UnwrapSchemaResult
elemSchema) NonEmpty UnwrapSchemaResult
elemSchemas
then UnwrapSchemaResult -> Q UnwrapSchemaResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UnwrapSchemaResult -> Q UnwrapSchemaResult)
-> UnwrapSchemaResult -> Q UnwrapSchemaResult
forall a b. (a -> b) -> a -> b
$ UnwrapSchemaResult -> UnwrapSchemaResult
SchemaResultList UnwrapSchemaResult
elemSchema
else String -> Q UnwrapSchemaResult
forall (m :: * -> *) a. MonadFail m => String -> m a
invalid String
"List contains different types in schema"
SchemaTypeV
_ -> String -> Q UnwrapSchemaResult
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 ([UnwrapSchemaResult] -> UnwrapSchemaResult)
-> Q [UnwrapSchemaResult] -> Q UnwrapSchemaResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GetterOps -> Q UnwrapSchemaResult)
-> [GetterOps] -> Q [UnwrapSchemaResult]
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 ([GetterOperation] -> Q UnwrapSchemaResult)
-> (GetterOps -> [GetterOperation])
-> GetterOps
-> Q UnwrapSchemaResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GetterOps -> [GetterOperation]
forall a. NonEmpty a -> [a]
NonEmpty.toList) (NonEmpty GetterOps -> [GetterOps]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty GetterOps
elemOps)
SchemaTypeV
_ -> String -> Q UnwrapSchemaResult
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
(UnwrapSchemaResult -> UnwrapSchemaResult -> Bool)
-> (UnwrapSchemaResult -> UnwrapSchemaResult -> Bool)
-> Eq UnwrapSchemaResult
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