{-# 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.JSON.Compat
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           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
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
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
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
Record -> ShowS
Field -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: Record -> ShowS
$cshowList :: Record -> 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)   = forall a. NFData a => a -> ()
rnf Text
t
  rnf (UTCTime UTCTime
t)  = forall a. NFData a => a -> ()
rnf UTCTime
t
  rnf (Bytes Binary
b)    = forall a. NFData a => a -> ()
rnf Binary
b
  rnf (Bool Bool
b)     = forall a. NFData a => a -> ()
rnf Bool
b
  rnf (Int Int
i)      = forall a. NFData a => a -> ()
rnf Int
i
  rnf (List [Value]
xs)    = forall a. NFData a => a -> ()
rnf [Value]
xs
  rnf (Maybe Maybe Value
mb)   = forall a. NFData a => a -> ()
rnf Maybe Value
mb
  rnf (Union FieldName
fn Value
v) = forall a. NFData a => a -> ()
rnf FieldName
fn seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf Value
v
  rnf (Enum FieldName
fn)    = forall a. NFData a => a -> ()
rnf FieldName
fn
  rnf (Record Record
xs)  = forall a. NFData a => a -> ()
rnf Record
xs
  rnf (JSON Value
v)     = forall a. NFData a => a -> ()
rnf Value
v

instance NFData Field where
  rnf :: Field -> ()
rnf (Field FieldName
x Value
y) = forall a. NFData a => a -> ()
rnf FieldName
x seq :: forall a b. a -> b -> b
`seq` 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)    -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Value] -> Value
List [])
    (TyMaybe APIType
_, DefaultValue
DefValMaybe)   -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Value -> Value
Maybe forall a. Maybe a
Nothing)
    (TyMaybe APIType
ty, DefaultValue
_)            -> Maybe Value -> Value
Maybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just 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
_)             -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Value
JSON (DefaultValue -> Value
defaultValueAsJsValue DefaultValue
dv))
    (TyName TypeName
tname, DefaultValue
_)          -> do NormTypeDecl
d <- 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 forall a. Ord a => a -> Set a -> Bool
`Set.member` NormEnumType
vals
                                                      -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (FieldName -> Value
Enum (Text -> FieldName
FieldName Text
s))
                                       NormTypeDecl
_ -> forall a. Maybe a
Nothing
    (APIType, DefaultValue)
_ -> 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) -> 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 -> forall a. a -> Maybe a
Just (Binary -> Value
Bytes Binary
b)
                                    Left  String
_ -> forall a. Maybe a
Nothing
    (BasicType
BTbool, DefValBool Bool
b)     -> forall a. a -> Maybe a
Just (Bool -> Value
Bool Bool
b)
    (BasicType
BTint, DefValInt Int
i)       -> forall a. a -> Maybe a
Just (Int -> Value
Int Int
i)
    (BasicType
BTutc, DefValUtc UTCTime
u)       -> forall a. a -> Maybe a
Just (UTCTime -> Value
UTCTime UTCTime
u)
    (BasicType, DefaultValue)
_                          -> 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        -> forall a. ToJSON a => a -> Value
JS.toJSON Binary
b
                Bool Bool
b         -> Bool -> Value
JS.Bool Bool
b
                Int Int
i          -> forall a. ToJSON a => a -> Value
JS.toJSON Int
i
                List [Value]
vs        -> forall a. ToJSON a => a -> Value
JS.toJSON [Value]
vs
                Maybe Maybe Value
Nothing  -> Value
JS.Null
                Maybe (Just Value
v) -> forall a. ToJSON a => a -> Value
JS.toJSON Value
v
                Union FieldName
fn Value
v     -> [Pair] -> Value
JS.object [FieldName -> Key
fieldNameToKey FieldName
fn forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JS..= Value
v]
                Enum FieldName
fn        -> Text -> Value
JS.String (FieldName -> Text
_FieldName FieldName
fn)
                Record Record
