{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
module Data.API.Value
(
Value(..)
, Record
, Field(..)
, fromDefaultValue
, fromJSON
, parseJSON
, encode
, decode
, matchesNormAPI
, expectRecord
, expectEnum
, expectUnion
, expectList
, expectMaybe
, lookupType
, recordToMap
, mapToRecord
, insertField
, renameField
, deleteField
, findField
, joinRecords
, 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
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)
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
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
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
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
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
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
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)
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
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
]
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 }
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
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 }
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)
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)
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
lookupSet k s = case Set.lookupLE k s of
Just k' | k == k' -> Just k'
_ -> Nothing
#endif
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
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
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)
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
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
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