serialise-0.1.0.0: tests/Tests/Reference/Implementation.hs
{-# LANGUAGE CPP, BangPatterns, MagicHash, UnboxedTuples, RankNTypes, ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-----------------------------------------------------------------------------
-- |
-- Module : Codec.CBOR
-- Copyright : 2013 Simon Meier <iridcode@gmail.com>,
-- 2013-2014 Duncan Coutts,
-- License : BSD3-style (see LICENSE.txt)
--
-- Maintainer : Duncan Coutts
-- Stability :
-- Portability : portable
--
-- CBOR format support.
--
-----------------------------------------------------------------------------
module Tests.Reference.Implementation (
serialise,
deserialise,
Term(..),
reservedTag,
reservedSimple,
eqTerm,
canonicaliseTerm,
UInt(..),
fromUInt,
toUInt,
canonicaliseUInt,
Decoder,
runDecoder,
testDecode,
decodeTerm,
decodeTokens,
decodeToken,
diagnosticNotation,
encodeTerm,
encodeToken,
prop_InitialByte,
prop_AdditionalInfo,
prop_TokenHeader,
prop_TokenHeader2,
prop_Token,
prop_Term,
-- properties of internal helpers
prop_integerToFromBytes,
prop_word16ToFromNet,
prop_word32ToFromNet,
prop_word64ToFromNet,
prop_halfToFromFloat,
arbitraryFullRangeIntegral,
) where
import Data.Bits
import Data.Word
import Data.Int
import Numeric.Half (Half)
import qualified Numeric.Half as Half
import Data.List
import Numeric
import GHC.Float (float2Double)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Monoid ((<>))
import Foreign
import System.IO.Unsafe
import Control.Monad (ap)
import Test.QuickCheck.Arbitrary
import Test.QuickCheck.Gen
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid (Monoid(..))
import Control.Applicative
#endif
serialise :: Term -> LBS.ByteString
serialise = LBS.pack . encodeTerm
deserialise :: LBS.ByteString -> Term
deserialise bytes =
case runDecoder decodeTerm (LBS.unpack bytes) of
Just (term, []) -> term
Just _ -> error "ReferenceImpl.deserialise: trailing data"
Nothing -> error "ReferenceImpl.deserialise: decoding failed"
------------------------------------------------------------------------
newtype Decoder a = Decoder { runDecoder :: [Word8] -> Maybe (a, [Word8]) }
instance Functor Decoder where
fmap f a = a >>= return . f
instance Applicative Decoder where
pure = return
(<*>) = ap
instance Monad Decoder where
return x = Decoder (\ws -> Just (x, ws))
d >>= f = Decoder (\ws -> case runDecoder d ws of
Nothing -> Nothing
Just (x, ws') -> runDecoder (f x) ws')
fail _ = Decoder (\_ -> Nothing)
getByte :: Decoder Word8
getByte =
Decoder $ \ws ->
case ws of
w:ws' -> Just (w, ws')
_ -> Nothing
getBytes :: Integral n => n -> Decoder [Word8]
getBytes n =
Decoder $ \ws ->
case genericSplitAt n ws of
(ws', []) | genericLength ws' == n -> Just (ws', [])
| otherwise -> Nothing
(ws', ws'') -> Just (ws', ws'')
eof :: Decoder Bool
eof = Decoder $ \ws -> Just (null ws, ws)
type Encoder a = a -> [Word8]
-- The initial byte of each data item contains both information about
-- the major type (the high-order 3 bits, described in Section 2.1) and
-- additional information (the low-order 5 bits).
data MajorType = MajorType0 | MajorType1 | MajorType2 | MajorType3
| MajorType4 | MajorType5 | MajorType6 | MajorType7
deriving (Show, Eq, Ord, Enum)
instance Arbitrary MajorType where
arbitrary = elements [MajorType0 .. MajorType7]
encodeInitialByte :: MajorType -> Word -> Word8
encodeInitialByte mt ai
| ai < 2^(5 :: Int)
= fromIntegral (fromIntegral (fromEnum mt) `shiftL` 5 .|. ai)
| otherwise
= error "encodeInitialByte: invalid additional info value"
decodeInitialByte :: Word8 -> (MajorType, Word)
decodeInitialByte ib = ( toEnum $ fromIntegral $ ib `shiftR` 5
, fromIntegral $ ib .&. 0x1f)
prop_InitialByte :: Bool
prop_InitialByte =
and [ (uncurry encodeInitialByte . decodeInitialByte) w8 == w8
| w8 <- [minBound..maxBound] ]
-- When the value of the
-- additional information is less than 24, it is directly used as a
-- small unsigned integer. When it is 24 to 27, the additional bytes
-- for a variable-length integer immediately follow; the values 24 to 27
-- of the additional information specify that its length is a 1-, 2-,
-- 4-, or 8-byte unsigned integer, respectively. Additional information
-- value 31 is used for indefinite-length items, described in
-- Section 2.2. Additional information values 28 to 30 are reserved for
-- future expansion.
--
-- In all additional information values, the resulting integer is
-- interpreted depending on the major type. It may represent the actual
-- data: for example, in integer types, the resulting integer is used
-- for the value itself. It may instead supply length information: for
-- example, in byte strings it gives the length of the byte string data
-- that follows.
data UInt =
UIntSmall Word
| UInt8 Word8
| UInt16 Word16
| UInt32 Word32
| UInt64 Word64
deriving (Eq, Show)
data AdditionalInformation =
AiValue UInt
| AiIndefLen
| AiReserved Word
deriving (Eq, Show)
instance Arbitrary UInt where
arbitrary =
sized $ \n ->
oneof $ take (1 + n `div` 2)
[ UIntSmall <$> choose (0, 23)
, UInt8 <$> arbitraryBoundedIntegral
, UInt16 <$> arbitraryBoundedIntegral
, UInt32 <$> arbitraryBoundedIntegral
, UInt64 <$> arbitraryBoundedIntegral
]
instance Arbitrary AdditionalInformation where
arbitrary =
frequency
[ (7, AiValue <$> arbitrary)
, (2, pure AiIndefLen)
, (1, AiReserved <$> choose (28, 30))
]
decodeAdditionalInfo :: Word -> Decoder AdditionalInformation
decodeAdditionalInfo = dec
where
dec n
| n < 24 = return (AiValue (UIntSmall n))
dec 24 = do w <- getByte
return (AiValue (UInt8 w))
dec 25 = do [w1,w0] <- getBytes (2 :: Int)
let w = word16FromNet w1 w0
return (AiValue (UInt16 w))
dec 26 = do [w3,w2,w1,w0] <- getBytes (4 :: Int)
let w = word32FromNet w3 w2 w1 w0
return (AiValue (UInt32 w))
dec 27 = do [w7,w6,w5,w4,w3,w2,w1,w0] <- getBytes (8 :: Int)
let w = word64FromNet w7 w6 w5 w4 w3 w2 w1 w0
return (AiValue (UInt64 w))
dec 31 = return AiIndefLen
dec n
| n < 31 = return (AiReserved n)
dec _ = fail ""
encodeAdditionalInfo :: AdditionalInformation -> (Word, [Word8])
encodeAdditionalInfo = enc
where
enc (AiValue (UIntSmall n))
| n < 24 = (n, [])
| otherwise = error "invalid UIntSmall value"
enc (AiValue (UInt8 w)) = (24, [w])
enc (AiValue (UInt16 w)) = (25, [w1, w0])
where (w1, w0) = word16ToNet w
enc (AiValue (UInt32 w)) = (26, [w3, w2, w1, w0])
where (w3, w2, w1, w0) = word32ToNet w
enc (AiValue (UInt64 w)) = (27, [w7, w6, w5, w4,
w3, w2, w1, w0])
where (w7, w6, w5, w4,
w3, w2, w1, w0) = word64ToNet w
enc AiIndefLen = (31, [])
enc (AiReserved n)
| n >= 28 && n < 31 = (n, [])
| otherwise = error "invalid AiReserved value"
prop_AdditionalInfo :: AdditionalInformation -> Bool
prop_AdditionalInfo ai =
let (w, ws) = encodeAdditionalInfo ai
Just (ai', _) = runDecoder (decodeAdditionalInfo w) ws
in ai == ai'
data TokenHeader = TokenHeader MajorType AdditionalInformation
deriving (Show, Eq)
instance Arbitrary TokenHeader where
arbitrary = TokenHeader <$> arbitrary <*> arbitrary
decodeTokenHeader :: Decoder TokenHeader
decodeTokenHeader = do
b <- getByte
let (mt, ai) = decodeInitialByte b
ai' <- decodeAdditionalInfo ai
return (TokenHeader mt ai')
encodeTokenHeader :: Encoder TokenHeader
encodeTokenHeader (TokenHeader mt ai) =
let (w, ws) = encodeAdditionalInfo ai
in encodeInitialByte mt w : ws
prop_TokenHeader :: TokenHeader -> Bool
prop_TokenHeader header =
let ws = encodeTokenHeader header
Just (header', _) = runDecoder decodeTokenHeader ws
in header == header'
prop_TokenHeader2 :: Bool
prop_TokenHeader2 =
and [ w8 : extraused == encoded
| w8 <- [minBound..maxBound]
, let extra = [1..8]
Just (header, unused) = runDecoder decodeTokenHeader (w8 : extra)
encoded = encodeTokenHeader header
extraused = take (8 - length unused) extra
]
data Token =
MT0_UnsignedInt UInt
| MT1_NegativeInt UInt
| MT2_ByteString UInt [Word8]
| MT2_ByteStringIndef
| MT3_String UInt [Word8]
| MT3_StringIndef
| MT4_ArrayLen UInt
| MT4_ArrayLenIndef
| MT5_MapLen UInt
| MT5_MapLenIndef
| MT6_Tag UInt
| MT7_Simple Word8
| MT7_Float16 Half
| MT7_Float32 Float
| MT7_Float64 Double
| MT7_Break
deriving (Show, Eq)
instance Arbitrary Token where
arbitrary =
oneof
[ MT0_UnsignedInt <$> arbitrary
, MT1_NegativeInt <$> arbitrary
, do ws <- arbitrary
MT2_ByteString <$> arbitraryLengthUInt ws <*> pure ws
, pure MT2_ByteStringIndef
, do cs <- arbitrary
let ws = encodeUTF8 cs
MT3_String <$> arbitraryLengthUInt ws <*> pure ws
, pure MT3_StringIndef
, MT4_ArrayLen <$> arbitrary
, pure MT4_ArrayLenIndef
, MT5_MapLen <$> arbitrary
, pure MT5_MapLenIndef
, MT6_Tag <$> arbitrary
, MT7_Simple <$> arbitrary
, MT7_Float16 . getFloatSpecials <$> arbitrary
, MT7_Float32 . getFloatSpecials <$> arbitrary
, MT7_Float64 . getFloatSpecials <$> arbitrary
, pure MT7_Break
]
where
arbitraryLengthUInt xs =
let n = length xs in
elements $
[ UIntSmall (fromIntegral n) | n < 24 ]
++ [ UInt8 (fromIntegral n) | n < 255 ]
++ [ UInt16 (fromIntegral n) | n < 65536 ]
++ [ UInt32 (fromIntegral n)
, UInt64 (fromIntegral n) ]
testDecode :: [Word8] -> Term
testDecode ws =
case runDecoder decodeTerm ws of
Just (x, []) -> x
_ -> error "testDecode: parse error"
decodeTokens :: Decoder [Token]
decodeTokens = do
done <- eof
if done
then return []
else do tok <- decodeToken
toks <- decodeTokens
return (tok:toks)
decodeToken :: Decoder Token
decodeToken = do
header <- decodeTokenHeader
extra <- getBytes (tokenExtraLen header)
either fail return (packToken header extra)
tokenExtraLen :: TokenHeader -> Word64
tokenExtraLen (TokenHeader MajorType2 (AiValue n)) = fromUInt n -- bytestrings
tokenExtraLen (TokenHeader MajorType3 (AiValue n)) = fromUInt n -- unicode strings
tokenExtraLen _ = 0
packToken :: TokenHeader -> [Word8] -> Either String Token
packToken (TokenHeader mt ai) extra = case (mt, ai) of
-- Major type 0: an unsigned integer. The 5-bit additional information
-- is either the integer itself (for additional information values 0
-- through 23) or the length of additional data.
(MajorType0, AiValue n) -> return (MT0_UnsignedInt n)
-- Major type 1: a negative integer. The encoding follows the rules
-- for unsigned integers (major type 0), except that the value is
-- then -1 minus the encoded unsigned integer.
(MajorType1, AiValue n) -> return (MT1_NegativeInt n)
-- Major type 2: a byte string. The string's length in bytes is
-- represented following the rules for positive integers (major type 0).
(MajorType2, AiValue n) -> return (MT2_ByteString n extra)
(MajorType2, AiIndefLen) -> return MT2_ByteStringIndef
-- Major type 3: a text string, specifically a string of Unicode
-- characters that is encoded as UTF-8 [RFC3629]. The format of this
-- type is identical to that of byte strings (major type 2), that is,
-- as with major type 2, the length gives the number of bytes.
(MajorType3, AiValue n) -> return (MT3_String n extra)
(MajorType3, AiIndefLen) -> return MT3_StringIndef
-- Major type 4: an array of data items. The array's length follows the
-- rules for byte strings (major type 2), except that the length
-- denotes the number of data items, not the length in bytes that the
-- array takes up.
(MajorType4, AiValue n) -> return (MT4_ArrayLen n)
(MajorType4, AiIndefLen) -> return MT4_ArrayLenIndef
-- Major type 5: a map of pairs of data items. A map is comprised of
-- pairs of data items, each pair consisting of a key that is
-- immediately followed by a value. The map's length follows the
-- rules for byte strings (major type 2), except that the length
-- denotes the number of pairs, not the length in bytes that the map
-- takes up.
(MajorType5, AiValue n) -> return (MT5_MapLen n)
(MajorType5, AiIndefLen) -> return MT5_MapLenIndef
-- Major type 6: optional semantic tagging of other major types.
-- The initial bytes of the tag follow the rules for positive integers
-- (major type 0).
(MajorType6, AiValue n) -> return (MT6_Tag n)
-- Major type 7 is for two types of data: floating-point numbers and
-- "simple values" that do not need any content. Each value of the
-- 5-bit additional information in the initial byte has its own separate
-- meaning, as defined in Table 1.
-- | 0..23 | Simple value (value 0..23) |
-- | 24 | Simple value (value 32..255 in following byte) |
-- | 25 | IEEE 754 Half-Precision Float (16 bits follow) |
-- | 26 | IEEE 754 Single-Precision Float (32 bits follow) |
-- | 27 | IEEE 754 Double-Precision Float (64 bits follow) |
-- | 28-30 | (Unassigned) |
-- | 31 | "break" stop code for indefinite-length items |
(MajorType7, AiValue (UIntSmall w)) -> return (MT7_Simple (fromIntegral w))
(MajorType7, AiValue (UInt8 w)) -> return (MT7_Simple (fromIntegral w))
(MajorType7, AiValue (UInt16 w)) -> return (MT7_Float16 (wordToHalf w))
(MajorType7, AiValue (UInt32 w)) -> return (MT7_Float32 (wordToFloat w))
(MajorType7, AiValue (UInt64 w)) -> return (MT7_Float64 (wordToDouble w))
(MajorType7, AiIndefLen) -> return (MT7_Break)
_ -> fail "invalid token header"
encodeToken :: Encoder Token
encodeToken tok =
let (header, extra) = unpackToken tok
in encodeTokenHeader header ++ extra
unpackToken :: Token -> (TokenHeader, [Word8])
unpackToken tok = (\(mt, ai, ws) -> (TokenHeader mt ai, ws)) $ case tok of
(MT0_UnsignedInt n) -> (MajorType0, AiValue n, [])
(MT1_NegativeInt n) -> (MajorType1, AiValue n, [])
(MT2_ByteString n ws) -> (MajorType2, AiValue n, ws)
MT2_ByteStringIndef -> (MajorType2, AiIndefLen, [])
(MT3_String n ws) -> (MajorType3, AiValue n, ws)
MT3_StringIndef -> (MajorType3, AiIndefLen, [])
(MT4_ArrayLen n) -> (MajorType4, AiValue n, [])
MT4_ArrayLenIndef -> (MajorType4, AiIndefLen, [])
(MT5_MapLen n) -> (MajorType5, AiValue n, [])
MT5_MapLenIndef -> (MajorType5, AiIndefLen, [])
(MT6_Tag n) -> (MajorType6, AiValue n, [])
(MT7_Simple n)
| n <= 23 -> (MajorType7, AiValue (UIntSmall (fromIntegral n)), [])
| otherwise -> (MajorType7, AiValue (UInt8 n), [])
(MT7_Float16 f) -> (MajorType7, AiValue (UInt16 (halfToWord f)), [])
(MT7_Float32 f) -> (MajorType7, AiValue (UInt32 (floatToWord f)), [])
(MT7_Float64 f) -> (MajorType7, AiValue (UInt64 (doubleToWord f)), [])
MT7_Break -> (MajorType7, AiIndefLen, [])
fromUInt :: UInt -> Word64
fromUInt (UIntSmall w) = fromIntegral w
fromUInt (UInt8 w) = fromIntegral w
fromUInt (UInt16 w) = fromIntegral w
fromUInt (UInt32 w) = fromIntegral w
fromUInt (UInt64 w) = fromIntegral w
toUInt :: Word64 -> UInt
toUInt n
| n < 24 = UIntSmall (fromIntegral n)
| n <= fromIntegral (maxBound :: Word8) = UInt8 (fromIntegral n)
| n <= fromIntegral (maxBound :: Word16) = UInt16 (fromIntegral n)
| n <= fromIntegral (maxBound :: Word32) = UInt32 (fromIntegral n)
| otherwise = UInt64 n
lengthUInt :: [a] -> UInt
lengthUInt = toUInt . fromIntegral . length
decodeUTF8 :: [Word8] -> Either String [Char]
decodeUTF8 = either (fail . show) (return . T.unpack) . T.decodeUtf8' . BS.pack
encodeUTF8 :: [Char] -> [Word8]
encodeUTF8 = BS.unpack . T.encodeUtf8 . T.pack
reservedSimple :: Word8 -> Bool
reservedSimple w = w >= 20 && w <= 31
reservedTag :: Word64 -> Bool
reservedTag w = w <= 5
prop_Token :: Token -> Bool
prop_Token token =
let ws = encodeToken token
Just (token', []) = runDecoder decodeToken ws
in token `eqToken` token'
-- NaNs are so annoying...
eqToken :: Token -> Token -> Bool
eqToken (MT7_Float16 f) (MT7_Float16 f') | isNaN f && isNaN f' = True
eqToken (MT7_Float32 f) (MT7_Float32 f') | isNaN f && isNaN f' = True
eqToken (MT7_Float64 f) (MT7_Float64 f') | isNaN f && isNaN f' = True
eqToken a b = a == b
data Term = TUInt UInt
| TNInt UInt
| TBigInt Integer
| TBytes [Word8]
| TBytess [[Word8]]
| TString [Char]
| TStrings [[Char]]
| TArray [Term]
| TArrayI [Term]
| TMap [(Term, Term)]
| TMapI [(Term, Term)]
| TTagged UInt Term
| TTrue
| TFalse
| TNull
| TUndef
| TSimple Word8
| TFloat16 Half
| TFloat32 Float
| TFloat64 Double
deriving (Show, Eq)
instance Arbitrary Term where
arbitrary =
frequency
[ (1, TUInt <$> arbitrary)
, (1, TNInt <$> arbitrary)
, (1, TBigInt . getLargeInteger <$> arbitrary)
, (1, TBytes <$> arbitrary)
, (1, TBytess <$> arbitrary)
, (1, TString <$> arbitrary)
, (1, TStrings <$> arbitrary)
, (2, TArray <$> listOfSmaller arbitrary)
, (2, TArrayI <$> listOfSmaller arbitrary)
, (2, TMap <$> listOfSmaller ((,) <$> arbitrary <*> arbitrary))
, (2, TMapI <$> listOfSmaller ((,) <$> arbitrary <*> arbitrary))
, (1, TTagged <$> arbitraryTag <*> sized (\sz -> resize (max 0 (sz-1)) arbitrary))
, (1, pure TFalse)
, (1, pure TTrue)
, (1, pure TNull)
, (1, pure TUndef)
, (1, TSimple <$> arbitrary `suchThat` (not . reservedSimple))
, (1, TFloat16 <$> arbitrary)
, (1, TFloat32 <$> arbitrary)
, (1, TFloat64 <$> arbitrary)
]
where
listOfSmaller :: Gen a -> Gen [a]
listOfSmaller gen =
sized $ \n -> do
k <- choose (0,n)
vectorOf k (resize (n `div` (k+1)) gen)
arbitraryTag = arbitrary `suchThat` (not . reservedTag . fromUInt)
shrink (TUInt n) = [ TUInt n' | n' <- shrink n ]
shrink (TNInt n) = [ TNInt n' | n' <- shrink n ]
shrink (TBigInt n) = [ TBigInt n' | n' <- shrink n ]
shrink (TBytes ws) = [ TBytes ws' | ws' <- shrink ws ]
shrink (TBytess wss) = [ TBytess wss' | wss' <- shrink wss ]
shrink (TString ws) = [ TString ws' | ws' <- shrink ws ]
shrink (TStrings wss) = [ TStrings wss' | wss' <- shrink wss ]
shrink (TArray xs@[x]) = x : [ TArray xs' | xs' <- shrink xs ]
shrink (TArray xs) = [ TArray xs' | xs' <- shrink xs ]
shrink (TArrayI xs@[x]) = x : [ TArrayI xs' | xs' <- shrink xs ]
shrink (TArrayI xs) = [ TArrayI xs' | xs' <- shrink xs ]
shrink (TMap xys@[(x,y)]) = x : y : [ TMap xys' | xys' <- shrink xys ]
shrink (TMap xys) = [ TMap xys' | xys' <- shrink xys ]
shrink (TMapI xys@[(x,y)]) = x : y : [ TMapI xys' | xys' <- shrink xys ]
shrink (TMapI xys) = [ TMapI xys' | xys' <- shrink xys ]
shrink (TTagged w t) = [ TTagged w' t' | (w', t') <- shrink (w, t)
, not (reservedTag (fromUInt w')) ]
shrink TFalse = []
shrink TTrue = []
shrink TNull = []
shrink TUndef = []
shrink (TSimple w) = [ TSimple w' | w' <- shrink w, not (reservedSimple w) ]
shrink (TFloat16 f) = [ TFloat16 f' | f' <- shrink f ]
shrink (TFloat32 f) = [ TFloat32 f' | f' <- shrink f ]
shrink (TFloat64 f) = [ TFloat64 f' | f' <- shrink f ]
decodeTerm :: Decoder Term
decodeTerm = decodeToken >>= decodeTermFrom
decodeTermFrom :: Token -> Decoder Term
decodeTermFrom tk =
case tk of
MT0_UnsignedInt n -> return (TUInt n)
MT1_NegativeInt n -> return (TNInt n)
MT2_ByteString _ bs -> return (TBytes bs)
MT2_ByteStringIndef -> decodeBytess []
MT3_String _ ws -> either fail (return . TString) (decodeUTF8 ws)
MT3_StringIndef -> decodeStrings []
MT4_ArrayLen len -> decodeArrayN (fromUInt len) []
MT4_ArrayLenIndef -> decodeArray []
MT5_MapLen len -> decodeMapN (fromUInt len) []
MT5_MapLenIndef -> decodeMap []
MT6_Tag tag -> decodeTagged tag
MT7_Simple 20 -> return TFalse
MT7_Simple 21 -> return TTrue
MT7_Simple 22 -> return TNull
MT7_Simple 23 -> return TUndef
MT7_Simple w -> return (TSimple w)
MT7_Float16 f -> return (TFloat16 f)
MT7_Float32 f -> return (TFloat32 f)
MT7_Float64 f -> return (TFloat64 f)
MT7_Break -> fail "unexpected"
decodeBytess :: [[Word8]] -> Decoder Term
decodeBytess acc = do
tk <- decodeToken
case tk of
MT7_Break -> return $! TBytess (reverse acc)
MT2_ByteString _ bs -> decodeBytess (bs : acc)
_ -> fail "unexpected"
decodeStrings :: [String] -> Decoder Term
decodeStrings acc = do
tk <- decodeToken
case tk of
MT7_Break -> return $! TStrings (reverse acc)
MT3_String _ ws -> do cs <- either fail return (decodeUTF8 ws)
decodeStrings (cs : acc)
_ -> fail "unexpected"
decodeArrayN :: Word64 -> [Term] -> Decoder Term
decodeArrayN n acc =
case n of
0 -> return $! TArray (reverse acc)
_ -> do t <- decodeTerm
decodeArrayN (n-1) (t : acc)
decodeArray :: [Term] -> Decoder Term
decodeArray acc = do
tk <- decodeToken
case tk of
MT7_Break -> return $! TArrayI (reverse acc)
_ -> do
tm <- decodeTermFrom tk
decodeArray (tm : acc)
decodeMapN :: Word64 -> [(Term, Term)] -> Decoder Term
decodeMapN n acc =
case n of
0 -> return $! TMap (reverse acc)
_ -> do
tm <- decodeTerm
tm' <- decodeTerm
decodeMapN (n-1) ((tm, tm') : acc)
decodeMap :: [(Term, Term)] -> Decoder Term
decodeMap acc = do
tk <- decodeToken
case tk of
MT7_Break -> return $! TMapI (reverse acc)
_ -> do
tm <- decodeTermFrom tk
tm' <- decodeTerm
decodeMap ((tm, tm') : acc)
decodeTagged :: UInt -> Decoder Term
decodeTagged tag | fromUInt tag == 2 = do
MT2_ByteString _ bs <- decodeToken
let !n = integerFromBytes bs
return (TBigInt n)
decodeTagged tag | fromUInt tag == 3 = do
MT2_ByteString _ bs <- decodeToken
let !n = integerFromBytes bs
return (TBigInt (-1 - n))
decodeTagged tag = do
tm <- decodeTerm
return (TTagged tag tm)
integerFromBytes :: [Word8] -> Integer
integerFromBytes [] = 0
integerFromBytes (w0:ws0) = go (fromIntegral w0) ws0
where
go !acc [] = acc
go !acc (w:ws) = go (acc `shiftL` 8 + fromIntegral w) ws
integerToBytes :: Integer -> [Word8]
integerToBytes n0
| n0 == 0 = [0]
| n0 < 0 = reverse (go (-n0))
| otherwise = reverse (go n0)
where
go n | n == 0 = []
| otherwise = narrow n : go (n `shiftR` 8)
narrow :: Integer -> Word8
narrow = fromIntegral
prop_integerToFromBytes :: LargeInteger -> Bool
prop_integerToFromBytes (LargeInteger n)
| n >= 0 =
let ws = integerToBytes n
n' = integerFromBytes ws
in n == n'
| otherwise =
let ws = integerToBytes n
n' = integerFromBytes ws
in n == -n'
-------------------------------------------------------------------------------
encodeTerm :: Encoder Term
encodeTerm (TUInt n) = encodeToken (MT0_UnsignedInt n)
encodeTerm (TNInt n) = encodeToken (MT1_NegativeInt n)
encodeTerm (TBigInt n)
| n >= 0 = encodeToken (MT6_Tag (UIntSmall 2))
<> let ws = integerToBytes n
len = lengthUInt ws in
encodeToken (MT2_ByteString len ws)
| otherwise = encodeToken (MT6_Tag (UIntSmall 3))
<> let ws = integerToBytes (-1 - n)
len = lengthUInt ws in
encodeToken (MT2_ByteString len ws)
encodeTerm (TBytes ws) = let len = lengthUInt ws in
encodeToken (MT2_ByteString len ws)
encodeTerm (TBytess wss) = encodeToken MT2_ByteStringIndef
<> mconcat [ encodeToken (MT2_ByteString len ws)
| ws <- wss
, let len = lengthUInt ws ]
<> encodeToken MT7_Break
encodeTerm (TString cs) = let ws = encodeUTF8 cs
len = lengthUInt ws in
encodeToken (MT3_String len ws)
encodeTerm (TStrings css) = encodeToken MT3_StringIndef
<> mconcat [ encodeToken (MT3_String len ws)
| cs <- css
, let ws = encodeUTF8 cs
len = lengthUInt ws ]
<> encodeToken MT7_Break
encodeTerm (TArray ts) = let len = lengthUInt ts in
encodeToken (MT4_ArrayLen len)
<> mconcat (map encodeTerm ts)
encodeTerm (TArrayI ts) = encodeToken MT4_ArrayLenIndef
<> mconcat (map encodeTerm ts)
<> encodeToken MT7_Break
encodeTerm (TMap kvs) = let len = lengthUInt kvs in
encodeToken (MT5_MapLen len)
<> mconcat [ encodeTerm k <> encodeTerm v
| (k,v) <- kvs ]
encodeTerm (TMapI kvs) = encodeToken MT5_MapLenIndef
<> mconcat [ encodeTerm k <> encodeTerm v
| (k,v) <- kvs ]
<> encodeToken MT7_Break
encodeTerm (TTagged tag t) = encodeToken (MT6_Tag tag)
<> encodeTerm t
encodeTerm TFalse = encodeToken (MT7_Simple 20)
encodeTerm TTrue = encodeToken (MT7_Simple 21)
encodeTerm TNull = encodeToken (MT7_Simple 22)
encodeTerm TUndef = encodeToken (MT7_Simple 23)
encodeTerm (TSimple w) = encodeToken (MT7_Simple w)
encodeTerm (TFloat16 f) = encodeToken (MT7_Float16 f)
encodeTerm (TFloat32 f) = encodeToken (MT7_Float32 f)
encodeTerm (TFloat64 f) = encodeToken (MT7_Float64 f)
-------------------------------------------------------------------------------
prop_Term :: Term -> Bool
prop_Term term =
let ws = encodeTerm term
Just (term', []) = runDecoder decodeTerm ws
in term `eqTerm` term'
-- NaNs are so annoying...
eqTerm :: Term -> Term -> Bool
eqTerm (TArray ts) (TArray ts') = and (zipWith eqTerm ts ts')
eqTerm (TArrayI ts) (TArrayI ts') = and (zipWith eqTerm ts ts')
eqTerm (TMap ts) (TMap ts') = and (zipWith eqTermPair ts ts')
eqTerm (TMapI ts) (TMapI ts') = and (zipWith eqTermPair ts ts')
eqTerm (TTagged w t) (TTagged w' t') = w == w' && eqTerm t t'
eqTerm (TFloat16 f) (TFloat16 f') | isNaN f && isNaN f' = True
eqTerm (TFloat32 f) (TFloat32 f') | isNaN f && isNaN f' = True
eqTerm (TFloat64 f) (TFloat64 f') | isNaN f && isNaN f' = True
eqTerm a b = a == b
eqTermPair :: (Term, Term) -> (Term, Term) -> Bool
eqTermPair (a,b) (a',b') = eqTerm a a' && eqTerm b b'
canonicaliseTerm :: Term -> Term
canonicaliseTerm (TUInt n) = TUInt (canonicaliseUInt n)
canonicaliseTerm (TNInt n) = TNInt (canonicaliseUInt n)
canonicaliseTerm (TBigInt n)
| n >= 0 && n <= fromIntegral (maxBound :: Word64)
= TUInt (toUInt (fromIntegral n))
| n < 0 && n >= -1 - fromIntegral (maxBound :: Word64)
= TNInt (toUInt (fromIntegral (-1 - n)))
| otherwise = TBigInt n
canonicaliseTerm (TFloat16 f) = TFloat16 (canonicaliseHalf f)
canonicaliseTerm (TBytess wss) = TBytess (filter (not . null) wss)
canonicaliseTerm (TStrings css) = TStrings (filter (not . null) css)
canonicaliseTerm (TArray ts) = TArray (map canonicaliseTerm ts)
canonicaliseTerm (TArrayI ts) = TArrayI (map canonicaliseTerm ts)
canonicaliseTerm (TMap ts) = TMap (map canonicaliseTermPair ts)
canonicaliseTerm (TMapI ts) = TMapI (map canonicaliseTermPair ts)
canonicaliseTerm (TTagged tag t) = TTagged (canonicaliseUInt tag) (canonicaliseTerm t)
canonicaliseTerm t = t
canonicaliseUInt :: UInt -> UInt
canonicaliseUInt = toUInt . fromUInt
-- some NaNs do not roundtrip https://github.com/ekmett/half/issues/3
canonicaliseHalf :: Half -> Half
canonicaliseHalf = Half.toHalf . Half.fromHalf
canonicaliseTermPair :: (Term, Term) -> (Term, Term)
canonicaliseTermPair (x,y) = (canonicaliseTerm x, canonicaliseTerm y)
-------------------------------------------------------------------------------
diagnosticNotation :: Term -> String
diagnosticNotation = \t -> showsTerm t ""
where
showsTerm tm = case tm of
TUInt n -> shows (fromUInt n)
TNInt n -> shows (-1 - fromIntegral (fromUInt n) :: Integer)
TBigInt n -> shows n
TBytes bs -> showsBytes bs
TBytess bss -> surround '(' ')' (underscoreSpace . commaSep showsBytes bss)
TString cs -> shows cs
TStrings css -> surround '(' ')' (underscoreSpace . commaSep shows css)
TArray ts -> surround '[' ']' (commaSep showsTerm ts)
TArrayI ts -> surround '[' ']' (underscoreSpace . commaSep showsTerm ts)
TMap ts -> surround '{' '}' (commaSep showsMapElem ts)
TMapI ts -> surround '{' '}' (underscoreSpace . commaSep showsMapElem ts)
TTagged tag t -> shows (fromUInt tag) . surround '(' ')' (showsTerm t)
TTrue -> showString "true"
TFalse -> showString "false"
TNull -> showString "null"
TUndef -> showString "undefined"
TSimple n -> showString "simple" . surround '(' ')' (shows n)
-- convert to float to work around https://github.com/ekmett/half/issues/2
TFloat16 f -> showFloatCompat (float2Double (Half.fromHalf f))
TFloat32 f -> showFloatCompat (float2Double f)
TFloat64 f -> showFloatCompat f
surround a b x = showChar a . x . showChar b
commaSpace = showChar ',' . showChar ' '
underscoreSpace = showChar '_' . showChar ' '
showsMapElem (k,v) = showsTerm k . showChar ':' . showChar ' ' . showsTerm v
catShows :: (a -> ShowS) -> [a] -> ShowS
catShows f xs = \s -> foldr (\x r -> f x . r) id xs s
sepShows :: ShowS -> (a -> ShowS) -> [a] -> ShowS
sepShows sep f xs = foldr (.) id (intersperse sep (map f xs))
commaSep = sepShows commaSpace
showsBytes :: [Word8] -> ShowS
showsBytes bs = showChar 'h' . showChar '\''
. catShows showFHex bs
. showChar '\''
showFHex n | n < 16 = showChar '0' . showHex n
| otherwise = showHex n
showFloatCompat n
| exponent' >= -5 && exponent' <= 15 = showFFloat Nothing n
| otherwise = showEFloat Nothing n
where exponent' = snd (floatToDigits 10 n)
word16FromNet :: Word8 -> Word8 -> Word16
word16FromNet w1 w0 =
fromIntegral w1 `shiftL` (8*1)
.|. fromIntegral w0 `shiftL` (8*0)
word16ToNet :: Word16 -> (Word8, Word8)
word16ToNet w =
( fromIntegral ((w `shiftR` (8*1)) .&. 0xff)
, fromIntegral ((w `shiftR` (8*0)) .&. 0xff)
)
word32FromNet :: Word8 -> Word8 -> Word8 -> Word8 -> Word32
word32FromNet w3 w2 w1 w0 =
fromIntegral w3 `shiftL` (8*3)
.|. fromIntegral w2 `shiftL` (8*2)
.|. fromIntegral w1 `shiftL` (8*1)
.|. fromIntegral w0 `shiftL` (8*0)
word32ToNet :: Word32 -> (Word8, Word8, Word8, Word8)
word32ToNet w =
( fromIntegral ((w `shiftR` (8*3)) .&. 0xff)
, fromIntegral ((w `shiftR` (8*2)) .&. 0xff)
, fromIntegral ((w `shiftR` (8*1)) .&. 0xff)
, fromIntegral ((w `shiftR` (8*0)) .&. 0xff)
)
word64FromNet :: Word8 -> Word8 -> Word8 -> Word8 ->
Word8 -> Word8 -> Word8 -> Word8 -> Word64
word64FromNet w7 w6 w5 w4 w3 w2 w1 w0 =
fromIntegral w7 `shiftL` (8*7)
.|. fromIntegral w6 `shiftL` (8*6)
.|. fromIntegral w5 `shiftL` (8*5)
.|. fromIntegral w4 `shiftL` (8*4)
.|. fromIntegral w3 `shiftL` (8*3)
.|. fromIntegral w2 `shiftL` (8*2)
.|. fromIntegral w1 `shiftL` (8*1)
.|. fromIntegral w0 `shiftL` (8*0)
word64ToNet :: Word64 -> (Word8, Word8, Word8, Word8,
Word8, Word8, Word8, Word8)
word64ToNet w =
( fromIntegral ((w `shiftR` (8*7)) .&. 0xff)
, fromIntegral ((w `shiftR` (8*6)) .&. 0xff)
, fromIntegral ((w `shiftR` (8*5)) .&. 0xff)
, fromIntegral ((w `shiftR` (8*4)) .&. 0xff)
, fromIntegral ((w `shiftR` (8*3)) .&. 0xff)
, fromIntegral ((w `shiftR` (8*2)) .&. 0xff)
, fromIntegral ((w `shiftR` (8*1)) .&. 0xff)
, fromIntegral ((w `shiftR` (8*0)) .&. 0xff)
)
prop_word16ToFromNet :: Word8 -> Word8 -> Bool
prop_word16ToFromNet w1 w0 =
word16ToNet (word16FromNet w1 w0) == (w1, w0)
prop_word32ToFromNet :: Word8 -> Word8 -> Word8 -> Word8 -> Bool
prop_word32ToFromNet w3 w2 w1 w0 =
word32ToNet (word32FromNet w3 w2 w1 w0) == (w3, w2, w1, w0)
prop_word64ToFromNet :: Word8 -> Word8 -> Word8 -> Word8 ->
Word8 -> Word8 -> Word8 -> Word8 -> Bool
prop_word64ToFromNet w7 w6 w5 w4 w3 w2 w1 w0 =
word64ToNet (word64FromNet w7 w6 w5 w4 w3 w2 w1 w0)
== (w7, w6, w5, w4, w3, w2, w1, w0)
wordToHalf :: Word16 -> Half
wordToHalf = Half.Half . fromIntegral
wordToFloat :: Word32 -> Float
wordToFloat = toFloat
wordToDouble :: Word64 -> Double
wordToDouble = toFloat
toFloat :: (Storable word, Storable float) => word -> float
toFloat w =
unsafeDupablePerformIO $ alloca $ \buf -> do
poke (castPtr buf) w
peek buf
halfToWord :: Half -> Word16
halfToWord (Half.Half w) = fromIntegral w
floatToWord :: Float -> Word32
floatToWord = fromFloat
doubleToWord :: Double -> Word64
doubleToWord = fromFloat
fromFloat :: (Storable word, Storable float) => float -> word
fromFloat float =
unsafeDupablePerformIO $ alloca $ \buf -> do
poke (castPtr buf) float
peek buf
-- Note: some NaNs do not roundtrip https://github.com/ekmett/half/issues/3
-- but all the others had better
prop_halfToFromFloat :: Bool
prop_halfToFromFloat =
all (\w -> roundTrip w || isNaN (Half.Half w)) [minBound..maxBound]
where
roundTrip w =
w == (Half.getHalf . Half.toHalf . Half.fromHalf . Half.Half $ w)
instance Arbitrary Half where
arbitrary = Half.Half . fromIntegral <$> (arbitrary :: Gen Word16)
newtype FloatSpecials n = FloatSpecials { getFloatSpecials :: n }
deriving (Show, Eq)
instance (Arbitrary n, RealFloat n) => Arbitrary (FloatSpecials n) where
arbitrary =
frequency
[ (7, FloatSpecials <$> arbitrary)
, (1, pure (FloatSpecials (1/0)) ) -- +Infinity
, (1, pure (FloatSpecials (0/0)) ) -- NaN
, (1, pure (FloatSpecials (-1/0)) ) -- -Infinity
]
newtype LargeInteger = LargeInteger { getLargeInteger :: Integer }
deriving (Show, Eq)
instance Arbitrary LargeInteger where
arbitrary =
sized $ \n ->
oneof $ take (1 + n `div` 10)
[ LargeInteger . fromIntegral <$> (arbitrary :: Gen Int8)
, LargeInteger . fromIntegral <$> choose (minBound, maxBound :: Int64)
, LargeInteger . bigger . fromIntegral <$> choose (minBound, maxBound :: Int64)
]
where
bigger n = n * abs n
arbitraryFullRangeIntegral :: forall a. (Bounded a,
#if MIN_VERSION_base(4,7,0)
FiniteBits a,
#else
Bits a,
#endif
Integral a) => Gen a
arbitraryFullRangeIntegral
| isSigned (undefined :: a)
= let maxBits = bitSize' (undefined :: a) - 1
in sized $ \s ->
let bound = fromIntegral (maxBound :: a)
`shiftR` ((maxBits - s) `max` 0)
in fmap fromInteger $ choose (-bound, bound)
| otherwise
= let maxBits = bitSize' (undefined :: a)
in sized $ \s ->
let bound = fromIntegral (maxBound :: a)
`shiftR` ((maxBits - s) `max` 0)
in fmap fromInteger $ choose (0, bound)
where
bitSize' =
#if MIN_VERSION_base(4,7,0)
finiteBitSize
#else
bitSize
#endif