{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}

-- | This module defines a generic representation of values belonging
-- to a schema, for use during data migration.
module Data.API.Value
    ( -- * Types
      Value(..)
    , Record
    , Field(..)

      -- * Converting to and from generic values
    , fromDefaultValue
    , fromJSON
    , parseJSON
    , encode
    , decode

      -- * Data validation
    , matchesNormAPI
    , expectRecord
    , expectEnum
    , expectUnion
    , expectList
    , expectMaybe
    , lookupType

      -- * Manipulating records
    , recordToMap
    , mapToRecord
    , insertField
    , renameField
    , deleteField
    , findField
    , joinRecords

      -- * QuickCheck test infrastructure
    , arbitrary
    , arbitraryOfType
    , arbitraryJSONValue
    , prop_jsonRoundTrip
    , prop_jsonGeneric
    , prop_cborRoundTrip
    , prop_cborGeneric
    ) where

import           Data.API.Error
import           Data.API.JSON
import           Data.API.NormalForm
import           Data.API.Time
import           Data.API.Types
import           Data.API.Utils

import           Control.Applicative
import           Control.Monad
import           Control.DeepSeq
import qualified Data.Aeson                     as JS
import qualified Codec.Serialise          as CBOR
import qualified Codec.Serialise.Decoding as CBOR
import qualified Codec.Serialise.Encoding as CBOR
import           Data.Binary.Serialise.CBOR.Extra
import qualified Codec.CBOR.FlatTerm as CBOR
import           Data.Binary.Serialise.CBOR.JSON
import qualified Data.HashMap.Strict            as HMap
import           Data.List (sortBy)
import qualified Data.Map.Strict                as Map
import           Data.Monoid
import           Data.Ord
import qualified Data.Set                       as Set
import qualified Data.Text                      as T
import           Data.Traversable
import           Data.Time (NominalDiffTime, UTCTime)
import           Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import qualified Data.Vector                    as V
import qualified Test.QuickCheck                as QC
import qualified Test.QuickCheck.Property       as QCP
import           Prelude


-- | Generic representation of a data value belonging to a schema
-- type.  This representation has the following properties:
--
--  * it is straightforward to convert into either CBOR or JSON;
--
--  * decoding CBOR or parsing JSON requires the schema, and takes
--    advantage of it by introducing type distinctions and interning
--    field names;
--
--  * decoding CBOR is relatively efficient.
data Value = String  !T.Text
           | UTCTime !UTCTime
           | Bytes   !Binary
           | Bool    !Bool
           | Int     !Int
           | List    ![Value]
           | Maybe   !(Maybe Value)
           | Union   !FieldName !Value
           | Enum    !FieldName
           | Record  !Record
           | JSON    !JS.Value
    deriving (Value -> Value -> Bool
(Value -> Value -> Bool) -> (Value -> Value -> Bool) -> Eq Value
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Value -> Value -> Bool
$c/= :: Value -> Value -> Bool
== :: Value -> Value -> Bool
$c== :: Value -> Value -> Bool
Eq, Int -> Value -> ShowS
[Value] -> ShowS
Value -> String
(Int -> Value -> ShowS)
-> (Value -> String) -> ([Value] -> ShowS) -> Show Value
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Value] -> ShowS
$cshowList :: [Value] -> ShowS
show :: Value -> String
$cshow :: Value -> String
showsPrec :: Int -> Value -> ShowS
$cshowsPrec :: Int -> Value -> ShowS
Show)

-- | A record is represented as a list of (field name, value) pairs.
--
-- Invariant: these are in ascending order by field name, and there
-- are no duplicates.
--
-- TODO: consider if it would be worth using 'Map.Map' instead.
type Record = [Field]

data Field = Field { Field -> FieldName
fieldName  :: FieldName
                   , Field -> Value
fieldValue :: Value
                   }
    deriving (Field -> Field -> Bool
(Field -> Field -> Bool) -> (Field -> Field -> Bool) -> Eq Field
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Field -> Field -> Bool
$c/= :: Field -> Field -> Bool
== :: Field -> Field -> Bool
$c== :: Field -> Field -> Bool
Eq, Int -> Field -> ShowS
[Field] -> ShowS
Field -> String
(Int -> Field -> ShowS)
-> (Field -> String) -> ([Field] -> ShowS) -> Show Field
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Field] -> ShowS
$cshowList :: [Field] -> ShowS
show :: Field -> String
$cshow :: Field -> String
showsPrec :: Int -> Field -> ShowS
$cshowsPrec :: Int -> Field -> ShowS
Show)

instance NFData Value where
  rnf :: Value -> ()
rnf (String Text
t)   = Text -> ()
forall a. NFData a => a -> ()
rnf Text
t
  rnf (UTCTime UTCTime
t)  = UTCTime -> ()
forall a. NFData a => a -> ()
rnf UTCTime
t
  rnf (Bytes Binary
b)    = Binary -> ()
forall a. NFData a => a -> ()
rnf Binary
b
  rnf (Bool Bool
b)     = Bool -> ()
forall a. NFData a => a -> ()
rnf Bool
b
  rnf (Int Int
i)      = Int -> ()
forall a. NFData a => a -> ()
rnf Int
i
  rnf (List [Value]
xs)    = [Value] -> ()
forall a. NFData a => a -> ()
rnf [Value]
xs
  rnf (Maybe Maybe Value
mb)   = Maybe Value -> ()
forall a. NFData a => a -> ()
rnf Maybe Value
mb
  rnf (Union FieldName
fn Value
v) = FieldName -> ()
forall a. NFData a => a -> ()
rnf FieldName
fn () -> () -> ()
`seq` Value -> ()
forall a. NFData a => a -> ()
rnf Value
v
  rnf (Enum FieldName
fn)    = FieldName -> ()
forall a. NFData a => a -> ()
rnf FieldName
fn
  rnf (Record [Field]
xs)  = [Field] -> ()
forall a. NFData a => a -> ()
rnf [Field]
xs
  rnf (JSON Value
v)     = Value -> ()
forall a. NFData a => a -> ()
rnf Value
v

instance NFData Field where
  rnf :: Field -> ()
rnf (Field FieldName
x Value
y) = FieldName -> ()
forall a. NFData a => a -> ()
rnf FieldName
x () -> () -> ()
`seq` Value -> ()
forall a. NFData a => a -> ()
rnf Value
y


-- | Convert a 'DefaultValue' into a generic 'Value', failing if the
-- type is not compatible.  This requires type information so that it
-- can introduce type distinctions absent in 'DefaultValue', e.g. when
-- 'DefValList' is used at type @'TyMaybe' ('TyList' t)@.
fromDefaultValue :: NormAPI -> APIType -> DefaultValue -> Maybe Value
fromDefaultValue :: NormAPI -> APIType -> DefaultValue -> Maybe Value
fromDefaultValue NormAPI
api APIType
ty0 DefaultValue
dv = case (APIType
ty0, DefaultValue
dv) of
    (TyList  APIType
_, DefaultValue
DefValList)    -> Value -> Maybe Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Value] -> Value
List [])
    (TyMaybe APIType
_, DefaultValue
DefValMaybe)   -> Value -> Maybe Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Value -> Value
Maybe Maybe Value
forall a. Maybe a
Nothing)
    (TyMaybe APIType
ty, DefaultValue
_)            -> Maybe Value -> Value
Maybe (Maybe Value -> Value) -> (Value -> Maybe Value) -> Value -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Value) -> Maybe Value -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NormAPI -> APIType -> DefaultValue -> Maybe Value
fromDefaultValue NormAPI
api APIType
ty DefaultValue
dv
    (TyBasic BasicType
bt, DefaultValue
_)            -> BasicType -> DefaultValue -> Maybe Value
fromDefaultValueBasic BasicType
bt DefaultValue
dv
    (APIType
TyJSON,    DefaultValue
_)             -> Value -> Maybe Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Value
JSON (DefaultValue -> Value
defaultValueAsJsValue DefaultValue
dv))
    (TyName TypeName
tname, DefaultValue
_)          -> do NormTypeDecl
d <- TypeName -> NormAPI -> Maybe NormTypeDecl
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TypeName
tname NormAPI
api
                                     case NormTypeDecl
d of
                                       NTypeSynonym APIType
ty -> NormAPI -> APIType -> DefaultValue -> Maybe Value
fromDefaultValue NormAPI
api APIType
ty DefaultValue
dv
                                       NNewtype BasicType
bt     -> BasicType -> DefaultValue -> Maybe Value
fromDefaultValueBasic BasicType
bt DefaultValue
dv
                                       NEnumType NormEnumType
