{-# 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
    { 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

-- | 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 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
      -- 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 -> 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"
        -- suffixes; ops should be empty

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

-- | 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