xs      -> [Pair] -> Value
JS.object forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\ (Field FieldName
fn Value
v) -> FieldName -> Key
fieldNameToKey FieldName
fn forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
JS..= Value
v) Record
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
     [(JSONWarning, Position)] (Value, [(JSONWarning, Position)])
fromJSON NormAPI
api APIType
ty Value
v = forall a.
ParseFlags
-> ParserWithErrs a
-> Either [(JSONWarning, Position)] (a, [(JSONWarning, 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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) (forall a. Vector a -> [a]
V.toList Array
arr)
                    Value
_            -> forall a. JSONWarning -> ParserWithErrs a
failWith (Value -> JSONWarning
expectedArray Value
v)
    TyMaybe APIType
ty -> case Value
v of
                    Value
JS.Null -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Value -> Value
Maybe forall a. Maybe a
Nothing)
                    Value
_       -> Maybe Value -> Value
Maybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just 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     -> 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 -> forall a.
String -> (Text -> ParserWithErrs a) -> Value -> ParserWithErrs a
withText   String
"String"  (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
String)
    BasicType
BTbinary -> forall a.
String -> (Binary -> ParserWithErrs a) -> Value -> ParserWithErrs a
withBinary String
"Bytes"   (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Binary -> Value
Bytes)
    BasicType
BTbool   -> forall a.
String -> (Bool -> ParserWithErrs a) -> Value -> ParserWithErrs a
withBool   String
"Bool"    (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Value
Bool)
    BasicType
BTint    -> forall a.
String -> (Int -> ParserWithErrs a) -> Value -> ParserWithErrs a
withInt    String
"Int"     (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Value
Int)
    BasicType
BTutc    -> forall a.
String
-> (UTCTime -> ParserWithErrs a) -> Value -> ParserWithErrs a
withUTC    String
"UTCTime" (forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 -> Record -> Value
Record forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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) (forall k a. Map k a -> [(k, a)]
Map.toList NormRecordType
nrt)
                                Value
_            -> forall a. JSONWarning -> ParserWithErrs a
failWith (Value -> JSONWarning
expectedObject Value
v)
    NUnionType  NormRecordType
nut -> forall a.
[(Text, Value -> ParserWithErrs a)] -> Value -> ParserWithErrs a
withUnion (forall a b. (a -> b) -> [a] -> [b]
map (\ (FieldName
fn, APIType
ty) -> (FieldName -> Text
_FieldName FieldName
fn, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FieldName -> Value -> Value
Union FieldName
fn) forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormAPI -> APIType -> Value -> ParserWithErrs Value
parseJSON NormAPI
api APIType
ty)) (forall k a. Map k a -> [(k, a)]
Map.toList NormRecordType
nut))
    NEnumType   NormEnumType
net -> forall a.
String -> (Text -> ParserWithErrs a) -> Value -> ParserWithErrs a
withText (Text -> String
T.unpack (TypeName -> Text
_TypeName TypeName
tn)) forall a b. (a -> b) -> a -> b
$ \ Text
k ->
                           case forall a. Ord a => a -> Set a -> Maybe a
lookupSet (Text -> FieldName
FieldName Text
k) NormEnumType
net of
                             Just FieldName
fn -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (FieldName -> Value
Enum FieldName
fn)
                             Maybe FieldName
