273 lines
10 KiB
Haskell
273 lines
10 KiB
Haskell
{-# language BangPatterns #-}
|
|
{-# language ScopedTypeVariables #-}
|
|
{-# language TypeApplications #-}
|
|
{-# language OverloadedStrings #-}
|
|
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
import Control.Applicative (liftA2)
|
|
import Control.Monad.ST (runST)
|
|
import Data.ByteArray.Builder
|
|
import Data.Bytes.Types (Bytes(Bytes))
|
|
import Data.Bytes.Chunks (Chunks(ChunksNil,ChunksCons))
|
|
import Data.Primitive (PrimArray)
|
|
import Data.Word
|
|
import Data.Char (ord,chr)
|
|
import Data.IORef (IORef,newIORef,readIORef,writeIORef)
|
|
import Data.Primitive (ByteArray)
|
|
import Data.Proxy (Proxy(..))
|
|
import Data.WideWord (Word128(Word128))
|
|
import Test.Tasty (defaultMain,testGroup,TestTree)
|
|
import Test.QuickCheck ((===),Arbitrary)
|
|
import Text.Printf (printf)
|
|
import Test.Tasty.HUnit ((@=?))
|
|
|
|
import qualified Arithmetic.Nat as Nat
|
|
import qualified Data.ByteString as ByteString
|
|
import qualified Data.ByteString.Builder as BB
|
|
import qualified Data.ByteString.Lazy.Char8 as LB
|
|
import qualified Data.Bytes.Chunks as Chunks
|
|
import qualified Data.List as L
|
|
import qualified Data.Primitive as PM
|
|
import qualified Data.Primitive.Unlifted.Array as PM
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.Encoding as TE
|
|
import qualified GHC.Exts as Exts
|
|
import qualified Test.QuickCheck.Classes as QCC
|
|
import qualified Test.Tasty.HUnit as THU
|
|
import qualified Test.Tasty.QuickCheck as TQC
|
|
|
|
import qualified HexWord64
|
|
import qualified Word16Tree
|
|
|
|
main :: IO ()
|
|
main = defaultMain tests
|
|
|
|
tests :: TestTree
|
|
tests = testGroup "Tests"
|
|
[ testGroup "live"
|
|
[ TQC.testProperty "word64Dec" $ \w ->
|
|
runConcat 1 (word64Dec w) === pack (show w)
|
|
, TQC.testProperty "word64Dec-x3" $ \x y z ->
|
|
runConcat 1 (word64Dec x <> word64Dec y <> word64Dec z)
|
|
===
|
|
pack (show x ++ show y ++ show z)
|
|
, TQC.testProperty "int64Dec-x3" $ \x y z ->
|
|
runConcat 1 (int64Dec x <> int64Dec y <> int64Dec z)
|
|
===
|
|
pack (show x ++ show y ++ show z)
|
|
, TQC.testProperty "word64BE-x3" $ \x y z ->
|
|
runConcat 1 (word64BE x <> word64BE y <> word64BE z)
|
|
===
|
|
pack (LB.unpack (BB.toLazyByteString (BB.word64BE x <> BB.word64BE y <> BB.word64BE z)))
|
|
, TQC.testProperty "word64PaddedUpperHex" $ \w ->
|
|
runConcat 1 (word64PaddedUpperHex w)
|
|
===
|
|
pack (showWord64PaddedUpperHex w)
|
|
, TQC.testProperty "word8Dec" $ \w ->
|
|
runConcat 1 (word8Dec w)
|
|
===
|
|
pack (show w)
|
|
, TQC.testProperty "consLength32BE" $ \w ->
|
|
runConcat 1 (consLength32BE (word8Dec w))
|
|
===
|
|
pack ('\x00' : '\x00' : '\x00' : chr (L.length (show w)) : show w)
|
|
, TQC.testProperty "consLength64BE-uni" $ \w ->
|
|
pack
|
|
( '\x00' : '\x00' : '\x00' : '\x00'
|
|
: '\x00' : '\x00' : '\x00' : chr (L.length (show w))
|
|
: show w
|
|
)
|
|
===
|
|
runConcat 1 (consLength64BE (word16Dec w))
|
|
, TQC.testProperty "consLength64BE-multi" $ \w ->
|
|
pack
|
|
( '\x00' : '\x00' : '\x00' : '\x00'
|
|
: '\x00' : '\x00' : '\x00' : chr (1 + L.length (show w))
|
|
: '\x42' : show w
|
|
)
|
|
===
|
|
runConcat 1 (consLength64BE (word8 0x42 <> flush 2 <> word16Dec w))
|
|
, THU.testCase "stringUtf8" $
|
|
packUtf8 "¿Cómo estás? I am doing well." @=?
|
|
runConcat 1 (stringUtf8 "¿Cómo estás? I am doing well.")
|
|
, THU.testCase "doubleDec-A" $
|
|
pack (show (2 :: Int)) @=? runConcat 1 (doubleDec 2.0)
|
|
, THU.testCase "doubleDec-B" $
|
|
pack (show (2.5 :: Double)) @=? runConcat 1 (doubleDec 2.5)
|
|
, THU.testCase "doubleDec-C" $
|
|
pack ("1e+15") @=? runConcat 1 (doubleDec 1e15)
|
|
, THU.testCase "doubleDec-D" $
|
|
pack ("-42") @=? runConcat 1 (doubleDec (-42))
|
|
, THU.testCase "doubleDec-E" $
|
|
pack ("-8.88888888888888e+14") @=? runConcat 1 (doubleDec (-888888888888888.8888888))
|
|
, THU.testCase "doubleDec-F" $
|
|
pack ("42") @=? runConcat 1 (doubleDec 42)
|
|
, THU.testCase "doubleDec-G" $
|
|
pack ("0") @=? runConcat 1 (doubleDec 0)
|
|
, THU.testCase "doubleDec-H" $
|
|
pack ("0.5") @=? runConcat 1 (doubleDec 0.5)
|
|
, THU.testCase "doubleDec-I" $
|
|
pack ("-0.5") @=? runConcat 1 (doubleDec (-0.5))
|
|
, THU.testCase "doubleDec-J" $
|
|
pack ("999999999") @=? runConcat 1 (doubleDec 999999999)
|
|
, THU.testCase "doubleDec-K" $
|
|
pack ("-99999999") @=? runConcat 1 (doubleDec (-99999999))
|
|
, THU.testCase "shortTextJsonString-A" $
|
|
pack ("\"hello\"") @=? runConcat 1 (shortTextJsonString "hello")
|
|
, THU.testCase "shortTextJsonString-B" $
|
|
pack ("\"\\\\_\\\"_/\"") @=? runConcat 1 (shortTextJsonString "\\_\"_/")
|
|
, THU.testCase "shortTextJsonString-C" $
|
|
pack ("\"Hi\\r\\nLo\"") @=? runConcat 1 (shortTextJsonString "Hi\r\nLo")
|
|
, THU.testCase "shortTextJsonString-D" $
|
|
pack ("\"Hi\\u001BLo\"") @=? runConcat 1 (shortTextJsonString "Hi\ESCLo")
|
|
, THU.testCase "word-16-tree" $
|
|
Word16Tree.expectedSmall @=? runConcat 1
|
|
(Word16Tree.encode Word16Tree.exampleSmall)
|
|
, THU.testCase "byteArray-small" $
|
|
let a = replicateByte 3 0x50
|
|
b = replicateByte 5 0x51
|
|
in mconcat [a,b] @=? runConcat 1
|
|
( byteArray a <> byteArray b )
|
|
, THU.testCase "byteArray-big" $
|
|
let a = replicateByte 2105 0x50
|
|
b = replicateByte 725 0x51
|
|
c = replicateByte 900 0x52
|
|
d = replicateByte 800 0x53
|
|
e = replicateByte 700 0x54
|
|
f = replicateByte 950 0x55
|
|
g = replicateByte 975 0x56
|
|
h = replicateByte 3000 0x57
|
|
i = replicateByte 125 0x58
|
|
in mconcat [a,b,c,d,e,f,g,h,i] @=? runConcat 1
|
|
( byteArray a <> byteArray b <> byteArray c <>
|
|
byteArray d <> byteArray e <> byteArray f <>
|
|
byteArray g <> byteArray h <> byteArray i
|
|
)
|
|
, TQC.testProperty "word16ArrayLE" $ \(xs :: [Word16]) ->
|
|
let ys = Exts.fromList xs :: PrimArray Word16
|
|
in runConcat 1 (foldMap word16LE xs)
|
|
===
|
|
runConcat 1 (word16ArrayLE ys 0 (Prelude.length xs))
|
|
, TQC.testProperty "word16ArrayBE" $ \(xs :: [Word16]) ->
|
|
let ys = Exts.fromList xs :: PrimArray Word16
|
|
in runConcat 1 (foldMap word16BE xs)
|
|
===
|
|
runConcat 1 (word16ArrayBE ys 0 (Prelude.length xs))
|
|
, TQC.testProperty "word32ArrayLE" $ \(xs :: [Word32]) ->
|
|
let ys = Exts.fromList xs :: PrimArray Word32
|
|
in runConcat 1 (foldMap word32LE xs)
|
|
===
|
|
runConcat 1 (word32ArrayLE ys 0 (Prelude.length xs))
|
|
, TQC.testProperty "word32ArrayBE" $ \(xs :: [Word32]) ->
|
|
let ys = Exts.fromList xs :: PrimArray Word32
|
|
in runConcat 1 (foldMap word32BE xs)
|
|
===
|
|
runConcat 1 (word32ArrayBE ys 0 (Prelude.length xs))
|
|
, TQC.testProperty "word64ArrayLE" $ \(xs :: [Word64]) ->
|
|
let ys = Exts.fromList xs :: PrimArray Word64
|
|
in runConcat 1 (foldMap word64LE xs)
|
|
===
|
|
runConcat 1 (word64ArrayLE ys 0 (Prelude.length xs))
|
|
, TQC.testProperty "word64ArrayBE" $ \(xs :: [Word64]) ->
|
|
let ys = Exts.fromList xs :: PrimArray Word64
|
|
in runConcat 1 (foldMap word64BE xs)
|
|
===
|
|
runConcat 1 (word64ArrayBE ys 0 (Prelude.length xs))
|
|
, TQC.testProperty "word128ArrayLE" $ \(xs :: [Word128]) ->
|
|
let ys = Exts.fromList xs :: PrimArray Word128
|
|
in runConcat 1 (foldMap word128LE xs)
|
|
===
|
|
runConcat 1 (word128ArrayLE ys 0 (Prelude.length xs))
|
|
, TQC.testProperty "word128ArrayBE" $ \(xs :: [Word128]) ->
|
|
let ys = Exts.fromList xs :: PrimArray Word128
|
|
in runConcat 1 (foldMap word128BE xs)
|
|
===
|
|
runConcat 1 (word128ArrayBE ys 0 (Prelude.length xs))
|
|
]
|
|
, testGroup "alternate"
|
|
[ TQC.testProperty "HexWord64" $ \x y ->
|
|
runConcat 1
|
|
( fromBounded Nat.constant (HexWord64.word64PaddedUpperHex x)
|
|
<> fromBounded Nat.constant (HexWord64.word64PaddedUpperHex y)
|
|
)
|
|
===
|
|
pack (showWord64PaddedUpperHex x <> showWord64PaddedUpperHex y)
|
|
]
|
|
, testGroup "Chunks"
|
|
[ lawsToTest (QCC.eqLaws (Proxy :: Proxy Chunks))
|
|
, lawsToTest (QCC.semigroupLaws (Proxy :: Proxy Chunks))
|
|
, lawsToTest (QCC.monoidLaws (Proxy :: Proxy Chunks))
|
|
]
|
|
, testGroup "putMany"
|
|
[ THU.testCase "A" $ do
|
|
ref <- newIORef []
|
|
let txt = "hello_world_are_you_listening" :: [Char]
|
|
putMany 7 ascii txt (ontoRef ref)
|
|
res <- readIORef ref
|
|
id $
|
|
[ map c2w "hello_w"
|
|
, map c2w "o"
|
|
, map c2w "rld_are"
|
|
, map c2w "_"
|
|
, map c2w "you_lis"
|
|
, map c2w "t"
|
|
, map c2w "ening"
|
|
] @=? map Exts.toList (Exts.toList res)
|
|
]
|
|
]
|
|
|
|
ontoRef ::
|
|
IORef [PM.ByteArray]
|
|
-> PM.UnliftedArray (PM.MutableByteArray Exts.RealWorld)
|
|
-> IO ()
|
|
ontoRef !ref xs = do
|
|
rs <- readIORef ref
|
|
ps <- PM.foldlUnliftedArrayM'
|
|
(\ys buf -> do
|
|
len <- PM.getSizeofMutableByteArray buf
|
|
dst <- PM.newByteArray len
|
|
PM.copyMutableByteArray dst 0 buf 0 len
|
|
dst' <- PM.unsafeFreezeByteArray dst
|
|
pure (ys ++ [dst'])
|
|
) [] xs
|
|
writeIORef ref (rs ++ ps)
|
|
|
|
instance Arbitrary Chunks where
|
|
arbitrary = do
|
|
xs :: [[Word8]] <- TQC.arbitrary
|
|
let ys = map
|
|
(\x -> Exts.fromList ([255] ++ x ++ [255]))
|
|
xs
|
|
zs = foldr
|
|
(\b cs ->
|
|
ChunksCons (Bytes b 1 (PM.sizeofByteArray b - 2)) cs
|
|
) ChunksNil ys
|
|
pure zs
|
|
|
|
lawsToTest :: QCC.Laws -> TestTree
|
|
lawsToTest (QCC.Laws name pairs) = testGroup name (map (uncurry TQC.testProperty) pairs)
|
|
|
|
replicateByte :: Int -> Word8 -> ByteArray
|
|
replicateByte n w = runST $ do
|
|
m <- PM.newByteArray n
|
|
PM.setByteArray m 0 n w
|
|
PM.unsafeFreezeByteArray m
|
|
|
|
pack :: String -> ByteArray
|
|
pack = Exts.fromList . map (fromIntegral @Int @Word8 . ord)
|
|
|
|
packUtf8 :: String -> ByteArray
|
|
packUtf8 = Exts.fromList . ByteString.unpack . TE.encodeUtf8 . T.pack
|
|
|
|
showWord64PaddedUpperHex :: Word64 -> String
|
|
showWord64PaddedUpperHex = printf "%016X"
|
|
|
|
runConcat :: Int -> Builder -> ByteArray
|
|
runConcat n = Chunks.concat . run n
|
|
|
|
c2w :: Char -> Word8
|
|
c2w = fromIntegral . ord
|
|
|
|
instance Arbitrary Word128 where
|
|
arbitrary = liftA2 Word128 TQC.arbitrary TQC.arbitrary
|