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

{-|
Module      :  Data.Aeson.Schema.TH.Unwrap
Maintainer  :  Brandon Chinn <brandonchinn178@gmail.com>
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
    { 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
startSchema :: String
getterOps :: GetterOps
$sel:startSchema:UnwrapSchema :: UnwrapSchema -> String
$sel:getterOps:UnwrapSchema :: UnwrapSchema -> GetterOps
..} = String -> Q SchemaV
reifySchema String
startSchema Q SchemaV -> (SchemaV -> Q Type) -> Q Type
forall a b. Q a -> (a -> Q b) -> Q b
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 $(SchemaV -> Q Type
schemaVToTypeQ (SchemaObjectMap' String NameLike -> SchemaV
forall s ty. SchemaObjectMap' s ty -> Schema' s ty
Schema SchemaObjectMap' String NameLike
pairs))|]
      SchemaResult SchemaTypeV
schemaType -> [t|SchemaResult $(SchemaTypeV -> Q Type
schemaTypeVToTypeQ SchemaTypeV
schemaType)|]
      SchemaResultList UnwrapSchemaResult
schemaResult -> Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT Q Type
forall (m :: * -> *). Quote m => m Type
listT (UnwrapSchemaResult -> Q Type
toResultTypeQ UnwrapSchemaResult
schemaResult)
      SchemaResultTuple [UnwrapSchemaResult]
schemaResults -> (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Int -> Q Type
forall (m :: * -> *). Quote m => Int -> m Type
tupleT (Int -> Q Type) -> Int -> Q Type
forall a b. (a -> b) -> a -> b
$ [UnwrapSchemaResult] -> Int
forall a. [a] -> 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 a. a -> Q a
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 a. 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 a b c. (a -> b) -> (a, c) -> (b, c)
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 a. [a] -> 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. HasCallStack => [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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NonEmpty a -> f (NonEmpty 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 a. a -> Q a
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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
$c== :: UnwrapSchemaResult -> UnwrapSchemaResult -> Bool
== :: UnwrapSchemaResult -> UnwrapSchemaResult -> Bool
$c/= :: UnwrapSchemaResult -> UnwrapSchemaResult -> Bool
/= :: 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