{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}

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

The 'schema' quasiquoter.
-}
module Data.Aeson.Schema.TH.Schema (schema) where

import Control.Monad (unless, (>=>))
import Data.Function (on)
import qualified Data.HashMap.Strict as HashMap
import Data.Hashable (Hashable)
import Data.List (nubBy)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NonEmpty
import Language.Haskell.TH
import Language.Haskell.TH.Quote (QuasiQuoter (..))

import Data.Aeson.Schema.Key (SchemaKey' (..), SchemaKeyV, fromSchemaKeyV)
import Data.Aeson.Schema.TH.Parse (
  SchemaDef (..),
  SchemaDefObjItem (..),
  SchemaDefObjKey (..),
  parseSchemaDef,
 )
import Data.Aeson.Schema.TH.Utils (reifySchema, schemaVToTypeQ)
import Data.Aeson.Schema.Type (
  Schema' (..),
  SchemaObjectMapV,
  SchemaType' (..),
  SchemaTypeV,
  fromSchemaV,
  showSchemaTypeV,
 )
import Data.Aeson.Schema.Utils.Invariant (unreachable)
import Data.Aeson.Schema.Utils.NameLike (NameLike (..))

{- | Defines a QuasiQuoter for writing schemas.

 Example:

 > import Data.Aeson.Schema (schema)
 >
 > type MySchema = [schema|
 >   {
 >     foo: {
 >       a: Int,
 >       // you can add comments like this
 >       nodes: List {
 >         b: Maybe Bool,
 >       },
 >       c: Text,
 >       d: Text,
 >       e: MyType,
 >       f: Maybe List {
 >         name: Text,
 >       },
 >     },
 >   }
 > |]

 Syntax:

 * @{ key: \<schema\>, ... }@ corresponds to a JSON 'Data.Aeson.Schema.Object' with the given key
   mapping to the given schema.

 * @Bool@, @Int@, @Double@, and @Text@ correspond to the usual Haskell values.

 * @Maybe \<schema\>@ and @List \<schema\>@ correspond to @Maybe@ and @[]@, containing values
   specified by the provided schema (no parentheses needed).

 * @Try \<schema\>@ corresponds to @Maybe@, where the value will be @Just@ if the given schema
   successfully parses the value, or @Nothing@ otherwise. Different from @Maybe \<schema\>@,
   where parsing @{ "foo": true }@ with @{ foo: Try Int }@ returns @Nothing@, whereas it would
   be a parse error with @{ foo: Maybe Int }@ (added in v1.2.0)

 * Any other uppercase identifier corresponds to the respective type in scope -- requires a
   FromJSON instance.

 Advanced syntax:

 * @\<schema1\> | \<schema2\>@ corresponds to a JSON value that matches one of the given schemas.
   When extracted from an 'Data.Aeson.Schema.Object', it deserializes into a
   'Data.Aeson.Schema.Utils.Sum.JSONSum' object. (added in v1.1.0)

 * @{ [key]: \<schema\> }@ uses the current object to resolve the keys in the given schema. Only
   object schemas are allowed here. (added in v1.2.0)

 * @{ key: #Other, ... }@ maps the given key to the @Other@ schema. The @Other@ schema needs to
   be defined in another module.

 * @{ #Other, ... }@ extends this schema with the @Other@ schema. The @Other@ schema needs to
   be defined in another module.
-}
schema :: QuasiQuoter
schema :: QuasiQuoter
schema =
  QuasiQuoter
    { quoteExp :: String -> Q Exp
quoteExp = forall a. HasCallStack => String -> a
error String
"Cannot use `schema` for Exp"
    , quoteDec :: String -> Q [Dec]
quoteDec = forall a. HasCallStack => String -> a
error String
"Cannot use `schema` for Dec"
    , quoteType :: String -> Q Type
quoteType =
        forall (m :: * -> *). MonadFail m => String -> m SchemaDef
parseSchemaDef forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \case
          SchemaDefObj NonEmpty SchemaDefObjItem
items -> NonEmpty SchemaDefObjItem -> Q Type
generateSchemaObject NonEmpty SchemaDefObjItem
items
          SchemaDef
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"`schema` definition must be an object"
    , quotePat :: String -> Q Pat
quotePat = forall a. HasCallStack => String -> a
error String
"Cannot use `schema` for Pat"
    }
  where
    generateSchemaObject :: NonEmpty SchemaDefObjItem -> Q Type
generateSchemaObject NonEmpty SchemaDefObjItem
items = SchemaV -> Q Type
schemaVToTypeQ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s ty. SchemaObjectMap' s ty -> Schema' s ty
Schema forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< NonEmpty SchemaDefObjItem -> Q (SchemaObjectMap' String NameLike)
generateSchemaObjectV NonEmpty SchemaDefObjItem
items

data KeySource = Provided | Imported
  deriving (Int -> KeySource -> ShowS
[KeySource] -> ShowS
KeySource -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [KeySource] -> ShowS
$cshowList :: [KeySource] -> ShowS
show :: KeySource -> String
$cshow :: KeySource -> String
showsPrec :: Int -> KeySource -> ShowS
$cshowsPrec :: Int -> KeySource -> ShowS
Show, KeySource -> KeySource -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KeySource -> KeySource -> Bool
$c/= :: KeySource -> KeySource -> Bool
== :: KeySource -> KeySource -> Bool
$c== :: KeySource -> KeySource -> Bool
Eq)

generateSchemaObjectV :: NonEmpty SchemaDefObjItem -> Q SchemaObjectMapV
generateSchemaObjectV :: NonEmpty SchemaDefObjItem -> Q (SchemaObjectMap' String NameLike)
generateSchemaObjectV NonEmpty SchemaDefObjItem
schemaDefObjItems = do
  NonEmpty (SchemaObjectMap' String NameLike, KeySource)
schemaObjectMapsWithSource <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM SchemaDefObjItem -> Q (SchemaObjectMap' String NameLike, KeySource)
getSchemaObjectMap NonEmpty SchemaDefObjItem
schemaDefObjItems

  let schemaObjectMaps :: LookupMap SchemaKeyV (KeySource, SchemaTypeV)
      schemaObjectMaps :: LookupMap SchemaKeyV (KeySource, SchemaType' String NameLike)
schemaObjectMaps = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall k v a. LookupMap k v -> a -> LookupMap k (a, v)
distribute) NonEmpty (SchemaObjectMap' String NameLike, KeySource)
schemaObjectMapsWithSource

  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a.
Show a =>
LookupMap SchemaKeyV (KeySource, a)
-> Either String (LookupMap SchemaKeyV a)
resolveKeys LookupMap SchemaKeyV (KeySource, SchemaType' String NameLike)
schemaObjectMaps

{- | Get the SchemaObjectMapV for the given SchemaDefObjItem, along with where the SchemaObjectMapV
 came from.
-}
getSchemaObjectMap :: SchemaDefObjItem -> Q (SchemaObjectMapV, KeySource)
getSchemaObjectMap :: SchemaDefObjItem -> Q (SchemaObjectMap' String NameLike, KeySource)
getSchemaObjectMap = \case
  SchemaDefObjPair (SchemaDefObjKey
schemaDefKey, SchemaDef
schemaDefType) -> do
    let schemaKey :: SchemaKeyV
schemaKey = SchemaDefObjKey -> SchemaKeyV
fromSchemaDefKey SchemaDefObjKey
schemaDefKey
    SchemaType' String NameLike
schemaType <- SchemaDef -> Q (SchemaType' String NameLike)
fromSchemaDefType SchemaDef
schemaDefType

    case SchemaKeyV
schemaKey of
      PhantomKey String
_ ->
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall {s} {ty}. SchemaType' s ty -> Bool
isValidPhantomSchema SchemaType' String NameLike
schemaType) forall a b. (a -> b) -> a -> b
$
          forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
            String
"Invalid schema for '" forall a. [a] -> [a] -> [a]
++ SchemaKeyV -> String
fromSchemaKeyV SchemaKeyV
schemaKey forall a. [a] -> [a] -> [a]
++ String
"': " forall a. [a] -> [a] -> [a]
++ SchemaType' String NameLike -> String
showSchemaTypeV SchemaType' String NameLike
schemaType
      SchemaKeyV
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

    forall (m :: * -> *) a. Monad m => a -> m a
return ([(SchemaKeyV
schemaKey, SchemaType' String NameLike
schemaType)], KeySource
Provided)
  SchemaDefObjExtend String
other -> do
    SchemaV
schemaV <- String -> Q SchemaV
reifySchema String
other
    forall (m :: * -> *) a. Monad m => a -> m a
return (SchemaV -> SchemaObjectMap' String NameLike
fromSchemaV SchemaV
schemaV, KeySource
Imported)
  where
    -- should return true if it's at all possible to get a valid parse
    isValidPhantomSchema :: SchemaType' s ty -> Bool
isValidPhantomSchema = \case
      SchemaMaybe SchemaType' s ty
inner -> SchemaType' s ty -> Bool
isValidPhantomSchema SchemaType' s ty
inner
      SchemaTry SchemaType' s ty
_ -> Bool
True -- even if inner is a non-object schema, it'll still parse to be Nothing
      SchemaUnion [SchemaType' s ty]
schemas -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any SchemaType' s ty -> Bool
isValidPhantomSchema [SchemaType' s ty]
schemas
      SchemaObject SchemaObjectMap' s ty
_ -> Bool
True
      SchemaInclude Either ty (Schema' s ty)
_ -> Bool
True
      SchemaType' s ty
_ -> Bool
False

{- | Resolve the given keys with the following rules:

 1. Any explicitly provided keys shadow/overwrite imported keys
 2. Fail if duplicate keys are both explicitly provided
 3. Fail if duplicate keys are both imported
-}
resolveKeys :: forall a. Show a => LookupMap SchemaKeyV (KeySource, a) -> Either String (LookupMap SchemaKeyV a)
resolveKeys :: forall a.
Show a =>
LookupMap SchemaKeyV (KeySource, a)
-> Either String (LookupMap SchemaKeyV a)
resolveKeys = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry SchemaKeyV -> [(KeySource, a)] -> Either String (SchemaKeyV, a)
resolveKey) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a k v.
(Eq a, Hashable a) =>
(k -> a) -> LookupMap k v -> LookupMap k [v]
groupByKeyWith SchemaKeyV -> String
fromSchemaKeyV
  where
    resolveKey :: SchemaKeyV -> [(KeySource, a)] -> Either String (SchemaKeyV, a)
    resolveKey :: SchemaKeyV -> [(KeySource, a)] -> Either String (SchemaKeyV, a)
resolveKey SchemaKeyV
key [(KeySource, a)]
sourcesAndVals =
      let provided :: [a]
provided = forall a b. Eq a => a -> [(a, b)] -> [b]
lookupAll KeySource
Provided [(KeySource, a)]
sourcesAndVals
          imported :: [a]
imported = forall a b. Eq a => a -> [(a, b)] -> [b]
lookupAll KeySource
Imported [(KeySource, a)]
sourcesAndVals
       in if
              | forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
provided forall a. Ord a => a -> a -> Bool
> Int
1 -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Key '" forall a. [a] -> [a] -> [a]
++ SchemaKeyV -> String
fromSchemaKeyV SchemaKeyV
key forall a. [a] -> [a] -> [a]
++ String
"' specified multiple times"
              | [a
val] <- [a]
provided -> forall a b. b -> Either a b
Right (SchemaKeyV
key, a
val)
              | forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
imported forall a. Ord a => a -> a -> Bool
> Int
1 -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Key '" forall a. [a] -> [a] -> [a]
++ SchemaKeyV -> String
fromSchemaKeyV SchemaKeyV
key forall a. [a] -> [a] -> [a]
++ String
"' declared in multiple imported schemas"
              | [a
val] <- [a]
imported -> forall a b. b -> Either a b
Right (SchemaKeyV
key, a
val)
              | Bool
otherwise -> forall a. String -> a
unreachable forall a b. (a -> b) -> a -> b
$ String
"resolveKey received: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (SchemaKeyV
key, [(KeySource, a)]
sourcesAndVals)

{- SchemaDef conversions -}

fromSchemaDefKey :: SchemaDefObjKey -> SchemaKeyV
fromSchemaDefKey :: SchemaDefObjKey -> SchemaKeyV
fromSchemaDefKey = \case
  SchemaDefObjKeyNormal String
key -> forall s. s -> SchemaKey' s
NormalKey String
key
  SchemaDefObjKeyPhantom String
key -> forall s. s -> SchemaKey' s
PhantomKey String
key

fromSchemaDefType :: SchemaDef -> Q SchemaTypeV
fromSchemaDefType :: SchemaDef -> Q (SchemaType' String NameLike)
fromSchemaDefType = \case
  SchemaDefType String
name -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s ty. ty -> SchemaType' s ty
SchemaScalar forall a b. (a -> b) -> a -> b
$ String -> NameLike
NameRef String
name
  SchemaDefMaybe SchemaDef
inner -> forall s ty. SchemaType' s ty -> SchemaType' s ty
SchemaMaybe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SchemaDef -> Q (SchemaType' String NameLike)
fromSchemaDefType SchemaDef
inner
  SchemaDefTry SchemaDef
inner -> forall s ty. SchemaType' s ty -> SchemaType' s ty
SchemaTry forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SchemaDef -> Q (SchemaType' String NameLike)
fromSchemaDefType SchemaDef
inner
  SchemaDefList SchemaDef
inner -> forall s ty. SchemaType' s ty -> SchemaType' s ty
SchemaList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SchemaDef -> Q (SchemaType' String NameLike)
fromSchemaDefType SchemaDef
inner
  SchemaDefInclude String
other -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s ty. Either ty (Schema' s ty) -> SchemaType' s ty
SchemaInclude forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> NameLike
NameRef String
other
  SchemaDefUnion NonEmpty SchemaDef
schemas -> forall s ty. [SchemaType' s ty] -> SchemaType' s ty
SchemaUnion forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> [a]
NonEmpty.toList 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 SchemaDef -> Q (SchemaType' String NameLike)
fromSchemaDefType NonEmpty SchemaDef
schemas
  SchemaDefObj NonEmpty SchemaDefObjItem
items -> forall s ty. SchemaObjectMap' s ty -> SchemaType' s ty
SchemaObject forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty SchemaDefObjItem -> Q (SchemaObjectMap' String NameLike)
generateSchemaObjectV NonEmpty SchemaDefObjItem
items

{- LookupMap utilities -}

type LookupMap k v = [(k, v)]

-- | Distribute the given element across the values in the map.
distribute :: LookupMap k v -> a -> LookupMap k (a, v)
distribute :: forall k v a. LookupMap k v -> a -> LookupMap k (a, v)
distribute LookupMap k v
lookupMap a
a = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a
a,)) LookupMap k v
lookupMap

{- | Find all values with the same key (according to the given function) and group them.

 Invariants:
 * [v] has length > 0
 * If the first occurence of k1 is before the first occurence of k2, k1 is before k2
   in the result
-}
groupByKeyWith :: (Eq a, Hashable a) => (k -> a) -> LookupMap k v -> LookupMap k [v]
groupByKeyWith :: forall a k v.
(Eq a, Hashable a) =>
(k -> a) -> LookupMap k v -> LookupMap k [v]
groupByKeyWith k -> a
f LookupMap k v
pairs = forall a b. (a -> b) -> [a] -> [b]
map (\k
key -> (k
key, HashMap a [v]
groups forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
HashMap.! k -> a
f k
key)) [k]
distinctKeys
  where
    -- don't use sort; keys should stay in the same order
    distinctKeys :: [k]
distinctKeys = forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` k -> a
f) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst LookupMap k v
pairs

    groups :: HashMap a [v]
groups = forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> [(k, v)] -> HashMap k v
HashMap.fromListWith (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. [a] -> [a] -> [a]
(++)) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(k
k, v
v) -> (k -> a
f k
k, [v
v])) LookupMap k v
pairs

{- Utilities -}

lookupAll :: Eq a => a -> [(a, b)] -> [b]
lookupAll :: forall a b. Eq a => a -> [(a, b)] -> [b]
lookupAll a
a = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
== a
a) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)