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

The 'schema' quasiquoter.
-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}

module Data.Aeson.Schema.TH.Schema (schema) where

import Control.Monad (unless, (>=>))
import Data.Function (on)
import Data.Hashable (Hashable)
import qualified Data.HashMap.Strict as HashMap
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 :: (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 `schema` for Exp"
  , quoteDec :: String -> Q [Dec]
quoteDec = String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"Cannot use `schema` for Dec"
  , quoteType :: String -> Q Type
quoteType = String -> Q SchemaDef
forall (m :: * -> *). MonadFail m => String -> m SchemaDef
parseSchemaDef (String -> Q SchemaDef)
-> (SchemaDef -> Q Type) -> String -> Q Type
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
_ -> String -> Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"`schema` definition must be an object"
  , quotePat :: String -> Q Pat
quotePat = String -> String -> Q Pat
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 (SchemaV -> Q Type)
-> (SchemaObjectMap' String NameLike -> SchemaV)
-> SchemaObjectMap' String NameLike
-> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SchemaObjectMap' String NameLike -> SchemaV
forall s ty. SchemaObjectMap' s ty -> Schema' s ty
Schema (SchemaObjectMap' String NameLike -> Q Type)
-> Q (SchemaObjectMap' String NameLike) -> Q Type
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
(Int -> KeySource -> ShowS)
-> (KeySource -> String)
-> ([KeySource] -> ShowS)
-> Show KeySource
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
(KeySource -> KeySource -> Bool)
-> (KeySource -> KeySource -> Bool) -> Eq KeySource
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 <- (SchemaDefObjItem
 -> Q (SchemaObjectMap' String NameLike, KeySource))
-> NonEmpty SchemaDefObjItem
-> Q (NonEmpty (SchemaObjectMap' String NameLike, KeySource))
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, SchemaTypeV)
schemaObjectMaps = ((SchemaObjectMap' String NameLike, KeySource)
 -> LookupMap SchemaKeyV (KeySource, SchemaTypeV))
-> NonEmpty (SchemaObjectMap' String NameLike, KeySource)
-> LookupMap SchemaKeyV (KeySource, SchemaTypeV)
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((SchemaObjectMap' String NameLike
 -> KeySource -> LookupMap SchemaKeyV (KeySource, SchemaTypeV))
-> (SchemaObjectMap' String NameLike, KeySource)
-> LookupMap SchemaKeyV (KeySource, SchemaTypeV)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry SchemaObjectMap' String NameLike
-> KeySource -> LookupMap SchemaKeyV (KeySource, SchemaTypeV)
forall k v a. LookupMap k v -> a -> LookupMap k (a, v)
distribute) NonEmpty (SchemaObjectMap' String NameLike, KeySource)
schemaObjectMapsWithSource

  (String -> Q (SchemaObjectMap' String NameLike))
-> (SchemaObjectMap' String NameLike
    -> Q (SchemaObjectMap' String NameLike))
-> Either String (SchemaObjectMap' String NameLike)
-> Q (SchemaObjectMap' String NameLike)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Q (SchemaObjectMap' String NameLike)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail SchemaObjectMap' String NameLike
-> Q (SchemaObjectMap' String NameLike)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (SchemaObjectMap' String NameLike)
 -> Q (SchemaObjectMap' String NameLike))
-> Either String (SchemaObjectMap' String NameLike)
-> Q (SchemaObjectMap' String NameLike)
forall a b. (a -> b) -> a -> b
$ LookupMap SchemaKeyV (KeySource, SchemaTypeV)
-> Either String (SchemaObjectMap' String NameLike)
forall a.
Show a =>
LookupMap SchemaKeyV (KeySource, a)
-> Either String (LookupMap SchemaKeyV a)
resolveKeys LookupMap SchemaKeyV (KeySource, SchemaTypeV)
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
    SchemaTypeV
schemaType <- SchemaDef -> Q SchemaTypeV
fromSchemaDefType SchemaDef
schemaDefType

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

    (SchemaObjectMap' String NameLike, KeySource)
-> Q (SchemaObjectMap' String NameLike, KeySource)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(SchemaKeyV
schemaKey, SchemaTypeV
schemaType)], KeySource
Provided)

  SchemaDefObjExtend String
other -> do
    SchemaV
schemaV <- String -> Q SchemaV
reifySchema String
other
    (SchemaObjectMap' String NameLike, KeySource)
-> Q (SchemaObjectMap' String NameLike, KeySource)
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 -> (SchemaType' s ty -> Bool) -> [SchemaType' s ty] -> Bool
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 :: Show a => LookupMap SchemaKeyV (KeySource, a) -> Either String (LookupMap SchemaKeyV a)
resolveKeys :: LookupMap SchemaKeyV (KeySource, a)
-> Either String (LookupMap SchemaKeyV a)
resolveKeys = ((SchemaKeyV, [(KeySource, a)]) -> Either String (SchemaKeyV, a))
-> [(SchemaKeyV, [(KeySource, a)])]
-> Either String (LookupMap SchemaKeyV a)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((SchemaKeyV -> [(KeySource, a)] -> Either String (SchemaKeyV, a))
-> (SchemaKeyV, [(KeySource, a)]) -> Either String (SchemaKeyV, a)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry SchemaKeyV -> [(KeySource, a)] -> Either String (SchemaKeyV, a)
forall b.
Show b =>
SchemaKeyV -> [(KeySource, b)] -> Either String (SchemaKeyV, b)
resolveKey) ([(SchemaKeyV, [(KeySource, a)])]
 -> Either String (LookupMap SchemaKeyV a))
-> (LookupMap SchemaKeyV (KeySource, a)
    -> [(SchemaKeyV, [(KeySource, a)])])
-> LookupMap SchemaKeyV (KeySource, a)
-> Either String (LookupMap SchemaKeyV a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SchemaKeyV -> String)
-> LookupMap SchemaKeyV (KeySource, a)
-> [(SchemaKeyV, [(KeySource, a)])]
forall a k v.
(Eq a, Hashable a) =>
(k -> a) -> LookupMap k v -> LookupMap k [v]
groupByKeyWith SchemaKeyV -> String
fromSchemaKeyV
  where
    resolveKey :: SchemaKeyV -> [(KeySource, b)] -> Either String (SchemaKeyV, b)
resolveKey SchemaKeyV
key [(KeySource, b)]
sourcesAndVals =
      let filterSource :: KeySource -> [b]
filterSource KeySource
source = ((KeySource, b) -> b) -> [(KeySource, b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (KeySource, b) -> b
forall a b. (a, b) -> b
snd ([(KeySource, b)] -> [b]) -> [(KeySource, b)] -> [b]
forall a b. (a -> b) -> a -> b
$ ((KeySource, b) -> Bool) -> [(KeySource, b)] -> [(KeySource, b)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((KeySource -> KeySource -> Bool
forall a. Eq a => a -> a -> Bool
== KeySource
source) (KeySource -> Bool)
-> ((KeySource, b) -> KeySource) -> (KeySource, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeySource, b) -> KeySource
forall a b. (a, b) -> a
fst) [(KeySource, b)]
sourcesAndVals
          numProvided :: Int
numProvided = [b] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([b] -> Int) -> [b] -> Int
forall a b. (a -> b) -> a -> b
$ KeySource -> [b]
filterSource KeySource
Provided
          numImported :: Int
numImported = [b] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([b] -> Int) -> [b] -> Int
forall a b. (a -> b) -> a -> b
$ KeySource -> [b]
filterSource KeySource
Imported
      in if
        | Int
numProvided Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 -> String -> Either String (SchemaKeyV, b)
forall a b. a -> Either a b
Left (String -> Either String (SchemaKeyV, b))
-> String -> Either String (SchemaKeyV, b)
forall a b. (a -> b) -> a -> b
$ String
"Key '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ SchemaKeyV -> String
fromSchemaKeyV SchemaKeyV
key String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' specified multiple times"
        | [b
val] <- KeySource -> [b]
filterSource KeySource
Provided -> (SchemaKeyV, b) -> Either String (SchemaKeyV, b)
forall a b. b -> Either a b
Right (SchemaKeyV
key, b
val)
        | Int
numImported Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 -> String -> Either String (SchemaKeyV, b)
forall a b. a -> Either a b
Left (String -> Either String (SchemaKeyV, b))
-> String -> Either String (SchemaKeyV, b)
forall a b. (a -> b) -> a -> b
$ String
"Key '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ SchemaKeyV -> String
fromSchemaKeyV SchemaKeyV
key String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' declared in multiple imported schemas"
        | [b
val] <- KeySource -> [b]
filterSource KeySource
Imported -> (SchemaKeyV, b) -> Either String (SchemaKeyV, b)
forall a b. b -> Either a b
Right (SchemaKeyV
key, b
val)
        | Bool
otherwise -> String -> Either String (SchemaKeyV, b)
forall a. String -> a
unreachable (String -> Either String (SchemaKeyV, b))
-> String -> Either String (SchemaKeyV, b)
forall a b. (a -> b) -> a -> b
$ String
"resolveKey received: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (SchemaKeyV, [(KeySource, b)]) -> String
forall a. Show a => a -> String
show (SchemaKeyV
key, [(KeySource, b)]
sourcesAndVals)

{- SchemaDef conversions -}

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

fromSchemaDefType :: SchemaDef -> Q SchemaTypeV
fromSchemaDefType :: SchemaDef -> Q SchemaTypeV
fromSchemaDefType = \case
  SchemaDefType String
name     -> SchemaTypeV -> Q SchemaTypeV
forall (m :: * -> *) a. Monad m => a -> m a
return (SchemaTypeV -> Q SchemaTypeV) -> SchemaTypeV -> Q SchemaTypeV
forall a b. (a -> b) -> a -> b
$ NameLike -> SchemaTypeV
forall s ty. ty -> SchemaType' s ty
SchemaScalar (NameLike -> SchemaTypeV) -> NameLike -> SchemaTypeV
forall a b. (a -> b) -> a -> b
$ String -> NameLike
NameRef String
name
  SchemaDefMaybe SchemaDef
inner   -> SchemaTypeV -> SchemaTypeV
forall s ty. SchemaType' s ty -> SchemaType' s ty
SchemaMaybe (SchemaTypeV -> SchemaTypeV) -> Q SchemaTypeV -> Q SchemaTypeV
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SchemaDef -> Q SchemaTypeV
fromSchemaDefType SchemaDef
inner
  SchemaDefTry SchemaDef
inner     -> SchemaTypeV -> SchemaTypeV
forall s ty. SchemaType' s ty -> SchemaType' s ty
SchemaTry (SchemaTypeV -> SchemaTypeV) -> Q SchemaTypeV -> Q SchemaTypeV
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SchemaDef -> Q SchemaTypeV
fromSchemaDefType SchemaDef
inner
  SchemaDefList SchemaDef
inner    -> SchemaTypeV -> SchemaTypeV
forall s ty. SchemaType' s ty -> SchemaType' s ty
SchemaList (SchemaTypeV -> SchemaTypeV) -> Q SchemaTypeV -> Q SchemaTypeV
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SchemaDef -> Q SchemaTypeV
fromSchemaDefType SchemaDef
inner
  SchemaDefInclude String
other -> SchemaTypeV -> Q SchemaTypeV
forall (m :: * -> *) a. Monad m => a -> m a
return (SchemaTypeV -> Q SchemaTypeV) -> SchemaTypeV -> Q SchemaTypeV
forall a b. (a -> b) -> a -> b
$ Either NameLike SchemaV -> SchemaTypeV
forall s ty. Either ty (Schema' s ty) -> SchemaType' s ty
SchemaInclude (Either NameLike SchemaV -> SchemaTypeV)
-> Either NameLike SchemaV -> SchemaTypeV
forall a b. (a -> b) -> a -> b
$ NameLike -> Either NameLike SchemaV
forall a b. a -> Either a b
Left (NameLike -> Either NameLike SchemaV)
-> NameLike -> Either NameLike SchemaV
forall a b. (a -> b) -> a -> b
$ String -> NameLike
NameRef String
other
  SchemaDefUnion NonEmpty SchemaDef
schemas -> [SchemaTypeV] -> SchemaTypeV
forall s ty. [SchemaType' s ty] -> SchemaType' s ty
SchemaUnion ([SchemaTypeV] -> SchemaTypeV)
-> (NonEmpty SchemaTypeV -> [SchemaTypeV])
-> NonEmpty SchemaTypeV
-> SchemaTypeV
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty SchemaTypeV -> [SchemaTypeV]
forall a. NonEmpty a -> [a]
NonEmpty.toList (NonEmpty SchemaTypeV -> SchemaTypeV)
-> Q (NonEmpty SchemaTypeV) -> Q SchemaTypeV
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SchemaDef -> Q SchemaTypeV)
-> NonEmpty SchemaDef -> Q (NonEmpty SchemaTypeV)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM SchemaDef -> Q SchemaTypeV
fromSchemaDefType NonEmpty SchemaDef
schemas
  SchemaDefObj NonEmpty SchemaDefObjItem
items     -> SchemaObjectMap' String NameLike -> SchemaTypeV
forall s ty. SchemaObjectMap' s ty -> SchemaType' s ty
SchemaObject (SchemaObjectMap' String NameLike -> SchemaTypeV)
-> Q (SchemaObjectMap' String NameLike) -> Q SchemaTypeV
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 :: LookupMap k v -> a -> LookupMap k (a, v)
distribute LookupMap k v
lookupMap a
a = ((k, v) -> (k, (a, v))) -> LookupMap k v -> LookupMap k (a, v)
forall a b. (a -> b) -> [a] -> [b]
map ((v -> (a, v)) -> (k, v) -> (k, (a, v))
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 :: (k -> a) -> LookupMap k v -> LookupMap k [v]
groupByKeyWith k -> a
f LookupMap k v
pairs = (k -> (k, [v])) -> [k] -> LookupMap k [v]
forall a b. (a -> b) -> [a] -> [b]
map (\k
key -> (k
key, HashMap a [v]
groups HashMap a [v] -> a -> [v]
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 = (k -> k -> Bool) -> [k] -> [k]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==) (a -> a -> Bool) -> (k -> a) -> k -> k -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` k -> a
f) ([k] -> [k]) -> [k] -> [k]
forall a b. (a -> b) -> a -> b
$ ((k, v) -> k) -> LookupMap k v -> [k]
forall a b. (a -> b) -> [a] -> [b]
map (k, v) -> k
forall a b. (a, b) -> a
fst LookupMap k v
pairs

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