vals | DefValString Text
s <- DefaultValue
dv
                                                      , Text -> FieldName
FieldName Text
s FieldName -> NormEnumType -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` NormEnumType
vals
                                                      -> Value -> Maybe Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FieldName -> Value
Enum (Text -> FieldName
FieldName Text
s))
                                       NormTypeDecl
_ -> Maybe Value
forall a. Maybe a
Nothing
    (APIType, DefaultValue)
_ -> Maybe Value
forall a. Maybe a
Nothing

fromDefaultValueBasic :: BasicType -> DefaultValue -> Maybe Value
fromDefaultValueBasic :: BasicType -> DefaultValue -> Maybe Value
fromDefaultValueBasic BasicType
bt DefaultValue
dv = case (BasicType
bt, DefaultValue
dv) of
    (BasicType
BTstring, DefValString Text
s) -> Value -> Maybe Value
forall a. a -> Maybe a
Just (Text -> Value
String Text
s)
    (BasicType
BTbinary, DefValString Text
s) -> case Text -> Either String Binary
base64ToBinary Text
s of
                                    Right Binary
b -> Value -> Maybe Value
forall a. a -> Maybe a
Just (Binary -> Value
Bytes Binary
b)
                                    Left  String
_ -> Maybe Value
forall a. Maybe a
Nothing
    (BasicType
BTbool, DefValBool Bool
b)     -> Value -> Maybe Value
forall a. a -> Maybe a
Just (Bool -> Value
Bool Bool
b)
    (BasicType
BTint, DefValInt Int
i)       -> Value -> Maybe Value
forall a. a -> Maybe a
Just (Int -> Value
Int Int
i)
    (BasicType
BTutc, DefValUtc UTCTime
u)       -> Value -> Maybe Value
forall a. a -> Maybe a
Just (UTCTime -> Value
UTCTime UTCTime
u)
    (BasicType, DefaultValue)
_                          -> Maybe Value
forall a. Maybe a
Nothing



instance JS.ToJSON Value where
  toJSON :: Value -> Value
toJSON Value
v0 = case Value
v0 of
                String Text
t       -> Text -> Value
JS.String Text
t
                UTCTime UTCTime
t      -> Text -> Value
JS.String (UTCTime -> Text
printUTC UTCTime
t)
                Bytes Binary
b        -> Binary -> Value
forall a. ToJSON a => a -> Value
JS.toJSON Binary
b
                Bool Bool
b         -> Bool -> Value
JS.Bool Bool
b
                Int Int
i          -> Int -> Value
forall a. ToJSON a => a -> Value
JS.toJSON Int
i
                List [Value]
vs        -> [Value] -> Value
forall a. ToJSON a => a -> Value
JS.toJSON [Value]
vs
                Maybe Maybe Value
Nothing  -> Value
JS.Null
                Maybe (Just Value
v) -> Value -> Value
forall a. ToJSON a => a -> Value
JS.toJSON Value
v
                Union FieldName
fn Value
v     -> [Pair] -> Value
JS.object [FieldName -> Text
_FieldName FieldName
fn Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
JS..= Value
v]
                Enum FieldName
fn        -> Text -> Value
JS.String (FieldName -> Text
_FieldName FieldName
fn)
                Record [Field]
xs      -> [Pair] -> Value
JS.object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ (Field -> Pair) -> [Field] -> [Pair]
forall a b. (a -> b) -> [a] -> [b]
map (\ (Field FieldName
fn Value
v) -> FieldName -> Text
_FieldName FieldName
fn Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
JS..= Value
v) [Field]
xs
                JSON Value
js        -> Value
js

-- | Parse a generic 'Value' from a JSON 'JS.Value', given the schema
-- and expected type.  This is not particularly optimized.  For the
-- other direction, use 'JS.toJSON'.
fromJSON :: NormAPI -> APIType -> JS.Value -> Either [(JSONError, Position)] (Value, [(JSONWarning, Position)])
fromJSON :: NormAPI
-> APIType
-> Value
-> Either [(JSONError, Position)] (Value, [(JSONError, Position)])
fromJSON NormAPI
api APIType
ty Value
v = ParseFlags
-> ParserWithErrs Value
-> Either [(JSONError, Position)] (Value, [(JSONError, Position)])
forall a.
ParseFlags
-> ParserWithErrs a
-> Either [(JSONError, Position)] (a, [(JSONError, Position)])
runParserWithErrsTop ParseFlags
defaultParseFlags (NormAPI -> APIType -> Value -> ParserWithErrs Value
parseJSON NormAPI
api APIType
ty Value
v)

parseJSON :: NormAPI -> APIType -> JS.Value -> ParserWithErrs Value
parseJSON :: NormAPI -> APIType -> Value -> ParserWithErrs Value
parseJSON NormAPI
api APIType
ty0 Value
v = case APIType
ty0 of
    TyName TypeName
tn  -> NormAPI
-> TypeName -> NormTypeDecl -> Value -> ParserWithErrs Value
parseJSONDecl NormAPI
api TypeName
tn (NormAPI -> TypeName -> NormTypeDecl
lookupTyName NormAPI
api TypeName
tn) Value
v
    TyList APIType
ty  -> case Value
v of
                    JS.Array Array
arr -> [Value] -> Value
List ([Value] -> Value)
-> ParserWithErrs [Value] -> ParserWithErrs Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> ParserWithErrs Value)
-> [Value] -> ParserWithErrs [Value]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (NormAPI -> APIType -> Value -> ParserWithErrs Value
parseJSON NormAPI
api APIType
ty) (Array -> [Value]
forall a. Vector a -> [a]
V.toList Array
arr)
                    Value
_            -> JSONError -> ParserWithErrs Value
forall a. JSONError -> ParserWithErrs a
failWith (Value -> JSONError
expectedArray Value
v)
    TyMaybe APIType
ty -> case Value
v of
                    Value
JS.Null -> Value -> ParserWithErrs Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Value -> Value
Maybe Maybe Value
forall a. Maybe a
Nothing)
                    Value
_       -> Maybe Value -> Value
Maybe (Maybe Value -> Value) -> (Value -> Maybe Value) -> Value -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Value) -> ParserWithErrs Value -> ParserWithErrs Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NormAPI -> APIType -> Value -> ParserWithErrs Value
parseJSON NormAPI
api APIType
ty Value
v
    APIType
TyJSON     -> Value -> ParserWithErrs Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Value
JSON Value
v)
    TyBasic BasicType
bt -> BasicType -> Value -> ParserWithErrs Value
parseJSONBasic BasicType
bt Value
v

parseJSONBasic :: BasicType -> JS.Value -> ParserWithErrs Value
parseJSONBasic :: BasicType -> Value -> ParserWithErrs Value
parseJSONBasic BasicType
bt = case BasicType
bt of
    BasicType
BTstring -> String
-> (Text -> ParserWithErrs Value) -> Value -> ParserWithErrs Value
forall a.
String -> (Text -> ParserWithErrs a) -> Value -> ParserWithErrs a
withText   String
"String"  (Value -> ParserWithErrs Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> ParserWithErrs Value)
-> (Text -> Value) -> Text -> ParserWithErrs Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
String)
    BasicType
BTbinary -> String
-> (Binary -> ParserWithErrs Value)
-> Value
-> ParserWithErrs Value
forall a.
String -> (Binary -> ParserWithErrs a) -> Value -> ParserWithErrs a
withBinary String
"Bytes"   (Value -> ParserWithErrs Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> ParserWithErrs Value)
-> (Binary -> Value) -> Binary -> ParserWithErrs Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Binary -> Value
Bytes)
    BasicType
BTbool   -> String
-> (Bool -> ParserWithErrs Value) -> Value -> ParserWithErrs Value
forall a.
String -> (Bool -> ParserWithErrs a) -> Value -> ParserWithErrs a
withBool   String
"Bool"    (Value -> ParserWithErrs Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> ParserWithErrs Value)
-> (Bool -> Value) -> Bool -> ParserWithErrs Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Value
Bool)
    BasicType
BTint    -> String
-> (Int -> ParserWithErrs Value) -> Value -> ParserWithErrs Value
forall a.
String -> (Int -> ParserWithErrs a) -> Value -> ParserWithErrs a
withInt    String
"Int"     (Value -> ParserWithErrs Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> ParserWithErrs Value)
-> (Int -> Value) -> Int -> ParserWithErrs Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Value
Int)
    BasicType
BTutc    -> String
-> (UTCTime -> ParserWithErrs Value)
-> Value
-> ParserWithErrs Value
forall a.
String
-> (UTCTime -> ParserWithErrs a) -> Value -> ParserWithErrs a
withUTC    String
"UTCTime" (Value -> ParserWithErrs Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> ParserWithErrs Value)
-> (UTCTime -> Value) -> UTCTime -> ParserWithErrs Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> Value
UTCTime)

parseJSONDecl :: NormAPI -> TypeName -> NormTypeDecl -> JS.Value -> ParserWithErrs Value
parseJSONDecl :: NormAPI
-> TypeName -> NormTypeDecl -> Value -> ParserWithErrs Value
parseJSONDecl NormAPI
api TypeName
tn NormTypeDecl
d = case NormTypeDecl
d of
    NRecordType NormRecordType
nrt -> \ Value
v -> case Value
v of
                                JS.Object Object
hm -> [Field] -> Value
Record ([Field] -> Value)
-> ParserWithErrs [Field] -> ParserWithErrs Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((FieldName, APIType) -> ParserWithErrs Field)
-> [(FieldName, APIType)] -> ParserWithErrs [Field]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Object -> (FieldName, APIType) -> ParserWithErrs Field
parseField Object
hm) (NormRecordType -> [(FieldName, APIType)]
forall k a. Map k a -> [(k, a)]
Map.toList NormRecordType
nrt)
                                Value
_            -> JSONError -> ParserWithErrs Value
forall a. JSONError -> ParserWithErrs a
failWith (Value -> JSONError
expectedObject Value
v)
    NUnionType  NormRecordType
nut -> [(Text, Value -> ParserWithErrs Value)]
-> Value -> ParserWithErrs Value
forall a.
[(Text, Value -> ParserWithErrs a)] -> Value -> ParserWithErrs a
withUnion (((FieldName, APIType) -> (Text, Value -> ParserWithErrs Value))
-> [(FieldName, APIType)]
-> [(Text, Value -> ParserWithErrs Value)]
forall a b. (a -> b) -> [a] -> [b]
map (\ (FieldName
fn, APIType
ty) -> (FieldName -> Text
_FieldName FieldName
fn, (Value -> Value) -> ParserWithErrs Value -> ParserWithErrs Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FieldName -> Value -> Value
Union FieldName
fn) (ParserWithErrs Value -> ParserWithErrs Value)
-> (Value -> ParserWithErrs Value) -> Value -> ParserWithErrs Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormAPI -> APIType -> Value -> ParserWithErrs Value
parseJSON NormAPI
api APIType
ty)) (NormRecordType -> [(FieldName, APIType)]
forall k a. Map k a -> [(k, a)]
Map.toList NormRecordType
nut))
    NEnumType   NormEnumType
net -> String
-> (Text -> ParserWithErrs Value) -> Value -> ParserWithErrs Value
forall a.
String -> (Text -> ParserWithErrs a) -> Value -> ParserWithErrs a
withText (Text -> String
T.unpack (TypeName -> Text
_TypeName TypeName
tn)) ((Text -> ParserWithErrs Value) -> Value -> ParserWithErrs Value)
-> (Text -> ParserWithErrs Value) -> Value -> ParserWithErrs Value
forall a b. (a -> b) -> a -> b
$ \ Text
k ->
                           case FieldName -> NormEnumType -> Maybe FieldName
forall a. Ord a => a -> Set a -> Maybe a
lookupSet (Text -> FieldName
FieldName Text
k) NormEnumType
net of
                             Just FieldName
fn -> Value -> ParserWithErrs Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FieldName -> Value
Enum FieldName
fn)
                             Maybe FieldName
Nothing -> JSONError -> ParserWithErrs Value
forall a. JSONError -> ParserWithErrs a
failWith ([Text] -> Text -> JSONError
UnexpectedEnumVal ((FieldName -> Text) -> [FieldName] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map FieldName -> Text
_FieldName (NormEnumType -> [FieldName]
forall a. Set a -> [a]
Set.toList NormEnumType
net)) Text
k)
    NTypeSynonym APIType
ty -> NormAPI -> APIType -> Value -> ParserWithErrs Value
parseJSON NormAPI
api APIType
ty
    NNewtype     BasicType
bt -> BasicType -> Value -> ParserWithErrs Value
parseJSONBasic BasicType
bt
  where
    parseField :: Object -> (FieldName, APIType) -> ParserWithErrs Field
parseField Object
hm (FieldName
fn, APIType
ty) = FieldName -> Value -> Field
Field FieldName
fn (Value -> Field) -> ParserWithErrs Value -> ParserWithErrs Field
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> (Value -> ParserWithErrs Value)
-> Object
-> ParserWithErrs Value
forall a.
Text -> (Value -> ParserWithErrs a) -> Object -> ParserWithErrs a
withField (FieldName -> Text
_FieldName FieldName
fn) (NormAPI -> APIType -> Value -> ParserWithErrs Value
parseJSON NormAPI
api APIType
ty) Object
hm



-- | Efficiently encode a generic 'Value' in CBOR format.
encode :: Value -> CBOR.Encoding
encode :: Value -> Encoding
encode Value
v0 = case Value
v0 of
    String Text
t   -> Text -> Encoding
CBOR.encodeString Text
t
    UTCTime UTCTime
t  -> UTCTime -> Encoding
forall a. Serialise a => a -> Encoding
CBOR.encode UTCTime
t
    Bytes Binary
b    -> Binary -> Encoding
forall a. Serialise a => a -> Encoding
CBOR.encode Binary
b
    Bool Bool
b     -> Bool -> Encoding
forall a. Serialise a => a -> Encoding
CBOR.encode Bool
b
    Int Int
i      -> Int -> Encoding
forall a. Serialise a => a -> Encoding
CBOR.encode Int
i
    List [Value]
vs    -> (Value -> Encoding) -> [Value] -> Encoding
forall a. (a -> Encoding) -> [a] -> Encoding
encodeListWith Value -> Encoding
encode [Value]
vs
    Maybe Maybe Value
mb_v -> (Value -> Encoding) -> Maybe Value -> Encoding
forall a. (a -> Encoding) -> Maybe a -> Encoding
encodeMaybeWith Value -> Encoding
encode Maybe Value
mb_v
    Union FieldName
fn Value
v -> Text -> Encoding -> Encoding
encodeUnion (FieldName -> Text
_FieldName FieldName
fn) (Value -> Encoding
encode Value
v)
    Enum FieldName
fn    -> Text -> Encoding
forall a. Serialise a => a -> Encoding
CBOR.encode (FieldName -> Text
_FieldName FieldName
fn)
    Record [Field]
xs  -> Word -> Encoding
CBOR.encodeMapLen (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Field] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Field]
xs))
                  Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> [Encoding] -> Encoding
encodeRecordFields ((Field -> Encoding) -> [Field] -> [Encoding]
forall a b. (a -> b) -> [a] -> [b]
map (\ (Field FieldName
fn Value
v) -> Text -> Encoding
forall a. Serialise a => a -> Encoding
CBOR.encode (FieldName -> Text
_FieldName FieldName
fn)
                                                                    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Value -> Encoding
encode Value
v) [Field]
xs)
    JSON Value
js    -> Value -> Encoding
encodeJSON Value
js


-- | Efficiently decode CBOR as a generic 'Value', given the schema
-- and expected type.
decode :: NormAPI -> APIType -> CBOR.Decoder s Value
decode :: NormAPI -> APIType -> Decoder s Value
decode NormAPI
api APIType
ty0 = case APIType
ty0 of
    TyName TypeName
tn  -> NormAPI -> NormTypeDecl -> Decoder s Value
forall s. NormAPI -> NormTypeDecl -> Decoder s Value
decodeDecl NormAPI
api (NormAPI -> TypeName -> NormTypeDecl
lookupTyName NormAPI
api TypeName
tn)
    TyList APIType
ty  -> [Value] -> Value
List  ([Value] -> Value) -> Decoder s [Value] -> Decoder s Value
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Decoder s Value -> Decoder s [Value]
forall s a. Decoder s a -> Decoder s [a]
decodeListWith (NormAPI -> APIType -> Decoder s Value
forall s. NormAPI -> APIType -> Decoder s Value
decode NormAPI
api APIType
ty)
    TyMaybe APIType
ty -> Maybe Value -> Value
Maybe (Maybe Value -> Value)
-> Decoder s (Maybe Value) -> Decoder s Value
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Decoder s Value -> Decoder s (Maybe Value)
forall s a. Decoder s a -> Decoder s (Maybe a)
decodeMaybeWith (NormAPI -> APIType -> Decoder s Value
forall s. NormAPI -> APIType -> Decoder s Value
decode NormAPI
api APIType
ty)
    APIType
TyJSON     -> Value -> Value
JSON  (Value -> Value) -> Decoder s Value -> Decoder s Value
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Decoder s Value
forall s. Decoder s Value
decodeJSON
    TyBasic BasicType
bt -> BasicType -> Decoder s Value
forall s. BasicType -> Decoder s Value
decodeBasic BasicType
bt

decodeBasic :: BasicType -> CBOR.Decoder s Value
decodeBasic :: BasicType -> Decoder s Value
decodeBasic BasicType
bt = case BasicType
bt of
    BasicType
BTstring -> Text -> Value
String (Text -> Value) -> Decoder s Text -> Decoder s Value
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Decoder s Text
forall a s. Serialise a => Decoder s a
CBOR.decode
    BasicType
BTbinary -> Binary -> Value
Bytes  (Binary -> Value) -> Decoder s Binary -> Decoder s Value
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Decoder s Binary
forall a s. Serialise a => Decoder s a
CBOR.decode
    BasicType
BTbool   -> Bool -> Value
Bool   (Bool -> Value) -> Decoder s Bool -> Decoder s Value
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Decoder s Bool
forall a s. Serialise a => Decoder s a
CBOR.decode
    BasicType
BTint    -> Int -> Value
Int    (Int -> Value) -> Decoder s Int -> Decoder s Value
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Decoder s Int
forall a s. Serialise a => Decoder s a
CBOR.decode
    BasicType
BTutc    -> UTCTime -> Value
UTCTime (UTCTime -> Value) -> Decoder s UTCTime -> Decoder s Value
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Decoder s UTCTime
forall a s. Serialise a => Decoder s a
CBOR.decode

decodeDecl :: NormAPI -> NormTypeDecl -> CBOR.Decoder s Value
decodeDecl :: NormAPI -> NormTypeDecl -> Decoder s Value
decodeDecl NormAPI
api NormTypeDecl
d = case NormTypeDecl
d of
    NRecordType NormRecordType
nrt -> do Int
_ <- Decoder s Int
forall s. Decoder s Int
CBOR.decodeMapLen
                          [Field] -> [(FieldName, APIType)] -> Decoder s Value
forall s. [Field] -> [(FieldName, APIType)] -> Decoder s Value
go [] (NormRecordType -> [(FieldName, APIType)]
forall k a. Map k a -> [(k, a)]
Map.toList NormRecordType
nrt)
    NUnionType  NormRecordType
nut -> do Int
_ <- Decoder s Int
forall s. Decoder s Int
CBOR.decodeMapLen
                          Text
k <- Decoder s Text
forall s. Decoder s Text
CBOR.decodeString
                          case FieldName -> NormRecordType -> Maybe (FieldName, APIType)
forall k a. Ord k => k -> Map k a -> Maybe (k, a)
lookupMap (Text -> FieldName
FieldName Text
k) NormRecordType
nut of
                            Just (FieldName
fn, APIType
ty) -> FieldName -> Value -> Value
Union FieldName
fn (Value -> Value) -> Decoder s Value -> Decoder s Value
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> NormAPI -> APIType -> Decoder s Value
forall s. NormAPI -> APIType -> Decoder s Value
decode NormAPI
api APIType
ty
                            Maybe (FieldName, APIType)
Nothing       -> String -> Decoder s Value
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s Value) -> String -> Decoder s Value
forall a b. (a -> b) -> a -> b
$ String
"unexpected union alternative: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
k
    NEnumType   NormEnumType
net -> do Text
k <- Decoder s Text
forall s. Decoder s Text
CBOR.decodeString
                          case FieldName -> NormEnumType -> Maybe FieldName
forall a. Ord a => a -> Set a -> Maybe a
lookupSet (Text -> FieldName
FieldName Text
k) NormEnumType
net of
                            Just FieldName
fn -> Value -> Decoder s Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FieldName -> Value
Enum FieldName
fn)
                            Maybe FieldName
Nothing -> String -> Decoder s Value
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s Value) -> String -> Decoder s Value
forall a b. (a -> b) -> a -> b
$ String
"unexpected enum alternative: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
k
    NTypeSynonym APIType
ty -> NormAPI -> APIType -> Decoder s Value
forall s. NormAPI -> APIType -> Decoder s Value
decode NormAPI
api APIType
ty
    NNewtype     BasicType
bt -> BasicType -> Decoder s Value
forall s. BasicType -> Decoder s Value
decodeBasic BasicType
bt
  where
    go :: [Field] -> [(FieldName, APIType)] -> Decoder s Value
go [Field]
xs []            = Value -> Decoder s Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Field] -> Value
Record ([Field] -> [Field]
forall a. [a] -> [a]
reverse [Field]
xs))
    go [Field]
xs ((FieldName
fn, APIType
ty):[(FieldName, APIType)]
ys) = do Text
_  <- Decoder s Text
forall s. Decoder s Text
CBOR.decodeString
                             !Value
v <- NormAPI -> APIType -> Decoder s Value
forall s. NormAPI -> APIType -> Decoder s Value
decode NormAPI
api APIType
ty
                             [Field] -> [(FieldName, APIType)] -> Decoder s Value
go (FieldName -> Value -> Field
Field FieldName
fn Value
vField -> [Field] -> [Field]
forall a. a -> [a] -> [a]
:[Field]
xs) [(FieldName, APIType)]
ys


-- | Check that the value is of the given type in the schema,
-- reporting the first error encountered if it does not conform.
matchesNormAPI :: NormAPI -> APIType -> Value -> Position -> Either (ValueError, Position) ()
matchesNormAPI :: NormAPI
-> APIType -> Value -> Position -> Either (ValueError, Position) ()
matchesNormAPI NormAPI
api APIType
ty0 Value
v0 Position
p = case APIType
ty0 of
    TyName TypeName
tn  -> do NormTypeDecl
d <- TypeName -> NormAPI -> Either ApplyFailure NormTypeDecl
lookupType TypeName
tn NormAPI
api Either ApplyFailure NormTypeDecl
-> (ApplyFailure -> (ValueError, Position))
-> Either (ValueError, Position) NormTypeDecl
forall e a e'. Either e a -> (e -> e') -> Either e' a
?!? (\ ApplyFailure
f -> (ApplyFailure -> ValueError
InvalidAPI ApplyFailure
f, Position
p))
                     NormAPI
-> NormTypeDecl
-> Value
-> Position
-> Either (ValueError, Position) ()
matchesNormAPIDecl NormAPI
api NormTypeDecl
d Value
v0 Position
p
    TyList APIType
ty  -> case Value
v0 of
                    List [Value]
vs -> ((Int, Value) -> Either (ValueError, Position) ())
-> [(Int, Value)] -> Either (ValueError, Position) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\ (Int
i, Value
v) -> NormAPI
-> APIType -> Value -> Position -> Either (ValueError, Position) ()
matchesNormAPI NormAPI
api APIType
ty Value
v (Int -> Step
InElem Int
i Step -> Position -> Position
forall a. a -> [a] -> [a]
: Position
p)) ([Int] -> [Value] -> [(Int, Value)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [Value]
vs)
                    Value
_       -> (ValueError, Position) -> Either (ValueError, Position) ()
forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError (Value -> JSONError
expectedArray Value
js_v), Position
p)
    TyMaybe APIType
ty -> case Value
v0 of
                    Maybe Maybe Value
Nothing -> () -> Either (ValueError, Position) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    Maybe (Just Value
v) -> NormAPI
-> APIType -> Value -> Position -> Either (ValueError, Position) ()
matchesNormAPI NormAPI
api APIType
ty Value
v Position
p
                    Value
_              -> (ValueError, Position) -> Either (ValueError, Position) ()
forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError (Expected -> String -> Value -> JSONError
Expected Expected
ExpObject String
"Maybe" Value
js_v), Position
p)
    APIType
TyJSON     -> case Value
v0 of
                    JSON Value
_ -> () -> Either (ValueError, Position) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    Value
_      -> (ValueError, Position) -> Either (ValueError, Position) ()
forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError (Expected -> String -> Value -> JSONError
Expected Expected
ExpObject String
"JSON" Value
js_v), Position
p)
    TyBasic BasicType
bt -> BasicType -> Value -> Position -> Either (ValueError, Position) ()
matchesNormAPIBasic BasicType
bt Value
v0 Position
p
  where
    js_v :: Value
js_v = Value -> Value
forall a. ToJSON a => a -> Value
JS.toJSON Value
v0

matchesNormAPIBasic :: BasicType -> Value -> Position -> Either (ValueError, Position) ()
matchesNormAPIBasic :: BasicType -> Value -> Position -> Either (ValueError, Position) ()
matchesNormAPIBasic BasicType
bt Value
v Position
p = case (BasicType
bt, Value
v) of
    (BasicType
BTstring, String Text
_) -> () -> Either (ValueError, Position) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    (BasicType
BTstring, Value
_)        -> (ValueError, Position) -> Either (ValueError, Position) ()
forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError (Value -> JSONError
expectedString Value
js_v), Position
p)
    (BasicType
BTbinary, Bytes Binary
_)  -> () -> Either (ValueError, Position) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    (BasicType
BTbinary, Value
_)        -> (ValueError, Position) -> Either (ValueError, Position) ()
forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError (Value -> JSONError
expectedString Value
js_v), Position
p)
    (BasicType
BTbool, Bool Bool
_)     -> () -> Either (ValueError, Position) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    (BasicType
BTbool, Value
_)          -> (ValueError, Position) -> Either (ValueError, Position) ()
forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError (Value -> JSONError
expectedBool Value
js_v), Position
p)
    (BasicType
BTint, Int Int
_)       -> () -> Either (ValueError, Position) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    (BasicType
BTint, Value
_)           -> (ValueError, Position) -> Either (ValueError, Position) ()
forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError (Value -> JSONError
expectedInt Value
js_v), Position
p)
    (BasicType
BTutc, UTCTime UTCTime
_)   -> () -> Either (ValueError, Position) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    (BasicType
BTutc, Value
_)           -> (ValueError, Position) -> Either (ValueError, Position) ()
forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError (Expected -> String -> Value -> JSONError
Expected Expected
ExpString String
"UTCTime" Value
js_v), Position
p)
  where
    js_v :: Value
js_v = Value -> Value
forall a. ToJSON a => a -> Value
JS.toJSON Value
v

matchesNormAPIDecl :: NormAPI -> NormTypeDecl -> Value -> Position -> Either (ValueError, Position) ()
matchesNormAPIDecl :: NormAPI
-> NormTypeDecl
-> Value
-> Position
-> Either (ValueError, Position) ()
matchesNormAPIDecl NormAPI
api NormTypeDecl
d Value
v0 Position
p = case NormTypeDecl
d of
    NRecordType NormRecordType
nrt -> do [Field]
xs <- Value -> Position -> Either (ValueError, Position) [Field]
expectRecord Value
v0 Position
p
                          case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ([Field] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Field]
xs) (NormRecordType -> Int
forall k a. Map k a -> Int
Map.size NormRecordType
nrt) of
                            Ordering
LT -> (ValueError, Position) -> Either (ValueError, Position) ()
forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError JSONError
MissingField, Position
p)
                            Ordering
EQ -> (((FieldName, APIType), Field) -> Either (ValueError, Position) ())
-> [((FieldName, APIType), Field)]
-> Either (ValueError, Position) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((FieldName, APIType), Field) -> Either (ValueError, Position) ()
matchesNormAPIField ([(FieldName, APIType)]
-> [Field] -> [((FieldName, APIType), Field)]
forall a b. [a] -> [b] -> [(a, b)]
zip (NormRecordType -> [(FieldName, APIType)]
forall k a. Map k a -> [(k, a)]
Map.toList NormRecordType
nrt) [Field]
xs)
                            Ordering
GT -> (ValueError, Position) -> Either (ValueError, Position) ()
forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError JSONError
UnexpectedField, Position
p)
    NUnionType  NormRecordType
nut -> do (FieldName
fn, Value
v) <- Value
-> Position -> Either (ValueError, Position) (FieldName, Value)
expectUnion Value
v0 Position
p
                          case FieldName -> NormRecordType -> Maybe APIType
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FieldName
fn NormRecordType
nut of
                            Just APIType
ty -> NormAPI
-> APIType -> Value -> Position -> Either (ValueError, Position) ()
matchesNormAPI NormAPI
api APIType
ty Value
v (FieldName -> Step
inField FieldName
fn Step -> Position -> Position
forall a. a -> [a] -> [a]
: Position
p)
                            Maybe APIType
Nothing -> (ValueError, Position) -> Either (ValueError, Position) ()
forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError JSONError
UnexpectedField, FieldName -> Step
inField FieldName
fn Step -> Position -> Position
forall a. a -> [a] -> [a]
: Position
p)
    NEnumType   NormEnumType
net -> do FieldName
fn <- Value -> Position -> Either (ValueError, Position) FieldName
expectEnum Value
v0 Position
p
                          Bool
-> Either (ValueError, Position) ()
-> Either (ValueError, Position) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FieldName -> NormEnumType -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member FieldName
fn NormEnumType
net) (Either (ValueError, Position) ()
 -> Either (ValueError, Position) ())
-> Either (ValueError, Position) ()
-> Either (ValueError, Position) ()
forall a b. (a -> b) -> a -> b
$ (ValueError, Position) -> Either (ValueError, Position) ()
forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError ([Text] -> Text -> JSONError
UnexpectedEnumVal ((FieldName -> Text) -> [FieldName] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map FieldName -> Text
_FieldName (NormEnumType -> [FieldName]
forall a. Set a -> [a]
Set.toList NormEnumType
net)) (FieldName -> Text
_FieldName FieldName
fn)), Position
p)
    NTypeSynonym APIType
ty -> NormAPI
-> APIType -> Value -> Position -> Either (ValueError, Position) ()
matchesNormAPI NormAPI
api APIType
ty Value
v0 Position
p
    NNewtype     BasicType
bt -> BasicType -> Value -> Position -> Either (ValueError, Position) ()
matchesNormAPIBasic BasicType
bt Value
v0 Position
p
  where
    matchesNormAPIField :: ((FieldName, APIType), Field) -> Either (ValueError, Position) ()
matchesNormAPIField ((FieldName
fn, APIType
ty), Field FieldName
fn' Value
v)
        | FieldName
fn FieldName -> FieldName -> Bool
forall a. Eq a => a -> a -> Bool
== FieldName
fn' = NormAPI
-> APIType -> Value -> Position -> Either (ValueError, Position) ()
matchesNormAPI NormAPI
api APIType
ty Value
v (FieldName -> Step
inField FieldName
fn Step -> Position -> Position
forall a. a -> [a] -> [a]
: Position
p)
        | Bool
otherwise = (ValueError, Position) -> Either (ValueError, Position) ()
forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError (String -> JSONError
SyntaxError ([String] -> String
unlines [String
"record out of order: ", FieldName -> String
forall a. Show a => a -> String
show FieldName
fn, FieldName -> String
forall a. Show a => a -> String
show FieldName
fn', NormTypeDecl -> String
forall a. Show a => a -> String
show NormTypeDecl
d, Value -> String
forall a. Show a => a -> String
show Value
v0])), Position
p)

expectRecord :: Value -> Position -> Either (ValueError, Position) Record
expectRecord :: Value -> Position -> Either (ValueError, Position) [Field]
expectRecord (Record [Field]
xs) Position
_ = [Field] -> Either (ValueError, Position) [Field]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Field]
xs
expectRecord Value
v           Position
p = (ValueError, Position) -> Either (ValueError, Position) [Field]
forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError (Expected -> String -> Value -> JSONError
Expected Expected
ExpObject String
"Record" (Value -> Value
forall a. ToJSON a => a -> Value
JS.toJSON Value
v)), Position
p)

expectEnum :: Value -> Position -> Either (ValueError, Position) FieldName
expectEnum :: Value -> Position -> Either (ValueError, Position) FieldName
expectEnum (Enum FieldName
s) Position
_ = FieldName -> Either (ValueError, Position) FieldName
forall (f :: * -> *) a. Applicative f => a -> f a
pure FieldName
s
expectEnum Value
v        Position
p = (ValueError, Position) -> Either (ValueError, Position) FieldName
forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError (Expected -> String -> Value -> JSONError
Expected Expected
ExpString String
"Enum" (Value -> Value
forall a. ToJSON a => a -> Value
JS.toJSON Value
v)), Position
p)

expectUnion :: Value -> Position -> Either (ValueError, Position) (FieldName, Value)
expectUnion :: Value
-> Position -> Either (ValueError, Position) (FieldName, Value)
expectUnion (Union FieldName
fname Value
v) Position
_ = (FieldName, Value)
-> Either (ValueError, Position) (FieldName, Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FieldName
fname, Value
v)
expectUnion Value
v               Position
p = (ValueError, Position)
-> Either (ValueError, Position) (FieldName, Value)
forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError (Expected -> String -> Value -> JSONError
Expected Expected
ExpObject String
"Union" (Value -> Value
forall a. ToJSON a => a -> Value
JS.toJSON Value
v)), Position
p)

expectList :: Value -> Position -> Either (ValueError, Position) [Value]
expectList :: Value -> Position -> Either (ValueError, Position) [Value]
expectList (List [Value]
xs) Position
_ = [Value] -> Either (ValueError, Position) [Value]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Value]
xs
expectList Value
v         Position
p = (ValueError, Position) -> Either (ValueError, Position) [Value]
forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError (Expected -> String -> Value -> JSONError
Expected Expected
ExpArray String
"List" (Value -> Value
forall a. ToJSON a => a -> Value
JS.toJSON Value
v)), Position
p)

expectMaybe :: Value -> Position -> Either (ValueError, Position) (Maybe Value)
expectMaybe :: Value -> Position -> Either (ValueError, Position) (Maybe Value)
expectMaybe (Maybe Maybe Value
v) Position
_ = Maybe Value -> Either (ValueError, Position) (Maybe Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Value
v
expectMaybe Value
v         Position
p = (ValueError, Position)
-> Either (ValueError, Position) (Maybe Value)
forall a b. a -> Either a b
Left (JSONError -> ValueError
JSONError (Expected -> String -> Value -> JSONError
Expected Expected
ExpArray String
"Maybe" (Value -> Value
forall a. ToJSON a => a -> Value
JS.toJSON Value
v)), Position
p)

lookupType :: TypeName -> NormAPI -> Either ApplyFailure NormTypeDecl
lookupType :: TypeName -> NormAPI -> Either ApplyFailure NormTypeDecl
lookupType TypeName
tname NormAPI
api = TypeName -> NormAPI -> Maybe NormTypeDecl
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TypeName
tname NormAPI
api Maybe NormTypeDecl
-> ApplyFailure -> Either ApplyFailure NormTypeDecl
forall a e. Maybe a -> e -> Either e a
?! TypeName -> ApplyFailure
TypeDoesNotExist TypeName
tname


-- | Given a schema, generate an arbitrary type corresponding to the
-- schema and an arbitrary value of that type.
arbitrary :: NormAPI -> QC.Gen (APIType, Value)
arbitrary :: NormAPI -> Gen (APIType, Value)
arbitrary NormAPI
api = do TypeName
tn <- [TypeName] -> Gen TypeName
forall a. [a] -> Gen a
QC.elements (NormAPI -> [TypeName]
forall k a. Map k a -> [k]
Map.keys NormAPI
api)
                   Value
v  <- NormAPI -> APIType -> Gen Value
arbitraryOfType NormAPI
api (TypeName -> APIType
TyName TypeName
tn)
                   (APIType, Value) -> Gen (APIType, Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeName -> APIType
TyName TypeName
tn, Value
v)

-- | Given a schema and a type, generate an arbitrary value of that
-- type.
arbitraryOfType :: NormAPI -> APIType -> QC.Gen Value
arbitraryOfType :: NormAPI -> APIType -> Gen Value
arbitraryOfType NormAPI
api APIType
ty0 = case APIType
ty0 of
    TyName  TypeName
tn -> NormAPI -> NormTypeDecl -> Gen Value
arbitraryOfDecl NormAPI
api (NormAPI -> TypeName -> NormTypeDecl
lookupTyName NormAPI
api TypeName
tn)
    TyList  APIType
ty -> [Value] -> Value
List  ([Value] -> Value) -> Gen [Value] -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Value -> Gen [Value]
forall a. Gen a -> Gen [a]
QC.listOf (NormAPI -> APIType -> Gen Value
arbitraryOfType NormAPI
api APIType
ty)
    TyMaybe APIType
ty -> Maybe Value -> Value
Maybe (Maybe Value -> Value) -> Gen (Maybe Value) -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Gen (Maybe Value)] -> Gen (Maybe Value)
forall a. [Gen a] -> Gen a
QC.oneof [Maybe Value -> Gen (Maybe Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Value
forall a. Maybe a
Nothing, Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Gen Value -> Gen (Maybe Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NormAPI -> APIType -> Gen Value
arbitraryOfType NormAPI
api APIType
ty]
    APIType
TyJSON     -> Value -> Value
JSON  (Value -> Value) -> Gen Value -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Value
arbitraryJSONValue
    TyBasic BasicType
bt -> BasicType -> Gen Value
arbitraryOfBasicType BasicType
bt

arbitraryOfBasicType :: BasicType -> QC.Gen Value
arbitraryOfBasicType :: BasicType -> Gen Value
arbitraryOfBasicType BasicType
bt = case BasicType
bt of
    BasicType
BTstring -> Text -> Value
String  (Text -> Value) -> Gen Text -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Text
forall a. Arbitrary a => Gen a
QC.arbitrary
    BasicType
BTbinary -> Binary -> Value
Bytes   (Binary -> Value) -> Gen Binary -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Binary
forall a. Arbitrary a => Gen a
QC.arbitrary
    BasicType
BTbool   -> Bool -> Value
Bool    (Bool -> Value) -> Gen Bool -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Bool
forall a. Arbitrary a => Gen a
QC.arbitrary
    BasicType
BTint    -> Int -> Value
Int     (Int -> Value) -> Gen Int -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Int
forall a. Arbitrary a => Gen a
QC.arbitrary
    BasicType
BTutc    -> UTCTime -> Value
UTCTime
                (UTCTime -> Value) -> (Int -> UTCTime) -> Int -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. POSIXTime -> UTCTime
posixSecondsToUTCTime
                (POSIXTime -> UTCTime) -> (Int -> POSIXTime) -> Int -> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> POSIXTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac :: Int -> NominalDiffTime)
                (Int -> Value) -> Gen Int -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Int
forall a. Arbitrary a => Gen a
QC.arbitrary

arbitraryOfDecl :: NormAPI -> NormTypeDecl -> QC.Gen Value
arbitraryOfDecl :: NormAPI -> NormTypeDecl -> Gen Value
arbitraryOfDecl NormAPI
api NormTypeDecl
d = case NormTypeDecl
d of
    NRecordType NormRecordType
nrt -> [Field] -> Value
Record ([Field] -> Value) -> Gen [Field] -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((FieldName, APIType) -> Gen Field)
-> [(FieldName, APIType)] -> Gen [Field]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\ (FieldName
fn, APIType
ty) -> FieldName -> Value -> Field
Field FieldName
fn (Value -> Field) -> Gen Value -> Gen Field
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NormAPI -> APIType -> Gen Value
arbitraryOfType NormAPI
api APIType
ty) (NormRecordType -> [(FieldName, APIType)]
forall k a. Map k a -> [(k, a)]
Map.toList NormRecordType
nrt)
    NUnionType  NormRecordType
nut -> do (FieldName
fn, APIType
ty) <- [(FieldName, APIType)] -> Gen (FieldName, APIType)
forall a. [a] -> Gen a
QC.elements (NormRecordType -> [(FieldName, APIType)]
forall k a. Map k a -> [(k, a)]
Map.toList NormRecordType
nut)
                          FieldName -> Value -> Value
Union FieldName
fn (Value -> Value) -> Gen Value -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NormAPI -> APIType -> Gen Value
arbitraryOfType NormAPI
api APIType
ty
    NEnumType   NormEnumType
net -> FieldName -> Value
Enum (FieldName -> Value) -> Gen FieldName -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FieldName] -> Gen FieldName
forall a. [a] -> Gen a
QC.elements (NormEnumType -> [FieldName]
forall a. Set a -> [a]
Set.toList NormEnumType
net)
    NTypeSynonym APIType
ty -> NormAPI -> APIType -> Gen Value
arbitraryOfType NormAPI
api APIType
ty
    NNewtype     BasicType
bt -> BasicType -> Gen Value
arbitraryOfBasicType BasicType
bt

-- | A reasonably varied generator for JSON 'JS.Value's.
--
-- Hack alert: we do not generate 'JS.Null', because Aeson fails to
-- round-trip @'Just' 'JS.Null' :: 'Maybe' 'JS.Value'@.
arbitraryJSONValue :: QC.Gen JS.Value
arbitraryJSONValue :: Gen Value
arbitraryJSONValue =
    (Int -> Gen Value) -> Gen Value
forall a. (Int -> Gen a) -> Gen a
QC.sized ((Int -> Gen Value) -> Gen Value)
-> (Int -> Gen Value) -> Gen Value
forall a b. (a -> b) -> a -> b
$ \ Int
size ->
        [Gen Value] -> Gen Value
forall a. [Gen a] -> Gen a
QC.oneof [ Object -> Value
JS.Object (Object -> Value) -> ([Pair] -> Object) -> [Pair] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pair] -> Object
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HMap.fromList ([Pair] -> Value) -> Gen [Pair] -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen [Pair] -> Gen [Pair]
forall a. Int -> Gen a -> Gen a
QC.resize (Int
size Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) (Gen Pair -> Gen [Pair]
forall a. Gen a -> Gen [a]
QC.listOf ((,) (Text -> Value -> Pair) -> Gen Text -> Gen (Value -> Pair)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Text
forall a. Arbitrary a => Gen a
QC.arbitrary Gen (Value -> Pair) -> Gen Value -> Gen Pair
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Value
arbitraryJSONValue))
                 , Array -> Value
JS.Array (Array -> Value) -> ([Value] -> Array) -> [Value] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> Array
forall a. [a] -> Vector a
V.fromList ([Value] -> Value) -> Gen [Value] -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen [Value] -> Gen [Value]
forall a. Int -> Gen a -> Gen a
QC.resize (Int
size Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) (Gen Value -> Gen [Value]
forall a. Gen a -> Gen [a]
QC.listOf Gen Value
arbitraryJSONValue)
                 , Text -> Value
JS.String (Text -> Value) -> Gen Text -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Text
forall a. Arbitrary a => Gen a
QC.arbitrary
                 , Scientific -> Value
JS.Number (Scientific -> Value)
-> (Integer -> Scientific) -> Integer -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Scientific
forall a. Num a => Integer -> a
fromInteger (Integer -> Value) -> Gen Integer -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Integer
forall a. Arbitrary a => Gen a
QC.arbitrary
                 , Bool -> Value
JS.Bool (Bool -> Value) -> Gen Bool -> Gen Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Bool
forall a. Arbitrary a => Gen a
QC.arbitrary
                 -- , pure JS.Null
                 ]



-- | QuickCheck property that converting a 'Value' to and from JSON
-- gives back the original value.
prop_jsonRoundTrip :: NormAPI -> QC.Property
prop_jsonRoundTrip :: NormAPI -> Property
prop_jsonRoundTrip NormAPI
api
  = Gen (APIType, Value) -> ((APIType, Value) -> Result) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
QC.forAll (NormAPI -> Gen (APIType, Value)
arbitrary NormAPI
api) (((APIType, Value) -> Result) -> Property)
-> ((APIType, Value) -> Result) -> Property
forall a b. (a -> b) -> a -> b
$ \ (APIType
ty, Value
v) ->
        case NormAPI
-> APIType
-> Value
-> Either [(JSONError, Position)] (Value, [(JSONError, Position)])
fromJSON NormAPI
api APIType
ty (Value -> Value
forall a. ToJSON a => a -> Value
JS.toJSON Value
v) of
          Right (Value
y, [(JSONError, Position)]
ws) | Value
v Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Value
y        -> Result
QCP.failed { reason :: String
QCP.reason = String
"Expected " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Show a => a -> String
show Value
v
                                                                       String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" but got " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Show a => a -> String
show Value
y }
                        | Bool -> Bool
not ([(JSONError, Position)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(JSONError, Position)]
ws) -> Result
QCP.failed { reason :: String
QCP.reason = String
"Unexpected warnings: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(JSONError, Position)] -> String
forall a. Show a => a -> String
show [(JSONError, Position)]
ws }
                        | Bool
otherwise     -> Result
QCP.succeeded
          Left [(JSONError, Position)]
err                      -> Result
QCP.failed { reason :: String
QCP.reason = String
"Parse error: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(JSONError, Position)] -> String
prettyJSONErrorPositions [(JSONError, Position)]
err }

-- | QuickCheck property that the type-specific JSON serialisation
-- agrees with deserialising as generic JSON and then serialising again.
prop_jsonGeneric :: JS.ToJSON a => API -> TypeName -> a -> QCP.Result
prop_jsonGeneric :: API -> TypeName -> a -> Result
prop_jsonGeneric API
api TypeName
tn a
x = case NormAPI
-> APIType
-> Value
-> Either [(JSONError, Position)] (Value, [(JSONError, Position)])
fromJSON NormAPI
napi (TypeName -> APIType
TyName TypeName
tn) Value
js_v of
    Right (Value
v, [(JSONError, Position)]
ws) | Value -> Value
forall a. ToJSON a => a -> Value
JS.toJSON Value
v Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Value
js_v -> Result
QCP.failed { reason :: String
QCP.reason = String
"Expected " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Show a => a -> String
show Value
js_v
                                                                       String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" but got " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Show a => a -> String
show (Value -> Value
forall a. ToJSON a => a -> Value
JS.toJSON Value
v) }
                  | Bool -> Bool
not ([(JSONError, Position)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(JSONError, Position)]
ws)       -> Result
QCP.failed { reason :: String
QCP.reason = String
"Unexpected warnings: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(JSONError, Position)] -> String
forall a. Show a => a -> String
show [(JSONError, Position)]
ws }
                  | Bool
otherwise           -> Result
QCP.succeeded
    Left [(JSONError, Position)]
err                            -> Result
QCP.failed { reason :: String
QCP.reason = String
"Parse error: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(JSONError, Position)] -> String
prettyJSONErrorPositions [(JSONError, Position)]
err }
  where
    napi :: NormAPI
napi = API -> NormAPI
apiNormalForm API
api
    js_v :: Value
js_v = a -> Value
forall a. ToJSON a => a -> Value
JS.toJSON a
x

-- | QuickCheck property that converting a 'Value' to and from CBOR
-- gives back the original value.
prop_cborRoundTrip :: NormAPI -> QC.Property
prop_cborRoundTrip :: NormAPI -> Property
prop_cborRoundTrip NormAPI
api
  = Gen (APIType, Value) -> ((APIType, Value) -> Result) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
QC.forAll (NormAPI -> Gen (APIType, Value)
arbitrary NormAPI
api) (((APIType, Value) -> Result) -> Property)
-> ((APIType, Value) -> Result) -> Property
forall a b. (a -> b) -> a -> b
$ \ (APIType
ty, Value
v) ->
       case (forall s. Decoder s Value) -> FlatTerm -> Either String Value
forall a. (forall s. Decoder s a) -> FlatTerm -> Either String a
CBOR.fromFlatTerm (NormAPI -> APIType -> Decoder s Value
forall s. NormAPI -> APIType -> Decoder s Value
decode NormAPI
api APIType
ty) (Encoding -> FlatTerm
CBOR.toFlatTerm (Value -> Encoding
encode Value
v)) of
         Right Value
v' | Value
v Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Value
v'   -> Result
QCP.failed { reason :: String
QCP.reason = String
"Expected " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Show a => a -> String
show Value
v
                                                             String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" but got " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Show a => a -> String
show Value
v' }
                  | Bool
otherwise -> Result
QCP.succeeded
         Left String
err             -> Result
QCP.failed { reason :: String
QCP.reason = String
"Parse error: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err }

-- | QuickCheck property that the type-specific CBOR serialisation
-- agrees with deserialising as generic CBOR and then serialising again.
prop_cborGeneric :: CBOR.Serialise a => API -> TypeName -> a -> QCP.Result
prop_cborGeneric :: API -> TypeName -> a -> Result
prop_cborGeneric API
api TypeName
tn a
x
  | Bool -> Bool
not (FlatTerm -> Bool
CBOR.validFlatTerm FlatTerm
bs) = Result
QCP.failed { reason :: String
QCP.reason = String
"Invalid CBOR: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FlatTerm -> String
forall a. Show a => a -> String
show FlatTerm
bs }
  | Bool
otherwise = case (forall s. Decoder s Value) -> FlatTerm -> Either String Value
forall a. (forall s. Decoder s a) -> FlatTerm -> Either String a
CBOR.fromFlatTerm (NormAPI -> APIType -> Decoder s Value
forall s. NormAPI -> APIType -> Decoder s Value
decode NormAPI
napi (TypeName -> APIType
TyName TypeName
tn)) FlatTerm
bs of
    Right Value
v | FlatTerm
bs' <- Encoding -> FlatTerm
CBOR.toFlatTerm (Value -> Encoding
encode Value
v)
            , FlatTerm
bs' FlatTerm -> FlatTerm -> Bool
forall a. Eq a => a -> a -> Bool
/= FlatTerm
bs -> Result
QCP.failed { reason :: String
QCP.reason = String
"Expected " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FlatTerm -> String
forall a. Show a => a -> String
show FlatTerm
bs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" but got " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FlatTerm -> String
forall a. Show a => a -> String
show FlatTerm
bs' }
            | Bool
otherwise      -> Result
QCP.succeeded
    Left String
err                 -> Result
QCP.failed { reason :: String
QCP.reason = String
"Decode error: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err }
  where
    napi :: NormAPI
napi = API -> NormAPI
apiNormalForm API
api
    bs :: FlatTerm
bs = Encoding -> FlatTerm
CBOR.toFlatTerm (a -> Encoding
forall a. Serialise a => a -> Encoding
CBOR.encode a
x)


-- | Look up a type in a schema, failing with an error if it is missing.
lookupTyName :: NormAPI -> TypeName -> NormTypeDecl
lookupTyName :: NormAPI -> TypeName -> NormTypeDecl
lookupTyName NormAPI
api TypeName
tn = case TypeName -> NormAPI -> Maybe NormTypeDecl
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TypeName
tn NormAPI
api of
                        Just NormTypeDecl
d  -> NormTypeDecl
d
                        Maybe NormTypeDecl
Nothing -> String -> NormTypeDecl
forall a. HasCallStack => String -> a
error (String -> NormTypeDecl) -> String -> NormTypeDecl
forall a b. (a -> b) -> a -> b
$ String
"lookupTyName: missing declaration for "
                                               String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack (TypeName -> Text
_TypeName TypeName
tn)

-- | Look up a key in a set, returning a pointer to the set's copy of
-- the key.  This is useful during deserialisation because it means we
-- can share a single key, avoiding retaining deserialised copies.
lookupSet :: Ord a => a -> Set.Set a -> Maybe a
#if MIN_VERSION_containers(0,5,2)
lookupSet :: a -> Set a -> Maybe a
lookupSet a
k Set a
s = (Int -> Set a -> a) -> Set a -> Int -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> Set a -> a
forall a. Int -> Set a -> a
Set.elemAt Set a
s (Int -> a) -> Maybe Int -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Set a -> Maybe Int
forall a. Ord a => a -> Set a -> Maybe Int
Set.lookupIndex a
k Set a
s
#else
-- alternative implementation for containers versions without lookupIndex/elemAt
lookupSet k s = case Set.lookupLE k s of
                  Just k' | k == k' -> Just k'
                  _                 -> Nothing
#endif

-- | Look up a key in a map, returning both the value and the map's
-- copy of the key.  This is useful during deserialisation because it
-- means we can share a single key, avoiding retaining deserialised
-- copies.
lookupMap :: Ord k => k -> Map.Map k a -> Maybe (k, a)
lookupMap :: k -> Map k a -> Maybe (k, a)
lookupMap k
k Map k a
m = (Int -> Map k a -> (k, a)) -> Map k a -> Int -> (k, a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> Map k a -> (k, a)
forall k a. Int -> Map k a -> (k, a)
Map.elemAt Map k a
m (Int -> (k, a)) -> Maybe Int -> Maybe (k, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k -> Map k a -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe Int
Map.lookupIndex k
k Map k a
m


recordToMap :: Record -> Map.Map FieldName Value
recordToMap :: [Field] -> Map FieldName Value
recordToMap = [(FieldName, Value)] -> Map FieldName Value
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(FieldName, Value)] -> Map FieldName Value)
-> ([Field] -> [(FieldName, Value)])
-> [Field]
-> Map FieldName Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Field -> (FieldName, Value)) -> [Field] -> [(FieldName, Value)]
forall a b. (a -> b) -> [a] -> [b]
map (\ (Field FieldName
fn Value
v) -> (FieldName
fn, Value
v))

mapToRecord :: Map.Map FieldName Value -> Record
mapToRecord :: Map FieldName Value -> [Field]
mapToRecord = ((FieldName, Value) -> Field) -> [(FieldName, Value)] -> [Field]
forall a b. (a -> b) -> [a] -> [b]
map ((FieldName -> Value -> Field) -> (FieldName, Value) -> Field
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry FieldName -> Value -> Field
Field) ([(FieldName, Value)] -> [Field])
-> (Map FieldName Value -> [(FieldName, Value)])
-> Map FieldName Value
-> [Field]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map FieldName Value -> [(FieldName, Value)]
forall k a. Map k a -> [(k, a)]
Map.toList

-- | Insert a (field, value) pair into a record, replacing the
-- existing field if it is present and preserving the ordering
-- invariant.
insertField :: FieldName -> Value -> Record -> Record
insertField :: FieldName -> Value -> [Field] -> [Field]
insertField FieldName
fname Value
v []                      = [FieldName -> Value -> Field
Field FieldName
fname Value
v]
insertField FieldName
fname Value
v xxs :: [Field]
xxs@(x :: Field
x@(Field FieldName
fn Value
_):[Field]
xs) = case FieldName -> FieldName -> Ordering
forall a. Ord a => a -> a -> Ordering
compare FieldName
fname FieldName
fn of
                                                Ordering
GT -> Field
x Field -> [Field] -> [Field]
forall a. a -> [a] -> [a]
: FieldName -> Value -> [Field] -> [Field]
insertField FieldName
fname Value
v [Field]
xs
                                                Ordering
EQ -> FieldName -> Value -> Field
Field FieldName
fname Value
v Field -> [Field] -> [Field]
forall a. a -> [a] -> [a]
: [Field]
xs
                                                Ordering
LT -> FieldName -> Value -> Field
Field FieldName
fname Value
v Field -> [Field] -> [Field]
forall a. a -> [a] -> [a]
: [Field]
xxs

-- | Delete a field from a record, trivially preserving the ordering
-- invariant.
deleteField :: FieldName -> Record -> Record
deleteField :: FieldName -> [Field] -> [Field]
deleteField FieldName
fname = (Field -> Bool) -> [Field] -> [Field]
forall a. (a -> Bool) -> [a] -> [a]
filter ((FieldName
fname FieldName -> FieldName -> Bool
forall a. Eq a => a -> a -> Bool
/=) (FieldName -> Bool) -> (Field -> FieldName) -> Field -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> FieldName
fieldName)

-- | Rename a field in a record, preserving the ordering invariant.
renameField :: FieldName -> FieldName -> Record -> Record
renameField :: FieldName -> FieldName -> [Field] -> [Field]
renameField FieldName
fname FieldName
fname' = (Field -> Field -> Ordering) -> [Field] -> [Field]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Field -> FieldName) -> Field -> Field -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Field -> FieldName
fieldName) ([Field] -> [Field]) -> ([Field] -> [Field]) -> [Field] -> [Field]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Field -> Field) -> [Field] -> [Field]
forall a b. (a -> b) -> [a] -> [b]
map Field -> Field
f
  where
    f :: Field -> Field
f x :: Field
x@(Field FieldName
fn Value
v) | FieldName
fn FieldName -> FieldName -> Bool
forall a. Eq a => a -> a -> Bool
== FieldName
fname = FieldName -> Value -> Field
Field FieldName
fname' Value
v
                     | Bool
otherwise   = Field
x

-- | Split a record at a given field, returning the preceding fields,
-- value and succeeding fields.  Fails if the field is absent.
findField :: FieldName -> Record -> Maybe (Record, Value, Record)
findField :: FieldName -> [Field] -> Maybe ([Field], Value, [Field])
findField FieldName
fname [Field]
xs = case (Field -> Bool) -> [Field] -> ([Field], [Field])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break ((FieldName
fname FieldName -> FieldName -> Bool
forall a. Eq a => a -> a -> Bool
==) (FieldName -> Bool) -> (Field -> FieldName) -> Field -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> FieldName
fieldName) [Field]
xs of
                       ([Field]
ys, (Field FieldName
_ Value
v):[Field]
zs) -> ([Field], Value, [Field]) -> Maybe ([Field], Value, [Field])
forall a. a -> Maybe a
Just ([Field]
ys, Value
v, [Field]
zs)
                       ([Field]
_, [])              -> Maybe ([Field], Value, [Field])
forall a. Maybe a
Nothing

-- | Join together two records with a (field, value) pair in between.
-- The ordering invariant is not checked!
joinRecords :: Record -> FieldName -> Value -> Record -> Record
joinRecords :: [Field] -> FieldName -> Value -> [Field] -> [Field]
joinRecords [Field]
ys FieldName
fname Value
v [Field]
zs = [Field]
ys [Field] -> [Field] -> [Field]
forall a. [a] -> [a] -> [a]
++ FieldName -> Value -> Field
Field FieldName
fname Value
v Field -> [Field] -> [Field]
forall a. a -> [a] -> [a]
: [Field]
zs