Nothing -> forall a. JSONWarning -> ParserWithErrs a
failWith ([Text] -> Text -> JSONWarning
UnexpectedEnumVal (forall a b. (a -> b) -> [a] -> [b]
map FieldName -> Text
_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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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  -> forall a. Serialise a => a -> Encoding
CBOR.encode UTCTime
t
    Bytes Binary
b    -> forall a. Serialise a => a -> Encoding
CBOR.encode Binary
b
    Bool Bool
b     -> forall a. Serialise a => a -> Encoding
CBOR.encode Bool
b
    Int Int
i      -> forall a. Serialise a => a -> Encoding
CBOR.encode Int
i
    List [Value]
vs    -> forall a. (a -> Encoding) -> [a] -> Encoding
encodeListWith Value -> Encoding
encode [Value]
vs
    Maybe Maybe Value
mb_v -> 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    -> forall a. Serialise a => a -> Encoding
CBOR.encode (FieldName -> Text
_FieldName FieldName
fn)
    Record Record
xs  -> Word -> Encoding
CBOR.encodeMapLen (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int
length Record
xs))
                  forall a. Semigroup a => a -> a -> a
<> [Encoding] -> Encoding
encodeRecordFields (forall a b. (a -> b) -> [a] -> [b]
map (\ (Field FieldName
fn Value
v) -> forall a. Serialise a => a -> Encoding
CBOR.encode (FieldName -> Text
_FieldName FieldName
fn)
                                                                    forall a. Semigroup a => a -> a -> a
<> Value -> Encoding
encode Value
v) Record
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 :: forall s. NormAPI -> APIType -> Decoder s Value
decode NormAPI
api APIType
ty0 = case APIType
ty0 of
    TyName TypeName
tn  -> forall s. NormAPI -> NormTypeDecl -> Decoder s Value
decodeDecl NormAPI
api (NormAPI -> TypeName -> NormTypeDecl
lookupTyName NormAPI
api TypeName
tn)
    TyList APIType
ty  -> [Value] -> Value
List  forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> forall s a. Decoder s a -> Decoder s [a]
decodeListWith (forall s. NormAPI -> APIType -> Decoder s Value
decode NormAPI
api APIType
ty)
    TyMaybe APIType
ty -> Maybe Value -> Value
Maybe forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> forall s a. Decoder s a -> Decoder s (Maybe a)
decodeMaybeWith (forall s. NormAPI -> APIType -> Decoder s Value
decode NormAPI
api APIType
ty)
    APIType
TyJSON     -> Value -> Value
JSON  forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> forall s. Decoder s Value
decodeJSON
    TyBasic BasicType
bt -> forall s. BasicType -> Decoder s Value
decodeBasic BasicType
bt

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

decodeDecl :: NormAPI -> NormTypeDecl -> CBOR.Decoder s Value
decodeDecl :: forall s. NormAPI -> NormTypeDecl -> Decoder s Value
decodeDecl NormAPI
api NormTypeDecl
d = case NormTypeDecl
d of
    NRecordType NormRecordType
nrt -> do Int
_ <- forall s. Decoder s Int
CBOR.decodeMapLen
                          forall {s}. Record -> [(FieldName, APIType)] -> Decoder s Value
go [] (forall k a. Map k a -> [(k, a)]
Map.toList NormRecordType
nrt)
    NUnionType  NormRecordType
nut -> do Int
_ <- forall s. Decoder s Int
CBOR.decodeMapLen
                          Text
k <- forall s. Decoder s Text
CBOR.decodeString
                          case 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 forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> forall s. NormAPI -> APIType -> Decoder s Value
decode NormAPI
api APIType
ty
                            Maybe (FieldName, APIType)
Nothing       -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"unexpected union alternative: " forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
k
    NEnumType   NormEnumType
net -> do Text
k <- forall s. Decoder s Text
CBOR.decodeString
                          case forall a. Ord a => a -> Set a -> Maybe a
lookupSet (Text -> FieldName
FieldName Text
k) NormEnumType
net of
                            Just FieldName
fn -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (FieldName -> Value
Enum FieldName
fn)
                            Maybe FieldName
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"unexpected enum alternative: " forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
k
    NTypeSynonym APIType
ty -> forall s. NormAPI -> APIType -> Decoder s Value
decode NormAPI
api APIType
ty
    NNewtype     BasicType
bt -> forall s. BasicType -> Decoder s Value
decodeBasic BasicType
bt
  where
    go :: Record -> [(FieldName, APIType)] -> Decoder s Value
go Record
xs []            = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Record -> Value
Record (forall a. [a] -> [a]
reverse Record
xs))
    go Record
xs ((FieldName
fn, APIType
ty):[(FieldName, APIType)]
ys) = do Text
_  <- forall s. Decoder s Text
CBOR.decodeString
                             !Value
v <- forall s. NormAPI -> APIType -> Decoder s Value
decode NormAPI
api APIType
ty
                             Record -> [(FieldName, APIType)] -> Decoder s Value
go (FieldName -> Value -> Field
Field FieldName
fn Value
vforall a. a -> [a] -> [a]
:Record
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 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 -> 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 forall a. a -> [a] -> [a]
: Position
p)) (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [Value]
vs)
                    Value
