{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
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 (..))
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
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
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
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
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)
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
type LookupMap k v = [(k, v)]
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
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
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
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)