{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}

{- |
Module      :  Data.Aeson.Schema.TH.Unwrap
Maintainer  :  Brandon Chinn <brandon@leapyear.io>
Stability   :  experimental
Portability :  portable

The 'unwrap' quasiquoter.
-}
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,
 )

{- | Defines a QuasiQuoter to extract a schema within the given schema.

 The base schema needs to be defined in a separate module.

 For example:

 > -- | MyFoo ~ Object [schema| { b: Maybe Bool } |]
 > type MyFoo = [unwrap| MySchema.foo.nodes[] |]

 If the schema is imported qualified, you can use parentheses to distinguish it from the
 expression:

 > type MyFoo = [unwrap| (MyModule.Schema).foo.nodes[] |]

 You can then use the type alias as usual:

 > parseBar :: MyFoo -> String
 > parseBar = maybe "null" show . [get| .b |]
 >
 > foo = map parseBar [get| result.foo.nodes[] |]

 The syntax is mostly the same as 'Data.Aeson.Schema.TH.get', except the operations run on the
 type itself, instead of the values. Differences from 'Data.Aeson.Schema.TH.get':

 * @x!@ is only valid if @x@ is a @Maybe a@ type. Returns @a@, the type wrapped in the 'Maybe'.

 * @x?@ is the same as @x!@.

 * @x[]@ is only valid if @x@ is a @[a]@ type. Returns @a@, the type contained in the list.

 * @x\@#@ is only valid if @x@ is a @SumType@. Returns the type at that branch in the sum type.
-}
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

-- | Unwrap the given schema by applying the given operations, stripping out functors.
unwrapSchema :: GetterOps -> SchemaV -> TypeQ
unwrapSchema :: GetterOps -> SchemaV -> Q Type
unwrapSchema = FunctorHandler -> GetterOps -> SchemaV -> Q Type
unwrapSchemaUsing FunctorHandler
StripFunctors

-- | Unwrap the given schema by applying the given operations, using the given 'FunctorHandler'.
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
      -- special case SchemaObject to make it further inspectable
      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"
        -- suffixes; ops should be empty

        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]
  | -- | Type should be of kind `* -> *`
    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)

-- | A data type that indicates how to handle functors when unwrapping a schema.
data FunctorHandler
  = -- | handleFunctor Maybe Int ==> Maybe Int
    ApplyFunctors
  | -- | handleFunctor Maybe Int ==> Int
    StripFunctors