_       -> forall a b. a -> Either a b
Left (JSONWarning -> ValueError
JSONError (Value -> JSONWarning
expectedArray Value
js_v), Position
p)
    TyMaybe APIType
ty -> case Value
v0 of
                    Maybe Maybe Value
Nothing -> 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
_              -> forall a b. a -> Either a b
Left (JSONWarning -> ValueError
JSONError (Expected -> String -> Value -> JSONWarning
Expected Expected
ExpObject String
"Maybe" Value
js_v), Position
p)
    APIType
TyJSON     -> case Value
v0 of
                    JSON Value
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    Value
_      -> forall a b. a -> Either a b
Left (JSONWarning -> ValueError
JSONError (Expected -> String -> Value -> JSONWarning
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 = 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
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    (BasicType
BTstring, Value
_)        -> forall a b. a -> Either a b
Left (JSONWarning -> ValueError
JSONError (Value -> JSONWarning
expectedString Value
js_v), Position
p)
    (BasicType
BTbinary, Bytes Binary
_)  -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    (BasicType
BTbinary, Value
_)        -> forall a b. a -> Either a b
Left (JSONWarning -> ValueError
JSONError (Value -> JSONWarning
expectedString Value
js_v), Position
p)
    (BasicType
BTbool, Bool Bool
_)     -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    (BasicType
BTbool, Value
_)          -> forall a b. a -> Either a b
Left (JSONWarning -> ValueError
JSONError (Value -> JSONWarning
expectedBool Value
js_v), Position
p)
    (BasicType
BTint, Int Int
_)       -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    (BasicType
BTint, Value
_)           -> forall a b. a -> Either a b
Left (JSONWarning -> ValueError
JSONError (Value -> JSONWarning
expectedInt Value
js_v), Position
p)
    (BasicType
BTutc, UTCTime UTCTime
_)   -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    (BasicType
BTutc, Value
_)           -> forall a b. a -> Either a b
Left (JSONWarning -> ValueError
JSONError (Expected -> String -> Value -> JSONWarning
Expected Expected
ExpString String
"UTCTime" Value
js_v), Position
p)
  where
    js_v :: Value
js_v = 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 Record
xs <- Value -> Position -> Either (ValueError, Position) Record
expectRecord Value
v0 Position
p
                          case forall a. Ord a => a -> a -> Ordering
compare (forall (t :: * -> *) a. Foldable t => t a -> Int
length Record
xs) (forall k a. Map k a -> Int
Map.size NormRecordType
nrt) of
                            Ordering
LT -> forall a b. a -> Either a b
Left (JSONWarning -> ValueError
JSONError JSONWarning
MissingField, Position
p)
                            Ordering
EQ -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((FieldName, APIType), Field) -> Either (ValueError, Position) ()
matchesNormAPIField (forall a b. [a] -> [b] -> [(a, b)]
zip (forall k a. Map k a -> [(k, a)]
Map.toList NormRecordType
nrt) Record
xs)
                            Ordering
GT -> forall a b. a -> Either a b
Left (JSONWarning -> ValueError
JSONError JSONWarning
UnexpectedField, Position
p)
    NUnionType  NormRecordType
nut -> do (FieldName
fn, Value
v) <- Value
-> Position -> Either (ValueError, Position) (FieldName, Value)
expectUnion Value
v0 Position
p
                          case 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 forall a. a -> [a] -> [a]
: Position
p)
                            Maybe APIType
Nothing -> forall a b. a -> Either a b
Left (JSONWarning -> ValueError
JSONError JSONWarning
UnexpectedField, FieldName -> Step
inField FieldName
fn forall a. a -> [a] -> [a]
: Position
p)
    NEnumType   NormEnumType
net -> do FieldName
fn <- Value -> Position -> Either (ValueError, Position) FieldName
expectEnum Value
v0 Position
p
                          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Ord a => a -> Set a -> Bool
Set.member FieldName
fn NormEnumType
net) forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (JSONWarning -> ValueError
JSONError ([Text] -> Text -> JSONWarning
UnexpectedEnumVal (forall a b. (a -> b) -> [a] -> [b]
map FieldName -> Text
_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 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 forall a. a -> [a] -> [a]
: Position
p)
        | Bool
otherwise = forall a b. a -> Either a b
Left (JSONWarning -> ValueError
JSONError (String -> JSONWarning
SyntaxError ([String] -> String
unlines [String
"record out of order: ", forall a. Show a => a -> String
show FieldName
fn, forall a. Show a => a -> String
show FieldName
fn', forall a. Show a => a -> String
show NormTypeDecl
d, forall a. Show a => a -> String
show Value
v0])), Position
p)

expectRecord :: Value -> Position -> Either (ValueError, Position) Record
expectRecord :: Value -> Position -> Either (ValueError, Position) Record
expectRecord (Record Record
xs) Position
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure Record
xs
expectRecord Value
v           Position
p = forall a b. a -> Either a b
Left (JSONWarning -> ValueError
JSONError (Expected -> String -> Value -> JSONWarning
Expected Expected
ExpObject String
"Record" (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
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure FieldName
s
expectEnum Value
v        Position
p = forall a b. a -> Either a b
Left (JSONWarning -> ValueError
JSONError (Expected -> String -> Value -> JSONWarning
Expected Expected
ExpString String
"Enum" (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
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure (FieldName
fname, Value
v)
expectUnion Value
v               Position
p = forall a b. a -> Either a b
Left (JSONWarning -> ValueError
JSONError (Expected -> String -> Value -> JSONWarning
Expected Expected
ExpObject String
"Union" (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
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure [Value]
xs
expectList Value
v         Position
p = forall a b. a -> Either a b
Left (JSONWarning -> ValueError
JSONError (Expected -> String -> Value -> JSONWarning
Expected Expected
ExpArray String
"List" (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
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Value
v
expectMaybe Value
v         Position
p = forall a b. a -> Either a b
Left (JSONWarning -> ValueError
JSONError (Expected -> String -> Value -> JSONWarning
Expected Expected
ExpArray String
"Maybe" (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 = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TypeName
tname NormAPI
api 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 <- forall a. [a] -> Gen a
QC.elements (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)
                   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  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Gen a -> Gen [a]
QC.listOf (NormAPI -> APIType -> Gen Value
arbitraryOfType NormAPI
api APIType
ty)
    TyMaybe APIType
ty -> Maybe Value -> Value
Maybe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [Gen a] -> Gen a
QC.oneof [forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing, forall a. a -> Maybe a
Just 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  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  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
QC.arbitrary
    BasicType
BTbinary -> Binary -> Value
Bytes   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
QC.arbitrary
    BasicType
BTbool   -> Bool -> Value
Bool    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
QC.arbitrary
    BasicType
BTint    -> Int -> Value
Int     forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
QC.arbitrary
    BasicType
BTutc    -> UTCTime -> Value
UTCTime
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTime -> UTCTime
posixSecondsToUTCTime
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (Real a, Fractional b) => a -> b
realToFrac :: Int -> NominalDiffTime)
                forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 -> Record -> Value
Record forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NormAPI -> APIType -> Gen Value
arbitraryOfType NormAPI
api APIType
ty) (forall k a. Map k a -> [(k, a)]
Map.toList NormRecordType
nrt)
    NUnionType  NormRecordType
nut -> do (FieldName
fn, APIType
ty) <- forall a. [a] -> Gen a
QC.elements (forall k a. Map k a -> [(k, a)]
Map.toList NormRecordType
nut)
                          FieldName -> Value -> Value
Union FieldName
fn 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> Gen a
QC.elements (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 =
    forall a. (Int -> Gen a) -> Gen a
QC.sized forall a b. (a -> b) -> a -> b
$ \ Int
size ->
        forall a. [Gen a] -> Gen a
QC.oneof [ Object -> Value
JS.Object forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [(Text, a)] -> KeyMap a
listToObject forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Int -> Gen a -> Gen a
QC.resize (Int
size forall a. Integral a => a -> a -> a
`div` Int
2) (forall a. Gen a -> Gen [a]
QC.listOf ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
QC.arbitrary forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Value
arbitraryJSONValue))
                 , Array -> Value
JS.Array forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Vector a
V.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Int -> Gen a -> Gen a
QC.resize (Int
size forall a. Integral a => a -> a -> a
`div` Int
2) (forall a. Gen a -> Gen [a]
QC.listOf Gen Value
arbitraryJSONValue)
                 , Text -> Value
JS.String forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
QC.arbitrary
                 , Scientific -> Value
JS.Number forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => Integer -> a
fromInteger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
QC.arbitrary
                 , Bool -> Value
JS.Bool forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
  = forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
QC.forAll (NormAPI -> Gen (APIType, Value)
arbitrary NormAPI
api) forall a b. (a -> b) -> a -> b
$ \ (APIType
ty, Value
v) ->
        case NormAPI
-> APIType
-> Value
-> Either
     [(JSONWarning, Position)] (Value, [(JSONWarning, Position)])
fromJSON NormAPI
api APIType
ty (forall a. ToJSON a => a -> Value
JS.toJSON Value
v) of
          Right (Value
y, [(JSONWarning, Position)]
ws) | Value
v forall a. Eq a => a -> a -> Bool
/= Value
y        -> Result
QCP.failed { reason :: String
QCP.reason = String
"Expected " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Value
v
                                                                       forall a. [a] -> [a] -> [a]
++ String
" but got " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Value
y }
                        | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(JSONWarning, Position)]
ws) -> Result
QCP.failed { reason :: String
QCP.reason = String
"Unexpected warnings: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [(JSONWarning, Position)]
ws }
                        | Bool
otherwise     -> Result
QCP.succeeded
          Left [(JSONWarning, Position)]
err                      -> Result
QCP.failed { reason :: String
QCP.reason = String
"Parse error: " forall a. [a] -> [a] -> [a]
++ [(JSONWarning, Position)] -> String
prettyJSONErrorPositions [(JSONWarning, 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 :: forall a. ToJSON a => API -> TypeName -> a -> Result
prop_jsonGeneric API
api TypeName
tn a
x = case NormAPI
-> APIType
-> Value
-> Either
     [(JSONWarning, Position)] (Value, [(JSONWarning, Position)])
fromJSON NormAPI
napi (TypeName -> APIType
TyName TypeName
tn) Value
js_v of
    Right (Value
v, [(JSONWarning, Position)]
ws) | forall a. ToJSON a => a -> Value
JS.toJSON Value
v forall a. Eq a => a -> a -> Bool
/= Value
js_v -> Result
QCP.failed { reason :: String
QCP.reason = String
"Expected " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Value
js_v
                                                                       forall a. [a] -> [a] -> [a]
++ String
" but got " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. ToJSON a => a -> Value
JS.toJSON Value
v) }
                  | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(JSONWarning, Position)]
ws)       -> Result
QCP.failed { reason :: String
QCP.reason = String
"Unexpected warnings: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [(JSONWarning, Position)]
ws }
                  | Bool
otherwise           -> Result
QCP.succeeded
    Left [(JSONWarning, Position)]
err                            -> Result
QCP.failed { reason :: String
QCP.reason = String
"Parse error: " forall a. [a] -> [a] -> [a]
++ [(JSONWarning, Position)] -> String
prettyJSONErrorPositions [(JSONWarning, Position)]
err }
  where
    napi :: NormAPI
napi = API -> NormAPI
apiNormalForm API
api
    js_v :: Value
js_v = 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
  = forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
QC.forAll (NormAPI -> Gen (APIType, Value)
arbitrary NormAPI
api) forall a b. (a -> b) -> a -> b
$ \ (APIType
ty, Value
v) ->
       case forall a. (forall s. Decoder s a) -> FlatTerm -> Either String a
CBOR.fromFlatTerm (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 forall a. Eq a => a -> a -> Bool
/= Value
v'   -> Result
QCP.failed { reason :: String
QCP.reason = String
"Expected " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Value
v
                                                             forall a. [a] -> [a] -> [a]
++ String
" but got " forall a. [a] -> [a] -> [a]
++ 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: " 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 :: forall a. Serialise a => 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: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show FlatTerm
bs }
  | Bool
otherwise = case forall a. (forall s. Decoder s a) -> FlatTerm -> Either String a
CBOR.fromFlatTerm (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' forall a. Eq a => a -> a -> Bool
/= FlatTerm
bs -> Result
QCP.failed { reason :: String
QCP.reason = String
"Expected " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show FlatTerm
bs forall a. [a] -> [a] -> [a]
++ String
" but got " forall a. [a] -> [a] -> [a]
++ 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: " forall a. [a] -> [a] -> [a]
++ String
err }
  where
    napi :: NormAPI
napi = API -> NormAPI
apiNormalForm API
api
    bs :: FlatTerm
bs = Encoding -> FlatTerm
CBOR.toFlatTerm (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 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 -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"lookupTyName: missing declaration for "
                                               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 :: forall a. Ord a => a -> Set a -> Maybe a
lookupSet a
k Set a
s = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Int -> Set a -> a
Set.elemAt Set a
s forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 :: forall k a. Ord k => k -> Map k a -> Maybe (k, a)
lookupMap k
k Map k a
m = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Int -> Map k a -> (k, a)
Map.elemAt Map k a
m forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 :: Record -> Map FieldName Value
recordToMap = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 -> Record
mapToRecord = forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry FieldName -> Value -> Field
Field) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 -> Record -> Record
insertField FieldName
fname Value
v []                      = [FieldName -> Value -> Field
Field FieldName
fname Value
v]
insertField FieldName
fname Value
v xxs :: Record
xxs@(x :: Field
x@(Field FieldName
fn Value
_):Record
xs) = case forall a. Ord a => a -> a -> Ordering
compare FieldName
fname FieldName
fn of
                                                Ordering
GT -> Field
x forall a. a -> [a] -> [a]
: FieldName -> Value -> Record -> Record
insertField FieldName
fname Value
v Record
xs
                                                Ordering
EQ -> FieldName -> Value -> Field
Field FieldName
fname Value
v forall a. a -> [a] -> [a]
: Record
xs
                                                Ordering
LT -> FieldName -> Value -> Field
Field FieldName
fname Value
v forall a. a -> [a] -> [a]
: Record
xxs

-- | Delete a field from a record, trivially preserving the ordering
-- invariant.
deleteField :: FieldName -> Record -> Record
deleteField :: FieldName -> Record -> Record
deleteField FieldName
fname = forall a. (a -> Bool) -> [a] -> [a]
filter ((FieldName
fname forall a. Eq a => a -> a -> 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 -> Record -> Record
renameField FieldName
fname FieldName
fname' = forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Field -> FieldName
fieldName) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 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 -> Record -> Maybe (Record, Value, Record)
findField FieldName
fname Record
xs = case forall a. (a -> Bool) -> [a] -> ([a], [a])
break ((FieldName
fname forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> FieldName
fieldName) Record
xs of
                       (Record
ys, (Field FieldName
_ Value
v):Record
zs) -> forall a. a -> Maybe a
Just (Record
ys, Value
v, Record
zs)
                       (Record
_, [])              -> 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 :: Record -> FieldName -> Value -> Record -> Record
joinRecords Record
ys FieldName
fname Value
v Record
zs = Record
ys forall a. [a] -> [a] -> [a]
++ FieldName -> Value -> Field
Field FieldName
fname Value
v forall a. a -> [a] -> [a]
: Record
zs