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

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

-- | 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]
  | SchemaResultWrapped Type UnwrapSchemaResult -- ^ Type should be of kind `* -> *`
  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
  = ApplyFunctors -- ^ handleFunctor Maybe Int ==> Maybe Int
  | StripFunctors -- ^ handleFunctor Maybe Int ==> Int