diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for serialise + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE.txt b/LICENSE.txt new file mode 100644 --- /dev/null +++ b/LICENSE.txt @@ -0,0 +1,30 @@ +Copyright (c) 2017, Duncan Coutts + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Duncan Coutts nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bench/instances/Instances/Integer.hs b/bench/instances/Instances/Integer.hs new file mode 100644 --- /dev/null +++ b/bench/instances/Instances/Integer.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Instances.Integer + ( benchmarks -- :: [Benchmark] + ) where + +import Criterion.Main +import qualified Data.ByteString.Lazy as BS +import qualified Data.Vector as Vector + +import Codec.Serialise + +benchmarks :: [Benchmark] +benchmarks = + [ bgroup "serialise" + [ bench "small positive" (nf goSerialise integerDataSmallPos) + , bench "small negative" (nf goSerialise integerDataSmallNeg) + , bench "large positive" (nf goSerialise integerDataLargePos) + , bench "large negative" (nf goSerialise integerDataLargeNeg) + ] + , bgroup "deserialise" + [ bench "small positive" (nf goDeserialise integerDataSerialisedSmallPos) + , bench "small negative" (nf goDeserialise integerDataSerialisedSmallNeg) + , bench "large positive" (nf goDeserialise integerDataSerialisedLargePos) + , bench "large negative" (nf goDeserialise integerDataSerialisedLargeNeg) + ] + ] + where + goSerialise = BS.length . serialise + goDeserialise :: BS.ByteString -> Vector.Vector Integer + goDeserialise = deserialise + integerDataSmallPos = Vector.replicate (100 :: Int) (10 :: Integer) + integerDataSmallNeg = Vector.replicate (100 :: Int) (-10 :: Integer) + integerDataLargePos = Vector.replicate (100 :: Int) (two^(two * 100)) + integerDataLargeNeg = Vector.replicate (100 :: Int) (-(two^(two * 100))) + integerDataSerialisedSmallPos = serialise integerDataSmallPos + integerDataSerialisedSmallNeg = serialise integerDataSmallNeg + integerDataSerialisedLargePos = serialise integerDataLargePos + integerDataSerialisedLargeNeg = serialise integerDataLargeNeg + two = 2 :: Integer + diff --git a/bench/instances/Instances/Time.hs b/bench/instances/Instances/Time.hs new file mode 100644 --- /dev/null +++ b/bench/instances/Instances/Time.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Instances.Time + ( benchmarks -- :: [Benchmark] + ) where + +import Criterion.Main +import Data.Time.Clock (UTCTime(..)) +import Data.Time.Calendar (Day(..)) +import Codec.Serialise +import Control.DeepSeq (force) +import qualified Data.ByteString.Lazy as BSL + +benchmarks :: [Benchmark] +benchmarks = + [ bench "serialise UTCTime" (whnf (BSL.length . serialise) timestamps) + , bench "deserialise UTCTime" (nf (deserialise :: BSL.ByteString -> [UTCTime]) serialisedTimestamps) + ] + where + faketime = UTCTime (ModifiedJulianDay 0) 0 + timestamps = force (replicate 100 faketime) + serialisedTimestamps = force (serialise timestamps) diff --git a/bench/instances/Instances/Vector.hs b/bench/instances/Instances/Vector.hs new file mode 100644 --- /dev/null +++ b/bench/instances/Instances/Vector.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Instances.Vector + ( benchmarks -- :: [Benchmark] + ) where + +import Data.Proxy +import Criterion.Main +import qualified Data.Vector.Generic as VG +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector as V +import qualified Data.ByteString.Lazy as BSL +import Codec.Serialise +import Control.DeepSeq (force) + +benchmarks :: [Benchmark] +benchmarks = + [ bgroup "unboxed" + [ bgroup "encode" + [ vectorEncode unboxed (42 :: Int) 500 + , vectorEncode unboxed (42 :: Int) 5000 + , vectorEncode unboxed (42 :: Int) 50000 + , vectorEncode unboxed (42 :: Int) 500000 + ] + , bgroup "decode" + [ vectorDecode unboxed (42 :: Int) 500 + , vectorDecode unboxed (42 :: Int) 5000 + , vectorDecode unboxed (42 :: Int) 50000 + , vectorDecode unboxed (42 :: Int) 500000 + ] + ] + , bgroup "boxed" + [ bgroup "encode" + [ vectorEncode boxed (42 :: Int) 500 + , vectorEncode boxed (42 :: Int) 5000 + , vectorEncode boxed (42 :: Int) 50000 + , vectorEncode boxed (42 :: Int) 500000 + ] + , bgroup "decode" + [ vectorDecode boxed (42 :: Int) 500 + , vectorDecode boxed (42 :: Int) 5000 + , vectorDecode boxed (42 :: Int) 50000 + , vectorDecode boxed (42 :: Int) 500000 + ] + ] + ] + where + unboxed = Proxy :: Proxy VU.Vector + boxed = Proxy :: Proxy V.Vector + +-------------------------------------------------------------------------------- +-- Encoding + +vectorEncode :: forall v a. (Serialise (v a), VG.Vector v a) + => Proxy v + -> a + -> Int + -> Benchmark +vectorEncode Proxy x len + = bench (show len) $ benchEncode (asVector $ VG.replicate len x) + where + asVector v = v :: v a + + benchEncode :: Serialise s => s -> Benchmarkable + benchEncode = whnf (BSL.length . serialise) + {-# INLINE benchEncode #-} + +-------------------------------------------------------------------------------- +-- Decoding + +vectorDecode :: forall v a. (Serialise (v a), VG.Vector v a, Num a) + => Proxy v + -> a + -> Int + -> Benchmark +vectorDecode Proxy x len + = bench (show len) $ benchDecode (force $ serialise $ asVector $ VG.replicate len x) + where + asVector v = v :: v a + + benchDecode :: BSL.ByteString -> Benchmarkable + benchDecode = whnf (VG.sum . asVector . deserialise) + {-# INLINE benchDecode #-} diff --git a/bench/instances/Main.hs b/bench/instances/Main.hs new file mode 100644 --- /dev/null +++ b/bench/instances/Main.hs @@ -0,0 +1,18 @@ +module Main + ( main -- :: IO () + ) where + +import Criterion.Main (bgroup, defaultMain) + +import qualified Instances.Integer as Integer +import qualified Instances.Time as Time +import qualified Instances.Vector as Vector + +-------------------------------------------------------------------------------- + +main :: IO () +main = defaultMain + [ bgroup "integer" Integer.benchmarks + , bgroup "time" Time.benchmarks + , bgroup "vector" Vector.benchmarks + ] diff --git a/bench/micro/Main.hs b/bench/micro/Main.hs new file mode 100644 --- /dev/null +++ b/bench/micro/Main.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +module Main + ( main -- :: IO () + ) where + +import Criterion.Main (defaultMain, bgroup) + +import qualified Micro as Micro +import qualified SimpleVersus as Versus + +-------------------------------------------------------------------------------- + +-- A simple driver, for running every set of benchmarks. +main :: IO () +main = defaultMain + [ bgroup "micro" Micro.benchmarks + , bgroup "versus" Versus.benchmarks + ] diff --git a/bench/micro/Micro.hs b/bench/micro/Micro.hs new file mode 100644 --- /dev/null +++ b/bench/micro/Micro.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +module Micro + ( benchmarks -- :: [Benchmark] + ) where + +import Criterion.Main +import Control.DeepSeq +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BS + +import Foreign + +import Codec.CBOR.Magic + +import qualified Micro.MemSize +import Micro.DeepSeq () +import qualified Micro.Load as Micro.Load +import qualified Micro.Types as Micro.Types () + +import qualified Micro.ReadShow as Micro.ReadShow +import qualified Micro.PkgBinary as Micro.PkgBinary +import qualified Micro.PkgCereal as Micro.PkgCereal +import qualified Micro.PkgStore as Micro.PkgStore +import qualified Micro.PkgAesonGeneric as Micro.PkgAesonGeneric +import qualified Micro.PkgAesonTH as Micro.PkgAesonTH +import qualified Micro.CBOR as Micro.CBOR + +-------------------------------------------------------------------------------- + +-- A simple driver, for running every set of benchmarks. +benchmarks :: [Benchmark] +benchmarks = + [ bgroup "reference" + [ bench "deepseq" (whnf rnf tstdata) + , bench "memSize" (whnf (flip Micro.MemSize.memSize 0) tstdata) + ] + , bgroup "encoding" $ deepseq tstdata + [ bench "binary" (whnf perfEncodeBinary tstdata) + , bench "cereal" (whnf perfEncodeCereal tstdata) + , bench "aeson generic" (whnf perfEncodeAesonGeneric tstdata) + , bench "aeson TH" (whnf perfEncodeAesonTH tstdata) + , bench "read/show" (whnf perfEncodeReadShow tstdata) + , bench "store" (whnf perfEncodeStore tstdata) + , bench "cbor" (whnf perfEncodeCBOR tstdata) + ] + , bgroup "decoding" $ deepseq (tstdataB, tstdataC, tstdataA, tstdataS, + tstdataR) + [ bench "binary" (whnf perfDecodeBinary tstdataB) + , bench "cereal" (whnf perfDecodeCereal tstdataC) + , bench "aeson generic" (whnf perfDecodeAesonGeneric tstdataA) + , bench "aeson TH" (whnf perfDecodeAesonTH tstdataA) + , bench "read/show" (whnf perfDecodeReadShow tstdataS) + , bench "store" (whnf perfDecodeStore tstdataP) + , bench "cbor" (whnf perfDecodeCBOR tstdataR) + ] + , bgroup "decoding + deepseq" $ deepseq (tstdataB, tstdataC, tstdataA, + tstdataS, tstdataR) + [ bench "binary" (nf perfDecodeBinary tstdataB) + , bench "cereal" (nf perfDecodeCereal tstdataC) + , bench "aeson generic" (nf perfDecodeAesonGeneric tstdataA) + , bench "aeson TH" (nf perfDecodeAesonTH tstdataA) + , bench "read/show" (nf perfDecodeReadShow tstdataS) + , bench "store" (nf perfDecodeStore tstdataP) + , bench "cbor" (nf perfDecodeCBOR tstdataR) + ] + , env lowlevelPtrEnv $ \ptr -> + bgroup "lowlevel" + [ bench "grabWord16" (nf grabWord16 ptr) + , bench "grabWord32" (nf grabWord32 ptr) + , bench "grabWord64" (nf grabWord64 ptr) + ] + ] + where + -- Input data + tstdata = Micro.Load.mkBigTree 16 -- tree of size 2^16 + !tstdataB = combineChunks $ Micro.PkgBinary.serialise tstdata + !tstdataC = combineChunks $ Micro.PkgCereal.serialise tstdata + !tstdataA = combineChunks $ Micro.PkgAesonTH.serialise tstdata + !tstdataS = combineChunks $ Micro.ReadShow.serialise tstdata + !tstdataP = Micro.PkgStore.serialise tstdata + !tstdataR = combineChunks $ Micro.CBOR.serialise tstdata + + -- Encoding tests + perfEncodeBinary = BS.length . Micro.PkgBinary.serialise + perfEncodeCereal = BS.length . Micro.PkgCereal.serialise + perfEncodeAesonGeneric = BS.length . Micro.PkgAesonGeneric.serialise + perfEncodeAesonTH = BS.length . Micro.PkgAesonTH.serialise + perfEncodeReadShow = BS.length . Micro.ReadShow.serialise + perfEncodeStore = B.length . Micro.PkgStore.serialise + perfEncodeCBOR = BS.length . Micro.CBOR.serialise + + -- Decoding tests + perfDecodeBinary = Micro.PkgBinary.deserialise + perfDecodeCereal = Micro.PkgCereal.deserialise + perfDecodeAesonGeneric = Micro.PkgAesonGeneric.deserialise + perfDecodeAesonTH = Micro.PkgAesonTH.deserialise + perfDecodeReadShow = Micro.ReadShow.deserialise + perfDecodeStore = Micro.PkgStore.deserialise + perfDecodeCBOR = Micro.CBOR.deserialise + + -- | Allocate an 8-byte pointer, write a 64-bit word into + -- it, and return a @'Ptr' ()@ to be used by the low-level routines. + lowlevelPtrEnv :: IO (Ptr ()) + lowlevelPtrEnv = do + ptr <- mallocBytes 8 + poke ptr (0xDEADBEEFCAFEBABE :: Word64) + return (castPtr ptr) + + -- Create lazy bytestring that contains single chunk, from the + -- bytestring that may contain multiple chunks. + combineChunks :: BS.ByteString -> BS.ByteString + combineChunks = BS.fromStrict . BS.toStrict + +-------------------------------------------------------------------------------- + +-- An NFData instance for Ptr is in deepseq HEAD/1.4.2, but it's not released. +#if !MIN_VERSION_deepseq(1,4,2) +instance NFData (Ptr a) where rnf !_ = () +#endif diff --git a/bench/micro/Micro/CBOR.hs b/bench/micro/Micro/CBOR.hs new file mode 100644 --- /dev/null +++ b/bench/micro/Micro/CBOR.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Micro.CBOR (serialise, deserialise) where + +import Micro.Types + +import Codec.Serialise.Class +import Codec.Serialise.Encoding +import Codec.Serialise.Decoding hiding (DecodeAction(Done, Fail)) +import qualified Codec.Serialise as Serialise +import Data.Monoid + +import qualified Data.ByteString.Lazy as BS + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +import Data.Word +#endif + +serialise :: Tree -> BS.ByteString +serialise = Serialise.serialise + +deserialise :: BS.ByteString -> Tree +deserialise = Serialise.deserialise + +encodeCtr0 :: Word -> Encoding +encodeCtr2 :: (Serialise a, Serialise b) => Word -> a -> b -> Encoding + +encodeCtr0 n = encodeListLen 1 <> encode (n :: Word) +encodeCtr2 n a b = encodeListLen 3 <> encode (n :: Word) <> encode a <> encode b + +{-# INLINE encodeCtr0 #-} +{-# INLINE encodeCtr2 #-} + +{-# INLINE decodeCtrTag #-} +{-# INLINE decodeCtrBody0 #-} +{-# INLINE decodeCtrBody2 #-} + +decodeCtrTag :: Decoder s (Word, Int) +decodeCtrTag = (\len tag -> (tag, len)) <$> decodeListLen <*> decodeWord + +decodeCtrBody0 :: Int -> a -> Decoder s a +decodeCtrBody0 1 f = pure f +decodeCtrBody0 x _ = error $ "decodeCtrBody0: impossible tag " ++ show x + +decodeCtrBody2 + :: (Serialise a, Serialise b) => Int -> (a -> b -> c) -> Decoder s c +decodeCtrBody2 3 f = do x1 <- decode + x2 <- decode + return (f x1 x2) +decodeCtrBody2 x _ = error $ "decodeCtrBody2: impossible tag " ++ show x + +instance Serialise Tree where + encode Leaf = encodeCtr0 1 + encode (Fork a b) = encodeCtr2 2 a b + + decode = do + (t,l) <- decodeCtrTag + case t of + 1 -> decodeCtrBody0 l Leaf + 2 -> decodeCtrBody2 l Fork + x -> error $ "Serialise Tree: decode: impossible tag " ++ show x diff --git a/bench/micro/Micro/DeepSeq.hs b/bench/micro/Micro/DeepSeq.hs new file mode 100644 --- /dev/null +++ b/bench/micro/Micro/DeepSeq.hs @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Micro.DeepSeq where + +import Micro.Types + +import Control.DeepSeq + +instance NFData Tree where + rnf Leaf = () + rnf (Fork a b) = rnf a `seq` rnf b `seq` () + diff --git a/bench/micro/Micro/Load.hs b/bench/micro/Micro/Load.hs new file mode 100644 --- /dev/null +++ b/bench/micro/Micro/Load.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE BangPatterns #-} +module Micro.Load (mkBigTree, mkBigTrees) where + +import Micro.Types +import Micro.ReadShow () + + +mkBigTrees :: Int -> Int -> [Tree] +mkBigTrees n depth = + let !tree = mkBigTree depth + in replicate n tree + +mkBigTree :: Int -> Tree +mkBigTree 0 = Leaf +mkBigTree depth = + let !subtree = mkBigTree (depth-1) + in Fork subtree subtree + diff --git a/bench/micro/Micro/MemSize.hs b/bench/micro/Micro/MemSize.hs new file mode 100644 --- /dev/null +++ b/bench/micro/Micro/MemSize.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE BangPatterns #-} +module Micro.MemSize where + +import Micro.Types + +class MemSize a where + memSize :: a -> Int -> Int + +memSize0 :: Int -> Int +memSize2 :: (MemSize a, MemSize a1) => + a -> a1 -> Int -> Int + +memSize0 = \ !sz -> sz +memSize2 a b = \ !sz -> memSize a . memSize b $ 2 + sz +{-# INLINE memSize0 #-} +{-# INLINE memSize2 #-} + +instance MemSize Tree where + memSize Leaf = memSize0 + memSize (Fork b a) = memSize2 a b + diff --git a/bench/micro/Micro/PkgAesonGeneric.hs b/bench/micro/Micro/PkgAesonGeneric.hs new file mode 100644 --- /dev/null +++ b/bench/micro/Micro/PkgAesonGeneric.hs @@ -0,0 +1,17 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Micro.PkgAesonGeneric where + +import Micro.Types +import Data.Aeson as Aeson +import Data.ByteString.Lazy as BS +import Data.Maybe + +serialise :: Tree -> BS.ByteString +serialise = Aeson.encode + +deserialise :: BS.ByteString -> Tree +deserialise = fromJust . Aeson.decode' + +instance ToJSON Tree +instance FromJSON Tree + diff --git a/bench/micro/Micro/PkgAesonTH.hs b/bench/micro/Micro/PkgAesonTH.hs new file mode 100644 --- /dev/null +++ b/bench/micro/Micro/PkgAesonTH.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Micro.PkgAesonTH where + +import Micro.Types +import Data.Aeson as Aeson +import Data.Aeson.TH as Aeson +import Data.ByteString.Lazy as BS +import Data.Maybe + +serialise :: Tree -> BS.ByteString +serialise = Aeson.encode + +deserialise :: BS.ByteString -> Tree +deserialise = fromJust . Aeson.decode' + +deriveJSON defaultOptions ''Tree + diff --git a/bench/micro/Micro/PkgBinary.hs b/bench/micro/Micro/PkgBinary.hs new file mode 100644 --- /dev/null +++ b/bench/micro/Micro/PkgBinary.hs @@ -0,0 +1,15 @@ +{-# OPTIONS_GHC -fno-warn-orphans -fsimpl-tick-factor=500 #-} +module Micro.PkgBinary (serialise, deserialise) where + +import Micro.Types +import Data.Binary as Binary +import Data.ByteString.Lazy as BS + +serialise :: Tree -> BS.ByteString +serialise = Binary.encode + +deserialise :: BS.ByteString -> Tree +deserialise = Binary.decode + +instance Binary Tree + diff --git a/bench/micro/Micro/PkgCereal.hs b/bench/micro/Micro/PkgCereal.hs new file mode 100644 --- /dev/null +++ b/bench/micro/Micro/PkgCereal.hs @@ -0,0 +1,15 @@ +{-# OPTIONS_GHC -fno-warn-orphans -fsimpl-tick-factor=500 #-} +module Micro.PkgCereal (serialise, deserialise) where + +import Micro.Types +import Data.Serialize as Cereal +import Data.ByteString.Lazy as BS + +serialise :: Tree -> BS.ByteString +serialise = Cereal.encodeLazy + +deserialise :: BS.ByteString -> Tree +deserialise = (\(Right x) -> x) . Cereal.decodeLazy + +instance Serialize Tree + diff --git a/bench/micro/Micro/PkgStore.hs b/bench/micro/Micro/PkgStore.hs new file mode 100644 --- /dev/null +++ b/bench/micro/Micro/PkgStore.hs @@ -0,0 +1,15 @@ +{-# OPTIONS_GHC -fno-warn-orphans -fsimpl-tick-factor=500 #-} +module Micro.PkgStore (serialise, deserialise) where + +import Micro.Types +import Data.Store as Store +import Data.ByteString as BS + +serialise :: Tree -> BS.ByteString +serialise pkgs = Store.encode pkgs + +deserialise :: BS.ByteString -> Tree +deserialise = (\(Right x) -> x) . Store.decode + +instance Store Tree + diff --git a/bench/micro/Micro/ReadShow.hs b/bench/micro/Micro/ReadShow.hs new file mode 100644 --- /dev/null +++ b/bench/micro/Micro/ReadShow.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Micro.ReadShow where + +import Micro.Types +import Data.ByteString.Lazy.Char8 as BS + +serialise :: Tree -> BS.ByteString +serialise = BS.pack . show + +deserialise :: BS.ByteString -> Tree +deserialise = read . BS.unpack + +deriving instance Show Tree +deriving instance Read Tree + diff --git a/bench/micro/Micro/Types.hs b/bench/micro/Micro/Types.hs new file mode 100644 --- /dev/null +++ b/bench/micro/Micro/Types.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE DeriveGeneric #-} +module Micro.Types (Tree(..)) where + +import GHC.Generics + +data Tree = Leaf | Fork Tree Tree + deriving (Eq, Ord, Generic) + diff --git a/bench/micro/SimpleVersus.hs b/bench/micro/SimpleVersus.hs new file mode 100644 --- /dev/null +++ b/bench/micro/SimpleVersus.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE BangPatterns #-} +module SimpleVersus + ( benchmarks -- :: [Benchmark] + ) where + +import Control.DeepSeq +import Criterion.Main +import qualified Data.Binary as Binary +import qualified Codec.Serialise as Serialise +import qualified Data.ByteString as ByteStringStrict +import qualified Data.ByteString.Lazy as ByteString +import qualified Data.Serialize as Cereal +import qualified Data.Store as Store +import Data.Vector.Serialize () +import qualified Data.Vector.Unboxed as Unboxed + +benchmarks :: [Benchmark] +benchmarks = + [ bgroup "unboxed-vector" + [ bgroup "serialise" + [ bench "binary" $ nf binarySerialise vector + , bench "cbor" $ nf cborSerialise vector + , bench "cereal" $ nf cerealSerialise vector + , bench "store" $ nf storeSerialise vector + ] + , bgroup "deserialise" + [ bench "binary" $ nf binaryDeserialise binaryVector + , bench "cbor" $ nf cborDeserialise cborVector + , bench "cereal" $ nf cerealDeserialise cerealVector + , bench "store" $ nf storeDeserialise storeVector + ] + ] + ] + where + cborVector, cerealVector, binaryVector :: ByteString.ByteString + !cborVector = force $ cborSerialise vector + !cerealVector = force $ cerealSerialise vector + !binaryVector = force $ binarySerialise vector + storeVector :: ByteStringStrict.ByteString + !storeVector = force $ storeSerialise vector + !vector = Unboxed.fromList list + list :: [Int] + list = [1.. 1024 * 1024] + +binarySerialise, cborSerialise, cerealSerialise + :: Unboxed.Vector Int -> ByteString.ByteString +binarySerialise = Binary.encode +cborSerialise = Serialise.serialise +cerealSerialise = Cereal.encodeLazy +storeSerialise :: Unboxed.Vector Int -> ByteStringStrict.ByteString +storeSerialise = Store.encode + +binaryDeserialise, cborDeserialise, cerealDeserialise + :: ByteString.ByteString -> Unboxed.Vector Int +binaryDeserialise = Binary.decode +cerealDeserialise = (\(Right x) -> x) . Cereal.decodeLazy +cborDeserialise = Serialise.deserialise + +storeDeserialise :: ByteStringStrict.ByteString -> Unboxed.Vector Int +storeDeserialise = (\(Right x) -> x) . Store.decode diff --git a/bench/versus/Macro.hs b/bench/versus/Macro.hs new file mode 100644 --- /dev/null +++ b/bench/versus/Macro.hs @@ -0,0 +1,125 @@ +module Macro + ( benchmarks -- :: [Benchmark] + ) where +import Data.Int + +import Criterion.Main +import Control.DeepSeq +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BS +import qualified Codec.Compression.GZip as GZip + +import qualified Macro.Types as Types +import qualified Macro.MemSize +import Macro.DeepSeq () +import qualified Macro.Load as Load + +import qualified Macro.ReadShow as ReadShow +import qualified Macro.PkgBinary as PkgBinary +import qualified Macro.PkgCereal as PkgCereal +import qualified Macro.PkgAesonGeneric as PkgAesonGeneric +import qualified Macro.PkgAesonTH as PkgAesonTH +import qualified Macro.PkgStore as PkgStore + +import qualified Macro.CBOR as CBOR + +readBigTestData :: IO [Types.GenericPackageDescription] +readBigTestData = do + Right pkgs_ <- fmap (Load.readPkgIndex . GZip.decompress) + (BS.readFile "bench/data/01-index.tar.gz") + let tstdata = take 100 pkgs_ + return tstdata + +benchmarks :: [Benchmark] +benchmarks = + [ env readBigTestData $ \tstdata -> + bgroup "reference" + [ bench "deepseq" (whnf rnf tstdata) + , bench "memSize" (whnf (flip Macro.MemSize.memSize 0) tstdata) + ] + + , env readBigTestData $ \tstdata -> + bgroup "encoding" + [ bench "binary" (whnf perfEncodeBinary tstdata) + , bench "cereal" (whnf perfEncodeCereal tstdata) + , bench "aeson generic" (whnf perfEncodeAesonGeneric tstdata) + , bench "aeson TH" (whnf perfEncodeAesonTH tstdata) + , bench "read/show" (whnf perfEncodeReadShow tstdata) + , bench "cbor" (whnf perfEncodeCBOR tstdata) + , bench "store" (whnf perfEncodeStore tstdata) + ] + + , env readBigTestData $ \tstdata -> + bgroup "decoding whnf" + [ env (return $ combineChunks $ PkgBinary.serialise tstdata) + $ \tstdataB -> bench "binary" (whnf perfDecodeBinary tstdataB) + , env (return $ combineChunks $ PkgCereal.serialise tstdata) + $ \tstdataC -> bench "cereal" (whnf perfDecodeCereal tstdataC) + , env (return $ combineChunks $ PkgAesonTH.serialise tstdata) + $ \tstdataA -> bgroup "aeson" + [ bench "generic" (whnf perfDecodeAesonGeneric tstdataA) + , bench "TH" (whnf perfDecodeAesonTH tstdataA) + ] + , env (return $ combineChunks $ ReadShow.serialise tstdata) + $ \tstdataS -> bench "read/show" (whnf perfDecodeReadShow tstdataS) + , env (return $ PkgStore.serialise tstdata) + $ \tstdataR -> bench "store" (whnf perfDecodeStore tstdataR) + , env (return $ combineChunks $ CBOR.serialise tstdata) + $ \tstdataR -> bench "cbor" (whnf perfDecodeCBOR tstdataR) + ] + + , env readBigTestData $ \tstdata -> + bgroup "decoding nf" + [ env (return $ combineChunks $ PkgBinary.serialise tstdata) + $ \tstdataB -> bench "binary" (nf perfDecodeBinary tstdataB) + , env (return $ combineChunks $ PkgCereal.serialise tstdata) + $ \tstdataC -> bench "cereal" (nf perfDecodeCereal tstdataC) + , env (return $ combineChunks $ PkgAesonTH.serialise tstdata) + $ \tstdataA -> bgroup "aeson" + [ bench "generic" (nf perfDecodeAesonGeneric tstdataA) + , bench "TH" (nf perfDecodeAesonTH tstdataA) + ] + + , env (return $ combineChunks $ ReadShow.serialise tstdata) + $ \tstdataS -> bench "read/show" (nf perfDecodeReadShow tstdataS) + , env (return $ PkgStore.serialise tstdata) + $ \tstdataR -> bench "store" (nf perfDecodeStore tstdataR) + , env (return $ combineChunks $ CBOR.serialise tstdata) + $ \tstdataR -> bench "cbor" (nf perfDecodeCBOR tstdataR) + ] + ] + where + perfEncodeBinary, perfEncodeCereal, perfEncodeAesonGeneric, + perfEncodeAesonTH, perfEncodeReadShow, + perfEncodeCBOR + :: [Types.GenericPackageDescription] -> Int64 + + + perfEncodeBinary = BS.length . PkgBinary.serialise + perfEncodeCereal = BS.length . PkgCereal.serialise + perfEncodeAesonGeneric = BS.length . PkgAesonGeneric.serialise + perfEncodeAesonTH = BS.length . PkgAesonTH.serialise + perfEncodeReadShow = BS.length . ReadShow.serialise + perfEncodeCBOR = BS.length . CBOR.serialise + + perfDecodeBinary, perfDecodeCereal, perfDecodeAesonGeneric, + perfDecodeAesonTH, perfDecodeReadShow, + perfDecodeCBOR + :: BS.ByteString -> [Types.GenericPackageDescription] + + perfDecodeBinary = PkgBinary.deserialise + perfDecodeCereal = PkgCereal.deserialise + perfDecodeAesonGeneric = PkgAesonGeneric.deserialise + perfDecodeAesonTH = PkgAesonTH.deserialise + perfDecodeReadShow = ReadShow.deserialise + perfDecodeCBOR = CBOR.deserialise + + perfDecodeStore :: B.ByteString -> [Types.GenericPackageDescription] + perfDecodeStore = PkgStore.deserialise + perfEncodeStore :: [Types.GenericPackageDescription] -> Int + perfEncodeStore = B.length . PkgStore.serialise + + -- Convert any lazy ByteString to ByteString lazy bytestring + -- that have only single chunk. + combineChunks :: BS.ByteString -> BS.ByteString + combineChunks = BS.fromStrict . BS.toStrict diff --git a/bench/versus/Macro/CBOR.hs b/bench/versus/Macro/CBOR.hs new file mode 100644 --- /dev/null +++ b/bench/versus/Macro/CBOR.hs @@ -0,0 +1,520 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +-- For PackageDescription and friends +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- For encodeCtrN/decodeCtrBodyN/etc +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +module Macro.CBOR (serialise, deserialise, deserialiseNull) where + +import Macro.Types + +import Codec.Serialise.Class +import Codec.Serialise.Encoding hiding (Tokens(..)) +import Codec.Serialise.Decoding hiding (DecodeAction(Done, Fail)) +import Codec.CBOR.Read +import Codec.CBOR.Write +import Data.Monoid + +import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString.Builder as BS + +import Control.Exception (throw) +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +import Data.Word +#endif + +serialise :: [GenericPackageDescription] -> BS.ByteString +--serialise :: Serialise a => a -> BS.ByteString +serialise = BS.toLazyByteString . toBuilder . encode + +deserialise :: BS.ByteString -> [GenericPackageDescription] +deserialise = either throw snd . deserialiseFromBytes decode + +deserialiseNull :: BS.ByteString -> () +deserialiseNull = either throw snd . deserialiseFromBytes decodeListNull + where + decodeListNull :: Decoder s () + decodeListNull = do decodeListLenIndef; go + + go = do stop <- decodeBreakOr + if stop then return () + else do !_ <- decode :: Decoder s GenericPackageDescription + go + +encodeCtr0 n = encodeListLen 1 <> encode (n :: Word) +encodeCtr1 n a = encodeListLen 2 <> encode (n :: Word) <> encode a +encodeCtr2 n a b = encodeListLen 3 <> encode (n :: Word) <> encode a <> encode b +encodeCtr3 n a b c + = encodeListLen 4 <> encode (n :: Word) <> encode a <> encode b + <> encode c +encodeCtr4 n a b c d + = encodeListLen 5 <> encode (n :: Word) <> encode a <> encode b + <> encode c <> encode d +encodeCtr6 n a b c d e f + = encodeListLen 7 <> encode (n :: Word) <> encode a <> encode b + <> encode c <> encode d <> encode e <> encode f +encodeCtr7 n a b c d e f g + = encodeListLen 8 <> encode (n :: Word) <> encode a <> encode b + <> encode c <> encode d <> encode e <> encode f + <> encode g + +{-# INLINE encodeCtr0 #-} +{-# INLINE encodeCtr1 #-} +{-# INLINE encodeCtr2 #-} +{-# INLINE encodeCtr3 #-} +{-# INLINE encodeCtr4 #-} +{-# INLINE encodeCtr6 #-} +{-# INLINE encodeCtr7 #-} + +{-# INLINE decodeCtrTag #-} +{-# INLINE decodeCtrBody0 #-} +{-# INLINE decodeCtrBody1 #-} +{-# INLINE decodeCtrBody2 #-} + +decodeCtrTag = (\len tag -> (tag, len)) <$> decodeListLen <*> decodeWord + +decodeCtrBody0 1 f = pure f +decodeCtrBody0 x _ = error $ "decodeCtrBody0: impossible tag " ++ show x +decodeCtrBody1 2 f = do x1 <- decode + return $! f x1 +decodeCtrBody1 x _ = error $ "decodeCtrBody1: impossible tag " ++ show x +decodeCtrBody2 3 f = do x1 <- decode + x2 <- decode + return $! f x1 x2 +decodeCtrBody2 x _ = error $ "decodeCtrBody2: impossible tag " ++ show x + +{-# INLINE decodeSingleCtr1 #-} +{-# INLINE decodeSingleCtr2 #-} +{-# INLINE decodeSingleCtr3 #-} +{-# INLINE decodeSingleCtr4 #-} +{-# INLINE decodeSingleCtr6 #-} +{-# INLINE decodeSingleCtr7 #-} + +decodeSingleCtr1 v f = decodeListLenOf 2 *> decodeWordOf v *> pure f <*> decode +decodeSingleCtr2 v f = decodeListLenOf 3 *> decodeWordOf v *> pure f <*> decode <*> decode +decodeSingleCtr3 v f = decodeListLenOf 4 *> decodeWordOf v *> pure f <*> decode <*> decode <*> decode +decodeSingleCtr4 v f = decodeListLenOf 5 *> decodeWordOf v *> pure f <*> decode <*> decode <*> decode <*> decode +decodeSingleCtr6 v f = decodeListLenOf 7 *> decodeWordOf v *> pure f <*> decode <*> decode <*> decode <*> decode <*> decode <*> decode +decodeSingleCtr7 v f = decodeListLenOf 8 *> decodeWordOf v *> pure f <*> decode <*> decode <*> decode <*> decode <*> decode <*> decode <*> decode + + +instance Serialise PackageName where + encode (PackageName a) = encodeCtr1 1 a + decode = decodeSingleCtr1 1 PackageName + +instance Serialise Version where + encode (Version a b) = encodeCtr2 1 a b + decode = decodeSingleCtr2 1 Version + +instance Serialise PackageId where + encode (PackageId a b) = encodeCtr2 1 a b + decode = decodeSingleCtr2 1 PackageId + +instance Serialise VersionRange where + encode AnyVersion = encodeCtr0 1 + encode (ThisVersion a) = encodeCtr1 2 a + encode (LaterVersion a) = encodeCtr1 3 a + encode (EarlierVersion a) = encodeCtr1 4 a + encode (WildcardVersion a) = encodeCtr1 5 a + encode (UnionVersionRanges a b) = encodeCtr2 6 a b + encode (IntersectVersionRanges a b) = encodeCtr2 7 a b + encode (VersionRangeParens a) = encodeCtr1 8 a + + decode = do + (t,l) <- decodeCtrTag + case t of + 1 -> decodeCtrBody0 l AnyVersion + 2 -> decodeCtrBody1 l ThisVersion + 3 -> decodeCtrBody1 l LaterVersion + 4 -> decodeCtrBody1 l EarlierVersion + 5 -> decodeCtrBody1 l WildcardVersion + 6 -> decodeCtrBody2 l UnionVersionRanges + 7 -> decodeCtrBody2 l IntersectVersionRanges + 8 -> decodeCtrBody1 l VersionRangeParens + x -> error $ "Serialise VersionRange: decode: impossible tag " ++ show x + + +instance Serialise Dependency where + encode (Dependency a b) = encodeCtr2 1 a b + decode = decodeSingleCtr2 1 Dependency + +instance Serialise CompilerFlavor where + encode GHC = encodeCtr0 1 + encode NHC = encodeCtr0 2 + encode YHC = encodeCtr0 3 + encode Hugs = encodeCtr0 4 + encode HBC = encodeCtr0 5 + encode Helium = encodeCtr0 6 + encode JHC = encodeCtr0 7 + encode LHC = encodeCtr0 8 + encode UHC = encodeCtr0 9 + encode (HaskellSuite a) = encodeCtr1 10 a + encode (OtherCompiler a) = encodeCtr1 11 a + + decode = do + (t,l) <- decodeCtrTag + case t of + 1 -> decodeCtrBody0 l GHC + 2 -> decodeCtrBody0 l NHC + 3 -> decodeCtrBody0 l YHC + 4 -> decodeCtrBody0 l Hugs + 5 -> decodeCtrBody0 l HBC + 6 -> decodeCtrBody0 l Helium + 7 -> decodeCtrBody0 l JHC + 8 -> decodeCtrBody0 l LHC + 9 -> decodeCtrBody0 l UHC + 10 -> decodeCtrBody1 l HaskellSuite + 11 -> decodeCtrBody1 l OtherCompiler + x -> error $ "Serialise CompilerFlavor: decode: impossible tag " ++ show x + +instance Serialise License where + encode (GPL a) = encodeCtr1 1 a + encode (AGPL a) = encodeCtr1 2 a + encode (LGPL a) = encodeCtr1 3 a + encode BSD3 = encodeCtr0 4 + encode BSD4 = encodeCtr0 5 + encode MIT = encodeCtr0 6 + encode (Apache a) = encodeCtr1 7 a + encode PublicDomain = encodeCtr0 8 + encode AllRightsReserved = encodeCtr0 9 + encode OtherLicense = encodeCtr0 10 + encode (UnknownLicense a) = encodeCtr1 11 a + + decode = do + (t,l) <- decodeCtrTag + case t of + 1 -> decodeCtrBody1 l GPL + 2 -> decodeCtrBody1 l AGPL + 3 -> decodeCtrBody1 l LGPL + 4 -> decodeCtrBody0 l BSD3 + 5 -> decodeCtrBody0 l BSD4 + 6 -> decodeCtrBody0 l MIT + 7 -> decodeCtrBody1 l Apache + 8 -> decodeCtrBody0 l PublicDomain + 9 -> decodeCtrBody0 l AllRightsReserved + 10 -> decodeCtrBody0 l OtherLicense + 11 -> decodeCtrBody1 l UnknownLicense + x -> error $ "Serialise License: decode: impossible tag " ++ show x + +instance Serialise SourceRepo where + encode (SourceRepo a b c d e f g) = encodeCtr7 1 a b c d e f g + decode = decodeSingleCtr7 1 SourceRepo + +instance Serialise RepoKind where + encode RepoHead = encodeCtr0 1 + encode RepoThis = encodeCtr0 2 + encode (RepoKindUnknown a) = encodeCtr1 3 a + decode = do + (t,l) <- decodeCtrTag + case t of + 1 -> decodeCtrBody0 l RepoHead + 2 -> decodeCtrBody0 l RepoThis + 3 -> decodeCtrBody1 l RepoKindUnknown + x -> error $ "Serialise RepoKind: decode: impossible tag " ++ show x + +instance Serialise RepoType where + encode Darcs = encodeCtr0 1 + encode Git = encodeCtr0 2 + encode SVN = encodeCtr0 3 + encode CVS = encodeCtr0 4 + encode Mercurial = encodeCtr0 5 + encode GnuArch = encodeCtr0 6 + encode Bazaar = encodeCtr0 7 + encode Monotone = encodeCtr0 8 + encode (OtherRepoType a) = encodeCtr1 9 a + + decode = do + (t,l) <- decodeCtrTag + case t of + 1 -> decodeCtrBody0 l Darcs + 2 -> decodeCtrBody0 l Git + 3 -> decodeCtrBody0 l SVN + 4 -> decodeCtrBody0 l CVS + 5 -> decodeCtrBody0 l Mercurial + 6 -> decodeCtrBody0 l GnuArch + 7 -> decodeCtrBody0 l Bazaar + 8 -> decodeCtrBody0 l Monotone + 9 -> decodeCtrBody1 l OtherRepoType + x -> error $ "Serialise RepoType: decode: impossible tag " ++ show x + +instance Serialise BuildType where + encode Simple = encodeCtr0 1 + encode Configure = encodeCtr0 2 + encode Make = encodeCtr0 3 + encode Custom = encodeCtr0 4 + encode (UnknownBuildType a) = encodeCtr1 5 a + + decode = do + (t,l) <- decodeCtrTag + case t of + 1 -> decodeCtrBody0 l Simple + 2 -> decodeCtrBody0 l Configure + 3 -> decodeCtrBody0 l Make + 4 -> decodeCtrBody0 l Custom + 5 -> decodeCtrBody1 l UnknownBuildType + x -> error $ "Serialise BuildType: decode: impossible tag " ++ show x + +instance Serialise Library where + encode (Library a b c) = encodeCtr3 1 a b c + decode = decodeSingleCtr3 1 Library + +instance Serialise Executable where + encode (Executable a b c) = encodeCtr3 1 a b c + decode = decodeSingleCtr3 1 Executable + +instance Serialise TestSuite where + encode (TestSuite a b c d) = encodeCtr4 1 a b c d + decode = decodeSingleCtr4 1 TestSuite + +instance Serialise TestSuiteInterface where + encode (TestSuiteExeV10 a b) = encodeCtr2 1 a b + encode (TestSuiteLibV09 a b) = encodeCtr2 2 a b + encode (TestSuiteUnsupported a) = encodeCtr1 3 a + + decode = do + (t,l) <- decodeCtrTag + case t of + 1 -> decodeCtrBody2 l TestSuiteExeV10 + 2 -> decodeCtrBody2 l TestSuiteLibV09 + 3 -> decodeCtrBody1 l TestSuiteUnsupported + x -> error $ + "Serialise TestSuiteInterface: decode: impossible tag " ++ show x + +instance Serialise TestType where + encode (TestTypeExe a) = encodeCtr1 1 a + encode (TestTypeLib a) = encodeCtr1 2 a + encode (TestTypeUnknown a b) = encodeCtr2 3 a b + + decode = do + (t,l) <- decodeCtrTag + case t of + 1 -> decodeCtrBody1 l TestTypeExe + 2 -> decodeCtrBody1 l TestTypeLib + 3 -> decodeCtrBody2 l TestTypeUnknown + x -> error $ "Serialise TestType: decode: impossible tag " ++ show x + +instance Serialise Benchmark where + encode (Benchmark a b c d) = encodeCtr4 1 a b c d + decode = decodeSingleCtr4 1 Benchmark + +instance Serialise BenchmarkInterface where + encode (BenchmarkExeV10 a b) = encodeCtr2 1 a b + encode (BenchmarkUnsupported a) = encodeCtr1 2 a + + decode = do + (t,l) <- decodeCtrTag + case t of + 1 -> decodeCtrBody2 l BenchmarkExeV10 + 2 -> decodeCtrBody1 l BenchmarkUnsupported + x -> error $ + "Serialise BenchmarkInterface: decode: impossible tag " ++ show x + +instance Serialise BenchmarkType where + encode (BenchmarkTypeExe a) = encodeCtr1 1 a + encode (BenchmarkTypeUnknown a b) = encodeCtr2 2 a b + + decode = do + (t,l) <- decodeCtrTag + case t of + 1 -> decodeCtrBody1 l BenchmarkTypeExe + 2 -> decodeCtrBody2 l BenchmarkTypeUnknown + x -> error $ "Serialise BenchmarkType: decode: impossible tag " ++ show x + +instance Serialise ModuleName where + encode (ModuleName a) = encodeCtr1 1 a + decode = decodeSingleCtr1 1 ModuleName + +instance Serialise BuildInfo where + encode (BuildInfo a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 + a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 + a21 a22 a23 a24 a25) = + encodeListLen 26 <> encode (1 :: Word) <> + encode a1 <> encode a2 <> encode a3 <> encode a4 <> encode a5 <> + encode a6 <> encode a7 <> encode a8 <> encode a9 <> encode a10 <> + encode a11 <> encode a12 <> encode a13 <> encode a14 <> encode a15 <> + encode a16 <> encode a17 <> encode a18 <> encode a19 <> encode a20 <> + encode a21 <> encode a22 <> encode a23 <> encode a24 <> encode a25 + + decode = decodeListLenOf 26 *> decodeWordOf 1 *> + pure BuildInfo <*> decode <*> decode <*> decode <*> decode <*> decode + <*> decode <*> decode <*> decode <*> decode <*> decode + <*> decode <*> decode <*> decode <*> decode <*> decode + <*> decode <*> decode <*> decode <*> decode <*> decode + <*> decode <*> decode <*> decode <*> decode <*> decode + +instance Serialise Language where + encode Haskell98 = encodeCtr0 1 + encode Haskell2010 = encodeCtr0 2 + encode (UnknownLanguage a) = encodeCtr1 3 a + + decode = do + (t,l) <- decodeCtrTag + case t of + 1 -> decodeCtrBody0 l Haskell98 + 2 -> decodeCtrBody0 l Haskell2010 + 3 -> decodeCtrBody1 l UnknownLanguage + x -> error $ "Serialise Language: decode: impossible tag " ++ show x + +instance Serialise Extension where + encode (EnableExtension a) = encodeCtr1 1 a + encode (DisableExtension a) = encodeCtr1 2 a + encode (UnknownExtension a) = encodeCtr1 3 a + + decode = do + (t,l) <- decodeCtrTag + case t of + 1 -> decodeCtrBody1 l EnableExtension + 2 -> decodeCtrBody1 l DisableExtension + 3 -> decodeCtrBody1 l UnknownExtension + x -> error $ "Serialise Extension: decode: impossible tag " ++ show x + +instance Serialise KnownExtension where + encode ke = encodeCtr1 1 (fromEnum ke) + decode = decodeSingleCtr1 1 toEnum + +instance Serialise PackageDescription where + encode (PackageDescription a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 + a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 + a21 a22 a23 a24 a25 a26 a27 a28) = + encodeListLen 29 <> encode (1 :: Word) <> + encode a1 <> encode a2 <> encode a3 <> encode a4 <> encode a5 <> + encode a6 <> encode a7 <> encode a8 <> encode a9 <> encode a10 <> + encode a11 <> encode a12 <> encode a13 <> encode a14 <> encode a15 <> + encode a16 <> encode a17 <> encode a18 <> encode a19 <> encode a20 <> + encode a21 <> encode a22 <> encode a23 <> encode a24 <> encode a25 <> + encode a26 <> encode a27 <> encode a28 + + decode = decodeListLenOf 29 *> decodeWordOf 1 *> + pure PackageDescription + <*> decode <*> decode <*> decode <*> decode <*> decode + <*> decode <*> decode <*> decode <*> decode <*> decode + <*> decode <*> decode <*> decode <*> decode <*> decode + <*> decode <*> decode <*> decode <*> decode <*> decode + <*> decode <*> decode <*> decode <*> decode <*> decode + <*> decode <*> decode <*> decode + +instance Serialise OS where + encode Linux = encodeCtr0 1 + encode Windows = encodeCtr0 2 + encode OSX = encodeCtr0 3 + encode FreeBSD = encodeCtr0 4 + encode OpenBSD = encodeCtr0 5 + encode NetBSD = encodeCtr0 6 + encode Solaris = encodeCtr0 7 + encode AIX = encodeCtr0 8 + encode HPUX = encodeCtr0 9 + encode IRIX = encodeCtr0 10 + encode HaLVM = encodeCtr0 11 + encode IOS = encodeCtr0 12 + encode (OtherOS a) = encodeCtr1 13 a + + decode = do + (t,l) <- decodeCtrTag + case t of + 1 -> decodeCtrBody0 l Linux + 2 -> decodeCtrBody0 l Windows + 3 -> decodeCtrBody0 l OSX + 4 -> decodeCtrBody0 l FreeBSD + 5 -> decodeCtrBody0 l OpenBSD + 6 -> decodeCtrBody0 l NetBSD + 7 -> decodeCtrBody0 l Solaris + 8 -> decodeCtrBody0 l AIX + 9 -> decodeCtrBody0 l HPUX + 10 -> decodeCtrBody0 l IRIX + 11 -> decodeCtrBody0 l HaLVM + 12 -> decodeCtrBody0 l IOS + 13 -> decodeCtrBody1 l OtherOS + x -> error $ "Serialise OS: decode: impossible tag " ++ show x + +instance Serialise Arch where + encode I386 = encodeCtr0 1 + encode X86_64 = encodeCtr0 2 + encode PPC = encodeCtr0 3 + encode PPC64 = encodeCtr0 4 + encode Sparc = encodeCtr0 5 + encode Arm = encodeCtr0 6 + encode Mips = encodeCtr0 7 + encode SH = encodeCtr0 8 + encode IA64 = encodeCtr0 9 + encode S390 = encodeCtr0 10 + encode Alpha = encodeCtr0 11 + encode Hppa = encodeCtr0 12 + encode Rs6000 = encodeCtr0 13 + encode M68k = encodeCtr0 14 + encode (OtherArch a) = encodeCtr1 15 a + encode Vax = encodeCtr0 16 + + decode = do + (t,l) <- decodeCtrTag + case t of + 1 -> decodeCtrBody0 l I386 + 2 -> decodeCtrBody0 l X86_64 + 3 -> decodeCtrBody0 l PPC + 4 -> decodeCtrBody0 l PPC64 + 5 -> decodeCtrBody0 l Sparc + 6 -> decodeCtrBody0 l Arm + 7 -> decodeCtrBody0 l Mips + 8 -> decodeCtrBody0 l SH + 9 -> decodeCtrBody0 l IA64 + 10 -> decodeCtrBody0 l S390 + 11 -> decodeCtrBody0 l Alpha + 12 -> decodeCtrBody0 l Hppa + 13 -> decodeCtrBody0 l Rs6000 + 14 -> decodeCtrBody0 l M68k + 15 -> decodeCtrBody1 l OtherArch + 16 -> decodeCtrBody0 l Vax + x -> error $ "Serialise Arch: decode: impossible tag " ++ show x + +instance Serialise Flag where + encode (MkFlag a b c d) = encodeCtr4 1 a b c d + decode = decodeSingleCtr4 1 MkFlag + +instance Serialise FlagName where + encode (FlagName a) = encodeCtr1 1 a + decode = decodeSingleCtr1 1 FlagName + +instance (Serialise a, Serialise b, Serialise c) => Serialise (CondTree a b c) where + encode (CondNode a b c) = encodeCtr3 1 a b c + decode = decodeSingleCtr3 1 CondNode + + {-# SPECIALIZE instance Serialise c => Serialise (CondTree ConfVar [Dependency] c) #-} + +instance Serialise ConfVar where + encode (OS a) = encodeCtr1 1 a + encode (Arch a) = encodeCtr1 2 a + encode (Flag a) = encodeCtr1 3 a + encode (Impl a b) = encodeCtr2 4 a b + + decode = do + (t,l) <- decodeCtrTag + case t of + 1 -> decodeCtrBody1 l OS + 2 -> decodeCtrBody1 l Arch + 3 -> decodeCtrBody1 l Flag + 4 -> decodeCtrBody2 l Impl + x -> error $ "Serialise ConfVar: decode: impossible tag " ++ show x + +instance Serialise a => Serialise (Condition a) where + encode (Var a) = encodeCtr1 1 a + encode (Lit a) = encodeCtr1 2 a + encode (CNot a) = encodeCtr1 3 a + encode (COr a b) = encodeCtr2 4 a b + encode (CAnd a b) = encodeCtr2 5 a b + + decode = do + (t,l) <- decodeCtrTag + case t of + 1 -> decodeCtrBody1 l Var + 2 -> decodeCtrBody1 l Lit + 3 -> decodeCtrBody1 l CNot + 4 -> decodeCtrBody2 l COr + 5 -> decodeCtrBody2 l CAnd + x -> error $ "Serialise (Condition a): decode: impossible tag " ++ show x + + {-# SPECIALIZE instance Serialise (Condition ConfVar) #-} + +instance Serialise GenericPackageDescription where + encode (GenericPackageDescription a b c d e f) = encodeCtr6 1 a b c d e f + decode = decodeSingleCtr6 1 GenericPackageDescription + diff --git a/bench/versus/Macro/DeepSeq.hs b/bench/versus/Macro/DeepSeq.hs new file mode 100644 --- /dev/null +++ b/bench/versus/Macro/DeepSeq.hs @@ -0,0 +1,245 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Macro.DeepSeq where + +import Macro.Types + +import Control.DeepSeq + +rnf0 :: () +rnf1 :: NFData a => a -> () +rnf2 :: (NFData a, NFData a1) => a -> a1 -> () +rnf3 :: (NFData a, NFData a1, NFData a2) => + a -> a1 -> a2 -> () +rnf4 :: (NFData a, NFData a1, NFData a2, NFData a3) => + a -> a1 -> a2 -> a3 -> () +rnf5 :: (NFData a, NFData a1, NFData a2, NFData a3, NFData a4) => + a -> a1 -> a2 -> a3 -> a4 -> () +rnf6 :: (NFData a, NFData a1, NFData a2, NFData a3, NFData a4, + NFData a5) => + a -> a1 -> a2 -> a3 -> a4 -> a5 -> () +rnf7 :: (NFData a, NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, + NFData a6) => + a -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> () + + +rnf0 = () +rnf1 a = rnf a `seq` () +rnf2 a b = rnf a `seq` rnf b `seq` () +rnf3 a b c = rnf a `seq` rnf b `seq` rnf c `seq` () +rnf4 a b c d = rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` () +rnf5 a b c d e = rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` rnf e `seq` () +rnf6 a b c d e + f = rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` rnf e `seq` + rnf f `seq` () +rnf7 a b c d e + f g = rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` rnf e `seq` + rnf f `seq` rnf g `seq` () +{-# INLINE rnf0 #-} +{-# INLINE rnf1 #-} +{-# INLINE rnf2 #-} +{-# INLINE rnf3 #-} +{-# INLINE rnf4 #-} +{-# INLINE rnf5 #-} +{-# INLINE rnf6 #-} +{-# INLINE rnf7 #-} + +instance NFData PackageName where + rnf (PackageName a) = rnf1 a + +instance NFData PackageId where + rnf (PackageId a b) = rnf2 a b + +instance NFData Version where + rnf (Version a b) = rnf2 a b + +instance NFData VersionRange where + rnf AnyVersion = rnf0 + rnf (ThisVersion a) = rnf1 a + rnf (LaterVersion a) = rnf1 a + rnf (EarlierVersion a) = rnf1 a + rnf (WildcardVersion a) = rnf1 a + rnf (UnionVersionRanges a b) = rnf2 a b + rnf (IntersectVersionRanges a b) = rnf2 a b + rnf (VersionRangeParens a) = rnf1 a + +instance NFData Dependency where + rnf (Dependency a b) = rnf2 a b + +instance NFData CompilerFlavor where + rnf GHC = rnf0 + rnf NHC = rnf0 + rnf YHC = rnf0 + rnf Hugs = rnf0 + rnf HBC = rnf0 + rnf Helium = rnf0 + rnf JHC = rnf0 + rnf LHC = rnf0 + rnf UHC = rnf0 + rnf (HaskellSuite a) = rnf1 a + rnf (OtherCompiler a) = rnf1 a + +instance NFData License where + rnf (GPL a) = rnf1 a + rnf (AGPL a) = rnf1 a + rnf (LGPL a) = rnf1 a + rnf BSD3 = rnf0 + rnf BSD4 = rnf0 + rnf MIT = rnf0 + rnf (Apache a) = rnf1 a + rnf PublicDomain = rnf0 + rnf AllRightsReserved = rnf0 + rnf OtherLicense = rnf0 + rnf (UnknownLicense a) = rnf1 a + +instance NFData SourceRepo where + rnf (SourceRepo a b c d e f g) = rnf7 a b c d e f g + +instance NFData RepoKind where + rnf RepoHead = rnf0 + rnf RepoThis = rnf0 + rnf (RepoKindUnknown a) = rnf1 a + + +instance NFData RepoType where + rnf Darcs = rnf0 + rnf Git = rnf0 + rnf SVN = rnf0 + rnf CVS = rnf0 + rnf Mercurial = rnf0 + rnf GnuArch = rnf0 + rnf Bazaar = rnf0 + rnf Monotone = rnf0 + rnf (OtherRepoType a) = rnf1 a + +instance NFData BuildType where + rnf Simple = rnf0 + rnf Configure = rnf0 + rnf Make = rnf0 + rnf Custom = rnf0 + rnf (UnknownBuildType a) = rnf1 a + +instance NFData Library where + rnf (Library a b c) = rnf3 a b c + +instance NFData Executable where + rnf (Executable a b c) = rnf3 a b c + +instance NFData TestSuite where + rnf (TestSuite a b c d) = rnf4 a b c d + +instance NFData TestSuiteInterface where + rnf (TestSuiteExeV10 a b) = rnf2 a b + rnf (TestSuiteLibV09 a b) = rnf2 a b + rnf (TestSuiteUnsupported a) = rnf1 a + +instance NFData TestType where + rnf (TestTypeExe a) = rnf1 a + rnf (TestTypeLib a) = rnf1 a + rnf (TestTypeUnknown a b) = rnf2 a b + +instance NFData Benchmark where + rnf (Benchmark a b c d) = rnf4 a b c d + +instance NFData BenchmarkInterface where + rnf (BenchmarkExeV10 a b) = rnf2 a b + rnf (BenchmarkUnsupported a) = rnf1 a + +instance NFData BenchmarkType where + rnf (BenchmarkTypeExe a) = rnf1 a + rnf (BenchmarkTypeUnknown a b) = rnf2 a b + +instance NFData ModuleName where + rnf (ModuleName a) = rnf1 a + +instance NFData BuildInfo where + rnf (BuildInfo a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 + a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 + a21 a22 a23 a24 a25) = + rnf a1 `seq` rnf a2 `seq` rnf a3 `seq` rnf a4 `seq` rnf a5 `seq` + rnf a6 `seq` rnf a7 `seq` rnf a8 `seq` rnf a9 `seq` rnf a10 `seq` + rnf a11 `seq` rnf a12 `seq` rnf a13 `seq` rnf a14 `seq` rnf a15 `seq` + rnf a16 `seq` rnf a17 `seq` rnf a18 `seq` rnf a19 `seq` rnf a20 `seq` + rnf a21 `seq` rnf a22 `seq` rnf a23 `seq` rnf a24 `seq` rnf a25 `seq` () + + +instance NFData Language where + rnf Haskell98 = rnf0 + rnf Haskell2010 = rnf0 + rnf (UnknownLanguage a) = rnf1 a + +instance NFData Extension where + rnf (EnableExtension a) = rnf1 a + rnf (DisableExtension a) = rnf1 a + rnf (UnknownExtension a) = rnf1 a + +instance NFData KnownExtension + +instance NFData PackageDescription where + rnf (PackageDescription a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 + a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 + a21 a22 a23 a24 a25 a26 a27 a28) = + rnf a1 `seq` rnf a2 `seq` rnf a3 `seq` rnf a4 `seq` rnf a5 `seq` + rnf a6 `seq` rnf a7 `seq` rnf a8 `seq` rnf a9 `seq` rnf a10 `seq` + rnf a11 `seq` rnf a12 `seq` rnf a13 `seq` rnf a14 `seq` rnf a15 `seq` + rnf a16 `seq` rnf a17 `seq` rnf a18 `seq` rnf a19 `seq` rnf a20 `seq` + rnf a21 `seq` rnf a22 `seq` rnf a23 `seq` rnf a24 `seq` rnf a25 `seq` + rnf a26 `seq` rnf a27 `seq` rnf a28 `seq` () + +instance NFData OS where + rnf Linux = rnf0 + rnf Windows = rnf0 + rnf OSX = rnf0 + rnf FreeBSD = rnf0 + rnf OpenBSD = rnf0 + rnf NetBSD = rnf0 + rnf Solaris = rnf0 + rnf AIX = rnf0 + rnf HPUX = rnf0 + rnf IRIX = rnf0 + rnf HaLVM = rnf0 + rnf IOS = rnf0 + rnf (OtherOS a) = rnf1 a + +instance NFData Arch where + rnf I386 = rnf0 + rnf X86_64 = rnf0 + rnf PPC = rnf0 + rnf PPC64 = rnf0 + rnf Sparc = rnf0 + rnf Arm = rnf0 + rnf Mips = rnf0 + rnf SH = rnf0 + rnf IA64 = rnf0 + rnf S390 = rnf0 + rnf Alpha = rnf0 + rnf Hppa = rnf0 + rnf Rs6000 = rnf0 + rnf M68k = rnf0 + rnf (OtherArch a) = rnf1 a + rnf Vax = rnf0 + +instance NFData Flag where + rnf (MkFlag a b c d) = rnf4 a b c d + +instance NFData FlagName where + rnf (FlagName a) = rnf1 a + +instance (NFData a, NFData b, NFData c) => NFData (CondTree a b c) where + rnf (CondNode a b c) = rnf3 a b c + +instance NFData ConfVar where + rnf (OS a) = rnf1 a + rnf (Arch a) = rnf1 a + rnf (Flag a) = rnf1 a + rnf (Impl a b) = rnf2 a b + +instance NFData a => NFData (Condition a) where + rnf (Var a) = rnf1 a + rnf (Lit a) = rnf1 a + rnf (CNot a) = rnf1 a + rnf (COr a b) = rnf2 a b + rnf (CAnd a b) = rnf2 a b + +instance NFData GenericPackageDescription where + rnf (GenericPackageDescription a b c d e f) = rnf6 a b c d e f + diff --git a/bench/versus/Macro/Load.hs b/bench/versus/Macro/Load.hs new file mode 100644 --- /dev/null +++ b/bench/versus/Macro/Load.hs @@ -0,0 +1,2600 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing #-} +module Macro.Load (readPkgIndex) where + +import Macro.Types +import Macro.ReadShow () + +import Text.ParserCombinators.ReadP as ReadP hiding (get) +import qualified Text.ParserCombinators.ReadP as Parse +import qualified Text.PrettyPrint as Disp +import qualified Data.Char as Char (isDigit, isAlphaNum, isSpace) +import Text.PrettyPrint hiding (braces) + +import Data.List +import Data.Function (on) +import Data.Char as Char (chr, ord, isSpace, isUpper, toLower, isAlphaNum, isDigit) +import Data.Maybe +import Data.Tree as Tree (Tree(..), flatten) +import Data.Array (Array, accumArray, bounds, Ix(inRange), (!)) +import Data.Bits +import Control.Monad +import Control.Exception +import qualified Data.ByteString.Lazy.Char8 as BS +import System.FilePath (normalise, splitDirectories, takeExtension) +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Archive.Tar.Entry as Tar + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative (Applicative(..)) +import Data.Monoid hiding ((<>)) +#endif + +readPkgIndex :: BS.ByteString -> Either String [GenericPackageDescription] +readPkgIndex = fmap extractCabalFiles . readTarIndex + where + extractCabalFiles entries = + [ pkgDesc + | entry@Tar.Entry { + Tar.entryContent = Tar.NormalFile cabalFile _ + } <- entries + , let filename = Tar.entryPath entry + , takeExtension filename == ".cabal" + , let pkgDesc = case parsePackageDescription + . ignoreBOM . fromUTF8 . BS.unpack $ cabalFile of + ParseOk _ pkg -> pkg + ParseFailed err -> error (filename ++ ": " ++ show err) + ] + + readTarIndex :: BS.ByteString + -> Either String [Tar.Entry] + readTarIndex indexFileContent = collect [] entries + where + entries = Tar.read indexFileContent + collect es' Tar.Done = Right es' + collect es' (Tar.Next e es) = case entry e of + Just e' -> collect (e':es') es + Nothing -> collect es' es + collect _ (Tar.Fail err) = Left (show err) + + entry e + | [_pkgname,versionStr,_] <- splitDirectories (normalise (Tar.entryPath e)) + , Just (Version _ []) <- simpleParse versionStr + = Just e + entry _ = Nothing + +fromUTF8 :: String -> String +fromUTF8 [] = [] +fromUTF8 (c:cs) + | c <= '\x7F' = c : fromUTF8 cs + | c <= '\xBF' = replacementChar : fromUTF8 cs + | c <= '\xDF' = twoBytes c cs + | c <= '\xEF' = moreBytes 3 0x800 cs (ord c .&. 0xF) + | c <= '\xF7' = moreBytes 4 0x10000 cs (ord c .&. 0x7) + | c <= '\xFB' = moreBytes 5 0x200000 cs (ord c .&. 0x3) + | c <= '\xFD' = moreBytes 6 0x4000000 cs (ord c .&. 0x1) + | otherwise = replacementChar : fromUTF8 cs + where + twoBytes c0 (c1:cs') + | ord c1 .&. 0xC0 == 0x80 + = let d = ((ord c0 .&. 0x1F) `shiftL` 6) + .|. (ord c1 .&. 0x3F) + in if d >= 0x80 + then chr d : fromUTF8 cs' + else replacementChar : fromUTF8 cs' + twoBytes _ cs' = replacementChar : fromUTF8 cs' + + moreBytes :: Int -> Int -> [Char] -> Int -> [Char] + moreBytes 1 overlong cs' acc + | overlong <= acc && acc <= 0x10FFFF + && (acc < 0xD800 || 0xDFFF < acc) + && (acc < 0xFFFE || 0xFFFF < acc) + = chr acc : fromUTF8 cs' + + | otherwise + = replacementChar : fromUTF8 cs' + + moreBytes byteCount overlong (cn:cs') acc + | ord cn .&. 0xC0 == 0x80 + = moreBytes (byteCount-1) overlong cs' + ((acc `shiftL` 6) .|. ord cn .&. 0x3F) + + moreBytes _ _ cs' _ + = replacementChar : fromUTF8 cs' + + replacementChar = '\xfffd' + +ignoreBOM :: String -> String +ignoreBOM ('\xFEFF':string) = string +ignoreBOM string = string + +------------------------------------------------------------------------------ + + +type LineNo = Int + +data PError = AmbiguousParse String LineNo + | NoParse String LineNo + | TabsError LineNo + | FromString String (Maybe LineNo) + deriving (Eq, Show) + +data PWarning = PWarning String + | UTFWarning LineNo String + deriving (Eq, Show) + +data ParseResult a = ParseFailed PError | ParseOk [PWarning] a + deriving Show + +instance Functor ParseResult where + fmap _ (ParseFailed err) = ParseFailed err + fmap f (ParseOk ws x) = ParseOk ws $ f x + +instance Applicative ParseResult where + pure = return + (<*>) = ap + + +instance Monad ParseResult where + return = ParseOk [] + ParseFailed err >>= _ = ParseFailed err + ParseOk ws x >>= f = case f x of + ParseFailed err -> ParseFailed err + ParseOk ws' x' -> ParseOk (ws'++ws) x' + fail s = ParseFailed (FromString s Nothing) + +catchParseError :: ParseResult a -> (PError -> ParseResult a) + -> ParseResult a +p@(ParseOk _ _) `catchParseError` _ = p +ParseFailed e `catchParseError` k = k e + +parseFail :: PError -> ParseResult a +parseFail = ParseFailed + +runP :: LineNo -> String -> ReadP a -> String -> ParseResult a +runP line fieldname p s = + case [ x | (x,"") <- results ] of + [a] -> ParseOk (utf8Warnings line fieldname s) a + -- TODO FIXME: what is this double parse thing all about? Can't we + -- just do the all isSpace test the first time? + [] -> case [ x | (x,ys) <- results, all isSpace ys ] of + [a] -> ParseOk (utf8Warnings line fieldname s) a + [] -> ParseFailed (NoParse fieldname line) + _ -> ParseFailed (AmbiguousParse fieldname line) + _ -> ParseFailed (AmbiguousParse fieldname line) + where results = readP_to_S p s + + +-- | Parser with simple error reporting +newtype ReadE a = ReadE {_runReadE :: String -> Either ErrorMsg a} +type ErrorMsg = String + +instance Functor ReadE where + fmap f (ReadE p) = ReadE $ \txt -> case p txt of + Right a -> Right (f a) + Left err -> Left err + +utf8Warnings :: LineNo -> String -> String -> [PWarning] +utf8Warnings line fieldname s = + take 1 [ UTFWarning n fieldname + | (n,l) <- zip [line..] (lines s) + , '\xfffd' `elem` l ] + +syntaxError :: LineNo -> String -> ParseResult a +syntaxError n s = ParseFailed $ FromString s (Just n) + +tabsError :: LineNo -> ParseResult a +tabsError ln = ParseFailed $ TabsError ln + +warning :: String -> ParseResult () +warning s = ParseOk [PWarning s] () + +-- | Field descriptor. The parameter @a@ parameterizes over where the field's +-- value is stored in. +data FieldDescr a + = FieldDescr + { fieldName :: String + , _fieldGet :: a -> Doc + , _fieldSet :: LineNo -> String -> a -> ParseResult a + -- ^ @fieldSet n str x@ Parses the field value from the given input + -- string @str@ and stores the result in @x@ if the parse was + -- successful. Otherwise, reports an error on line number @n@. + } + +field :: String -> (a -> Doc) -> ReadP a -> FieldDescr a +field name showF readF = + FieldDescr name showF (\line val _st -> runP line name readF val) + +-- Lift a field descriptor storing into an 'a' to a field descriptor storing +-- into a 'b'. +liftField :: (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b +liftField get set (FieldDescr name showF parseF) + = FieldDescr name (showF . get) + (\line str b -> do + a <- parseF line str (get b) + return (set a b)) + +-- Parser combinator for simple fields. Takes a field name, a pretty printer, +-- a parser function, an accessor, and a setter, returns a FieldDescr over the +-- compoid structure. +simpleField :: String -> (a -> Doc) -> ReadP a + -> (b -> a) -> (a -> b -> b) -> FieldDescr b +simpleField name showF readF get set + = liftField get set $ field name showF readF + +commaListField :: String -> (a -> Doc) -> ReadP a + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +commaListField name showF readF get set = + liftField get set' $ + field name (fsep . punctuate comma . map showF) (parseCommaList readF) + where + set' xs b = set (get b ++ xs) b + +spaceListField :: String -> (a -> Doc) -> ReadP a + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +spaceListField name showF readF get set = + liftField get set' $ + field name (fsep . map showF) (parseSpaceList readF) + where + set' xs b = set (get b ++ xs) b + +listField :: String -> (a -> Doc) -> ReadP a + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +listField name showF readF get set = + liftField get set' $ + field name (fsep . map showF) (parseOptCommaList readF) + where + set' xs b = set (get b ++ xs) b + +optsField :: String -> CompilerFlavor -> (b -> [(CompilerFlavor,[String])]) + -> ([(CompilerFlavor,[String])] -> b -> b) -> FieldDescr b +optsField name flavor get set = + liftField (fromMaybe [] . lookup flavor . get) + (\opts b -> set (reorder (update flavor opts (get b))) b) $ + field name (hsep . map text) + (sepBy parseTokenQ' (munch1 isSpace)) + where + update _ opts l | all null opts = l --empty opts as if no opts + update f opts [] = [(f,opts)] + update f opts ((f',opts'):rest) + | f == f' = (f, opts' ++ opts) : rest + | otherwise = (f',opts') : update f opts rest + reorder = sortBy (compare `on` fst) + +boolField :: String -> (b -> Bool) -> (Bool -> b -> b) -> FieldDescr b +boolField name get set = liftField get set (FieldDescr name showF readF) + where + showF = text . show + readF line str _ + | str == "True" = ParseOk [] True + | str == "False" = ParseOk [] False + | lstr == "true" = ParseOk [caseWarning] True + | lstr == "false" = ParseOk [caseWarning] False + | otherwise = ParseFailed (NoParse name line) + where + lstr = lowercase str + caseWarning = PWarning $ + "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'." + +type UnrecFieldParser a = (String,String) -> a -> Maybe a + +-- | A default unrecognized field parser which simply returns Nothing, +-- i.e. ignores all unrecognized fields, so warnings will be generated. +warnUnrec :: UnrecFieldParser a +warnUnrec _ _ = Nothing + +------------------------------------------------------------------------------ + +-- The data type for our three syntactic categories +data Field + = F LineNo String String + -- ^ A regular @: @ field + | Section LineNo String String [Field] + -- ^ A section with a name and possible parameter. The syntactic + -- structure is: + -- + -- @ + -- { + -- * + -- } + -- @ + | IfBlock LineNo String [Field] [Field] + -- ^ A conditional block with an optional else branch: + -- + -- @ + -- if { + -- * + -- } else { + -- * + -- } + -- @ + deriving (Show + ,Eq) -- for testing + +lineNo :: Field -> LineNo +lineNo (F n _ _) = n +lineNo (Section n _ _ _) = n +lineNo (IfBlock n _ _ _) = n + +fName :: Field -> String +fName (F _ n _) = n +fName (Section _ n _ _) = n +fName _ = error "fname: not a field or section" + +readFields :: String -> ParseResult [Field] +readFields input = ifelse + =<< mapM (mkField 0) + =<< mkTree tokens + + where ls = (lines . normaliseLineEndings) input + tokens = (concatMap tokeniseLine . trimLines) ls + +normaliseLineEndings :: String -> String +normaliseLineEndings [] = [] +normaliseLineEndings ('\r':'\n':s) = '\n' : normaliseLineEndings s -- windows +normaliseLineEndings ('\r':s) = '\n' : normaliseLineEndings s -- old osx +normaliseLineEndings ( c :s) = c : normaliseLineEndings s + +-- attach line number and determine indentation +trimLines :: [String] -> [(LineNo, Indent, HasTabs, String)] +trimLines ls = [ (lineno, indent, hastabs, trimTrailing l') + | (lineno, l) <- zip [1..] ls + , let (sps, l') = span isSpace l + indent = length sps + hastabs = '\t' `elem` sps + , validLine l' ] + where validLine ('-':'-':_) = False -- Comment + validLine [] = False -- blank line + validLine _ = True + +-- | We parse generically based on indent level and braces '{' '}'. To do that +-- we split into lines and then '{' '}' tokens and other spans within a line. +data Token = + -- | The 'Line' token is for bits that /start/ a line, eg: + -- + -- > "\n blah blah { blah" + -- + -- tokenises to: + -- + -- > [Line n 2 False "blah blah", OpenBracket, Span n "blah"] + -- + -- so lines are the only ones that can have nested layout, since they + -- have a known indentation level. + -- + -- eg: we can't have this: + -- + -- > if ... { + -- > } else + -- > other + -- + -- because other cannot nest under else, since else doesn't start a line + -- so cannot have nested layout. It'd have to be: + -- + -- > if ... { + -- > } + -- > else + -- > other + -- + -- but that's not so common, people would normally use layout or + -- brackets not both in a single @if else@ construct. + -- + -- > if ... { foo : bar } + -- > else + -- > other + -- + -- this is ok + Line LineNo Indent HasTabs String + | Span LineNo String -- ^ span in a line, following brackets + | OpenBracket LineNo | CloseBracket LineNo + +type Indent = Int +type HasTabs = Bool + +-- | Tokenise a single line, splitting on '{' '}' and the spans inbetween. +-- Also trims leading & trailing space on those spans within the line. +tokeniseLine :: (LineNo, Indent, HasTabs, String) -> [Token] +tokeniseLine (n0, i, t, l) = case split n0 l of + (Span _ l':ss) -> Line n0 i t l' :ss + cs -> cs + where split _ "" = [] + split n s = case span (\c -> c /='}' && c /= '{') s of + ("", '{' : s') -> OpenBracket n : split n s' + (w , '{' : s') -> mkspan n w (OpenBracket n : split n s') + ("", '}' : s') -> CloseBracket n : split n s' + (w , '}' : s') -> mkspan n w (CloseBracket n : split n s') + (w , _) -> mkspan n w [] + + mkspan n s ss | null s' = ss + | otherwise = Span n s' : ss + where s' = trimTrailing (trimLeading s) + +trimLeading, trimTrailing :: String -> String +trimLeading = dropWhile isSpace +trimTrailing = reverse . dropWhile isSpace . reverse + + +type SyntaxTree = Tree (LineNo, HasTabs, String) + +-- | Parse the stream of tokens into a tree of them, based on indent \/ layout +mkTree :: [Token] -> ParseResult [SyntaxTree] +mkTree toks = + layout 0 [] toks >>= \(trees, trailing) -> case trailing of + [] -> return trees + OpenBracket n:_ -> syntaxError n "mismatched backets, unexpected {" + CloseBracket n:_ -> syntaxError n "mismatched backets, unexpected }" + -- the following two should never happen: + Span n l :_ -> syntaxError n $ "unexpected span: " ++ show l + Line n _ _ l :_ -> syntaxError n $ "unexpected line: " ++ show l + + +-- | Parse the stream of tokens into a tree of them, based on indent +-- This parse state expect to be in a layout context, though possibly +-- nested within a braces context so we may still encounter closing braces. +layout :: Indent -- ^ indent level of the parent\/previous line + -> [SyntaxTree] -- ^ accumulating param, trees in this level + -> [Token] -- ^ remaining tokens + -> ParseResult ([SyntaxTree], [Token]) + -- ^ collected trees on this level and trailing tokens +layout _ a [] = return (reverse a, []) +layout i a (s@(Line _ i' _ _):ss) | i' < i = return (reverse a, s:ss) +layout i a (Line n _ t l:OpenBracket n':ss) = do + (sub, ss') <- braces n' [] ss + layout i (Node (n,t,l) sub:a) ss' + +layout i a (Span n l:OpenBracket n':ss) = do + (sub, ss') <- braces n' [] ss + layout i (Node (n,False,l) sub:a) ss' + +-- look ahead to see if following lines are more indented, giving a sub-tree +layout i a (Line n i' t l:ss) = do + lookahead <- layout (i'+1) [] ss + case lookahead of + ([], _) -> layout i (Node (n,t,l) [] :a) ss + (ts, ss') -> layout i (Node (n,t,l) ts :a) ss' + +layout _ _ ( OpenBracket n :_) = syntaxError n "unexpected '{'" +layout _ a (s@(CloseBracket _):ss) = return (reverse a, s:ss) +layout _ _ ( Span n l : _) = syntaxError n $ "unexpected span: " + ++ show l + +-- | Parse the stream of tokens into a tree of them, based on explicit braces +-- This parse state expects to find a closing bracket. +braces :: LineNo -- ^ line of the '{', used for error messages + -> [SyntaxTree] -- ^ accumulating param, trees in this level + -> [Token] -- ^ remaining tokens + -> ParseResult ([SyntaxTree],[Token]) + -- ^ collected trees on this level and trailing tokens +braces m a (Line n _ t l:OpenBracket n':ss) = do + (sub, ss') <- braces n' [] ss + braces m (Node (n,t,l) sub:a) ss' + +braces m a (Span n l:OpenBracket n':ss) = do + (sub, ss') <- braces n' [] ss + braces m (Node (n,False,l) sub:a) ss' + +braces m a (Line n i t l:ss) = do + lookahead <- layout (i+1) [] ss + case lookahead of + ([], _) -> braces m (Node (n,t,l) [] :a) ss + (ts, ss') -> braces m (Node (n,t,l) ts :a) ss' + +braces m a (Span n l:ss) = braces m (Node (n,False,l) []:a) ss +braces _ a (CloseBracket _:ss) = return (reverse a, ss) +braces n _ [] = syntaxError n $ "opening brace '{'" + ++ "has no matching closing brace '}'" +braces _ _ (OpenBracket n:_) = syntaxError n "unexpected '{'" + +-- | Convert the parse tree into the Field AST +-- Also check for dodgy uses of tabs in indentation. +mkField :: Int -> SyntaxTree -> ParseResult Field +mkField d (Node (n,t,_) _) | d >= 1 && t = tabsError n +mkField d (Node (n,_,l) ts) = case span (\c -> isAlphaNum c || c == '-') l of + ([], _) -> syntaxError n $ "unrecognised field or section: " ++ show l + (name, rest) -> case trimLeading rest of + (':':rest') -> do let followingLines = concatMap Tree.flatten ts + tabs = not (null [()| (_,True,_) <- followingLines ]) + if tabs && d >= 1 + then tabsError n + else return $ F n (map toLower name) + (fieldValue rest' followingLines) + rest' -> do ts' <- mapM (mkField (d+1)) ts + return (Section n (map toLower name) rest' ts') + where fieldValue firstLine followingLines = + let firstLine' = trimLeading firstLine + followingLines' = map (\(_,_,s) -> stripDot s) followingLines + allLines | null firstLine' = followingLines' + | otherwise = firstLine' : followingLines' + in intercalate "\n" allLines + stripDot "." = "" + stripDot s = s + +-- | Convert if/then/else 'Section's to 'IfBlock's +ifelse :: [Field] -> ParseResult [Field] +ifelse [] = return [] +ifelse (Section n "if" cond thenpart + :Section _ "else" as elsepart:fs) + | null cond = syntaxError n "'if' with missing condition" + | null thenpart = syntaxError n "'then' branch of 'if' is empty" + | not (null as) = syntaxError n "'else' takes no arguments" + | null elsepart = syntaxError n "'else' branch of 'if' is empty" + | otherwise = do tp <- ifelse thenpart + ep <- ifelse elsepart + fs' <- ifelse fs + return (IfBlock n cond tp ep:fs') +ifelse (Section n "if" cond thenpart:fs) + | null cond = syntaxError n "'if' with missing condition" + | null thenpart = syntaxError n "'then' branch of 'if' is empty" + | otherwise = do tp <- ifelse thenpart + fs' <- ifelse fs + return (IfBlock n cond tp []:fs') +ifelse (Section n "else" _ _:_) = syntaxError n + "stray 'else' with no preceding 'if'" +ifelse (Section n s a fs':fs) = do fs'' <- ifelse fs' + fs''' <- ifelse fs + return (Section n s a fs'' : fs''') +ifelse (f:fs) = do fs' <- ifelse fs + return (f : fs') + +------------------------------------------------------------------------------ + +-- |parse a module Macro.name +parseModuleNameQ :: ReadP ModuleName +parseModuleNameQ = parseQuoted parse <++ parse + +parseFilePathQ :: ReadP FilePath +parseFilePathQ = parseTokenQ + -- removed until normalise is no longer broken, was: + -- liftM normalise parseTokenQ + +betweenSpaces :: ReadP a -> ReadP a +betweenSpaces act = do skipSpaces + res <- act + skipSpaces + return res + +parseBuildTool :: ReadP Dependency +parseBuildTool = do name <- parseBuildToolNameQ + ver <- betweenSpaces $ + parseVersionRangeQ <++ return AnyVersion + return $ Dependency name ver + +parseBuildToolNameQ :: ReadP PackageName +parseBuildToolNameQ = parseQuoted parseBuildToolName <++ parseBuildToolName + +-- like parsePackageName but accepts symbols in components +parseBuildToolName :: ReadP PackageName +parseBuildToolName = do ns <- sepBy1 component (ReadP.char '-') + return (PackageName (intercalate "-" ns)) + where component = do + cs <- munch1 (\c -> isAlphaNum c || c == '+' || c == '_') + if all isDigit cs then pfail else return cs + +-- pkg-config allows versions and other letters in package names, +-- eg "gtk+-2.0" is a valid pkg-config package _name_. +-- It then has a package version number like 2.10.13 +parsePkgconfigDependency :: ReadP Dependency +parsePkgconfigDependency = do name <- munch1 + (\c -> isAlphaNum c || c `elem` "+-._") + ver <- betweenSpaces $ + parseVersionRangeQ <++ return AnyVersion + return $ Dependency (PackageName name) ver + +parseVersionRangeQ :: ReadP VersionRange +parseVersionRangeQ = parseQuoted parse <++ parse + +parseTestedWithQ :: ReadP (CompilerFlavor,VersionRange) +parseTestedWithQ = parseQuoted tw <++ tw + where + tw :: ReadP (CompilerFlavor,VersionRange) + tw = do compiler <- parseCompilerFlavorCompat + version <- betweenSpaces $ parse <++ return AnyVersion + return (compiler,version) + +parseCompilerFlavorCompat :: Parse.ReadP CompilerFlavor +parseCompilerFlavorCompat = do + comp <- Parse.munch1 Char.isAlphaNum + when (all Char.isDigit comp) Parse.pfail + case lookup comp compilerMap of + Just compiler -> return compiler + Nothing -> return (OtherCompiler comp) + where + compilerMap = [ (show compiler, compiler) + | compiler <- knownCompilerFlavors + , compiler /= YHC ] + + knownCompilerFlavors :: [CompilerFlavor] + knownCompilerFlavors = [GHC, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC] + + +parseLicenseQ :: ReadP License +parseLicenseQ = parseQuoted parse <++ parse + +parseLanguageQ :: ReadP Language +parseLanguageQ = parseQuoted parse <++ parse + +parseExtensionQ :: ReadP Extension +parseExtensionQ = parseQuoted parse <++ parse + +parseHaskellString :: ReadP String +parseHaskellString = readS_to_P reads + +parseTokenQ :: ReadP String +parseTokenQ = parseHaskellString <++ munch1 (\x -> not (isSpace x) && x /= ',') + +parseTokenQ' :: ReadP String +parseTokenQ' = parseHaskellString <++ munch1 (not . isSpace) + +parseSepList :: ReadP b + -> ReadP a -- ^The parser for the stuff between commas + -> ReadP [a] +parseSepList sepr p = sepBy p separator + where separator = betweenSpaces sepr + +parseSpaceList :: ReadP a -- ^The parser for the stuff between commas + -> ReadP [a] +parseSpaceList p = sepBy p skipSpaces + +parseCommaList :: ReadP a -- ^The parser for the stuff between commas + -> ReadP [a] +parseCommaList = parseSepList (ReadP.char ',') + +parseOptCommaList :: ReadP a -- ^The parser for the stuff between commas + -> ReadP [a] +parseOptCommaList = parseSepList (optional (ReadP.char ',')) + +parseQuoted :: ReadP a -> ReadP a +parseQuoted = between (ReadP.char '"') (ReadP.char '"') + +parseFreeText :: ReadP.ReadP String +parseFreeText = ReadP.munch (const True) + +ident :: Parse.ReadP String +ident = Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-') + +lowercase :: String -> String +lowercase = map Char.toLower + + +-- -------------------------------------------- +-- ** Pretty printing + +showFilePath :: FilePath -> Doc +showFilePath = showToken + +showToken :: String -> Doc +showToken str + | not (any dodgy str) && + not (null str) = text str + | otherwise = text (show str) + where dodgy c = isSpace c || c == ',' + +showTestedWith :: (CompilerFlavor,VersionRange) -> Doc +showTestedWith (compiler, version) = text (show compiler) <+> disp version + +-- | Pretty-print free-format text, ensuring that it is vertically aligned, +-- and with blank lines replaced by dots for correct re-parsing. +showFreeText :: String -> Doc +showFreeText "" = empty +showFreeText ('\n' :r) = text " " $+$ text "." $+$ showFreeText r +showFreeText s = vcat [text (if null l then "." else l) | l <- lines_ s] + +-- | 'lines_' breaks a string up into a list of strings at newline +-- characters. The resulting strings do not contain newlines. +lines_ :: String -> [String] +lines_ [] = [""] +lines_ s = let (l, s') = break (== '\n') s + in l : case s' of + [] -> [] + (_:s'') -> lines_ s'' + +class Text a where + disp :: a -> Disp.Doc + parse :: Parse.ReadP a + +display :: Text a => a -> String +display = Disp.renderStyle style . disp + where style = Disp.Style { + Disp.mode = Disp.PageMode, + Disp.lineLength = 79, + Disp.ribbonsPerLine = 1.0 + } + +simpleParse :: Text a => String -> Maybe a +simpleParse str = case [ p | (p, s) <- Parse.readP_to_S parse str + , all Char.isSpace s ] of + [] -> Nothing + (p:_) -> Just p + +-- ----------------------------------------------------------------------------- +-- Instances for types from the base package + +instance Text Bool where + disp = Disp.text . show + parse = Parse.choice [ (Parse.string "True" Parse.+++ + Parse.string "true") >> return True + , (Parse.string "False" Parse.+++ + Parse.string "false") >> return False ] + +instance Text Version where + disp (Version branch _tags) -- Death to version tags!! + = Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int branch)) + + parse = do + branch <- Parse.sepBy1 digits (Parse.char '.') + tags <- Parse.many (Parse.char '-' >> Parse.munch1 Char.isAlphaNum) + return (Version branch tags) -- TODO FIXME: should we ignore the tags? + where + digits = do + first <- Parse.satisfy Char.isDigit + if first == '0' + then return 0 + else do rest <- Parse.munch Char.isDigit + return (read (first : rest)) + + +-- ----------------------------------------------------------------------------- + +instance Text InstalledPackageId where + disp (InstalledPackageId str) = text str + + parse = InstalledPackageId `fmap` Parse.munch1 abi_char + where abi_char c = Char.isAlphaNum c || c `elem` ":-_." + +instance Text ModuleName where + disp (ModuleName ms) = + Disp.hcat (intersperse (Disp.char '.') (map Disp.text ms)) + + parse = do + ms <- Parse.sepBy1 component (Parse.char '.') + return (ModuleName ms) + + where + component = do + c <- Parse.satisfy Char.isUpper + cs <- Parse.munch validModuleChar + return (c:cs) + +validModuleChar :: Char -> Bool +validModuleChar c = Char.isAlphaNum c || c == '_' || c == '\'' + +instance Text PackageName where + disp (PackageName n) = Disp.text n + parse = do + ns <- Parse.sepBy1 component (Parse.char '-') + return (PackageName (intercalate "-" ns)) + where + component = do + cs <- Parse.munch1 Char.isAlphaNum + if all Char.isDigit cs then Parse.pfail else return cs + -- each component must contain an alphabetic character, to avoid + -- ambiguity in identifiers like foo-1 (the 1 is the version number). + +instance Text PackageId where + disp (PackageId n v) = case v of + Version [] _ -> disp n -- if no version, don't show version. + _ -> disp n <> Disp.char '-' <> disp v + + parse = do + n <- parse + v <- (Parse.char '-' >> parse) <++ return (Version [] []) + return (PackageId n v) + +instance Text VersionRange where + disp = fst + . foldVersionRange' -- precedence: + ( Disp.text "-any" , 0 :: Int) + (\v -> (Disp.text "==" <> disp v , 0)) + (\v -> (Disp.char '>' <> disp v , 0)) + (\v -> (Disp.char '<' <> disp v , 0)) + (\v -> (Disp.text ">=" <> disp v , 0)) + (\v -> (Disp.text "<=" <> disp v , 0)) + (\v _ -> (Disp.text "==" <> dispWild v , 0)) + (\(r1, p1) (r2, p2) -> (punct 2 p1 r1 <+> Disp.text "||" <+> punct 2 p2 r2 , 2)) + (\(r1, p1) (r2, p2) -> (punct 1 p1 r1 <+> Disp.text "&&" <+> punct 1 p2 r2 , 1)) + (\(r, p) -> (Disp.parens r, p)) + + where dispWild (Version b _) = + Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int b)) + <> Disp.text ".*" + punct p p' | p < p' = Disp.parens + | otherwise = id + + parse = expr + where + expr = do Parse.skipSpaces + t <- term + Parse.skipSpaces + (do _ <- Parse.string "||" + Parse.skipSpaces + e <- expr + return (UnionVersionRanges t e) + +++ + return t) + term = do f <- factor + Parse.skipSpaces + (do _ <- Parse.string "&&" + Parse.skipSpaces + t <- term + return (IntersectVersionRanges f t) + +++ + return f) + factor = Parse.choice $ parens expr + : parseAnyVersion + : parseWildcardRange + : map parseRangeOp rangeOps + parseAnyVersion = Parse.string "-any" >> return AnyVersion + + parseWildcardRange = do + _ <- Parse.string "==" + Parse.skipSpaces + branch <- Parse.sepBy1 digits (Parse.char '.') + _ <- Parse.char '.' + _ <- Parse.char '*' + return (WildcardVersion (Version branch [])) + + parens p = Parse.between (Parse.char '(' >> Parse.skipSpaces) + (Parse.char ')' >> Parse.skipSpaces) + (do a <- p + Parse.skipSpaces + return (VersionRangeParens a)) + + digits = do + first <- Parse.satisfy Char.isDigit + if first == '0' + then return 0 + else do rest <- Parse.munch Char.isDigit + return (read (first : rest)) + + parseRangeOp (s,f) = Parse.string s >> Parse.skipSpaces >> fmap f parse + rangeOps = [ ("<", EarlierVersion), + ("<=", orEarlierVersion), + (">", LaterVersion), + (">=", orLaterVersion), + ("==", ThisVersion) ] + +orLaterVersion :: Version -> VersionRange +orLaterVersion v = UnionVersionRanges (ThisVersion v) (LaterVersion v) + +orEarlierVersion :: Version -> VersionRange +orEarlierVersion v = UnionVersionRanges (ThisVersion v) (EarlierVersion v) + +foldVersionRange :: a -- ^ @\"-any\"@ version + -> (Version -> a) -- ^ @\"== v\"@ + -> (Version -> a) -- ^ @\"> v\"@ + -> (Version -> a) -- ^ @\"< v\"@ + -> (a -> a -> a) -- ^ @\"_ || _\"@ union + -> (a -> a -> a) -- ^ @\"_ && _\"@ intersection + -> VersionRange -> a +foldVersionRange anyv this later earlier union intersect = fold + where + fold AnyVersion = anyv + fold (ThisVersion v) = this v + fold (LaterVersion v) = later v + fold (EarlierVersion v) = earlier v + fold (WildcardVersion v) = fold (wildcard v) + fold (UnionVersionRanges v1 v2) = union (fold v1) (fold v2) + fold (IntersectVersionRanges v1 v2) = intersect (fold v1) (fold v2) + fold (VersionRangeParens v) = fold v + + wildcard v = IntersectVersionRanges + (orLaterVersion v) + (EarlierVersion (wildcardUpperBound v)) + +foldVersionRange' :: a -- ^ @\"-any\"@ version + -> (Version -> a) -- ^ @\"== v\"@ + -> (Version -> a) -- ^ @\"> v\"@ + -> (Version -> a) -- ^ @\"< v\"@ + -> (Version -> a) -- ^ @\">= v\"@ + -> (Version -> a) -- ^ @\"<= v\"@ + -> (Version -> Version -> a) -- ^ @\"== v.*\"@ wildcard. The + -- function is passed the + -- inclusive lower bound and the + -- exclusive upper bounds of the + -- range defined by the wildcard. + -> (a -> a -> a) -- ^ @\"_ || _\"@ union + -> (a -> a -> a) -- ^ @\"_ && _\"@ intersection + -> (a -> a) -- ^ @\"(_)\"@ parentheses + -> VersionRange -> a +foldVersionRange' anyv this later earlier orLater orEarlier + wildcard union intersect parens = fold + where + fold AnyVersion = anyv + fold (ThisVersion v) = this v + fold (LaterVersion v) = later v + fold (EarlierVersion v) = earlier v + + fold (UnionVersionRanges (ThisVersion v) + (LaterVersion v')) | v==v' = orLater v + fold (UnionVersionRanges (LaterVersion v) + (ThisVersion v')) | v==v' = orLater v + fold (UnionVersionRanges (ThisVersion v) + (EarlierVersion v')) | v==v' = orEarlier v + fold (UnionVersionRanges (EarlierVersion v) + (ThisVersion v')) | v==v' = orEarlier v + + fold (WildcardVersion v) = wildcard v (wildcardUpperBound v) + fold (UnionVersionRanges v1 v2) = union (fold v1) (fold v2) + fold (IntersectVersionRanges v1 v2) = intersect (fold v1) (fold v2) + fold (VersionRangeParens v) = parens (fold v) + +wildcardUpperBound :: Version -> Version +wildcardUpperBound (Version lowerBound ts) = Version upperBound ts + where + upperBound = init lowerBound ++ [last lowerBound + 1] + +asVersionIntervals :: VersionRange -> [VersionInterval] +asVersionIntervals = versionIntervals . toVersionIntervals + +newtype VersionIntervals = VersionIntervals [VersionInterval] + deriving (Eq, Show) + +-- | Inspect the list of version intervals. +-- +versionIntervals :: VersionIntervals -> [VersionInterval] +versionIntervals (VersionIntervals is) = is + +type VersionInterval = (LowerBound, UpperBound) +data LowerBound = LowerBound Version !Bound deriving (Eq, Show) +data UpperBound = NoUpperBound | UpperBound Version !Bound deriving (Eq, Show) +data Bound = ExclusiveBound | InclusiveBound deriving (Eq, Show) + +minLowerBound :: LowerBound +minLowerBound = LowerBound (Version [0] []) InclusiveBound + +isVersion0 :: Version -> Bool +isVersion0 (Version [0] _) = True +isVersion0 _ = False + +instance Ord LowerBound where + LowerBound ver bound <= LowerBound ver' bound' = case compare ver ver' of + LT -> True + EQ -> not (bound == ExclusiveBound && bound' == InclusiveBound) + GT -> False + +instance Ord UpperBound where + _ <= NoUpperBound = True + NoUpperBound <= UpperBound _ _ = False + UpperBound ver bound <= UpperBound ver' bound' = case compare ver ver' of + LT -> True + EQ -> not (bound == InclusiveBound && bound' == ExclusiveBound) + GT -> False + +invariant :: VersionIntervals -> Bool +invariant (VersionIntervals intervals) = all validInterval intervals + && all doesNotTouch' adjacentIntervals + where + doesNotTouch' :: (VersionInterval, VersionInterval) -> Bool + doesNotTouch' ((_,u), (l',_)) = doesNotTouch u l' + + adjacentIntervals :: [(VersionInterval, VersionInterval)] + adjacentIntervals + | null intervals = [] + | otherwise = zip intervals (tail intervals) + +checkInvariant :: VersionIntervals -> VersionIntervals +checkInvariant is = assert (invariant is) is + +validVersion :: Version -> Bool +validVersion (Version [] _) = False +validVersion (Version vs _) = all (>=0) vs + +validInterval :: (LowerBound, UpperBound) -> Bool +validInterval i@(l, u) = validLower l && validUpper u && nonEmpty i + where + validLower (LowerBound v _) = validVersion v + validUpper NoUpperBound = True + validUpper (UpperBound v _) = validVersion v + +-- Check an interval is non-empty +-- +nonEmpty :: VersionInterval -> Bool +nonEmpty (_, NoUpperBound ) = True +nonEmpty (LowerBound l lb, UpperBound u ub) = + (l < u) || (l == u && lb == InclusiveBound && ub == InclusiveBound) + +-- Check an upper bound does not intersect, or even touch a lower bound: +-- +-- ---| or ---) but not ---] or ---) or ---] +-- |--- (--- (--- [--- [--- +-- +doesNotTouch :: UpperBound -> LowerBound -> Bool +doesNotTouch NoUpperBound _ = False +doesNotTouch (UpperBound u ub) (LowerBound l lb) = + u < l + || (u == l && ub == ExclusiveBound && lb == ExclusiveBound) + +-- | Check an upper bound does not intersect a lower bound: +-- +-- ---| or ---) or ---] or ---) but not ---] +-- |--- (--- (--- [--- [--- +-- +doesNotIntersect :: UpperBound -> LowerBound -> Bool +doesNotIntersect NoUpperBound _ = False +doesNotIntersect (UpperBound u ub) (LowerBound l lb) = + u < l + || (u == l && not (ub == InclusiveBound && lb == InclusiveBound)) + +toVersionIntervals :: VersionRange -> VersionIntervals +toVersionIntervals = foldVersionRange + ( chkIvl (minLowerBound, NoUpperBound)) + (\v -> chkIvl (LowerBound v InclusiveBound, UpperBound v InclusiveBound)) + (\v -> chkIvl (LowerBound v ExclusiveBound, NoUpperBound)) + (\v -> if isVersion0 v then VersionIntervals [] else + chkIvl (minLowerBound, UpperBound v ExclusiveBound)) + unionVersionIntervals + intersectVersionIntervals + where + chkIvl interval = checkInvariant (VersionIntervals [interval]) + +unionVersionIntervals :: VersionIntervals -> VersionIntervals + -> VersionIntervals +unionVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) = + checkInvariant (VersionIntervals (union is0 is'0)) + where + union is [] = is + union [] is' = is' + union (i:is) (i':is') = case unionInterval i i' of + Left Nothing -> i : union is (i' :is') + Left (Just i'') -> union is (i'':is') + Right Nothing -> i' : union (i :is) is' + Right (Just i'') -> union (i'':is) is' + +unionInterval :: VersionInterval -> VersionInterval + -> Either (Maybe VersionInterval) (Maybe VersionInterval) +unionInterval (lower , upper ) (lower', upper') + + -- Non-intersecting intervals with the left interval ending first + | upper `doesNotTouch` lower' = Left Nothing + + -- Non-intersecting intervals with the right interval first + | upper' `doesNotTouch` lower = Right Nothing + + -- Complete or partial overlap, with the left interval ending first + | upper <= upper' = lowerBound `seq` + Left (Just (lowerBound, upper')) + + -- Complete or partial overlap, with the left interval ending first + | otherwise = lowerBound `seq` + Right (Just (lowerBound, upper)) + where + lowerBound = min lower lower' + +intersectVersionIntervals :: VersionIntervals -> VersionIntervals + -> VersionIntervals +intersectVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) = + checkInvariant (VersionIntervals (intersect is0 is'0)) + where + intersect _ [] = [] + intersect [] _ = [] + intersect (i:is) (i':is') = case intersectInterval i i' of + Left Nothing -> intersect is (i':is') + Left (Just i'') -> i'' : intersect is (i':is') + Right Nothing -> intersect (i:is) is' + Right (Just i'') -> i'' : intersect (i:is) is' + +intersectInterval :: VersionInterval -> VersionInterval + -> Either (Maybe VersionInterval) (Maybe VersionInterval) +intersectInterval (lower , upper ) (lower', upper') + + -- Non-intersecting intervals with the left interval ending first + | upper `doesNotIntersect` lower' = Left Nothing + + -- Non-intersecting intervals with the right interval first + | upper' `doesNotIntersect` lower = Right Nothing + + -- Complete or partial overlap, with the left interval ending first + | upper <= upper' = lowerBound `seq` + Left (Just (lowerBound, upper)) + + -- Complete or partial overlap, with the right interval ending first + | otherwise = lowerBound `seq` + Right (Just (lowerBound, upper')) + where + lowerBound = max lower lower' + + +instance Text Dependency where + disp (Dependency name ver) = + disp name <+> disp ver + + parse = do name <- parse + Parse.skipSpaces + ver <- parse <++ return AnyVersion + Parse.skipSpaces + return (Dependency name ver) + +instance Text License where + disp (GPL version) = Disp.text "GPL" <> dispOptVersion version + disp (LGPL version) = Disp.text "LGPL" <> dispOptVersion version + disp (AGPL version) = Disp.text "AGPL" <> dispOptVersion version + disp (Apache version) = Disp.text "Apache" <> dispOptVersion version + disp (UnknownLicense other) = Disp.text other + disp other = Disp.text (show other) + + parse = do + name <- Parse.munch1 (\c -> Char.isAlphaNum c && c /= '-') + version <- Parse.option Nothing (Parse.char '-' >> fmap Just parse) + return $! case (name, version :: Maybe Version) of + ("GPL", _ ) -> GPL version + ("LGPL", _ ) -> LGPL version + ("AGPL", _ ) -> AGPL version + ("BSD3", Nothing) -> BSD3 + ("BSD4", Nothing) -> BSD4 + ("MIT", Nothing) -> MIT + ("Apache", _ ) -> Apache version + ("PublicDomain", Nothing) -> PublicDomain + ("AllRightsReserved", Nothing) -> AllRightsReserved + ("OtherLicense", Nothing) -> OtherLicense + _ -> UnknownLicense $ name + ++ maybe "" (('-':) . display) version + +dispOptVersion :: Maybe Version -> Disp.Doc +dispOptVersion Nothing = Disp.empty +dispOptVersion (Just v) = Disp.char '-' <> disp v + +instance Text CompilerFlavor where + disp (OtherCompiler name) = Disp.text name + disp (HaskellSuite name) = Disp.text name + disp NHC = Disp.text "nhc98" + disp other = Disp.text (lowercase (show other)) + + parse = do + comp <- Parse.munch1 Char.isAlphaNum + when (all Char.isDigit comp) Parse.pfail + return (classifyCompilerFlavor comp) + +classifyCompilerFlavor :: String -> CompilerFlavor +classifyCompilerFlavor s = + fromMaybe (OtherCompiler s) $ lookup (lowercase s) compilerMap + where + compilerMap = [ (display compiler, compiler) + | compiler <- knownCompilerFlavors ] + +knownCompilerFlavors :: [CompilerFlavor] +knownCompilerFlavors = [GHC, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC] + +instance Text Language where + disp (UnknownLanguage other) = Disp.text other + disp other = Disp.text (show other) + + parse = do + lang <- Parse.munch1 Char.isAlphaNum + return (classifyLanguage lang) + +classifyLanguage :: String -> Language +classifyLanguage = \str -> case lookup str langTable of + Just lang -> lang + Nothing -> UnknownLanguage str + where + langTable = [ (show lang, lang) + | lang <- knownLanguages ] + +knownLanguages :: [Language] +knownLanguages = [Haskell98, Haskell2010] + +instance Text Extension where + disp (UnknownExtension other) = Disp.text other + disp (EnableExtension ke) = Disp.text (show ke) + disp (DisableExtension ke) = Disp.text ("No" ++ show ke) + + parse = do + extension <- Parse.munch1 Char.isAlphaNum + return (classifyExtension extension) + +instance Text KnownExtension where + disp ke = Disp.text (show ke) + + parse = do + extension <- Parse.munch1 Char.isAlphaNum + case classifyKnownExtension extension of + Just ke -> + return ke + Nothing -> + fail ("Can't parse " ++ show extension ++ " as KnownExtension") + +classifyExtension :: String -> Extension +classifyExtension string + = case classifyKnownExtension string of + Just ext -> EnableExtension ext + Nothing -> + case string of + 'N':'o':string' -> + case classifyKnownExtension string' of + Just ext -> DisableExtension ext + Nothing -> UnknownExtension string + _ -> UnknownExtension string + +-- | 'read' for 'KnownExtension's is really really slow so for the Text +-- instance +-- what we do is make a simple table indexed off the first letter in the +-- extension name. The extension names actually cover the range @'A'-'Z'@ +-- pretty densely and the biggest bucket is 7 so it's not too bad. We just do +-- a linear search within each bucket. +-- +-- This gives an order of magnitude improvement in parsing speed, and it'll +-- also allow us to do case insensitive matches in future if we prefer. +-- +classifyKnownExtension :: String -> Maybe KnownExtension +classifyKnownExtension "" = Nothing +classifyKnownExtension string@(c : _) + | inRange (bounds knownExtensionTable) c + = lookup string (knownExtensionTable ! c) + | otherwise = Nothing + +knownExtensionTable :: Array Char [(String, KnownExtension)] +knownExtensionTable = + accumArray (flip (:)) [] ('A', 'Z') + [ (head str, (str, extension)) + | extension <- [toEnum 0 ..] + , let str = show extension ] + +instance Text BuildType where + disp (UnknownBuildType other) = Disp.text other + disp other = Disp.text (show other) + + parse = do + name <- Parse.munch1 Char.isAlphaNum + return $ case name of + "Simple" -> Simple + "Configure" -> Configure + "Custom" -> Custom + "Make" -> Make + _ -> UnknownBuildType name + +instance Text BenchmarkType where + disp (BenchmarkTypeExe ver) = text "exitcode-stdio-" <> disp ver + disp (BenchmarkTypeUnknown name ver) = text name <> Disp.char '-' <> disp ver + + parse = stdParse $ \ver name -> case name of + "exitcode-stdio" -> BenchmarkTypeExe ver + _ -> BenchmarkTypeUnknown name ver + +stdParse :: Text ver => (ver -> String -> res) -> Parse.ReadP res +stdParse f = do + cs <- Parse.sepBy1 component (Parse.char '-') + _ <- Parse.char '-' + ver <- parse + let name = intercalate "-" cs + return $! f ver (lowercase name) + where + component = do + cs <- Parse.munch1 Char.isAlphaNum + if all Char.isDigit cs then Parse.pfail else return cs + -- each component must contain an alphabetic character, to avoid + -- ambiguity in identifiers like foo-1 (the 1 is the version number). + +instance Text RepoKind where + disp RepoHead = Disp.text "head" + disp RepoThis = Disp.text "this" + disp (RepoKindUnknown other) = Disp.text other + + parse = do + name <- ident + return $ case lowercase name of + "head" -> RepoHead + "this" -> RepoThis + _ -> RepoKindUnknown name + +instance Text RepoType where + disp (OtherRepoType other) = Disp.text other + disp other = Disp.text (lowercase (show other)) + parse = fmap classifyRepoType ident + +classifyRepoType :: String -> RepoType +classifyRepoType s = + fromMaybe (OtherRepoType s) $ lookup (lowercase s) repoTypeMap + where + repoTypeMap = [ (name, repoType') + | repoType' <- knownRepoTypes + , name <- display repoType' : repoTypeAliases repoType' ] + +knownRepoTypes :: [RepoType] +knownRepoTypes = [Darcs, Git, SVN, CVS + ,Mercurial, GnuArch, Bazaar, Monotone] + +repoTypeAliases :: RepoType -> [String] +repoTypeAliases Bazaar = ["bzr"] +repoTypeAliases Mercurial = ["hg"] +repoTypeAliases GnuArch = ["arch"] +repoTypeAliases _ = [] + +instance Text Arch where + disp (OtherArch name) = Disp.text name + disp other = Disp.text (lowercase (show other)) + + parse = fmap classifyArch ident + +classifyArch :: String -> Arch +classifyArch s = + fromMaybe (OtherArch s) $ lookup (lowercase s) archMap + where + archMap = [ (display arch, arch) + | arch <- knownArches ] + +knownArches :: [Arch] +knownArches = [I386, X86_64, PPC, PPC64, Sparc + ,Arm, Mips, SH + ,IA64, S390 + ,Alpha, Hppa, Rs6000 + ,M68k, Vax] + +instance Text OS where + disp (OtherOS name) = Disp.text name + disp other = Disp.text (lowercase (show other)) + + parse = fmap classifyOS ident + +classifyOS :: String -> OS +classifyOS s = + fromMaybe (OtherOS s) $ lookup (lowercase s) osMap + where + osMap = [ (name, os) + | os <- knownOSs + , name <- display os : osAliases os ] + +knownOSs :: [OS] +knownOSs = [Linux, Windows, OSX + ,FreeBSD, OpenBSD, NetBSD + ,Solaris, AIX, HPUX, IRIX + ,HaLVM + ,IOS] + +osAliases :: OS -> [String] +osAliases Windows = ["mingw32", "win32"] +osAliases _ = [] + + +-- ----------------------------------------------------------------------------- +-- The PackageDescription type + +pkgDescrFieldDescrs :: [FieldDescr PackageDescription] +pkgDescrFieldDescrs = + [ simpleField "name" + disp parse + (pkgName.package) (\name pkg -> pkg{package=(package pkg){pkgName=name}}) + , simpleField "version" + disp parse + (pkgVersion.package) (\ver pkg -> pkg{package=(package pkg){pkgVersion=ver}}) + , simpleField "cabal-version" + (either disp disp) (liftM Left parse +++ liftM Right parse) + specVersionRaw (\v pkg -> pkg{specVersionRaw=v}) + , simpleField "build-type" + (maybe empty disp) (fmap Just parse) + buildType (\t pkg -> pkg{buildType=t}) + , simpleField "license" + disp parseLicenseQ + license (\l pkg -> pkg{license=l}) + , simpleField "license-file" + showFilePath parseFilePathQ + licenseFile (\l pkg -> pkg{licenseFile=l}) + , simpleField "copyright" + showFreeText parseFreeText + copyright (\val pkg -> pkg{copyright=val}) + , simpleField "maintainer" + showFreeText parseFreeText + maintainer (\val pkg -> pkg{maintainer=val}) + , commaListField "build-depends" + disp parse + buildDepends (\xs pkg -> pkg{buildDepends=xs}) + , simpleField "stability" + showFreeText parseFreeText + stability (\val pkg -> pkg{stability=val}) + , simpleField "homepage" + showFreeText parseFreeText + homepage (\val pkg -> pkg{homepage=val}) + , simpleField "package-url" + showFreeText parseFreeText + pkgUrl (\val pkg -> pkg{pkgUrl=val}) + , simpleField "bug-reports" + showFreeText parseFreeText + bugReports (\val pkg -> pkg{bugReports=val}) + , simpleField "synopsis" + showFreeText parseFreeText + synopsis (\val pkg -> pkg{synopsis=val}) + , simpleField "description" + showFreeText parseFreeText + description (\val pkg -> pkg{description=val}) + , simpleField "category" + showFreeText parseFreeText + category (\val pkg -> pkg{category=val}) + , simpleField "author" + showFreeText parseFreeText + author (\val pkg -> pkg{author=val}) + , listField "tested-with" + showTestedWith parseTestedWithQ + testedWith (\val pkg -> pkg{testedWith=val}) + , listField "data-files" + showFilePath parseFilePathQ + dataFiles (\val pkg -> pkg{dataFiles=val}) + , simpleField "data-dir" + showFilePath parseFilePathQ + dataDir (\val pkg -> pkg{dataDir=val}) + , listField "extra-source-files" + showFilePath parseFilePathQ + extraSrcFiles (\val pkg -> pkg{extraSrcFiles=val}) + , listField "extra-tmp-files" + showFilePath parseFilePathQ + extraTmpFiles (\val pkg -> pkg{extraTmpFiles=val}) + , listField "extra-doc-files" + showFilePath parseFilePathQ + extraDocFiles (\val pkg -> pkg{extraDocFiles=val}) + ] + +-- | Store any fields beginning with "x-" in the customFields field of +-- a PackageDescription. All other fields will generate a warning. +storeXFieldsPD :: UnrecFieldParser PackageDescription +storeXFieldsPD (f@('x':'-':_),val) pkg = + Just pkg{ customFieldsPD = + customFieldsPD pkg ++ [(f,val)]} +storeXFieldsPD _ _ = Nothing + +-- --------------------------------------------------------------------------- +-- The Library type + +libFieldDescrs :: [FieldDescr Library] +libFieldDescrs = + [ listField "exposed-modules" disp parseModuleNameQ + exposedModules (\mods lib -> lib{exposedModules=mods}) + + , boolField "exposed" + libExposed (\val lib -> lib{libExposed=val}) + ] ++ map biToLib binfoFieldDescrs + where biToLib = liftField libBuildInfo (\bi lib -> lib{libBuildInfo=bi}) + +storeXFieldsLib :: UnrecFieldParser Library +storeXFieldsLib (f@('x':'-':_), val) l@(Library { libBuildInfo = bi }) = + Just $ l {libBuildInfo = + bi{ customFieldsBI = customFieldsBI bi ++ [(f,val)]}} +storeXFieldsLib _ _ = Nothing + +-- --------------------------------------------------------------------------- +-- The Executable type + + +executableFieldDescrs :: [FieldDescr Executable] +executableFieldDescrs = + [ -- note ordering: configuration must come first, for + -- showPackageDescription. + simpleField "executable" + showToken parseTokenQ + exeName (\xs exe -> exe{exeName=xs}) + , simpleField "main-is" + showFilePath parseFilePathQ + modulePath (\xs exe -> exe{modulePath=xs}) + ] + ++ map biToExe binfoFieldDescrs + where biToExe = liftField buildInfo (\bi exe -> exe{buildInfo=bi}) + +storeXFieldsExe :: UnrecFieldParser Executable +storeXFieldsExe (f@('x':'-':_), val) e@(Executable { buildInfo = bi }) = + Just $ e {buildInfo = bi{ customFieldsBI = (f,val):customFieldsBI bi}} +storeXFieldsExe _ _ = Nothing + +-- --------------------------------------------------------------------------- +-- The TestSuite type + +-- | An intermediate type just used for parsing the test-suite stanza. +-- After validation it is converted into the proper 'TestSuite' type. +data TestSuiteStanza = TestSuiteStanza { + testStanzaTestType :: Maybe TestType, + testStanzaMainIs :: Maybe FilePath, + testStanzaTestModule :: Maybe ModuleName, + testStanzaBuildInfo :: BuildInfo + } + +emptyTestStanza :: TestSuiteStanza +emptyTestStanza = TestSuiteStanza Nothing Nothing Nothing mempty + +testSuiteFieldDescrs :: [FieldDescr TestSuiteStanza] +testSuiteFieldDescrs = + [ simpleField "type" + (maybe empty disp) (fmap Just parse) + testStanzaTestType (\x suite -> suite { testStanzaTestType = x }) + , simpleField "main-is" + (maybe empty showFilePath) (fmap Just parseFilePathQ) + testStanzaMainIs (\x suite -> suite { testStanzaMainIs = x }) + , simpleField "test-module" + (maybe empty disp) (fmap Just parseModuleNameQ) + testStanzaTestModule (\x suite -> suite { testStanzaTestModule = x }) + ] + ++ map biToTest binfoFieldDescrs + where + biToTest = liftField testStanzaBuildInfo + (\bi suite -> suite { testStanzaBuildInfo = bi }) + +storeXFieldsTest :: UnrecFieldParser TestSuiteStanza +storeXFieldsTest (f@('x':'-':_), val) t@(TestSuiteStanza { testStanzaBuildInfo = bi }) = + Just $ t {testStanzaBuildInfo = bi{ customFieldsBI = (f,val):customFieldsBI bi}} +storeXFieldsTest _ _ = Nothing + +validateTestSuite :: LineNo -> TestSuiteStanza -> ParseResult TestSuite +validateTestSuite line stanza = + case testStanzaTestType stanza of + Nothing -> return $ + emptyTestSuite { testBuildInfo = testStanzaBuildInfo stanza } + + Just tt@(TestTypeUnknown _ _) -> + return emptyTestSuite { + testInterface = TestSuiteUnsupported tt, + testBuildInfo = testStanzaBuildInfo stanza + } + + Just tt | tt `notElem` knownTestTypes -> + return emptyTestSuite { + testInterface = TestSuiteUnsupported tt, + testBuildInfo = testStanzaBuildInfo stanza + } + + Just tt@(TestTypeExe ver) -> + case testStanzaMainIs stanza of + Nothing -> syntaxError line (missingField "main-is" tt) + Just file -> do + when (isJust (testStanzaTestModule stanza)) $ + warning (extraField "test-module" tt) + return emptyTestSuite { + testInterface = TestSuiteExeV10 ver file, + testBuildInfo = testStanzaBuildInfo stanza + } + + Just tt@(TestTypeLib ver) -> + case testStanzaTestModule stanza of + Nothing -> syntaxError line (missingField "test-module" tt) + Just module_ -> do + when (isJust (testStanzaMainIs stanza)) $ + warning (extraField "main-is" tt) + return emptyTestSuite { + testInterface = TestSuiteLibV09 ver module_, + testBuildInfo = testStanzaBuildInfo stanza + } + + where + missingField name tt = "The '" ++ name ++ "' field is required for the " + ++ display tt ++ " test suite type." + + extraField name tt = "The '" ++ name ++ "' field is not used for the '" + ++ display tt ++ "' test suite type." + +instance Text TestType where + disp (TestTypeExe ver) = text "exitcode-stdio-" <> disp ver + disp (TestTypeLib ver) = text "detailed-" <> disp ver + disp (TestTypeUnknown name ver) = text name <> Disp.char '-' <> disp ver + + parse = stdParse $ \ver name -> case name of + "exitcode-stdio" -> TestTypeExe ver + "detailed" -> TestTypeLib ver + _ -> TestTypeUnknown name ver + +knownTestTypes :: [TestType] +knownTestTypes = [ TestTypeExe (Version [1,0] []) + , TestTypeLib (Version [0,9] []) ] + +-- --------------------------------------------------------------------------- +-- The Benchmark type + +-- | An intermediate type just used for parsing the benchmark stanza. +-- After validation it is converted into the proper 'Benchmark' type. +data BenchmarkStanza = BenchmarkStanza { + benchmarkStanzaBenchmarkType :: Maybe BenchmarkType, + benchmarkStanzaMainIs :: Maybe FilePath, + benchmarkStanzaBenchmarkModule :: Maybe ModuleName, + benchmarkStanzaBuildInfo :: BuildInfo + } + +emptyBenchmarkStanza :: BenchmarkStanza +emptyBenchmarkStanza = BenchmarkStanza Nothing Nothing Nothing mempty + +benchmarkFieldDescrs :: [FieldDescr BenchmarkStanza] +benchmarkFieldDescrs = + [ simpleField "type" + (maybe empty disp) (fmap Just parse) + benchmarkStanzaBenchmarkType + (\x suite -> suite { benchmarkStanzaBenchmarkType = x }) + , simpleField "main-is" + (maybe empty showFilePath) (fmap Just parseFilePathQ) + benchmarkStanzaMainIs + (\x suite -> suite { benchmarkStanzaMainIs = x }) + ] + ++ map biToBenchmark binfoFieldDescrs + where + biToBenchmark = liftField benchmarkStanzaBuildInfo + (\bi suite -> suite { benchmarkStanzaBuildInfo = bi }) + +storeXFieldsBenchmark :: UnrecFieldParser BenchmarkStanza +storeXFieldsBenchmark (f@('x':'-':_), val) + t@(BenchmarkStanza { benchmarkStanzaBuildInfo = bi }) = + Just $ t {benchmarkStanzaBuildInfo = + bi{ customFieldsBI = (f,val):customFieldsBI bi}} +storeXFieldsBenchmark _ _ = Nothing + +validateBenchmark :: LineNo -> BenchmarkStanza -> ParseResult Benchmark +validateBenchmark line stanza = + case benchmarkStanzaBenchmarkType stanza of + Nothing -> return $ + emptyBenchmark { benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza } + + Just tt@(BenchmarkTypeUnknown _ _) -> + return emptyBenchmark { + benchmarkInterface = BenchmarkUnsupported tt, + benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza + } + + Just tt | tt `notElem` knownBenchmarkTypes -> + return emptyBenchmark { + benchmarkInterface = BenchmarkUnsupported tt, + benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza + } + + Just tt@(BenchmarkTypeExe ver) -> + case benchmarkStanzaMainIs stanza of + Nothing -> syntaxError line (missingField "main-is" tt) + Just file -> do + when (isJust (benchmarkStanzaBenchmarkModule stanza)) $ + warning (extraField "benchmark-module" tt) + return emptyBenchmark { + benchmarkInterface = BenchmarkExeV10 ver file, + benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza + } + + where + missingField name tt = "The '" ++ name ++ "' field is required for the " + ++ display tt ++ " benchmark type." + + extraField name tt = "The '" ++ name ++ "' field is not used for the '" + ++ display tt ++ "' benchmark type." + +knownBenchmarkTypes :: [BenchmarkType] +knownBenchmarkTypes = [ BenchmarkTypeExe (Version [1,0] []) ] + + +-- --------------------------------------------------------------------------- +-- The BuildInfo type + + +binfoFieldDescrs :: [FieldDescr BuildInfo] +binfoFieldDescrs = + [ boolField "buildable" + buildable (\val binfo -> binfo{buildable=val}) + , commaListField "build-tools" + disp parseBuildTool + buildTools (\xs binfo -> binfo{buildTools=xs}) + , spaceListField "cpp-options" + showToken parseTokenQ' + cppOptions (\val binfo -> binfo{cppOptions=val}) + , spaceListField "cc-options" + showToken parseTokenQ' + ccOptions (\val binfo -> binfo{ccOptions=val}) + , spaceListField "ld-options" + showToken parseTokenQ' + ldOptions (\val binfo -> binfo{ldOptions=val}) + , commaListField "pkgconfig-depends" + disp parsePkgconfigDependency + pkgconfigDepends (\xs binfo -> binfo{pkgconfigDepends=xs}) + , listField "frameworks" + showToken parseTokenQ + frameworks (\val binfo -> binfo{frameworks=val}) + , listField "c-sources" + showFilePath parseFilePathQ + cSources (\paths binfo -> binfo{cSources=paths}) + + , simpleField "default-language" + (maybe empty disp) (option Nothing (fmap Just parseLanguageQ)) + defaultLanguage (\lang binfo -> binfo{defaultLanguage=lang}) + , listField "other-languages" + disp parseLanguageQ + otherLanguages (\langs binfo -> binfo{otherLanguages=langs}) + , listField "default-extensions" + disp parseExtensionQ + defaultExtensions (\exts binfo -> binfo{defaultExtensions=exts}) + , listField "other-extensions" + disp parseExtensionQ + otherExtensions (\exts binfo -> binfo{otherExtensions=exts}) + , listField "extensions" + disp parseExtensionQ + oldExtensions (\exts binfo -> binfo{oldExtensions=exts}) + + , listField "extra-libraries" + showToken parseTokenQ + extraLibs (\xs binfo -> binfo{extraLibs=xs}) + , listField "extra-lib-dirs" + showFilePath parseFilePathQ + extraLibDirs (\xs binfo -> binfo{extraLibDirs=xs}) + , listField "includes" + showFilePath parseFilePathQ + includes (\paths binfo -> binfo{includes=paths}) + , listField "install-includes" + showFilePath parseFilePathQ + installIncludes (\paths binfo -> binfo{installIncludes=paths}) + , listField "include-dirs" + showFilePath parseFilePathQ + includeDirs (\paths binfo -> binfo{includeDirs=paths}) + , listField "hs-source-dirs" + showFilePath parseFilePathQ + hsSourceDirs (\paths binfo -> binfo{hsSourceDirs=paths}) + , listField "other-modules" + disp parseModuleNameQ + otherModules (\val binfo -> binfo{otherModules=val}) + , listField "ghc-prof-options" + text parseTokenQ + ghcProfOptions (\val binfo -> binfo{ghcProfOptions=val}) + , listField "ghc-shared-options" + text parseTokenQ + ghcSharedOptions (\val binfo -> binfo{ghcSharedOptions=val}) + , optsField "ghc-options" GHC + options (\path binfo -> binfo{options=path}) + , optsField "hugs-options" Hugs + options (\path binfo -> binfo{options=path}) + , optsField "nhc98-options" NHC + options (\path binfo -> binfo{options=path}) + , optsField "jhc-options" JHC + options (\path binfo -> binfo{options=path}) + ] + +------------------------------------------------------------------------------ + +flagFieldDescrs :: [FieldDescr Flag] +flagFieldDescrs = + [ simpleField "description" + showFreeText parseFreeText + flagDescription (\val fl -> fl{ flagDescription = val }) + , boolField "default" + flagDefault (\val fl -> fl{ flagDefault = val }) + , boolField "manual" + flagManual (\val fl -> fl{ flagManual = val }) + ] + +------------------------------------------------------------------------------ + +sourceRepoFieldDescrs :: [FieldDescr SourceRepo] +sourceRepoFieldDescrs = + [ simpleField "type" + (maybe empty disp) (fmap Just parse) + repoType (\val repo -> repo { repoType = val }) + , simpleField "location" + (maybe empty showFreeText) (fmap Just parseFreeText) + repoLocation (\val repo -> repo { repoLocation = val }) + , simpleField "module" + (maybe empty showToken) (fmap Just parseTokenQ) + repoModule (\val repo -> repo { repoModule = val }) + , simpleField "branch" + (maybe empty showToken) (fmap Just parseTokenQ) + repoBranch (\val repo -> repo { repoBranch = val }) + , simpleField "tag" + (maybe empty showToken) (fmap Just parseTokenQ) + repoTag (\val repo -> repo { repoTag = val }) + , simpleField "subdir" + (maybe empty showFilePath) (fmap Just parseFilePathQ) + repoSubdir (\val repo -> repo { repoSubdir = val }) + ] + +-- --------------------------------------------------------------- +-- Parsing + + +mapSimpleFields :: (Field -> ParseResult Field) -> [Field] + -> ParseResult [Field] +mapSimpleFields f = mapM walk + where + walk fld@F{} = f fld + walk (IfBlock l c fs1 fs2) = do + fs1' <- mapM walk fs1 + fs2' <- mapM walk fs2 + return (IfBlock l c fs1' fs2') + walk (Section ln n l fs1) = do + fs1' <- mapM walk fs1 + return (Section ln n l fs1') + +-- prop_isMapM fs = mapSimpleFields return fs == return fs + + +-- names of fields that represents dependencies, thus consrca +constraintFieldNames :: [String] +constraintFieldNames = ["build-depends"] + +-- Possible refactoring would be to have modifiers be explicit about what +-- they add and define an accessor that specifies what the dependencies +-- are. This way we would completely reuse the parsing knowledge from the +-- field descriptor. +parseConstraint :: Field -> ParseResult [Dependency] +parseConstraint (F l n v) + | n == "build-depends" = runP l n (parseCommaList parse) v +parseConstraint f = userBug $ "Constraint was expected (got: " ++ show f ++ ")" + +{- +headerFieldNames :: [String] +headerFieldNames = filter (\n -> not (n `elem` constraintFieldNames)) + . map fieldName $ pkgDescrFieldDescrs +-} + +libFieldNames :: [String] +libFieldNames = map fieldName libFieldDescrs + ++ buildInfoNames ++ constraintFieldNames + +-- exeFieldNames :: [String] +-- exeFieldNames = map fieldName executableFieldDescrs +-- ++ buildInfoNames + +buildInfoNames :: [String] +buildInfoNames = map fieldName binfoFieldDescrs + ++ map fst deprecatedFieldsBuildInfo + +-- A minimal implementation of the StateT monad transformer to avoid depending +-- on the 'mtl' package. +newtype StT s m a = StT { runStT :: s -> m (a,s) } + +instance Functor f => Functor (StT s f) where + fmap g (StT f) = StT $ fmap (\(x, s) -> (g x, s)) . f + +instance (Monad m, Functor m) => Applicative (StT s m) where + pure = return + (<*>) = ap + +instance Monad m => Monad (StT s m) where + return a = StT (\s -> return (a,s)) + StT f >>= g = StT $ \s -> do + (a,s') <- f s + runStT (g a) s' + +get :: Monad m => StT s m s +get = StT $ \s -> return (s, s) + +modify :: Monad m => (s -> s) -> StT s m () +modify f = StT $ \s -> return ((),f s) + +lift :: Monad m => m a -> StT s m a +lift m = StT $ \s -> m >>= \a -> return (a,s) + +evalStT :: Monad m => StT s m a -> s -> m a +evalStT st s = liftM fst $ runStT st s + +-- Our monad for parsing a list/tree of fields. +-- +-- The state represents the remaining fields to be processed. +type PM a = StT [Field] ParseResult a + + + +-- return look-ahead field or nothing if we're at the end of the file +peekField :: PM (Maybe Field) +peekField = liftM listToMaybe get + +-- Unconditionally discard the first field in our state. Will error when it +-- reaches end of file. (Yes, that's evil.) +skipField :: PM () +skipField = modify tail + +parsePackageDescription :: String -> ParseResult GenericPackageDescription +parsePackageDescription file = do + + -- This function is quite complex because it needs to be able to parse + -- both pre-Cabal-1.2 and post-Cabal-1.2 files. Additionally, it contains + -- a lot of parser-related noise since we do not want to depend on Parsec. + -- + -- If we detect an pre-1.2 file we implicitly convert it to post-1.2 + -- style. See 'sectionizeFields' below for details about the conversion. + + fields0 <- readFields file `catchParseError` \err -> + let tabs = findIndentTabs file in + case err of + -- In case of a TabsError report them all at once. + TabsError tabLineNo -> reportTabsError + -- but only report the ones including and following + -- the one that caused the actual error + [ t | t@(lineNo',_) <- tabs + , lineNo' >= tabLineNo ] + _ -> parseFail err + + let cabalVersionNeeded = + head $ [ minVersionBound versionRange + | Just versionRange <- [ simpleParse v + | F _ "cabal-version" v <- fields0 ] ] + ++ [Version [0] []] + minVersionBound versionRange = + case asVersionIntervals versionRange of + [] -> Version [0] [] + ((LowerBound version _, _):_) -> version + + handleFutureVersionParseFailure cabalVersionNeeded $ do + + let sf = sectionizeFields fields0 -- ensure 1.2 format + + -- figure out and warn about deprecated stuff (warnings are collected + -- inside our parsing monad) + fields <- mapSimpleFields deprecField sf + + -- Our parsing monad takes the not-yet-parsed fields as its state. + -- After each successful parse we remove the field from the state + -- ('skipField') and move on to the next one. + -- + -- Things are complicated a bit, because fields take a tree-like + -- structure -- they can be sections or "if"/"else" conditionals. + + flip evalStT fields $ do + + -- The header consists of all simple fields up to the first section + -- (flag, library, executable). + header_fields <- getHeader [] + + -- Parses just the header fields and stores them in a + -- 'PackageDescription'. Note that our final result is a + -- 'GenericPackageDescription'; for pragmatic reasons we just store + -- the partially filled-out 'PackageDescription' inside the + -- 'GenericPackageDescription'. + pkg <- lift $ parseFields pkgDescrFieldDescrs + storeXFieldsPD + emptyPackageDescription + header_fields + + -- 'getBody' assumes that the remaining fields only consist of + -- flags, lib and exe sections. + (repos, flags, mlib, exes, tests, bms) <- getBody + warnIfRest -- warn if getBody did not parse up to the last field. + -- warn about using old/new syntax with wrong cabal-version: + maybeWarnCabalVersion (not $ oldSyntax fields0) pkg + checkForUndefinedFlags flags mlib exes tests + return $ GenericPackageDescription + pkg { sourceRepos = repos } + flags mlib exes tests bms + + where + oldSyntax = all isSimpleField + reportTabsError tabs = + syntaxError (fst (head tabs)) $ + "Do not use tabs for indentation (use spaces instead)\n" + ++ " Tabs were used at (line,column): " ++ show tabs + + maybeWarnCabalVersion newsyntax pkg + | newsyntax && specVersion pkg < Version [1,2] [] + = lift $ warning $ + "A package using section syntax must specify at least\n" + ++ "'cabal-version: >= 1.2'." + + maybeWarnCabalVersion newsyntax pkg + | not newsyntax && specVersion pkg >= Version [1,2] [] + = lift $ warning $ + "A package using 'cabal-version: " + ++ displaySpecVersion (specVersionRaw pkg) + ++ "' must use section syntax. See the Cabal user guide for details." + where + displaySpecVersion (Left version) = display version + displaySpecVersion (Right versionRange) = + case asVersionIntervals versionRange of + [] {- impossible -} -> display versionRange + ((LowerBound version _, _):_) -> display (orLaterVersion version) + + maybeWarnCabalVersion _ _ = return () + + specVersion :: PackageDescription -> Version + specVersion pkg = case specVersionRaw pkg of + Left version -> version + Right versionRange -> case asVersionIntervals versionRange of + [] -> Version [0] [] + ((LowerBound version _, _):_) -> version + + + handleFutureVersionParseFailure cabalVersionNeeded parseBody = + (unless versionOk (warning message) >> parseBody) + `catchParseError` \parseError -> case parseError of + TabsError _ -> parseFail parseError + _ | versionOk -> parseFail parseError + | otherwise -> fail message + where versionOk = cabalVersionNeeded <= cabalVersion + message = "This package requires at least Cabal version " + ++ display cabalVersionNeeded + + cabalVersion :: Version + cabalVersion = Version [1,16] [] + + -- "Sectionize" an old-style Cabal file. A sectionized file has: + -- + -- * all global fields at the beginning, followed by + -- + -- * all flag declarations, followed by + -- + -- * an optional library section, and an arbitrary number of executable + -- sections (in any order). + -- + -- The current implementatition just gathers all library-specific fields + -- in a library section and wraps all executable stanzas in an executable + -- section. + sectionizeFields :: [Field] -> [Field] + sectionizeFields fs + | oldSyntax fs = + let + -- "build-depends" is a local field now. To be backwards + -- compatible, we still allow it as a global field in old-style + -- package description files and translate it to a local field by + -- adding it to every non-empty section + (hdr0, exes0) = break ((=="executable") . fName) fs + (hdr, libfs0) = partition (not . (`elem` libFieldNames) . fName) hdr0 + + (deps, libfs) = partition ((== "build-depends") . fName) + libfs0 + + exes = unfoldr toExe exes0 + toExe [] = Nothing + toExe (F l e n : r) + | e == "executable" = + let (efs, r') = break ((=="executable") . fName) r + in Just (Section l "executable" n (deps ++ efs), r') + toExe _ = cabalBug "unexpected input to 'toExe'" + in + hdr ++ + (if null libfs then [] + else [Section (lineNo (head libfs)) "library" "" (deps ++ libfs)]) + ++ exes + | otherwise = fs + + isSimpleField F{} = True + isSimpleField _ = False + + -- warn if there's something at the end of the file + warnIfRest :: PM () + warnIfRest = do + s <- get + case s of + [] -> return () + _ -> lift $ warning "Ignoring trailing declarations." -- add line no. + + -- all simple fields at the beginning of the file are (considered) header + -- fields + getHeader :: [Field] -> PM [Field] + getHeader acc = peekField >>= \mf -> case mf of + Just f@F{} -> skipField >> getHeader (f:acc) + _ -> return (reverse acc) + + -- + -- body ::= { repo | flag | library | executable | test }+ -- at most one lib + -- + -- The body consists of an optional sequence of declarations of flags and + -- an arbitrary number of executables and at most one library. + getBody :: PM ([SourceRepo], [Flag] + ,Maybe (CondTree ConfVar [Dependency] Library) + ,[(String, CondTree ConfVar [Dependency] Executable)] + ,[(String, CondTree ConfVar [Dependency] TestSuite)] + ,[(String, CondTree ConfVar [Dependency] Benchmark)]) + getBody = peekField >>= \mf -> case mf of + Just (Section line_no sec_type sec_label sec_fields) + | sec_type == "executable" -> do + when (null sec_label) $ lift $ syntaxError line_no + "'executable' needs one argument (the executable's name)" + exename <- lift $ runP line_no "executable" parseTokenQ sec_label + flds <- collectFields parseExeFields sec_fields + skipField + (repos, flags, lib, exes, tests, bms) <- getBody + return (repos, flags, lib, (exename, flds): exes, tests, bms) + + | sec_type == "test-suite" -> do + when (null sec_label) $ lift $ syntaxError line_no + "'test-suite' needs one argument (the test suite's name)" + testname <- lift $ runP line_no "test" parseTokenQ sec_label + flds <- collectFields (parseTestFields line_no) sec_fields + + -- Check that a valid test suite type has been chosen. A type + -- field may be given inside a conditional block, so we must + -- check for that before complaining that a type field has not + -- been given. The test suite must always have a valid type, so + -- we need to check both the 'then' and 'else' blocks, though + -- the blocks need not have the same type. + let checkTestType ts ct = + let ts' = mappend ts $ condTreeData ct + -- If a conditional has only a 'then' block and no + -- 'else' block, then it cannot have a valid type + -- in every branch, unless the type is specified at + -- a higher level in the tree. + checkComponent (_, _, Nothing) = False + -- If a conditional has a 'then' block and an 'else' + -- block, both must specify a test type, unless the + -- type is specified higher in the tree. + checkComponent (_, t, Just e) = + checkTestType ts' t && checkTestType ts' e + -- Does the current node specify a test type? + hasTestType = testInterface ts' + /= testInterface emptyTestSuite + components = condTreeComponents ct + -- If the current level of the tree specifies a type, + -- then we are done. If not, then one of the conditional + -- branches below the current node must specify a type. + -- Each node may have multiple immediate children; we + -- only one need one to specify a type because the + -- configure step uses 'mappend' to join together the + -- results of flag resolution. + in hasTestType || any checkComponent components + if checkTestType emptyTestSuite flds + then do + skipField + (repos, flags, lib, exes, tests, bms) <- getBody + return (repos, flags, lib, exes, (testname, flds) : tests, bms) + else lift $ syntaxError line_no $ + "Test suite \"" ++ testname + ++ "\" is missing required field \"type\" or the field " + ++ "is not present in all conditional branches. The " + ++ "available test types are: " + ++ intercalate ", " (map display knownTestTypes) + + | sec_type == "benchmark" -> do + when (null sec_label) $ lift $ syntaxError line_no + "'benchmark' needs one argument (the benchmark's name)" + benchname <- lift $ runP line_no "benchmark" parseTokenQ sec_label + flds <- collectFields (parseBenchmarkFields line_no) sec_fields + + -- Check that a valid benchmark type has been chosen. A type + -- field may be given inside a conditional block, so we must + -- check for that before complaining that a type field has not + -- been given. The benchmark must always have a valid type, so + -- we need to check both the 'then' and 'else' blocks, though + -- the blocks need not have the same type. + let checkBenchmarkType ts ct = + let ts' = mappend ts $ condTreeData ct + -- If a conditional has only a 'then' block and no + -- 'else' block, then it cannot have a valid type + -- in every branch, unless the type is specified at + -- a higher level in the tree. + checkComponent (_, _, Nothing) = False + -- If a conditional has a 'then' block and an 'else' + -- block, both must specify a benchmark type, unless the + -- type is specified higher in the tree. + checkComponent (_, t, Just e) = + checkBenchmarkType ts' t && checkBenchmarkType ts' e + -- Does the current node specify a benchmark type? + hasBenchmarkType = benchmarkInterface ts' + /= benchmarkInterface emptyBenchmark + components = condTreeComponents ct + -- If the current level of the tree specifies a type, + -- then we are done. If not, then one of the conditional + -- branches below the current node must specify a type. + -- Each node may have multiple immediate children; we + -- only one need one to specify a type because the + -- configure step uses 'mappend' to join together the + -- results of flag resolution. + in hasBenchmarkType || any checkComponent components + if checkBenchmarkType emptyBenchmark flds + then do + skipField + (repos, flags, lib, exes, tests, bms) <- getBody + return (repos, flags, lib, exes, tests, (benchname, flds) : bms) + else lift $ syntaxError line_no $ + "Benchmark \"" ++ benchname + ++ "\" is missing required field \"type\" or the field " + ++ "is not present in all conditional branches. The " + ++ "available benchmark types are: " + ++ intercalate ", " (map display knownBenchmarkTypes) + + | sec_type == "library" -> do + unless (null sec_label) $ lift $ + syntaxError line_no "'library' expects no argument" + flds <- collectFields parseLibFields sec_fields + skipField + (repos, flags, lib, exes, tests, bms) <- getBody + when (isJust lib) $ lift $ syntaxError line_no + "There can only be one library section in a package description." + return (repos, flags, Just flds, exes, tests, bms) + + | sec_type == "flag" -> do + when (null sec_label) $ lift $ + syntaxError line_no "'flag' needs one argument (the flag's name)" + flag <- lift $ parseFields + flagFieldDescrs + warnUnrec + (MkFlag (FlagName (lowercase sec_label)) "" True False) + sec_fields + skipField + (repos, flags, lib, exes, tests, bms) <- getBody + return (repos, flag:flags, lib, exes, tests, bms) + + | sec_type == "source-repository" -> do + when (null sec_label) $ lift $ syntaxError line_no $ + "'source-repository' needs one argument, " + ++ "the repo kind which is usually 'head' or 'this'" + kind <- case simpleParse sec_label of + Just kind -> return kind + Nothing -> lift $ syntaxError line_no $ + "could not parse repo kind: " ++ sec_label + repo <- lift $ parseFields + sourceRepoFieldDescrs + warnUnrec + SourceRepo { + repoKind = kind, + repoType = Nothing, + repoLocation = Nothing, + repoModule = Nothing, + repoBranch = Nothing, + repoTag = Nothing, + repoSubdir = Nothing + } + sec_fields + skipField + (repos, flags, lib, exes, tests, bms) <- getBody + return (repo:repos, flags, lib, exes, tests, bms) + + | otherwise -> do + lift $ warning $ "Ignoring unknown section type: " ++ sec_type + skipField + getBody + Just f -> do + _ <- lift $ syntaxError (lineNo f) $ + "Construct not supported at this position: " ++ show f + skipField + getBody + Nothing -> return ([], [], Nothing, [], [], []) + + -- Extracts all fields in a block and returns a 'CondTree'. + -- + -- We have to recurse down into conditionals and we treat fields that + -- describe dependencies specially. + collectFields :: ([Field] -> PM a) -> [Field] + -> PM (CondTree ConfVar [Dependency] a) + collectFields parser allflds = do + + let simplFlds = [ F l n v | F l n v <- allflds ] + condFlds = [ f | f@IfBlock{} <- allflds ] + + let (depFlds, dataFlds) = partition isConstraint simplFlds + + a <- parser dataFlds + deps <- liftM concat . mapM (lift . parseConstraint) $ depFlds + + ifs <- mapM processIfs condFlds + + return (CondNode a deps ifs) + where + isConstraint (F _ n _) = n `elem` constraintFieldNames + isConstraint _ = False + + processIfs (IfBlock l c t e) = do + cnd <- lift $ runP l "if" parseCondition c + t' <- collectFields parser t + e' <- case e of + [] -> return Nothing + es -> do fs <- collectFields parser es + return (Just fs) + return (cnd, t', e') + processIfs _ = cabalBug "processIfs called with wrong field type" + + parseLibFields :: [Field] -> PM Library + parseLibFields = lift . parseFields libFieldDescrs storeXFieldsLib emptyLibrary + + -- Note: we don't parse the "executable" field here, hence the tail hack. + parseExeFields :: [Field] -> PM Executable + parseExeFields = lift . parseFields (tail executableFieldDescrs) + storeXFieldsExe emptyExecutable + + parseTestFields :: LineNo -> [Field] -> PM TestSuite + parseTestFields line fields = do + x <- lift $ parseFields testSuiteFieldDescrs storeXFieldsTest + emptyTestStanza fields + lift $ validateTestSuite line x + + parseBenchmarkFields :: LineNo -> [Field] -> PM Benchmark + parseBenchmarkFields line fields = do + x <- lift $ parseFields benchmarkFieldDescrs storeXFieldsBenchmark + emptyBenchmarkStanza fields + lift $ validateBenchmark line x + + checkForUndefinedFlags :: + [Flag] -> + Maybe (CondTree ConfVar [Dependency] Library) -> + [(String, CondTree ConfVar [Dependency] Executable)] -> + [(String, CondTree ConfVar [Dependency] TestSuite)] -> + PM () + checkForUndefinedFlags flags mlib exes tests = do + let definedFlags = map flagName flags + maybe (return ()) (checkCondTreeFlags definedFlags) mlib + mapM_ (checkCondTreeFlags definedFlags . snd) exes + mapM_ (checkCondTreeFlags definedFlags . snd) tests + + checkCondTreeFlags :: [FlagName] -> CondTree ConfVar c a -> PM () + checkCondTreeFlags definedFlags ct = do + let fv = nub $ freeVars ct + unless (all (`elem` definedFlags) fv) $ + fail $ "These flags are used without having been defined: " + ++ intercalate ", " [ n | FlagName n <- fv \\ definedFlags ] + + findIndentTabs :: String -> [(Int,Int)] + findIndentTabs = concatMap checkLine + . zip [1..] + . lines + where + checkLine (lineno, l) = + let (indent, _content) = span isSpace l + tabCols = map fst . filter ((== '\t') . snd) . zip [0..] + addLineNo = map (\col -> (lineno,col)) + in addLineNo (tabCols indent) + +parseCondition :: ReadP (Condition ConfVar) +parseCondition = condOr + where + condOr = sepBy1 condAnd (oper "||") >>= return . foldl1 COr + condAnd = sepBy1 cond (oper "&&")>>= return . foldl1 CAnd + cond = sp >> (boolLiteral +++ inparens condOr +++ notCond +++ osCond + +++ archCond +++ flagCond +++ implCond ) + inparens = between (ReadP.char '(' >> sp) (sp >> ReadP.char ')' >> sp) + notCond = ReadP.char '!' >> sp >> cond >>= return . CNot + osCond = string "os" >> sp >> inparens osIdent >>= return . Var + archCond = string "arch" >> sp >> inparens archIdent >>= return . Var + flagCond = string "flag" >> sp >> inparens flagIdent >>= return . Var + implCond = string "impl" >> sp >> inparens implIdent >>= return . Var + boolLiteral = fmap Lit parse + archIdent = fmap Arch parse + osIdent = fmap OS parse + flagIdent = fmap (Flag . FlagName . lowercase) (munch1 isIdentChar) + isIdentChar c = isAlphaNum c || c == '_' || c == '-' + oper s = sp >> string s >> sp + sp = skipSpaces + implIdent = do i <- parse + vr <- sp >> option AnyVersion parse + return $ Impl i vr + +freeVars :: CondTree ConfVar c a -> [FlagName] +freeVars t = [ f | Flag f <- freeVars' t ] + where + freeVars' (CondNode _ _ ifs) = concatMap compfv ifs + compfv (c, ct, mct) = condfv c ++ freeVars' ct ++ maybe [] freeVars' mct + condfv c = case c of + Var v -> [v] + Lit _ -> [] + CNot c' -> condfv c' + COr c1 c2 -> condfv c1 ++ condfv c2 + CAnd c1 c2 -> condfv c1 ++ condfv c2 + + +emptyPackageDescription :: PackageDescription +emptyPackageDescription + = PackageDescription { + package = PackageId (PackageName "") + (Version [] []), + license = AllRightsReserved, + licenseFile = "", + specVersionRaw = Right AnyVersion, + buildType = Nothing, + copyright = "", + maintainer = "", + author = "", + stability = "", + testedWith = [], + buildDepends = [], + homepage = "", + pkgUrl = "", + bugReports = "", + sourceRepos = [], + synopsis = "", + description = "", + category = "", + customFieldsPD = [], + library = Nothing, + executables = [], + testSuites = [], + benchmarks = [], + dataFiles = [], + dataDir = "", + extraSrcFiles = [], + extraTmpFiles = [], + extraDocFiles = [] + } + + +instance Monoid Library where + mempty = Library { + exposedModules = mempty, + libExposed = True, + libBuildInfo = mempty + } + mappend a b = Library { + exposedModules = combine exposedModules, + libExposed = libExposed a && libExposed b, -- so False propagates + libBuildInfo = combine libBuildInfo + } + where combine field = field a `mappend` field b + +emptyLibrary :: Library +emptyLibrary = mempty + +instance Monoid Executable where + mempty = Executable { + exeName = mempty, + modulePath = mempty, + buildInfo = mempty + } + mappend a b = Executable{ + exeName = combine' exeName, + modulePath = combine modulePath, + buildInfo = combine buildInfo + } + where combine field = field a `mappend` field b + combine' field = case (field a, field b) of + ("","") -> "" + ("", x) -> x + (x, "") -> x + (x, y) -> error $ "Ambiguous values for executable field: '" + ++ x ++ "' and '" ++ y ++ "'" + +emptyExecutable :: Executable +emptyExecutable = mempty + +instance Monoid TestSuite where + mempty = TestSuite { + testName = mempty, + testInterface = mempty, + testBuildInfo = mempty, + testEnabled = False + } + + mappend a b = TestSuite { + testName = combine' testName, + testInterface = combine testInterface, + testBuildInfo = combine testBuildInfo, + testEnabled = testEnabled a || testEnabled b + } + where combine field = field a `mappend` field b + combine' f = case (f a, f b) of + ("", x) -> x + (x, "") -> x + (x, y) -> error "Ambiguous values for test field: '" + ++ x ++ "' and '" ++ y ++ "'" + +instance Monoid TestSuiteInterface where + mempty = TestSuiteUnsupported (TestTypeUnknown mempty (Version [] [])) + mappend a (TestSuiteUnsupported _) = a + mappend _ b = b + +emptyTestSuite :: TestSuite +emptyTestSuite = mempty + +instance Monoid Benchmark where + mempty = Benchmark { + benchmarkName = mempty, + benchmarkInterface = mempty, + benchmarkBuildInfo = mempty, + benchmarkEnabled = False + } + + mappend a b = Benchmark { + benchmarkName = combine' benchmarkName, + benchmarkInterface = combine benchmarkInterface, + benchmarkBuildInfo = combine benchmarkBuildInfo, + benchmarkEnabled = benchmarkEnabled a || benchmarkEnabled b + } + where combine field = field a `mappend` field b + combine' f = case (f a, f b) of + ("", x) -> x + (x, "") -> x + (x, y) -> error "Ambiguous values for benchmark field: '" + ++ x ++ "' and '" ++ y ++ "'" + +instance Monoid BenchmarkInterface where + mempty = BenchmarkUnsupported (BenchmarkTypeUnknown mempty (Version [] [])) + mappend a (BenchmarkUnsupported _) = a + mappend _ b = b + +emptyBenchmark :: Benchmark +emptyBenchmark = mempty + +instance Monoid BuildInfo where + mempty = BuildInfo { + buildable = True, + buildTools = [], + cppOptions = [], + ccOptions = [], + ldOptions = [], + pkgconfigDepends = [], + frameworks = [], + cSources = [], + hsSourceDirs = [], + otherModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibDirs = [], + includeDirs = [], + includes = [], + installIncludes = [], + options = [], + ghcProfOptions = [], + ghcSharedOptions = [], + customFieldsBI = [], + targetBuildDepends = [] + } + mappend a b = BuildInfo { + buildable = buildable a && buildable b, + buildTools = combine buildTools, + cppOptions = combine cppOptions, + ccOptions = combine ccOptions, + ldOptions = combine ldOptions, + pkgconfigDepends = combine pkgconfigDepends, + frameworks = combineNub frameworks, + cSources = combineNub cSources, + hsSourceDirs = combineNub hsSourceDirs, + otherModules = combineNub otherModules, + defaultLanguage = combineMby defaultLanguage, + otherLanguages = combineNub otherLanguages, + defaultExtensions = combineNub defaultExtensions, + otherExtensions = combineNub otherExtensions, + oldExtensions = combineNub oldExtensions, + extraLibs = combine extraLibs, + extraLibDirs = combineNub extraLibDirs, + includeDirs = combineNub includeDirs, + includes = combineNub includes, + installIncludes = combineNub installIncludes, + options = combine options, + ghcProfOptions = combine ghcProfOptions, + ghcSharedOptions = combine ghcSharedOptions, + customFieldsBI = combine customFieldsBI, + targetBuildDepends = combineNub targetBuildDepends + } + where + combine field = field a `mappend` field b + combineNub field = nub (combine field) + combineMby field = field b `mplus` field a + + +-- | Parse a list of fields, given a list of field descriptions, +-- a structure to accumulate the parsed fields, and a function +-- that can decide what to do with fields which don't match any +-- of the field descriptions. +parseFields :: [FieldDescr a] -- ^ descriptions of fields we know how to + -- parse + -> UnrecFieldParser a -- ^ possibly do something with + -- unrecognized fields + -> a -- ^ accumulator + -> [Field] -- ^ fields to be parsed + -> ParseResult a +parseFields descrs unrec ini fields = + do (a, unknowns) <- foldM (parseField descrs unrec) (ini, []) fields + unless (null unknowns) $ warning $ render $ + text "Unknown fields:" <+> + commaSep (map (\(l,u) -> u ++ " (line " ++ show l ++ ")") + (reverse unknowns)) + $+$ + text "Fields allowed in this section:" $$ + nest 4 (commaSep $ map fieldName descrs) + return a + where + commaSep = fsep . punctuate comma . map text + +parseField :: [FieldDescr a] -- ^ list of parseable fields + -> UnrecFieldParser a -- ^ possibly do something with + -- unrecognized fields + -> (a,[(Int,String)]) -- ^ accumulated result and warnings + -> Field -- ^ the field to be parsed + -> ParseResult (a, [(Int,String)]) +parseField (FieldDescr name _ parser : fields) unrec (a, us) (F line f val) + | name == f = parser line val a >>= \a' -> return (a',us) + | otherwise = parseField fields unrec (a,us) (F line f val) +parseField [] unrec (a,us) (F l f val) = return $ + case unrec (f,val) a of -- no fields matched, see if the 'unrec' + Just a' -> (a',us) -- function wants to do anything with it + Nothing -> (a, (l,f):us) +parseField _ _ _ _ = cabalBug "'parseField' called on a non-field" + +deprecatedFields :: [(String,String)] +deprecatedFields = + deprecatedFieldsPkgDescr ++ deprecatedFieldsBuildInfo + +deprecatedFieldsPkgDescr :: [(String,String)] +deprecatedFieldsPkgDescr = [ ("other-files", "extra-source-files") ] + +deprecatedFieldsBuildInfo :: [(String,String)] +deprecatedFieldsBuildInfo = [ ("hs-source-dir","hs-source-dirs") ] + +-- Handle deprecated fields +deprecField :: Field -> ParseResult Field +deprecField (F line fld val) = do + fld' <- case lookup fld deprecatedFields of + Nothing -> return fld + Just newName -> do + warning $ "The field \"" ++ fld + ++ "\" is deprecated, please use \"" ++ newName ++ "\"" + return newName + return (F line fld' val) +deprecField _ = cabalBug "'deprecField' called on a non-field" + +userBug :: String -> a +userBug msg = error $ msg ++ ". This is a bug in your .cabal file." + +cabalBug :: String -> a +cabalBug msg = error $ msg ++ ". This is possibly a bug in Cabal.\n" + ++ "Please report it to the developers: " + ++ "https://github.com/haskell/cabal/issues/new" + diff --git a/bench/versus/Macro/MemSize.hs b/bench/versus/Macro/MemSize.hs new file mode 100644 --- /dev/null +++ b/bench/versus/Macro/MemSize.hs @@ -0,0 +1,278 @@ +{-# LANGUAGE BangPatterns #-} +module Macro.MemSize where + +import Macro.Types + +class MemSize a where + memSize :: a -> Int -> Int + +memSize0 :: Int -> Int +memSize1 :: MemSize a => a -> Int -> Int +memSize2 :: (MemSize a, MemSize a1) => + a -> a1 -> Int -> Int +memSize3 :: (MemSize a, MemSize a1, MemSize a2) => + a -> a1 -> a2 -> Int -> Int +memSize4 :: (MemSize a, MemSize a1, MemSize a2, MemSize a3) => + a -> a1 -> a2 -> a3 -> Int -> Int +memSize5 :: (MemSize a, MemSize a1, MemSize a2, MemSize a3, MemSize a4) => + a -> a1 -> a2 -> a3 -> a4 -> Int -> Int +memSize6 :: (MemSize a, MemSize a1, MemSize a2, MemSize a3, MemSize a4, + MemSize a5) => + a -> a1 -> a2 -> a3 -> a4 -> a5 -> Int -> Int +memSize7 :: (MemSize a, MemSize a1, MemSize a2, MemSize a3, MemSize a4, + MemSize a5, MemSize a6) => + a -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> Int -> Int + + +memSize0 = \ !sz -> sz +memSize1 a = \ !sz -> memSize a $ 2 + sz +memSize2 a b = \ !sz -> memSize a . memSize b $ 2 + sz +memSize3 a b c = \ !sz -> memSize a . memSize b . memSize c $ 2 + sz +memSize4 a b c d = \ !sz -> memSize a . memSize b . memSize c . memSize d $ 2 + sz +memSize5 a b c d + e = \ !sz -> memSize a . memSize b . memSize c . memSize d . + memSize e $ 6 + sz +memSize6 a b c d + e f = \ !sz -> memSize a . memSize b . memSize c . memSize d . + memSize e . memSize f $ 7 + sz +memSize7 a b c d + e f g = \ !sz -> memSize a . memSize b . memSize c . memSize d . + memSize e . memSize f . memSize g $ 7 + sz +{-# INLINE memSize0 #-} +{-# INLINE memSize1 #-} +{-# INLINE memSize2 #-} +{-# INLINE memSize3 #-} +{-# INLINE memSize4 #-} +{-# INLINE memSize5 #-} +{-# INLINE memSize6 #-} +{-# INLINE memSize7 #-} + +instance MemSize Int where + memSize _ = (+2) + +instance MemSize Char where + memSize _ = memSize0 + +instance MemSize Bool where + memSize _ = memSize0 + +instance MemSize a => MemSize [a] where + memSize [] = memSize0 + memSize (x:xs) = memSize2 x xs + +instance (MemSize a, MemSize b) => MemSize (a,b) where + memSize (a,b) = memSize2 a b + +instance (MemSize a, MemSize b, MemSize c) => MemSize (a,b,c) where + memSize (a,b,c) = memSize3 a b c + +instance MemSize a => MemSize (Maybe a) where + memSize Nothing = memSize0 + memSize (Just a) = memSize1 a + +instance (MemSize a, MemSize b) => MemSize (Either a b) where + memSize (Left a) = memSize1 a + memSize (Right b) = memSize1 b + + +instance MemSize PackageName where + memSize (PackageName a) = memSize1 a + +instance MemSize PackageId where + memSize (PackageId a b) = memSize2 a b + +instance MemSize Version where + memSize (Version a b) = memSize2 a b + +instance MemSize VersionRange where + memSize AnyVersion = memSize0 + memSize (ThisVersion a) = memSize1 a + memSize (LaterVersion a) = memSize1 a + memSize (EarlierVersion a) = memSize1 a + memSize (WildcardVersion a) = memSize1 a + memSize (UnionVersionRanges a b) = memSize2 a b + memSize (IntersectVersionRanges a b) = memSize2 a b + memSize (VersionRangeParens a) = memSize1 a + +instance MemSize Dependency where + memSize (Dependency a b) = memSize2 a b + +instance MemSize CompilerFlavor where + memSize GHC = memSize0 + memSize NHC = memSize0 + memSize YHC = memSize0 + memSize Hugs = memSize0 + memSize HBC = memSize0 + memSize Helium = memSize0 + memSize JHC = memSize0 + memSize LHC = memSize0 + memSize UHC = memSize0 + memSize (HaskellSuite a) = memSize1 a + memSize (OtherCompiler a) = memSize1 a + +instance MemSize License where + memSize (GPL a) = memSize1 a + memSize (AGPL a) = memSize1 a + memSize (LGPL a) = memSize1 a + memSize BSD3 = memSize0 + memSize BSD4 = memSize0 + memSize MIT = memSize0 + memSize (Apache a) = memSize1 a + memSize PublicDomain = memSize0 + memSize AllRightsReserved = memSize0 + memSize OtherLicense = memSize0 + memSize (UnknownLicense a) = memSize1 a + +instance MemSize SourceRepo where + memSize (SourceRepo a b c d e f g) = memSize7 a b c d e f g + +instance MemSize RepoKind where + memSize RepoHead = memSize0 + memSize RepoThis = memSize0 + memSize (RepoKindUnknown a) = memSize1 a + + +instance MemSize RepoType where + memSize Darcs = memSize0 + memSize Git = memSize0 + memSize SVN = memSize0 + memSize CVS = memSize0 + memSize Mercurial = memSize0 + memSize GnuArch = memSize0 + memSize Bazaar = memSize0 + memSize Monotone = memSize0 + memSize (OtherRepoType a) = memSize1 a + +instance MemSize BuildType where + memSize Simple = memSize0 + memSize Configure = memSize0 + memSize Make = memSize0 + memSize Custom = memSize0 + memSize (UnknownBuildType a) = memSize1 a + +instance MemSize Library where + memSize (Library a b c) = memSize3 a b c + +instance MemSize Executable where + memSize (Executable a b c) = memSize3 a b c + +instance MemSize TestSuite where + memSize (TestSuite a b c d) = memSize4 a b c d + +instance MemSize TestSuiteInterface where + memSize (TestSuiteExeV10 a b) = memSize2 a b + memSize (TestSuiteLibV09 a b) = memSize2 a b + memSize (TestSuiteUnsupported a) = memSize1 a + +instance MemSize TestType where + memSize (TestTypeExe a) = memSize1 a + memSize (TestTypeLib a) = memSize1 a + memSize (TestTypeUnknown a b) = memSize2 a b + +instance MemSize Benchmark where + memSize (Benchmark a b c d) = memSize4 a b c d + +instance MemSize BenchmarkInterface where + memSize (BenchmarkExeV10 a b) = memSize2 a b + memSize (BenchmarkUnsupported a) = memSize1 a + +instance MemSize BenchmarkType where + memSize (BenchmarkTypeExe a) = memSize1 a + memSize (BenchmarkTypeUnknown a b) = memSize2 a b + +instance MemSize ModuleName where + memSize (ModuleName a) = memSize1 a + +instance MemSize BuildInfo where + memSize (BuildInfo a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 + a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 + a21 a22 a23 a24 a25) = + memSize a1 . memSize a2 . memSize a3 . memSize a4 . memSize a5 . + memSize a6 . memSize a7 . memSize a8 . memSize a9 . memSize a10 . + memSize a11 . memSize a12 . memSize a13 . memSize a14 . memSize a15 . + memSize a16 . memSize a17 . memSize a18 . memSize a19 . memSize a20 . + memSize a21 . memSize a22 . memSize a23 . memSize a24 . memSize a25 . (+26) + + +instance MemSize Language where + memSize Haskell98 = memSize0 + memSize Haskell2010 = memSize0 + memSize (UnknownLanguage a) = memSize1 a + +instance MemSize Extension where + memSize (EnableExtension a) = memSize1 a + memSize (DisableExtension a) = memSize1 a + memSize (UnknownExtension a) = memSize1 a + +instance MemSize KnownExtension where + memSize _ = memSize0 + +instance MemSize PackageDescription where + memSize (PackageDescription a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 + a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 + a21 a22 a23 a24 a25 a26 a27 a28) = + memSize a1 . memSize a2 . memSize a3 . memSize a4 . memSize a5 . + memSize a6 . memSize a7 . memSize a8 . memSize a9 . memSize a10 . + memSize a11 . memSize a12 . memSize a13 . memSize a14 . memSize a15 . + memSize a16 . memSize a17 . memSize a18 . memSize a19 . memSize a20 . + memSize a21 . memSize a22 . memSize a23 . memSize a24 . memSize a25 . + memSize a26 . memSize a27 . memSize a28 . (+29) + +instance MemSize OS where + memSize Linux = memSize0 + memSize Windows = memSize0 + memSize OSX = memSize0 + memSize FreeBSD = memSize0 + memSize OpenBSD = memSize0 + memSize NetBSD = memSize0 + memSize Solaris = memSize0 + memSize AIX = memSize0 + memSize HPUX = memSize0 + memSize IRIX = memSize0 + memSize HaLVM = memSize0 + memSize IOS = memSize0 + memSize (OtherOS a) = memSize1 a + +instance MemSize Arch where + memSize I386 = memSize0 + memSize X86_64 = memSize0 + memSize PPC = memSize0 + memSize PPC64 = memSize0 + memSize Sparc = memSize0 + memSize Arm = memSize0 + memSize Mips = memSize0 + memSize SH = memSize0 + memSize IA64 = memSize0 + memSize S390 = memSize0 + memSize Alpha = memSize0 + memSize Hppa = memSize0 + memSize Rs6000 = memSize0 + memSize M68k = memSize0 + memSize (OtherArch a) = memSize1 a + memSize Vax = memSize0 + +instance MemSize Flag where + memSize (MkFlag a b c d) = memSize4 a b c d + +instance MemSize FlagName where + memSize (FlagName a) = memSize1 a + +instance (MemSize a, MemSize b, MemSize c) => MemSize (CondTree a b c) where + memSize (CondNode a b c) = memSize3 a b c + +instance MemSize ConfVar where + memSize (OS a) = memSize1 a + memSize (Arch a) = memSize1 a + memSize (Flag a) = memSize1 a + memSize (Impl a b) = memSize2 a b + +instance MemSize a => MemSize (Condition a) where + memSize (Var a) = memSize1 a + memSize (Lit a) = memSize1 a + memSize (CNot a) = memSize1 a + memSize (COr a b) = memSize2 a b + memSize (CAnd a b) = memSize2 a b + +instance MemSize GenericPackageDescription where + memSize (GenericPackageDescription a b c d e f) = memSize6 a b c d e f + diff --git a/bench/versus/Macro/PkgAesonGeneric.hs b/bench/versus/Macro/PkgAesonGeneric.hs new file mode 100644 --- /dev/null +++ b/bench/versus/Macro/PkgAesonGeneric.hs @@ -0,0 +1,81 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Macro.PkgAesonGeneric where + +import Macro.Types +import Data.Aeson as Aeson +import Data.ByteString.Lazy as BS +import Data.Maybe + +serialise :: [GenericPackageDescription] -> BS.ByteString +serialise pkgs = Aeson.encode pkgs + +deserialise :: BS.ByteString -> [GenericPackageDescription] +deserialise = fromJust . Aeson.decode' + +instance ToJSON Version +instance ToJSON PackageName +instance ToJSON PackageId +instance ToJSON VersionRange +instance ToJSON Dependency +instance ToJSON CompilerFlavor +instance ToJSON License +instance ToJSON SourceRepo +instance ToJSON RepoKind +instance ToJSON RepoType +instance ToJSON BuildType +instance ToJSON Library +instance ToJSON Executable +instance ToJSON TestSuite +instance ToJSON TestSuiteInterface +instance ToJSON TestType +instance ToJSON Benchmark +instance ToJSON BenchmarkInterface +instance ToJSON BenchmarkType +instance ToJSON BuildInfo +instance ToJSON ModuleName +instance ToJSON Language +instance ToJSON Extension +instance ToJSON KnownExtension +instance ToJSON PackageDescription +instance ToJSON OS +instance ToJSON Arch +instance ToJSON Flag +instance ToJSON FlagName +instance (ToJSON a, ToJSON b, ToJSON c) => ToJSON (CondTree a b c) +instance ToJSON ConfVar +instance ToJSON a => ToJSON (Condition a) +instance ToJSON GenericPackageDescription + +instance FromJSON Version +instance FromJSON PackageName +instance FromJSON PackageId +instance FromJSON VersionRange +instance FromJSON Dependency +instance FromJSON CompilerFlavor +instance FromJSON License +instance FromJSON SourceRepo +instance FromJSON RepoKind +instance FromJSON RepoType +instance FromJSON BuildType +instance FromJSON Library +instance FromJSON Executable +instance FromJSON TestSuite +instance FromJSON TestSuiteInterface +instance FromJSON TestType +instance FromJSON Benchmark +instance FromJSON BenchmarkInterface +instance FromJSON BenchmarkType +instance FromJSON BuildInfo +instance FromJSON ModuleName +instance FromJSON Language +instance FromJSON Extension +instance FromJSON KnownExtension +instance FromJSON PackageDescription +instance FromJSON OS +instance FromJSON Arch +instance FromJSON Flag +instance FromJSON FlagName +instance (FromJSON a, FromJSON b, FromJSON c) => FromJSON (CondTree a b c) +instance FromJSON ConfVar +instance FromJSON a => FromJSON (Condition a) +instance FromJSON GenericPackageDescription diff --git a/bench/versus/Macro/PkgAesonTH.hs b/bench/versus/Macro/PkgAesonTH.hs new file mode 100644 --- /dev/null +++ b/bench/versus/Macro/PkgAesonTH.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Macro.PkgAesonTH where + +import Macro.Types +import Data.Aeson as Aeson +import Data.Aeson.TH as Aeson +import Data.ByteString.Lazy as BS +import Data.Maybe + +serialise :: [GenericPackageDescription] -> BS.ByteString +serialise pkgs = Aeson.encode pkgs + +deserialise :: BS.ByteString -> [GenericPackageDescription] +deserialise = fromJust . Aeson.decode' + +deriveJSON defaultOptions ''Version +deriveJSON defaultOptions ''PackageName +deriveJSON defaultOptions ''PackageId +deriveJSON defaultOptions ''VersionRange +deriveJSON defaultOptions ''Dependency +deriveJSON defaultOptions ''CompilerFlavor +deriveJSON defaultOptions ''License +deriveJSON defaultOptions ''SourceRepo +deriveJSON defaultOptions ''RepoKind +deriveJSON defaultOptions ''RepoType +deriveJSON defaultOptions ''BuildType +deriveJSON defaultOptions ''Library +deriveJSON defaultOptions ''Executable +deriveJSON defaultOptions ''TestSuite +deriveJSON defaultOptions ''TestSuiteInterface +deriveJSON defaultOptions ''TestType +deriveJSON defaultOptions ''Benchmark +deriveJSON defaultOptions ''BenchmarkInterface +deriveJSON defaultOptions ''BenchmarkType +deriveJSON defaultOptions ''BuildInfo +deriveJSON defaultOptions ''ModuleName +deriveJSON defaultOptions ''Language +deriveJSON defaultOptions ''Extension +deriveJSON defaultOptions ''KnownExtension +deriveJSON defaultOptions ''PackageDescription +deriveJSON defaultOptions ''OS +deriveJSON defaultOptions ''Arch +deriveJSON defaultOptions ''Flag +deriveJSON defaultOptions ''FlagName +deriveJSON defaultOptions ''CondTree +deriveJSON defaultOptions ''ConfVar +deriveJSON defaultOptions ''Condition +deriveJSON defaultOptions ''GenericPackageDescription diff --git a/bench/versus/Macro/PkgBinary.hs b/bench/versus/Macro/PkgBinary.hs new file mode 100644 --- /dev/null +++ b/bench/versus/Macro/PkgBinary.hs @@ -0,0 +1,57 @@ +{-# OPTIONS_GHC -fno-warn-orphans -fsimpl-tick-factor=500 #-} +module Macro.PkgBinary where + +import Macro.Types +import Data.Binary as Binary +import Data.Binary.Get as Binary +import Data.ByteString.Lazy as BS + +serialise :: [GenericPackageDescription] -> BS.ByteString +serialise pkgs = Binary.encode pkgs + +deserialise :: BS.ByteString -> [GenericPackageDescription] +deserialise = Binary.decode + +deserialiseNull :: BS.ByteString -> () +deserialiseNull = + Binary.runGet $ do + n <- get :: Get Int + go n + where + go 0 = return () + go i = do x <- get :: Get GenericPackageDescription + x `seq` go (i-1) + +instance Binary Version +instance Binary PackageName +instance Binary PackageId +instance Binary VersionRange +instance Binary Dependency +instance Binary CompilerFlavor +instance Binary License +instance Binary SourceRepo +instance Binary RepoKind +instance Binary RepoType +instance Binary BuildType +instance Binary Library +instance Binary Executable +instance Binary TestSuite +instance Binary TestSuiteInterface +instance Binary TestType +instance Binary Benchmark +instance Binary BenchmarkInterface +instance Binary BenchmarkType +instance Binary BuildInfo +instance Binary ModuleName +instance Binary Language +instance Binary Extension +instance Binary KnownExtension +instance Binary PackageDescription +instance Binary OS +instance Binary Arch +instance Binary Flag +instance Binary FlagName +instance (Binary a, Binary b, Binary c) => Binary (CondTree a b c) +instance Binary ConfVar +instance Binary a => Binary (Condition a) +instance Binary GenericPackageDescription diff --git a/bench/versus/Macro/PkgCereal.hs b/bench/versus/Macro/PkgCereal.hs new file mode 100644 --- /dev/null +++ b/bench/versus/Macro/PkgCereal.hs @@ -0,0 +1,59 @@ +{-# OPTIONS_GHC -fno-warn-orphans -fsimpl-tick-factor=500 #-} +module Macro.PkgCereal where + +import Macro.Types +import Data.Serialize as Cereal +import Data.ByteString.Lazy as BS + +serialise :: [GenericPackageDescription] -> BS.ByteString +serialise pkgs = Cereal.encodeLazy pkgs + +deserialise :: BS.ByteString -> [GenericPackageDescription] +deserialise = (\(Right x) -> x) . Cereal.decodeLazy + +deserialiseNull :: BS.ByteString -> () +deserialiseNull bs = + case Cereal.runGetLazy decodeListNull bs of + Right () -> () + Left e -> error $ "PkgCereal.deserialiseNull: decoding failed: " ++ e + where + decodeListNull = do + n <- get :: Get Int + go n + go 0 = return () + go i = do x <- get :: Get GenericPackageDescription + x `seq` go (i-1) + +instance Serialize Version +instance Serialize PackageName +instance Serialize PackageId +instance Serialize VersionRange +instance Serialize Dependency +instance Serialize CompilerFlavor +instance Serialize License +instance Serialize SourceRepo +instance Serialize RepoKind +instance Serialize RepoType +instance Serialize BuildType +instance Serialize Library +instance Serialize Executable +instance Serialize TestSuite +instance Serialize TestSuiteInterface +instance Serialize TestType +instance Serialize Benchmark +instance Serialize BenchmarkInterface +instance Serialize BenchmarkType +instance Serialize BuildInfo +instance Serialize ModuleName +instance Serialize Language +instance Serialize Extension +instance Serialize KnownExtension +instance Serialize PackageDescription +instance Serialize OS +instance Serialize Arch +instance Serialize Flag +instance Serialize FlagName +instance (Serialize a, Serialize b, Serialize c) => Serialize (CondTree a b c) +instance Serialize ConfVar +instance Serialize a => Serialize (Condition a) +instance Serialize GenericPackageDescription diff --git a/bench/versus/Macro/PkgStore.hs b/bench/versus/Macro/PkgStore.hs new file mode 100644 --- /dev/null +++ b/bench/versus/Macro/PkgStore.hs @@ -0,0 +1,46 @@ +{-# OPTIONS_GHC -fno-warn-orphans -fsimpl-tick-factor=500 #-} +module Macro.PkgStore where + +import Macro.Types +import Data.Store as Store +import Data.ByteString as BS + +serialise :: [GenericPackageDescription] -> BS.ByteString +serialise pkgs = Store.encode pkgs + +deserialise :: ByteString -> [GenericPackageDescription] +deserialise = (\(Right x) -> x) . Store.decode + +instance Store Version +instance Store PackageName +instance Store PackageId +instance Store VersionRange +instance Store Dependency +instance Store CompilerFlavor +instance Store License +instance Store SourceRepo +instance Store RepoKind +instance Store RepoType +instance Store BuildType +instance Store Library +instance Store Executable +instance Store TestSuite +instance Store TestSuiteInterface +instance Store TestType +instance Store Benchmark +instance Store BenchmarkInterface +instance Store BenchmarkType +instance Store BuildInfo +instance Store ModuleName +instance Store Language +instance Store Extension +instance Store KnownExtension +instance Store OS +instance Store Arch +instance Store Flag +instance Store FlagName +instance (Store a, Store b, Store c) => Store (CondTree a b c) +instance Store ConfVar +instance Store a => Store (Condition a) +instance Store PackageDescription +instance Store GenericPackageDescription diff --git a/bench/versus/Macro/ReadShow.hs b/bench/versus/Macro/ReadShow.hs new file mode 100644 --- /dev/null +++ b/bench/versus/Macro/ReadShow.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Macro.ReadShow where + +import Macro.Types +import Data.ByteString.Lazy.Char8 as BS + +serialise :: [GenericPackageDescription] -> BS.ByteString +serialise = BS.pack . show + +deserialise :: BS.ByteString -> [GenericPackageDescription] +deserialise = read . BS.unpack + +deriving instance Show Version +deriving instance Show PackageName +deriving instance Show PackageId +deriving instance Show VersionRange +deriving instance Show Dependency +deriving instance Show CompilerFlavor +deriving instance Show License +deriving instance Show SourceRepo +deriving instance Show RepoKind +deriving instance Show RepoType +deriving instance Show BuildType +deriving instance Show Library +deriving instance Show Executable +deriving instance Show TestSuite +deriving instance Show TestSuiteInterface +deriving instance Show TestType +deriving instance Show Benchmark +deriving instance Show BenchmarkInterface +deriving instance Show BenchmarkType +deriving instance Show BuildInfo +deriving instance Show ModuleName +deriving instance Show Language +deriving instance Show Extension +deriving instance Show KnownExtension +deriving instance Show PackageDescription +deriving instance Show OS +deriving instance Show Arch +deriving instance Show Flag +deriving instance Show FlagName +deriving instance (Show a, Show b, Show c) => Show (CondTree a b c) +deriving instance Show ConfVar +deriving instance Show a => Show (Condition a) +deriving instance Show GenericPackageDescription + +deriving instance Read Version +deriving instance Read PackageName +deriving instance Read PackageId +deriving instance Read VersionRange +deriving instance Read Dependency +deriving instance Read CompilerFlavor +deriving instance Read License +deriving instance Read SourceRepo +deriving instance Read RepoKind +deriving instance Read RepoType +deriving instance Read BuildType +deriving instance Read Library +deriving instance Read Executable +deriving instance Read TestSuite +deriving instance Read TestSuiteInterface +deriving instance Read TestType +deriving instance Read Benchmark +deriving instance Read BenchmarkInterface +deriving instance Read BenchmarkType +deriving instance Read BuildInfo +deriving instance Read ModuleName +deriving instance Read Language +deriving instance Read Extension +deriving instance Read KnownExtension +deriving instance Read PackageDescription +deriving instance Read OS +deriving instance Read Arch +deriving instance Read Flag +deriving instance Read FlagName +deriving instance (Read a, Read b, Read c) => Read (CondTree a b c) +deriving instance Read ConfVar +deriving instance Read a => Read (Condition a) +deriving instance Read GenericPackageDescription diff --git a/bench/versus/Macro/Types.hs b/bench/versus/Macro/Types.hs new file mode 100644 --- /dev/null +++ b/bench/versus/Macro/Types.hs @@ -0,0 +1,424 @@ +{-# LANGUAGE DeriveGeneric #-} +module Macro.Types (module Macro.Types, Version(..)) where + +import GHC.Generics + +newtype InstalledPackageId = InstalledPackageId String + deriving (Eq, Ord, Generic) + +newtype PackageName = PackageName String + deriving (Eq, Ord, Generic) + +data Version = Version [Int] [String] + deriving (Eq, Ord, Generic) + +data PackageId = PackageId { + pkgName :: PackageName, -- ^The name of this package, eg. foo + pkgVersion :: Version -- ^the version of this package, eg 1.2 + } + deriving (Eq, Ord, Generic) + +newtype ModuleName = ModuleName [String] + deriving (Eq, Ord, Generic) + +data License = + GPL (Maybe Version) + | AGPL (Maybe Version) + | LGPL (Maybe Version) + | BSD3 + | BSD4 + | MIT + | Apache (Maybe Version) + | PublicDomain + | AllRightsReserved + | OtherLicense + | UnknownLicense String + deriving (Eq, Generic) +{- +data InstalledPackageInfo = InstalledPackageInfo { + -- these parts are exactly the same as PackageDescription + installedPackageId :: InstalledPackageId, + sourcePackageId :: PackageId, + license :: License, + copyright :: String, + maintainer :: String, + author :: String, + stability :: String, + homepage :: String, + pkgUrl :: String, + synopsis :: String, + description :: String, + category :: String, + -- these parts are required by an installed package only: + exposed :: Bool, + exposedModules :: [ModuleName], + hiddenModules :: [ModuleName], + trusted :: Bool, + importDirs :: [FilePath], -- contain sources in case of Hugs + libraryDirs :: [FilePath], + hsLibraries :: [String], + extraLibraries :: [String], + extraGHCiLibraries:: [String], -- overrides extraLibraries for GHCi + includeDirs :: [FilePath], + includes :: [String], + depends :: [InstalledPackageId], + hugsOptions :: [String], + ccOptions :: [String], + ldOptions :: [String], + frameworkDirs :: [FilePath], + frameworks :: [String], + haddockInterfaces :: [FilePath], + haddockHTMLs :: [FilePath] + } + deriving (Eq, Generic) +-} + +data VersionRange + = AnyVersion + | ThisVersion Version -- = version + | LaterVersion Version -- > version (NB. not >=) + | EarlierVersion Version -- < version + | WildcardVersion Version -- == ver.* (same as >= ver && < ver+1) + | UnionVersionRanges VersionRange VersionRange + | IntersectVersionRanges VersionRange VersionRange + | VersionRangeParens VersionRange -- just '(exp)' parentheses syntax + deriving (Eq, Generic) + +data Dependency = Dependency PackageName VersionRange + deriving (Eq, Generic) + +data CompilerFlavor = GHC | NHC | YHC | Hugs | HBC | Helium | JHC | LHC | UHC + | HaskellSuite String -- string is the id of the actual compiler + | OtherCompiler String + deriving (Eq, Ord, Generic) + +data SourceRepo = SourceRepo { + repoKind :: RepoKind, + repoType :: Maybe RepoType, + repoLocation :: Maybe String, + repoModule :: Maybe String, + repoBranch :: Maybe String, + repoTag :: Maybe String, + repoSubdir :: Maybe FilePath + } + deriving (Eq, Generic) + +data RepoKind = + RepoHead + | RepoThis + | RepoKindUnknown String + deriving (Eq, Ord, Generic) + +data RepoType = Darcs | Git | SVN | CVS + | Mercurial | GnuArch | Bazaar | Monotone + | OtherRepoType String + deriving (Eq, Ord, Generic) + +data BuildType + = Simple + | Configure + | Make + | Custom + | UnknownBuildType String + deriving (Eq, Generic) + +data Library = Library { + exposedModules :: [ModuleName], + libExposed :: Bool, -- ^ Is the lib to be exposed by default? + libBuildInfo :: BuildInfo + } + deriving (Eq, Generic) + +data Executable = Executable { + exeName :: String, + modulePath :: FilePath, + buildInfo :: BuildInfo + } + deriving (Eq, Generic) + +data TestSuite = TestSuite { + testName :: String, + testInterface :: TestSuiteInterface, + testBuildInfo :: BuildInfo, + testEnabled :: Bool + } + deriving (Eq, Generic) + +data TestType = TestTypeExe Version + | TestTypeLib Version + | TestTypeUnknown String Version + deriving (Eq, Generic) + +data TestSuiteInterface = + TestSuiteExeV10 Version FilePath + | TestSuiteLibV09 Version ModuleName + | TestSuiteUnsupported TestType + deriving (Eq, Generic) + +data Benchmark = Benchmark { + benchmarkName :: String, + benchmarkInterface :: BenchmarkInterface, + benchmarkBuildInfo :: BuildInfo, + benchmarkEnabled :: Bool + } + deriving (Eq, Generic) + +data BenchmarkType = BenchmarkTypeExe Version + | BenchmarkTypeUnknown String Version + deriving (Eq, Generic) + +data BenchmarkInterface = + BenchmarkExeV10 Version FilePath + | BenchmarkUnsupported BenchmarkType + deriving (Eq, Generic) + +data Language = + Haskell98 + | Haskell2010 + | UnknownLanguage String + deriving (Eq, Generic) + +data Extension = + EnableExtension KnownExtension + | DisableExtension KnownExtension + | UnknownExtension String + deriving (Eq, Generic) + +data KnownExtension = + OverlappingInstances + | UndecidableInstances + | IncoherentInstances + | DoRec + | RecursiveDo + | ParallelListComp + | MultiParamTypeClasses + | MonomorphismRestriction + | FunctionalDependencies + | Rank2Types + | RankNTypes + | PolymorphicComponents + | ExistentialQuantification + | ScopedTypeVariables + | PatternSignatures + | ImplicitParams + | FlexibleContexts + | FlexibleInstances + | EmptyDataDecls + | CPP + | KindSignatures + | BangPatterns + | TypeSynonymInstances + | TemplateHaskell + | ForeignFunctionInterface + | Arrows + | Generics + | ImplicitPrelude + | NamedFieldPuns + | PatternGuards + | GeneralizedNewtypeDeriving + | ExtensibleRecords + | RestrictedTypeSynonyms + | HereDocuments + | MagicHash + | TypeFamilies + | StandaloneDeriving + | UnicodeSyntax + | UnliftedFFITypes + | InterruptibleFFI + | CApiFFI + | LiberalTypeSynonyms + | TypeOperators + | RecordWildCards + | RecordPuns + | DisambiguateRecordFields + | TraditionalRecordSyntax + | OverloadedStrings + | GADTs + | GADTSyntax + | MonoPatBinds + | RelaxedPolyRec + | ExtendedDefaultRules + | UnboxedTuples + | DeriveDataTypeable + | DeriveGeneric + | DefaultSignatures + | InstanceSigs + | ConstrainedClassMethods + | PackageImports + | ImpredicativeTypes + | NewQualifiedOperators + | PostfixOperators + | QuasiQuotes + | TransformListComp + | MonadComprehensions + | ViewPatterns + | XmlSyntax + | RegularPatterns + | TupleSections + | GHCForeignImportPrim + | NPlusKPatterns + | DoAndIfThenElse + | MultiWayIf + | LambdaCase + | RebindableSyntax + | ExplicitForAll + | DatatypeContexts + | MonoLocalBinds + | DeriveFunctor + | DeriveTraversable + | DeriveFoldable + | NondecreasingIndentation + | SafeImports + | Safe + | Trustworthy + | Unsafe + | ConstraintKinds + | PolyKinds + | DataKinds + | ParallelArrays + | RoleAnnotations + | OverloadedLists + | EmptyCase + | AutoDeriveTypeable + | NegativeLiterals + | NumDecimals + | NullaryTypeClasses + | ExplicitNamespaces + | AllowAmbiguousTypes + deriving (Eq, Enum, Bounded, Generic) + +data BuildInfo = BuildInfo { + buildable :: Bool, -- ^ component is buildable here + buildTools :: [Dependency], -- ^ tools needed to build this bit + cppOptions :: [String], -- ^ options for pre-processing Haskell code + ccOptions :: [String], -- ^ options for C compiler + ldOptions :: [String], -- ^ options for linker + pkgconfigDepends :: [Dependency], -- ^ pkg-config packages that are used + frameworks :: [String], -- ^support frameworks for Mac OS X + cSources :: [FilePath], + hsSourceDirs :: [FilePath], -- ^ where to look for the haskell module Macro.hierarchy + otherModules :: [ModuleName], -- ^ non-exposed or non-main modules + + defaultLanguage :: Maybe Language,-- ^ language used when not explicitly specified + otherLanguages :: [Language], -- ^ other languages used within the package + defaultExtensions :: [Extension], -- ^ language extensions used by all modules + otherExtensions :: [Extension], -- ^ other language extensions used within the package + oldExtensions :: [Extension], -- ^ the old extensions field, treated same as 'defaultExtensions' + + extraLibs :: [String], -- ^ what libraries to link with when compiling a program that uses your package + extraLibDirs :: [String], + includeDirs :: [FilePath], -- ^directories to find .h files + includes :: [FilePath], -- ^ The .h files to be found in includeDirs + installIncludes :: [FilePath], -- ^ .h files to install with the package + options :: [(CompilerFlavor,[String])], + ghcProfOptions :: [String], + ghcSharedOptions :: [String], + customFieldsBI :: [(String,String)], -- ^Custom fields starting + -- with x-, stored in a + -- simple assoc-list. + targetBuildDepends :: [Dependency] -- ^ Dependencies specific to a library or executable target + } + deriving (Eq, Generic) + +data PackageDescription = PackageDescription { + -- the following are required by all packages: + package :: PackageId, + license :: License, + licenseFile :: FilePath, + copyright :: String, + maintainer :: String, + author :: String, + stability :: String, + testedWith :: [(CompilerFlavor,VersionRange)], + homepage :: String, + pkgUrl :: String, + bugReports :: String, + sourceRepos :: [SourceRepo], + synopsis :: String, -- ^A one-line summary of this package + description :: String, -- ^A more verbose description of this package + category :: String, + customFieldsPD :: [(String,String)], -- ^Custom fields starting + -- with x-, stored in a + -- simple assoc-list. + buildDepends :: [Dependency], + -- | The version of the Cabal spec that this package description uses. + -- For historical reasons this is specified with a version range but + -- only ranges of the form @>= v@ make sense. We are in the process of + -- transitioning to specifying just a single version, not a range. + specVersionRaw :: Either Version VersionRange, + buildType :: Maybe BuildType, + -- components + library :: Maybe Library, + executables :: [Executable], + testSuites :: [TestSuite], + benchmarks :: [Benchmark], + dataFiles :: [FilePath], + dataDir :: FilePath, + extraSrcFiles :: [FilePath], + extraTmpFiles :: [FilePath], + extraDocFiles :: [FilePath] + } + deriving (Eq, Generic) + +data GenericPackageDescription = + GenericPackageDescription { + packageDescription :: PackageDescription, + genPackageFlags :: [Flag], + condLibrary :: Maybe (CondTree ConfVar [Dependency] Library), + condExecutables :: [(String, CondTree ConfVar [Dependency] Executable)], + condTestSuites :: [(String, CondTree ConfVar [Dependency] TestSuite)], + condBenchmarks :: [(String, CondTree ConfVar [Dependency] Benchmark)] + } + deriving (Eq, Generic) + +data OS = Linux | Windows | OSX -- tier 1 desktop OSs + | FreeBSD | OpenBSD | NetBSD -- other free unix OSs + | Solaris | AIX | HPUX | IRIX -- ageing Unix OSs + | HaLVM -- bare metal / VMs / hypervisors + | IOS -- iOS + | OtherOS String + deriving (Eq, Ord, Generic) + +data Arch = I386 | X86_64 | PPC | PPC64 | Sparc + | Arm | Mips | SH + | IA64 | S390 + | Alpha | Hppa | Rs6000 + | M68k | Vax + | OtherArch String + deriving (Eq, Ord, Generic) + +data Flag = MkFlag + { flagName :: FlagName + , flagDescription :: String + , flagDefault :: Bool + , flagManual :: Bool + } + deriving (Eq, Generic) + +newtype FlagName = FlagName String + deriving (Eq, Ord, Generic) + +type FlagAssignment = [(FlagName, Bool)] + +data ConfVar = OS OS + | Arch Arch + | Flag FlagName + | Impl CompilerFlavor VersionRange + deriving (Eq, Generic) + +data Condition c = Var c + | Lit Bool + | CNot (Condition c) + | COr (Condition c) (Condition c) + | CAnd (Condition c) (Condition c) + deriving (Eq, Generic) + +data CondTree v c a = CondNode + { condTreeData :: a + , condTreeConstraints :: c + , condTreeComponents :: [( Condition v + , CondTree v c a + , Maybe (CondTree v c a))] + } + deriving (Eq, Generic) + diff --git a/bench/versus/Main.hs b/bench/versus/Main.hs new file mode 100644 --- /dev/null +++ b/bench/versus/Main.hs @@ -0,0 +1,19 @@ +module Main + ( main -- :: IO () + ) where + +import Criterion.Main (bgroup, defaultMain) + +-- Import our benchmark suites +import qualified Mini as Mini +import qualified Macro as Macro + +import Utils (prepBenchmarkFiles) + + +-- A simple driver, for running every set of benchmarks. +main :: IO () +main = prepBenchmarkFiles >> defaultMain + [ bgroup "mini" Mini.benchmarks + , bgroup "macro" Macro.benchmarks + ] diff --git a/bench/versus/Mini.hs b/bench/versus/Mini.hs new file mode 100644 --- /dev/null +++ b/bench/versus/Mini.hs @@ -0,0 +1,62 @@ +module Mini + ( benchmarks -- :: [Benchmark] + ) where +import System.FilePath + +import Criterion.Main +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BS + +import Macro.DeepSeq () +import qualified Macro.PkgBinary as PkgBinary +import qualified Macro.PkgCereal as PkgCereal +import qualified Macro.PkgStore as PkgStore +import qualified Macro.CBOR as CBOR + + +benchmarks :: [Benchmark] +benchmarks = + [ bgroup "decode-index" + [ bgroup "binary" + [ envBinary $ \v -> + bench "deserialise" $ nf PkgBinary.deserialise v + ] + , bgroup "cereal" + [ envCereal $ \v -> + bench "deserialise" $ nf PkgCereal.deserialise v + ] + , bgroup "store" + [ envStore $ \v -> + bench "deserialise" $ nf PkgStore.deserialise v + ] + , bgroup "cbor" + [ envCBOR $ \v -> + bench "deserialise" $ nf CBOR.deserialise v + ] + ] + , bgroup "decode-index-noaccum" + [ bgroup "binary" + [ envBinary $ \v -> + bench "deserialise" $ nf PkgBinary.deserialiseNull v + ] + , bgroup "cereal" + [ envCereal $ \v -> + bench "deserialise" $ nf PkgCereal.deserialiseNull v + ] + , bgroup "cbor" + [ envCBOR $ \v -> + bench "deserialise" $ nf CBOR.deserialiseNull v + ] + ] + ] + where + -- Helpers for using Criterion environments. + envBinary = env (fmap BS.fromStrict (readBin "binary")) + envCereal = env (fmap BS.fromStrict (readBin "cereal")) + envStore = env (readBin "store") + envCBOR = env (fmap BS.fromStrict (readBin "cbor")) + + -- | Read one of the pre-encoded binary files out of the + -- data directory. + readBin :: FilePath -> IO B.ByteString + readBin f = B.readFile ("bench" "data" f <.> "bin") diff --git a/bench/versus/Utils.hs b/bench/versus/Utils.hs new file mode 100644 --- /dev/null +++ b/bench/versus/Utils.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE CPP #-} +module Utils + ( prepBenchmarkFiles -- :: IO () + ) where + +import Data.Time +import System.IO (hFlush, stdout) +import System.Mem +import Control.Monad (when) +import System.FilePath +import System.Directory + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BS +import qualified Codec.Compression.GZip as GZip + +import Macro.DeepSeq () +import qualified Macro.Load as Load +import qualified Macro.PkgBinary as PkgBinary +import qualified Macro.PkgCereal as PkgCereal +import qualified Macro.PkgStore as PkgStore +import qualified Macro.CBOR as CBOR + +-------------------------------------------------------------------------------- + +-- | Get the path to the Hackage.haskell.org package index. Works on Windows +-- and Linux. +getHackageIndexLocation :: IO FilePath +getHackageIndexLocation = do + cabalDir <- getAppUserDataDirectory "cabal" + let dir = cabalDir "packages" "hackage.haskell.org" + return (dir "01-index.tar.gz") + +-- | Copy the hackage index to a local directory. Returns the path to the +-- directory containing the file, and the file path itself. +copyHackageIndex :: IO (FilePath, FilePath) +copyHackageIndex = do + hackageIndex <- getHackageIndexLocation + + let dataDir = "bench" "data" + dest = dataDir "01-index.tar.gz" + + -- Create the data dir, and copy the index. + -- We do not try to create the 'bench' directory since it should exist. + createDirectoryIfMissing False dataDir + exists <- doesFileExist dest + when (not exists) $ do + notice "Copying hackage index" (copyFile hackageIndex dest) + + return (dataDir, dest) + +-- | Prepare all the files needed for the benchmarks to properly run, +-- including needing a copy of the Hackage index, and a few encodings +-- of some of its contents +prepBenchmarkFiles :: IO () +prepBenchmarkFiles = do + -- Set up index + (destDir, indexFile) <- copyHackageIndex + + -- Read it, and take about 20,000 entries. And a small set of 1,000 too. + let readIndex = Load.readPkgIndex . GZip.decompress + Right pkgs_ <- fmap readIndex (BS.readFile indexFile) + let _pkgs1k = take 1000 pkgs_ + _pkgs20k = take 20000 pkgs_ + + -- Write a file to the temporary directory, if it does not exist. + write p bs = do + let file = destDir p + exists <- doesFileExist file + when (not exists) $ do + let msg = "Creating " ++ file + notice msg (BS.writeFile file bs) + -- Write a file to the temporary directory, if it does not exist. + -- Strict version. + writeS p bs = do + let file = destDir p + exists <- doesFileExist file + when (not exists) $ do + let msg = "Creating " ++ file + notice msg (B.writeFile file bs) + + -- Encode that dense data in several forms, and write those forms out + -- to disk. TODO FIXME (aseipp): should we actually have the -small variant? + -- It doesn't have any similar benchmarks for the other libraries, and seems + -- like it isn't very useful, given the other ones. + write "binary.bin" (PkgBinary.serialise _pkgs20k) + write "cereal.bin" (PkgCereal.serialise _pkgs20k) + write "cbor.bin" (CBOR.serialise _pkgs20k) + writeS "store.bin" (PkgStore.serialise _pkgs20k) +--write "cbor-small.bin" (CBOR.serialise _pkgs1k) + + -- And before we finish: do a garbage collection to clean up anything left + -- over. + notice "Preparation done; performing GC" doGC + +-------------------------------------------------------------------------------- + +-- | Do a garbage collection. +doGC :: IO () +#if MIN_VERSION_base(4,7,0) +doGC = performMinorGC >> performMajorGC +#else +doGC = performGC +#endif + +-- Write a notice to the screen (with timing information). +notice :: String -> IO a -> IO a +notice m k = do + putStr ("INFO: " ++ m ++ "... ") + hFlush stdout + (v,t) <- timeIt k + putStrLn $ "OK (in " ++ show t ++ ")" + return v + +-- | Time some action and return the time difference. +timeIt :: IO a -> IO (a, NominalDiffTime) +timeIt action = do + t <- getCurrentTime + x <- action + t' <- getCurrentTime + return (x, diffUTCTime t' t) diff --git a/serialise.cabal b/serialise.cabal new file mode 100644 --- /dev/null +++ b/serialise.cabal @@ -0,0 +1,277 @@ +name: serialise +version: 0.1.0.0 +synopsis: A binary serialisation library for Haskell values. +description: + This package (formerly @binary-serialise-cbor@) provides pure, efficient + serialization of Haskell values directly into @ByteString@s for storage or + transmission purposes. By providing a set of type class instances, you can + also serialise any custom data type you have as well. + . + The underlying binary format used is the 'Concise Binary Object + Representation', or CBOR, specified in RFC 7049. As a result, + serialised Haskell values have implicit structure outside of the + Haskell program itself, meaning they can be inspected or analyzed + with custom tools. +homepage: https://github.com/well-typed/cborg +license: BSD3 +license-file: LICENSE.txt +author: Duncan Coutts +maintainer: duncan@community.haskell.org, ben@smart-cactus.org +bug-reports: https://github.com/well-typed/cborg/issues +copyright: 2015-2017 Duncan Coutts, + 2015-2017 Well-Typed LLP, + 2015 IRIS Connect Ltd +cabal-version: >=1.10 +category: Codec +build-type: Simple + +extra-source-files: + tests/test-vectors/appendix_a.json + tests/test-vectors/README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/well-typed/cborg.git + +-------------------------------------------------------------------------------- +-- Flags + +flag newtime15 + default: False + manual: False + description: Use the new time 1.5 library + +library + default-language: Haskell2010 + ghc-options: -Wall + hs-source-dirs: src + + exposed-modules: + Codec.Serialise + Codec.Serialise.Class + Codec.Serialise.Decoding + Codec.Serialise.Encoding + Codec.Serialise.IO + Codec.Serialise.Properties + Codec.Serialise.Tutorial + + build-depends: + array >= 0.4 && < 0.6, + base >= 4.6 && < 5.0, + bytestring >= 0.10.4 && < 0.11, + cborg == 0.1.*, + containers >= 0.5 && < 0.6, + ghc-prim >= 0.3 && < 0.6, + half >= 0.2.2.3 && < 0.3, + hashable >= 1.2 && < 2.0, + primitive >= 0.5 && < 0.7, + text >= 1.1 && < 1.3, + unordered-containers >= 0.2 && < 0.3, + vector >= 0.10 && < 0.13 + + if flag(newtime15) + build-depends: + time >= 1.5 && < 1.9 + else + build-depends: + time >= 1.4 && < 1.5, + old-locale + + if impl(ghc >= 8.0) + ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances + +-------------------------------------------------------------------------------- +-- Tests + +test-suite tests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Main.hs + + default-language: Haskell2010 + ghc-options: + -Wall -fno-warn-orphans -threaded -rtsopts "-with-rtsopts=-N" + + other-modules: + Tests.CBOR + Tests.IO + Tests.Negative + Tests.Orphanage + Tests.Serialise + Tests.Regress + Tests.Regress.Issue13 + Tests.Regress.Issue67 + Tests.Regress.Issue80 + Tests.Regress.Issue106 + Tests.Regress.FlatTerm + Tests.Reference + Tests.Reference.Implementation + Tests.Deriving + + build-depends: + array >= 0.4 && < 0.6, + base >= 4.6 && < 5.0, + binary >= 0.7 && < 0.9, + bytestring >= 0.10.4 && < 0.11, + directory >= 1.0 && < 1.4, + filepath >= 1.0 && < 1.5, + ghc-prim >= 0.3 && < 0.6, + text >= 1.1 && < 1.3, + time >= 1.4 && < 1.9, + containers >= 0.5 && < 0.6, + unordered-containers >= 0.2 && < 0.3, + hashable >= 1.2 && < 2.0, + cborg, + serialise, + + aeson >= 0.7 && < 1.2, + base64-bytestring >= 1.0 && < 1.1, + base16-bytestring >= 0.1 && < 0.2, + deepseq >= 1.0 && < 1.5, + half >= 0.2.2.3 && < 0.3, + QuickCheck >= 2.9 && < 2.10, + scientific >= 0.3 && < 0.4, + tasty >= 0.11 && < 0.12, + tasty-hunit >= 0.9 && < 0.10, + tasty-quickcheck >= 0.8 && < 0.9, + quickcheck-instances >= 0.3.12 && < 0.4, + vector >= 0.10 && < 0.13 + +-------------------------------------------------------------------------------- +-- Benchmarks + +benchmark instances + type: exitcode-stdio-1.0 + hs-source-dirs: bench/instances + main-is: Main.hs + + default-language: Haskell2010 + ghc-options: + -Wall -rtsopts -fno-cse -fno-ignore-asserts -fno-warn-orphans + + other-modules: + Instances.Integer + Instances.Vector + Instances.Time + + build-depends: + base >= 4.6 && < 5.0, + binary >= 0.7 && < 0.9, + bytestring >= 0.10.4 && < 0.11, + vector >= 0.10 && < 0.13, + cborg, + serialise, + + deepseq >= 1.0 && < 1.5, + criterion >= 1.0 && < 1.2 + + if flag(newtime15) + build-depends: + time >= 1.5 && < 1.9 + else + build-depends: + time >= 1.4 && < 1.5, + old-locale + +benchmark micro + type: exitcode-stdio-1.0 + hs-source-dirs: bench/micro + main-is: Main.hs + + default-language: Haskell2010 + ghc-options: + -Wall -rtsopts -fno-cse -fno-ignore-asserts -fno-warn-orphans + + other-modules: + Micro + Micro.Types + Micro.Load + Micro.DeepSeq + Micro.MemSize + Micro.ReadShow + Micro.PkgAesonGeneric + Micro.PkgAesonTH + Micro.PkgBinary + Micro.PkgCereal + Micro.PkgStore + Micro.CBOR + + SimpleVersus + + build-depends: + base >= 4.6 && < 5.0, + binary >= 0.7 && < 0.9, + bytestring >= 0.10.4 && < 0.11, + ghc-prim >= 0.3 && < 0.6, + vector >= 0.10 && < 0.13, + cborg, + serialise, + + aeson >= 0.7 && < 1.2, + deepseq >= 1.0 && < 1.5, + criterion >= 1.0 && < 1.2, + cereal >= 0.5.2.0 && < 0.6, + cereal-vector >= 0.2 && < 0.3, + store >= 0.4 && < 0.5 + +benchmark versus + type: exitcode-stdio-1.0 + hs-source-dirs: bench/versus + main-is: Main.hs + + default-language: Haskell2010 + ghc-options: + -Wall -rtsopts -fno-cse -fno-ignore-asserts -fno-warn-orphans + + other-modules: + Utils + + -- Suite #1 + Mini + + -- Suite #2 + Macro + Macro.Types + Macro.Load + Macro.DeepSeq + Macro.MemSize + Macro.ReadShow + Macro.PkgAesonGeneric + Macro.PkgAesonTH + Macro.PkgBinary + Macro.PkgCereal + Macro.PkgStore + Macro.CBOR + + build-depends: + array >= 0.4 && < 0.6, + base >= 4.6 && < 5.0, + binary >= 0.7 && < 0.9, + bytestring >= 0.10.4 && < 0.11, + directory >= 1.0 && < 1.4, + ghc-prim >= 0.3 && < 0.6, + text >= 1.1 && < 1.3, + vector >= 0.10 && < 0.13, + cborg, + serialise, + + filepath >= 1.0 && < 1.5, + containers >= 0.5 && < 0.6, + deepseq >= 1.0 && < 1.5, + aeson >= 0.7 && < 1.2, + cereal >= 0.5.2.0 && < 0.6, + half >= 0.2.2.3 && < 0.3, + tar >= 0.4 && < 0.6, + zlib >= 0.5 && < 0.7, + pretty >= 1.0 && < 1.2, + criterion >= 1.0 && < 1.2, + store >= 0.4 && < 0.5 + + if flag(newtime15) + build-depends: + time >= 1.5 && < 1.9 + else + build-depends: + time >= 1.4 && < 1.5, + old-locale diff --git a/src/Codec/Serialise.hs b/src/Codec/Serialise.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Serialise.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} + +-- | +-- Module : Codec.Serialise +-- Copyright : (c) Duncan Coutts 2015-2017 +-- License : BSD3-style (see LICENSE.txt) +-- +-- Maintainer : duncan@community.haskell.org +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- This module provides functions to serialise and deserialise Haskell +-- values for storage or transmission, to and from lazy +-- @'Data.ByteString.Lazy.ByteString'@s. It also provides a type class +-- and utilities to help you make your types serialisable. +-- +-- For a full tutorial on using this module, see +-- "Codec.CBOR.Tutorial". +-- +module Codec.Serialise + ( -- * High level, one-shot API + -- $highlevel + serialise + , deserialise + , deserialiseOrFail + + -- * Deserialisation exceptions + , CBOR.Read.DeserialiseFailure(..) + + -- * Incremental encoding interface + -- $primitives + , serialiseIncremental + , deserialiseIncremental + , CBOR.Read.IDecode(..) + + -- * The @'Serialise'@ class + , Serialise(..) + + -- * IO operations + -- | Convenient utilities for basic @'IO'@ operations. + + -- ** @'FilePath'@ API + , writeFileSerialise + , readFileDeserialise + -- ** @'Handle'@ API + , hPutSerialise + ) where + +import Control.Monad.ST +import System.IO (Handle, IOMode (..), withFile) +import Control.Exception (throw, throwIO) + +import qualified Data.ByteString.Builder as BS +import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString.Lazy.Internal as BS + +import Codec.Serialise.Class +import qualified Codec.CBOR.Read as CBOR.Read +import qualified Codec.CBOR.Write as CBOR.Write + + +-------------------------------------------------------------------------------- + +-- $primitives +-- The following API allows you to encode or decode CBOR values incrementally, +-- which is useful for large structures that require you to stream values in +-- over time. +-- + +-- | Serialise a Haskell value to an external binary representation. +-- +-- The output is represented as a 'BS.Builder' and is constructed incrementally. +-- The representation as a 'BS.Builder' allows efficient concatenation with +-- other data. +-- +-- @since 0.2.0.0 +serialiseIncremental :: Serialise a => a -> BS.Builder +serialiseIncremental = CBOR.Write.toBuilder . encode + +-- | Deserialise a Haskell value from the external binary representation. +-- +-- This allows /input/ data to be provided incrementally, rather than all in one +-- go. It also gives an explicit representation of deserialisation errors. +-- +-- Note that the incremental behaviour is only for the input data, not the +-- output value: the final deserialised value is constructed and returned as a +-- whole, not incrementally. +-- +-- @since 0.2.0.0 +deserialiseIncremental :: Serialise a => ST s (CBOR.Read.IDecode s a) +deserialiseIncremental = CBOR.Read.deserialiseIncremental decode + +-------------------------------------------------------------------------------- + +-- $highlevel +-- The following API exposes a high level interface allowing you to quickly +-- convert between arbitrary Haskell values (which are an instance of +-- @'Serialise'@) and lazy @'BS.ByteString'@s. +-- + +-- | Serialise a Haskell value to an external binary representation. +-- +-- The output is represented as a lazy 'BS.ByteString' and is constructed +-- incrementally. +-- +-- @since 0.2.0.0 +serialise :: Serialise a => a -> BS.ByteString +serialise = CBOR.Write.toLazyByteString . encode + +-- | Deserialise a Haskell value from the external binary representation +-- (which must have been made using 'serialise' or related function). +-- +-- /Throws/: @'CBOR.Read.DeserialiseFailure'@ if the given external +-- representation is invalid or does not correspond to a value of the +-- expected type. +-- +-- @since 0.2.0.0 +deserialise :: Serialise a => BS.ByteString -> a +deserialise bs0 = + runST (supplyAllInput bs0 =<< deserialiseIncremental) + where + supplyAllInput _bs (CBOR.Read.Done _ _ x) = return x + supplyAllInput bs (CBOR.Read.Partial k) = + case bs of + BS.Chunk chunk bs' -> k (Just chunk) >>= supplyAllInput bs' + BS.Empty -> k Nothing >>= supplyAllInput BS.Empty + supplyAllInput _ (CBOR.Read.Fail _ _ exn) = throw exn + +-- | Deserialise a Haskell value from the external binary representation, +-- or get back a @'DeserialiseFailure'@. +-- +-- @since 0.2.0.0 +deserialiseOrFail :: Serialise a => BS.ByteString -> Either CBOR.Read.DeserialiseFailure a +deserialiseOrFail bs0 = + runST (supplyAllInput bs0 =<< deserialiseIncremental) + where + supplyAllInput _bs (CBOR.Read.Done _ _ x) = return (Right x) + supplyAllInput bs (CBOR.Read.Partial k) = + case bs of + BS.Chunk chunk bs' -> k (Just chunk) >>= supplyAllInput bs' + BS.Empty -> k Nothing >>= supplyAllInput BS.Empty + supplyAllInput _ (CBOR.Read.Fail _ _ exn) = return (Left exn) + +-------------------------------------------------------------------------------- +-- File-based API + +-- | Serialise a @'BS.ByteString'@ (via @'serialise'@) and write it directly +-- to the specified @'Handle'@. +-- +-- @since 0.2.0.0 +hPutSerialise :: Serialise a + => Handle -- ^ The @'Handle'@ to write to. + -> a -- ^ The value to be serialised and written. + -> IO () +hPutSerialise hnd x = BS.hPut hnd (serialise x) + +-- | Serialise a @'BS.ByteString'@ and write it directly to the +-- specified file. +-- +-- @since 0.2.0.0 +writeFileSerialise :: Serialise a + => FilePath -- ^ The file to write to. + -> a -- ^ The value to be serialised and written. + -> IO () +writeFileSerialise fname x = + withFile fname WriteMode $ \hnd -> hPutSerialise hnd x + +-- | Read the specified file (internally, by reading a @'BS.ByteString'@) +-- and attempt to decode it into a Haskell value using @'deserialise'@ +-- (the type of which is determined by the choice of the result type). +-- +-- /Throws/: @'CBOR.Read.DeserialiseFailure'@ if the file fails to +-- deserialise properly. +-- +-- @since 0.2.0.0 +readFileDeserialise :: Serialise a + => FilePath -- ^ The file to read from. + -> IO a -- ^ The deserialised value. +readFileDeserialise fname = + withFile fname ReadMode $ \hnd -> do + input <- BS.hGetContents hnd + case deserialiseOrFail input of + Left err -> throwIO err + Right x -> return x diff --git a/src/Codec/Serialise/Class.hs b/src/Codec/Serialise/Class.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Serialise/Class.hs @@ -0,0 +1,1596 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module : Codec.Serialise.Class +-- Copyright : (c) Duncan Coutts 2015-2017 +-- License : BSD3-style (see LICENSE.txt) +-- +-- Maintainer : duncan@community.haskell.org +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- The @'Serialise'@ class allows you to encode a given type into a +-- CBOR object, or decode a CBOR object into the user-specified type. +-- +module Codec.Serialise.Class + ( -- * The Serialise class + Serialise(..) + , GSerialiseEncode(..) + , GSerialiseDecode(..) + , encodeVector + , decodeVector + ) where + +import Control.Applicative + +import Control.Monad +import Data.Hashable +import Data.Int +import Data.Monoid +import Data.Proxy +import Data.Version +import Data.Word +import Data.Complex +import Data.Fixed +import Data.Ratio +import Data.Ord + +#if MIN_VERSION_base(4,8,0) +import Numeric.Natural +import Data.Functor.Identity +#endif + +#if MIN_VERSION_base(4,9,0) +import qualified Data.Semigroup as Semigroup +import qualified Data.List.NonEmpty as NonEmpty +#endif + +import qualified Data.Foldable as Foldable +import qualified Data.ByteString as BS +import qualified Data.Text as Text + +-- TODO FIXME: more instances +--import qualified Data.Array as Array +--import qualified Data.Array.Unboxed as UArray +import qualified Data.ByteString.Lazy as BS.Lazy +import qualified Data.Map as Map +import qualified Data.Sequence as Sequence +import qualified Data.Set as Set +import qualified Data.IntSet as IntSet +import qualified Data.IntMap as IntMap +import qualified Data.HashSet as HashSet +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Tree as Tree +import qualified Data.Vector as Vector +import qualified Data.Vector.Unboxed as Vector.Unboxed +import qualified Data.Vector.Storable as Vector.Storable +import qualified Data.Vector.Primitive as Vector.Primitive +import qualified Data.Vector.Generic as Vector.Generic +import qualified Data.Text.Lazy as Text.Lazy +import Foreign.C.Types +import qualified Numeric.Half as Half + +import Data.Time (UTCTime (..), addUTCTime) +import Data.Time.Calendar (fromGregorian) +import Data.Time.Clock.POSIX (POSIXTime, utcTimeToPOSIXSeconds, + posixSecondsToUTCTime) +#if MIN_VERSION_time(1,5,0) +import Data.Time.Format (defaultTimeLocale, parseTimeM) +#else +import Data.Time.Format (parseTime) +import System.Locale (defaultTimeLocale) +#endif +import System.Exit (ExitCode(..)) + +import Prelude hiding (decodeFloat, encodeFloat, foldr) +import qualified Prelude +#if MIN_VERSION_base(4,10,0) +import Type.Reflection +import Type.Reflection.Unsafe +import GHC.Fingerprint +import GHC.Exts (VecCount(..), VecElem(..), RuntimeRep(..)) +import Data.Kind (Type) +#else +import Data.Typeable.Internal +#endif +import GHC.Generics + +import Codec.CBOR.Decoding +import Codec.CBOR.Encoding +import Codec.CBOR.Term + + +-------------------------------------------------------------------------------- +-- The Serialise class + +-- | Types that are instances of the @'Serialise'@ class allow values +-- to be quickly encoded or decoded directly to a CBOR representation, +-- for object transmission or storage. +-- +-- @since 0.2.0.0 +class Serialise a where + -- | Definition for encoding a given type into a binary + -- representation, using the @'Encoding'@ @'Monoid'@. + -- + -- @since 0.2.0.0 + encode :: a -> Encoding + default encode :: (Generic a, GSerialiseEncode (Rep a)) => a -> Encoding + encode = gencode . from + + -- | Definition of a given @'Decoder'@ for a type. + -- + -- @since 0.2.0.0 + decode :: Decoder s a + default decode :: (Generic a, GSerialiseDecode (Rep a)) => Decoder s a + decode = to <$> gdecode + + -- | Utility to support specialised encoding for some list type - + -- used for @'Char'@/@'String'@ instances in this package. + -- + -- @since 0.2.0.0 + encodeList :: [a] -> Encoding + encodeList = defaultEncodeList + + -- | Utility to support specialised decoding for some list type - + -- used for @'Char'@/@'String'@ instances in this package. + -- + -- @since 0.2.0.0 + decodeList :: Decoder s [a] + decodeList = defaultDecodeList + +-- | @since 0.2.0.0 +instance Serialise Term where + encode = encodeTerm + decode = decodeTerm + +-------------------------------------------------------------------------------- +-- Special list business + +-- | @since 0.2.0.0 +instance Serialise a => Serialise [a] where + encode = encodeList + decode = decodeList + +-- | Default @'Encoding'@ for list types. +-- +-- @since 0.2.0.0 +defaultEncodeList :: Serialise a => [a] -> Encoding +defaultEncodeList [] = encodeListLen 0 +defaultEncodeList xs = encodeListLenIndef + <> Prelude.foldr (\x r -> encode x <> r) encodeBreak xs + +-- | Default @'Decoder'@ for list types. +-- +-- @since 0.2.0.0 +defaultDecodeList :: Serialise a => Decoder s [a] +defaultDecodeList = do + mn <- decodeListLenOrIndef + case mn of + Nothing -> decodeSequenceLenIndef (flip (:)) [] reverse decode + Just n -> decodeSequenceLenN (flip (:)) [] reverse n decode + +-------------------------------------------------------------------------------- +-- Another case: NonEmpty lists + +#if MIN_VERSION_base(4,9,0) +-- | @since 0.2.0.0 +instance Serialise a => Serialise (NonEmpty.NonEmpty a) where + encode = defaultEncodeList . NonEmpty.toList + decode = do + l <- defaultDecodeList + case NonEmpty.nonEmpty l of + Nothing -> fail "Expected a NonEmpty list, but an empty list was found!" + Just xs -> return xs +#endif + +-------------------------------------------------------------------------------- +-- Primitive and integral instances + +-- | @since 0.2.0.0 +instance Serialise () where + encode = const encodeNull + decode = decodeNull + +-- | @since 0.2.0.0 +instance Serialise Bool where + encode = encodeBool + decode = decodeBool + +-- | @since 0.2.0.0 +instance Serialise Int where + encode = encodeInt + decode = decodeInt + +-- | @since 0.2.0.0 +instance Serialise Int8 where + encode = encodeInt8 + decode = decodeInt8 + +-- | @since 0.2.0.0 +instance Serialise Int16 where + encode = encodeInt16 + decode = decodeInt16 + +-- | @since 0.2.0.0 +instance Serialise Int32 where + encode = encodeInt32 + decode = decodeInt32 + +-- | @since 0.2.0.0 +instance Serialise Int64 where + encode = encodeInt64 + decode = decodeInt64 + +-- | @since 0.2.0.0 +instance Serialise Word where + encode = encodeWord + decode = decodeWord + +-- | @since 0.2.0.0 +instance Serialise Word8 where + encode = encodeWord8 + decode = decodeWord8 + +-- | @since 0.2.0.0 +instance Serialise Word16 where + encode = encodeWord16 + decode = decodeWord16 + +-- | @since 0.2.0.0 +instance Serialise Word32 where + encode = encodeWord32 + decode = decodeWord32 + +-- | @since 0.2.0.0 +instance Serialise Word64 where + encode = encodeWord64 + decode = decodeWord64 + +-- | @since 0.2.0.0 +instance Serialise Integer where + encode = encodeInteger + decode = decodeInteger + +#if MIN_VERSION_base(4,8,0) +-- | @since 0.2.0.0 +instance Serialise Natural where + encode = encodeInteger . toInteger + decode = do + n <- decodeInteger + if n >= 0 + then return (fromInteger n) + else fail "Expected non-negative Natural; but got a negative number" +#endif + +-- | @since 0.2.0.0 +instance Serialise Float where + encode = encodeFloat + decode = decodeFloat + +-- | @since 0.2.0.0 +instance Serialise Double where + encode = encodeDouble + decode = decodeDouble + +-- | @since 0.2.0.0 +instance Serialise Half.Half where + encode = encodeFloat16 . Half.fromHalf + decode = fmap Half.toHalf decodeFloat + +-------------------------------------------------------------------------------- +-- Core types + +#if MIN_VERSION_base(4,7,0) +-- | Values are serialised in units of least precision represented as +-- @Integer@. +-- +-- @since 0.2.0.0 +instance Serialise (Fixed e) where + encode (MkFixed i) = encode i + decode = MkFixed <$> decode + +-- | @since 0.2.0.0 +instance Serialise (Proxy a) where + encode _ = encodeNull + decode = Proxy <$ decodeNull +#endif + +-- | @since 0.2.0.0 +instance Serialise Char where + encode c = encodeString (Text.singleton c) + decode = do t <- decodeString + if Text.length t == 1 + then return $! Text.head t + else fail "expected a single char, found a string" + + -- For [Char]/String we have a special encoding + encodeList cs = encodeString (Text.pack cs) + decodeList = do txt <- decodeString + return (Text.unpack txt) -- unpack lazily + +-- | @since 0.2.0.0 +instance Serialise Text.Text where + encode = encodeString + decode = decodeString + +-- | @since 0.2.0.0 +instance Serialise BS.ByteString where + encode = encodeBytes + decode = decodeBytes + +encodeChunked :: Serialise c + => Encoding + -> ((c -> Encoding -> Encoding) -> Encoding -> a -> Encoding) + -> a + -> Encoding +encodeChunked encodeIndef foldrChunks a = + encodeIndef + <> foldrChunks (\x r -> encode x <> r) encodeBreak a + +decodeChunked :: Serialise c => Decoder s () -> ([c] -> a) -> Decoder s a +decodeChunked decodeIndef fromChunks = do + decodeIndef + decodeSequenceLenIndef (flip (:)) [] (fromChunks . reverse) decode + +-- | @since 0.2.0.0 +instance Serialise Text.Lazy.Text where + encode = encodeChunked encodeStringIndef Text.Lazy.foldrChunks + decode = decodeChunked decodeStringIndef Text.Lazy.fromChunks + +-- | @since 0.2.0.0 +instance Serialise BS.Lazy.ByteString where + encode = encodeChunked encodeBytesIndef BS.Lazy.foldrChunks + decode = decodeChunked decodeBytesIndef BS.Lazy.fromChunks + +-- | @since 0.2.0.0 +instance Serialise a => Serialise (Const a b) where + encode (Const a) = encode a + decode = Const <$> decode + +-- | @since 0.2.0.0 +instance Serialise a => Serialise (ZipList a) where + encode (ZipList xs) = encode xs + decode = ZipList <$> decode + +-- | @since 0.2.0.0 +instance (Serialise a, Integral a) => Serialise (Ratio a) where + encode a = encodeListLen 2 + <> encode (numerator a) + <> encode (denominator a) + decode = do decodeListLenOf 2 + !a <- decode + !b <- decode + return $ a % b + +-- | @since 0.2.0.0 +instance Serialise a => Serialise (Complex a) where + encode (r :+ i) = encodeListLen 2 + <> encode r + <> encode i + decode = do decodeListLenOf 2 + !r <- decode + !i <- decode + return $ r :+ i + +-- | @since 0.2.0.0 +instance Serialise Ordering where + encode a = encodeListLen 1 + <> encodeWord (case a of LT -> 0 + EQ -> 1 + GT -> 2) + decode = do + decodeListLenOf 1 + t <- decodeWord + case t of + 0 -> return LT + 1 -> return EQ + 2 -> return GT + _ -> fail "unexpected tag" + +-- | @since 0.2.0.0 +instance Serialise a => Serialise (Down a) where + encode (Down a) = encode a + decode = Down <$> decode + +-- | @since 0.2.0.0 +instance Serialise a => Serialise (Dual a) where + encode (Dual a) = encode a + decode = Dual <$> decode + +-- | @since 0.2.0.0 +instance Serialise All where + encode (All b) = encode b + decode = All <$> decode + +-- | @since 0.2.0.0 +instance Serialise Any where + encode (Any b) = encode b + decode = Any <$> decode + +-- | @since 0.2.0.0 +instance Serialise a => Serialise (Sum a) where + encode (Sum b) = encode b + decode = Sum <$> decode + +-- | @since 0.2.0.0 +instance Serialise a => Serialise (Product a) where + encode (Product b) = encode b + decode = Product <$> decode + +-- | @since 0.2.0.0 +instance Serialise a => Serialise (First a) where + encode (First b) = encode b + decode = First <$> decode + +-- | @since 0.2.0.0 +instance Serialise a => Serialise (Last a) where + encode (Last b) = encode b + decode = Last <$> decode + +#if MIN_VERSION_base(4,8,0) +-- | @since 0.2.0.0 +instance Serialise (f a) => Serialise (Alt f a) where + encode (Alt b) = encode b + decode = Alt <$> decode + +-- | @since 0.2.0.0 +instance Serialise a => Serialise (Identity a) where + encode (Identity b) = encode b + decode = Identity <$> decode +#endif + +-- | @since 0.2.0.0 +instance Serialise ExitCode where + encode ExitSuccess = encodeListLen 1 + <> encodeWord 0 + encode (ExitFailure i) = encodeListLen 2 + <> encodeWord 1 + <> encode i + decode = do + n <- decodeListLen + case n of + 1 -> do t <- decodeWord + case t of + 0 -> return ExitSuccess + _ -> fail "unexpected tag" + 2 -> do t <- decodeWord + case t of + 1 -> return () + _ -> fail "unexpected tag" + !i <- decode + return $ ExitFailure i + _ -> fail "Bad list length" + +-- Semigroup instances for GHC 8.0+ +#if MIN_VERSION_base(4,9,0) +-- | @since 0.2.0.0 +instance Serialise a => Serialise (Semigroup.Min a) where + encode = encode . Semigroup.getMin + decode = fmap Semigroup.Min decode + +-- | @since 0.2.0.0 +instance Serialise a => Serialise (Semigroup.Max a) where + encode = encode . Semigroup.getMax + decode = fmap Semigroup.Max decode + +-- | @since 0.2.0.0 +instance Serialise a => Serialise (Semigroup.First a) where + encode = encode . Semigroup.getFirst + decode = fmap Semigroup.First decode + +-- | @since 0.2.0.0 +instance Serialise a => Serialise (Semigroup.Last a) where + encode = encode . Semigroup.getLast + decode = fmap Semigroup.Last decode + +-- | @since 0.2.0.0 +instance Serialise a => Serialise (Semigroup.Option a) where + encode = encode . Semigroup.getOption + decode = fmap Semigroup.Option decode + +instance Serialise a => Serialise (Semigroup.WrappedMonoid a) where + encode = encode . Semigroup.unwrapMonoid + decode = fmap Semigroup.WrapMonoid decode +#endif + +-------------------------------------------------------------------------------- +-- Foreign types + +-- | @since 0.2.0.0 +instance Serialise CChar where + encode (CChar x) = encode x + decode = CChar <$> decode + +-- | @since 0.2.0.0 +instance Serialise CSChar where + encode (CSChar x) = encode x + decode = CSChar <$> decode + +-- | @since 0.2.0.0 +instance Serialise CUChar where + encode (CUChar x) = encode x + decode = CUChar <$> decode + +-- | @since 0.2.0.0 +instance Serialise CShort where + encode (CShort x) = encode x + decode = CShort <$> decode + +-- | @since 0.2.0.0 +instance Serialise CUShort where + encode (CUShort x) = encode x + decode = CUShort <$> decode + +-- | @since 0.2.0.0 +instance Serialise CInt where + encode (CInt x) = encode x + decode = CInt <$> decode + +-- | @since 0.2.0.0 +instance Serialise CUInt where + encode (CUInt x) = encode x + decode = CUInt <$> decode + +-- | @since 0.2.0.0 +instance Serialise CLong where + encode (CLong x) = encode x + decode = CLong <$> decode + +-- | @since 0.2.0.0 +instance Serialise CULong where + encode (CULong x) = encode x + decode = CULong <$> decode + +-- | @since 0.2.0.0 +instance Serialise CPtrdiff where + encode (CPtrdiff x) = encode x + decode = CPtrdiff <$> decode + +-- | @since 0.2.0.0 +instance Serialise CSize where + encode (CSize x) = encode x + decode = CSize <$> decode + +-- | @since 0.2.0.0 +instance Serialise CWchar where + encode (CWchar x) = encode x + decode = CWchar <$> decode + +-- | @since 0.2.0.0 +instance Serialise CSigAtomic where + encode (CSigAtomic x) = encode x + decode = CSigAtomic <$> decode + +-- | @since 0.2.0.0 +instance Serialise CLLong where + encode (CLLong x) = encode x + decode = CLLong <$> decode + +-- | @since 0.2.0.0 +instance Serialise CULLong where + encode (CULLong x) = encode x + decode = CULLong <$> decode + +-- | @since 0.2.0.0 +instance Serialise CIntPtr where + encode (CIntPtr x) = encode x + decode = CIntPtr <$> decode + +-- | @since 0.2.0.0 +instance Serialise CUIntPtr where + encode (CUIntPtr x) = encode x + decode = CUIntPtr <$> decode + +-- | @since 0.2.0.0 +instance Serialise CIntMax where + encode (CIntMax x) = encode x + decode = CIntMax <$> decode + +-- | @since 0.2.0.0 +instance Serialise CUIntMax where + encode (CUIntMax x) = encode x + decode = CUIntMax <$> decode + +-- | @since 0.2.0.0 +instance Serialise CClock where + encode (CClock x) = encode x + decode = CClock <$> decode + +-- | @since 0.2.0.0 +instance Serialise CTime where + encode (CTime x) = encode x + decode = CTime <$> decode + +-- | @since 0.2.0.0 +instance Serialise CUSeconds where + encode (CUSeconds x) = encode x + decode = CUSeconds <$> decode + +-- | @since 0.2.0.0 +instance Serialise CSUSeconds where + encode (CSUSeconds x) = encode x + decode = CSUSeconds <$> decode + +-- | @since 0.2.0.0 +instance Serialise CFloat where + encode (CFloat x) = encode x + decode = CFloat <$> decode + +-- | @since 0.2.0.0 +instance Serialise CDouble where + encode (CDouble x) = encode x + decode = CDouble <$> decode + +-------------------------------------------------------------------------------- +-- Structural instances + +-- | @since 0.2.0.0 +instance (Serialise a, Serialise b) => Serialise (a,b) where + encode (a,b) = encodeListLen 2 + <> encode a + <> encode b + decode = do decodeListLenOf 2 + !x <- decode + !y <- decode + return (x, y) + +-- | @since 0.2.0.0 +instance (Serialise a, Serialise b, Serialise c) => Serialise (a,b,c) where + encode (a,b,c) = encodeListLen 3 + <> encode a + <> encode b + <> encode c + + decode = do decodeListLenOf 3 + !x <- decode + !y <- decode + !z <- decode + return (x, y, z) + +-- | @since 0.2.0.0 +instance (Serialise a, Serialise b, Serialise c, Serialise d + ) => Serialise (a,b,c,d) where + encode (a,b,c,d) = encodeListLen 4 + <> encode a + <> encode b + <> encode c + <> encode d + + decode = do decodeListLenOf 4 + !a <- decode + !b <- decode + !c <- decode + !d <- decode + return (a, b, c, d) + +-- | @since 0.2.0.0 +instance (Serialise a, Serialise b, Serialise c, Serialise d, Serialise e + ) => Serialise (a,b,c,d,e) where + encode (a,b,c,d,e) = encodeListLen 5 + <> encode a + <> encode b + <> encode c + <> encode d + <> encode e + + decode = do decodeListLenOf 5 + !a <- decode + !b <- decode + !c <- decode + !d <- decode + !e <- decode + return (a, b, c, d, e) + +-- | @since 0.2.0.0 +instance ( Serialise a, Serialise b, Serialise c, Serialise d, Serialise e + , Serialise f + ) => Serialise (a,b,c,d,e,f) where + encode (a,b,c,d,e,f) = encodeListLen 6 + <> encode a + <> encode b + <> encode c + <> encode d + <> encode e + <> encode f + + decode = do decodeListLenOf 6 + !a <- decode + !b <- decode + !c <- decode + !d <- decode + !e <- decode + !f <- decode + return (a, b, c, d, e, f) + +-- | @since 0.2.0.0 +instance ( Serialise a, Serialise b, Serialise c, Serialise d, Serialise e + , Serialise f, Serialise g + ) => Serialise (a,b,c,d,e,f,g) where + encode (a,b,c,d,e,f,g) = encodeListLen 7 + <> encode a + <> encode b + <> encode c + <> encode d + <> encode e + <> encode f + <> encode g + + decode = do decodeListLenOf 7 + !a <- decode + !b <- decode + !c <- decode + !d <- decode + !e <- decode + !f <- decode + !g <- decode + return (a, b, c, d, e, f, g) + +-- | @since 0.2.0.0 +instance ( Serialise a, Serialise b, Serialise c, Serialise d, Serialise e + , Serialise f, Serialise g, Serialise h + ) => Serialise (a,b,c,d,e,f,g,h) where + encode (a,b,c,d,e,f,g,h) = encodeListLen 8 + <> encode a + <> encode b + <> encode c + <> encode d + <> encode e + <> encode f + <> encode g + <> encode h + + decode = do decodeListLenOf 8 + !a <- decode + !b <- decode + !c <- decode + !d <- decode + !e <- decode + !f <- decode + !g <- decode + !h <- decode + return (a, b, c, d, e, f, g, h) + +-- | @since 0.2.0.0 +instance ( Serialise a, Serialise b, Serialise c, Serialise d, Serialise e + , Serialise f, Serialise g, Serialise h, Serialise i + ) => Serialise (a,b,c,d,e,f,g,h,i) where + encode (a,b,c,d,e,f,g,h,i) = encodeListLen 9 + <> encode a + <> encode b + <> encode c + <> encode d + <> encode e + <> encode f + <> encode g + <> encode h + <> encode i + + decode = do decodeListLenOf 9 + !a <- decode + !b <- decode + !c <- decode + !d <- decode + !e <- decode + !f <- decode + !g <- decode + !h <- decode + !i <- decode + return (a, b, c, d, e, f, g, h, i) + +-- | @since 0.2.0.0 +instance Serialise a => Serialise (Maybe a) where + encode Nothing = encodeListLen 0 + encode (Just x) = encodeListLen 1 <> encode x + + decode = do n <- decodeListLen + case n of + 0 -> return Nothing + 1 -> do !x <- decode + return (Just x) + _ -> fail "unknown tag" + +-- | @since 0.2.0.0 +instance (Serialise a, Serialise b) => Serialise (Either a b) where + encode (Left x) = encodeListLen 2 <> encodeWord 0 <> encode x + encode (Right x) = encodeListLen 2 <> encodeWord 1 <> encode x + + decode = do decodeListLenOf 2 + t <- decodeWord + case t of + 0 -> do !x <- decode + return (Left x) + 1 -> do !x <- decode + return (Right x) + _ -> fail "unknown tag" + + +-------------------------------------------------------------------------------- +-- Container instances + +-- | @since 0.2.0.0 +instance Serialise a => Serialise (Tree.Tree a) where + encode (Tree.Node r sub) = encodeListLen 2 <> encode r <> encode sub + decode = decodeListLenOf 2 *> (Tree.Node <$> decode <*> decode) + +encodeContainerSkel :: (Word -> Encoding) + -> (container -> Int) + -> (accumFunc -> Encoding -> container -> Encoding) + -> accumFunc + -> container + -> Encoding +encodeContainerSkel encodeLen size foldr f c = + encodeLen (fromIntegral (size c)) <> foldr f mempty c +{-# INLINE encodeContainerSkel #-} + +decodeContainerSkelWithReplicate + :: (Serialise a) + => Decoder s Int + -- ^ How to get the size of the container + -> (Int -> Decoder s a -> Decoder s container) + -- ^ replicateM for the container + -> ([container] -> container) + -- ^ concat for the container + -> Decoder s container +decodeContainerSkelWithReplicate decodeLen replicateFun fromList = do + -- Look at how much data we have at the moment and use it as the limit for + -- the size of a single call to replicateFun. We don't want to use + -- replicateFun directly on the result of decodeLen since this might lead to + -- DOS attack (attacker providing a huge value for length). So if it's above + -- our limit, we'll do manual chunking and then combine the containers into + -- one. + size <- decodeLen + limit <- peekAvailable + if size <= limit + then replicateFun size decode + else do + -- Take the max of limit and a fixed chunk size (note: limit can be + -- 0). This basically means that the attacker can make us allocate a + -- container of size 128 even though there's no actual input. + let chunkSize = max limit 128 + (d, m) = size `divMod` chunkSize + buildOne s = replicateFun s decode + containers <- sequence $ buildOne m : replicate d (buildOne chunkSize) + return $! fromList containers +{-# INLINE decodeContainerSkelWithReplicate #-} + +-- | @since 0.2.0.0 +instance (Serialise a) => Serialise (Sequence.Seq a) where + encode = encodeContainerSkel + encodeListLen + Sequence.length + Foldable.foldr + (\a b -> encode a <> b) + decode = decodeContainerSkelWithReplicate + decodeListLen + Sequence.replicateM + mconcat + +-- | Generic encoder for vectors. Its intended use is to allow easy +-- definition of 'Serialise' instances for custom vector +-- +-- @since 0.2.0.0 +encodeVector :: (Serialise a, Vector.Generic.Vector v a) + => v a -> Encoding +encodeVector = encodeContainerSkel + encodeListLen + Vector.Generic.length + Vector.Generic.foldr + (\a b -> encode a <> b) +{-# INLINE encodeVector #-} + +-- | Generic decoder for vectors. Its intended use is to allow easy +-- definition of 'Serialise' instances for custom vector +-- +-- @since 0.2.0.0 +decodeVector :: (Serialise a, Vector.Generic.Vector v a) + => Decoder s (v a) +decodeVector = decodeContainerSkelWithReplicate + decodeListLen + Vector.Generic.replicateM + Vector.Generic.concat +{-# INLINE decodeVector #-} + +-- | @since 0.2.0.0 +instance (Serialise a) => Serialise (Vector.Vector a) where + encode = encodeVector + {-# INLINE encode #-} + decode = decodeVector + {-# INLINE decode #-} + +-- | @since 0.2.0.0 +instance (Serialise a, Vector.Unboxed.Unbox a) => + Serialise (Vector.Unboxed.Vector a) where + encode = encodeVector + {-# INLINE encode #-} + decode = decodeVector + {-# INLINE decode #-} + +-- | @since 0.2.0.0 +instance (Serialise a, Vector.Storable.Storable a) => Serialise (Vector.Storable.Vector a) where + encode = encodeVector + {-# INLINE encode #-} + decode = decodeVector + {-# INLINE decode #-} + +-- | @since 0.2.0.0 +instance (Serialise a, Vector.Primitive.Prim a) => Serialise (Vector.Primitive.Vector a) where + encode = encodeVector + {-# INLINE encode #-} + decode = decodeVector + {-# INLINE decode #-} + + + +encodeSetSkel :: Serialise a + => (s -> Int) + -> ((a -> Encoding -> Encoding) -> Encoding -> s -> Encoding) + -> s + -> Encoding +encodeSetSkel size foldr = + encodeContainerSkel encodeListLen size foldr (\a b -> encode a <> b) +{-# INLINE encodeSetSkel #-} + +decodeSetSkel :: Serialise a + => ([a] -> c) -> Decoder s c +decodeSetSkel fromList = do + n <- decodeListLen + fmap fromList (replicateM n decode) +{-# INLINE decodeSetSkel #-} + +-- | @since 0.2.0.0 +instance (Ord a, Serialise a) => Serialise (Set.Set a) where + encode = encodeSetSkel Set.size Set.foldr + decode = decodeSetSkel Set.fromList + +-- | @since 0.2.0.0 +instance Serialise IntSet.IntSet where + encode = encodeSetSkel IntSet.size IntSet.foldr + decode = decodeSetSkel IntSet.fromList + +-- | @since 0.2.0.0 +instance (Serialise a, Hashable a, Eq a) => Serialise (HashSet.HashSet a) where + encode = encodeSetSkel HashSet.size HashSet.foldr + decode = decodeSetSkel HashSet.fromList + +encodeMapSkel :: (Serialise k, Serialise v) + => (m -> Int) + -> ((k -> v -> Encoding -> Encoding) -> Encoding -> m -> Encoding) + -> m + -> Encoding +encodeMapSkel size foldrWithKey = + encodeContainerSkel + encodeMapLen + size + foldrWithKey + (\k v b -> encode k <> encode v <> b) +{-# INLINE encodeMapSkel #-} + +decodeMapSkel :: (Serialise k, Serialise v) + => ([(k,v)] -> m) + -> Decoder s m +decodeMapSkel fromList = do + n <- decodeMapLen + let decodeEntry = do + !k <- decode + !v <- decode + return (k, v) + fmap fromList (replicateM n decodeEntry) +{-# INLINE decodeMapSkel #-} + +-- | @since 0.2.0.0 +instance (Ord k, Serialise k, Serialise v) => Serialise (Map.Map k v) where + encode = encodeMapSkel Map.size Map.foldrWithKey + decode = decodeMapSkel Map.fromList + +-- | @since 0.2.0.0 +instance (Serialise a) => Serialise (IntMap.IntMap a) where + encode = encodeMapSkel IntMap.size IntMap.foldrWithKey + decode = decodeMapSkel IntMap.fromList + +-- | @since 0.2.0.0 +instance (Serialise k, Hashable k, Eq k, Serialise v) => + Serialise (HashMap.HashMap k v) where + encode = encodeMapSkel HashMap.size HashMap.foldrWithKey + decode = decodeMapSkel HashMap.fromList + + +-------------------------------------------------------------------------------- +-- Misc base package instances + +-- | @since 0.2.0.0 +instance Serialise Version where + encode (Version ns ts) = encodeListLen 3 + <> encodeWord 0 <> encode ns <> encode ts + decode = do + len <- decodeListLen + tag <- decodeWord + case tag of + 0 | len == 3 + -> do !x <- decode + !y <- decode + return (Version x y) + _ -> fail "unexpected tag" + +-- | @since 0.2.0.0 +instance Serialise Fingerprint where + encode (Fingerprint w1 w2) = encodeListLen 3 + <> encodeWord 0 + <> encode w1 + <> encode w2 + decode = do + decodeListLenOf 3 + tag <- decodeWord + case tag of + 0 -> do !w1 <- decode + !w2 <- decode + return $! Fingerprint w1 w2 + _ -> fail "unexpected tag" + +-- | @since 0.2.0.0 +instance Serialise TyCon where +#if MIN_VERSION_base(4,10,0) + encode tc + = encodeListLen 6 + <> encodeWord 0 + <> encode (tyConPackage tc) + <> encode (tyConModule tc) + <> encode (tyConName tc) + <> encode (tyConKindArgs tc) + <> encode (tyConKindRep tc) + decode = do + decodeListLenOf 6 + tag <- decodeWord + case tag of + 0 -> mkTyCon <$> decode <*> decode <*> decode <*> decode <*> decode + _ -> fail "unexpected tag" +#elif MIN_VERSION_base(4,9,0) + encode tycon + = encodeListLen 4 + <> encodeWord 0 + <> encode (tyConPackage tycon) + <> encode (tyConModule tycon) + <> encode (tyConName tycon) +#else + encode (TyCon _ pkg modname name) + = encodeListLen 4 + <> encodeWord 0 + <> encode pkg + <> encode modname + <> encode name +#endif + +#if !MIN_VERSION_base(4,10,0) + decode = do + decodeListLenOf 4 + tag <- decodeWord + case tag of + 0 -> do !pkg <- decode + !modname <- decode + !name <- decode + return $! mkTyCon3 pkg modname name + _ -> fail "unexpected tag" +#endif + +#if MIN_VERSION_base(4,10,0) +-- | @since 0.2.0.0 +instance Serialise VecCount where + encode c = encodeListLen 1 <> encodeWord (fromIntegral $ fromEnum c) + decode = do + decodeListLenOf 1 + toEnum . fromIntegral <$> decodeWord + +-- | @since 0.2.0.0 +instance Serialise VecElem where + encode e = encodeListLen 1 <> encodeWord (fromIntegral $ fromEnum e) + decode = do + decodeListLenOf 1 + toEnum . fromIntegral <$> decodeWord + +-- | @since 0.2.0.0 +instance Serialise RuntimeRep where + encode rr = + case rr of + VecRep a b -> encodeListLen 3 <> encodeWord 0 <> encode a <> encode b + TupleRep reps -> encodeListLen 2 <> encodeWord 1 <> encode reps + SumRep reps -> encodeListLen 2 <> encodeWord 2 <> encode reps + LiftedRep -> encodeListLen 1 <> encodeWord 3 + UnliftedRep -> encodeListLen 1 <> encodeWord 4 + IntRep -> encodeListLen 1 <> encodeWord 5 + WordRep -> encodeListLen 1 <> encodeWord 6 + Int64Rep -> encodeListLen 1 <> encodeWord 7 + Word64Rep -> encodeListLen 1 <> encodeWord 8 + AddrRep -> encodeListLen 1 <> encodeWord 9 + FloatRep -> encodeListLen 1 <> encodeWord 10 + DoubleRep -> encodeListLen 1 <> encodeWord 11 + + decode = do + len <- decodeListLen + tag <- decodeWord + case tag of + 0 | len == 3 -> VecRep <$> decode <*> decode + 1 | len == 2 -> TupleRep <$> decode + 2 | len == 2 -> SumRep <$> decode + 3 | len == 1 -> pure LiftedRep + 4 | len == 1 -> pure UnliftedRep + 5 | len == 1 -> pure IntRep + 6 | len == 1 -> pure WordRep + 7 | len == 1 -> pure Int64Rep + 8 | len == 1 -> pure Word64Rep + 9 | len == 1 -> pure AddrRep + 10 | len == 1 -> pure FloatRep + 11 | len == 1 -> pure DoubleRep + _ -> fail "Data.Serialise.Binary.CBOR.getRuntimeRep: invalid tag" + +-- | @since 0.2.0.0 +instance Serialise KindRep where + encode rep = + case rep of + KindRepTyConApp tc k -> encodeListLen 3 <> encodeWord 0 <> encode tc <> encode k + KindRepVar bndr -> encodeListLen 2 <> encodeWord 1 <> encode bndr + KindRepApp a b -> encodeListLen 3 <> encodeWord 2 <> encode a <> encode b + KindRepFun a b -> encodeListLen 3 <> encodeWord 3 <> encode a <> encode b + KindRepTYPE r -> encodeListLen 2 <> encodeWord 4 <> encode r + KindRepTypeLit sort r -> encodeListLen 3 <> encodeWord 5 <> encode sort <> encode r + + decode = do + len <- decodeListLen + tag <- decodeWord + case tag of + 0 | len == 3 -> KindRepTyConApp <$> decode <*> decode + 1 | len == 2 -> KindRepVar <$> decode + 2 | len == 3 -> KindRepApp <$> decode <*> decode + 3 | len == 3 -> KindRepFun <$> decode <*> decode + 4 | len == 2 -> KindRepTYPE <$> decode + 5 | len == 3 -> KindRepTypeLit <$> decode <*> decode + _ -> fail "Data.Serialise.Binary.CBOR.getKindRep: invalid tag" + +-- | @since 0.2.0.0 +instance Serialise TypeLitSort where + encode n + = encodeListLen 1 + <> case n of + TypeLitSymbol -> encodeWord 0 + TypeLitNat -> encodeWord 1 + decode = do + decodeListLenOf 1 + tag <- decodeWord + case tag of + 0 -> pure TypeLitSymbol + 1 -> pure TypeLitNat + _ -> fail "Data.Serialise.Binary.CBOR.putTypeLitSort: invalid tag" + +decodeSomeTypeRep :: Decoder s SomeTypeRep +decodeSomeTypeRep = do + len <- decodeListLen + tag <- decodeWord + case tag of + 0 | len == 1 -> + return $! SomeTypeRep (typeRep :: TypeRep Type) + 1 | len == 2 -> do + !con <- decode + !ks <- decode + return $! SomeTypeRep $ mkTrCon con ks + 2 | len == 2 -> do + SomeTypeRep f <- decodeSomeTypeRep + SomeTypeRep x <- decodeSomeTypeRep + case typeRepKind f of + Fun arg res -> + case arg `eqTypeRep` typeRepKind x of + Just HRefl -> do + case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of + Just HRefl -> return $! SomeTypeRep (mkTrApp f x) + _ -> failure "Kind mismatch" [] + _ -> failure "Kind mismatch" + [ "Found argument of kind: " ++ show (typeRepKind x) + , "Where the constructor: " ++ show f + , "Expects an argument of kind: " ++ show arg + ] + _ -> failure "Applied non-arrow type" + [ "Applied type: " ++ show f + , "To argument: " ++ show x + ] + 3 | len == 2 -> do + SomeTypeRep arg <- decodeSomeTypeRep + SomeTypeRep res <- decodeSomeTypeRep + case typeRepKind arg `eqTypeRep` (typeRep :: TypeRep Type) of + Just HRefl -> + case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of + Just HRefl -> return $! SomeTypeRep $ Fun arg res + Nothing -> failure "Kind mismatch" [] + Nothing -> failure "Kind mismatch" [] + _ -> failure "unexpected tag" [] + where + failure description info = + fail $ unlines $ [ "Codec.CBOR.Class.decodeSomeTypeRep: "++description ] + ++ map (" "++) info + +encodeTypeRep :: TypeRep a -> Encoding +encodeTypeRep rep -- Handle Type specially since it's so common + | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type) + = encodeListLen 1 + <> encodeWord 0 +encodeTypeRep (Con' con ks) + = encodeListLen 3 + <> encodeWord 1 + <> encode con + <> encode ks +encodeTypeRep (App f x) + = encodeListLen 3 + <> encodeWord 2 + <> encodeTypeRep f + <> encodeTypeRep x +encodeTypeRep (Fun arg res) + = encodeListLen 3 + <> encodeWord 3 + <> encodeTypeRep arg + <> encodeTypeRep res +encodeTypeRep _ = error "Codec.CBOR.Class.encodeTypeRep: Impossible" + +-- | @since 0.2.0.0 +instance Typeable a => Serialise (TypeRep (a :: k)) where + encode = encodeTypeRep + decode = do + SomeTypeRep rep <- decodeSomeTypeRep + case rep `eqTypeRep` expected of + Just HRefl -> pure rep + Nothing -> fail $ unlines + [ "Codec.CBOR.Class.decode(TypeRep): Type mismatch" + , " Deserialized type: " ++ show rep + , " Expected type: " ++ show expected + ] + where expected = typeRep :: TypeRep a + +-- | @since 0.2.0.0 +instance Serialise SomeTypeRep where + encode (SomeTypeRep rep) = encodeTypeRep rep + decode = decodeSomeTypeRep + +#else + +-- | @since 0.2.0.0 +instance Serialise TypeRep where +#if MIN_VERSION_base(4,8,0) + encode (TypeRep fp tycon kirep tyrep) + = encodeListLen 5 + <> encodeWord 0 + <> encode fp + <> encode tycon + <> encode kirep + <> encode tyrep + + decode = do + decodeListLenOf 5 + tag <- decodeWord + case tag of + 0 -> do !fp <- decode + !tycon <- decode + !kirep <- decode + !tyrep <- decode + return $! TypeRep fp tycon kirep tyrep + _ -> fail "unexpected tag" +#else + encode (TypeRep fp tycon tyrep) + = encodeListLen 4 + <> encodeWord 0 + <> encode fp + <> encode tycon + <> encode tyrep + + decode = do + decodeListLenOf 4 + tag <- decodeWord + case tag of + 0 -> do !fp <- decode + !tycon <- decode + !tyrep <- decode + return $! TypeRep fp tycon tyrep + _ -> fail "unexpected tag" +#endif + +#endif /* !MIN_VERBOSE_base(4,10,0) */ + +-------------------------------------------------------------------------------- +-- Time instances +-- +-- CBOR has some special encodings for times/timestamps + +-- | 'UTCTime' is encoded using the extended time format which is currently in +-- Internet Draft state, +-- https://tools.ietf.org/html/draft-bormann-cbor-time-tag-00. +-- +-- @since 0.2.0.0 +instance Serialise UTCTime where + encode t = + encodeTag 1000 + <> encodeMapLen 2 + <> encodeWord 1 <> encodeInt64 secs + <> encodeInt (-12) <> encodeWord64 psecs + where + (secs, frac) = case properFraction $ utcTimeToPOSIXSeconds t of + -- fractional part must be positive + (secs', frac') + | frac' < 0 -> (secs' - 1, frac' + 1) + | otherwise -> (secs', frac') + psecs = round $ frac * 1000000000000 + + decode = do + tag <- decodeTag + case tag of + 0 -> do str <- decodeString + case parseUTCrfc3339 (Text.unpack str) of + Just t -> return $! forceUTCTime t + Nothing -> fail "Could not parse RFC3339 date" + + 1 -> do + tt <- peekTokenType + case tt of + TypeUInt -> utcFromIntegral <$> decodeWord + TypeUInt64 -> utcFromIntegral <$> decodeWord64 + TypeNInt -> utcFromIntegral <$> decodeInt + TypeNInt64 -> utcFromIntegral <$> decodeInt64 + TypeInteger -> utcFromIntegral <$> decodeInteger + TypeFloat16 -> utcFromReal <$> decodeFloat + TypeFloat32 -> utcFromReal <$> decodeFloat + TypeFloat64 -> utcFromReal <$> decodeDouble + _ -> fail "Expected numeric type following tag 1 (epoch offset)" + + -- Extended time + 1000 -> do + len <- decodeMapLen + when (len /= 2) $ fail "Expected list of length two (UTCTime)" + + k0 <- decodeInt + when (k0 /= 1) $ fail "Expected key 1 in extended time" + v0 <- decodeInt64 + + k1 <- decodeInt + when (k1 /= (-12)) $ fail "Expected key -12 in extended time" + v1 <- decodeWord64 + let psecs :: Pico + psecs = realToFrac v1 / 1000000000000 + + dt :: POSIXTime + dt = realToFrac v0 + realToFrac psecs + return $! forceUTCTime (posixSecondsToUTCTime dt) + + _ -> fail "Expected timestamp (tag 0, 1, or 40)" + +epoch :: UTCTime +epoch = UTCTime (fromGregorian 1970 1 1) 0 + +{-# INLINE utcFromIntegral #-} +utcFromIntegral :: Integral a => a -> UTCTime +utcFromIntegral i = addUTCTime (fromIntegral i) epoch + +{-# INLINE utcFromReal #-} +utcFromReal :: Real a => a -> UTCTime +utcFromReal f = addUTCTime (fromRational (toRational f)) epoch + + +-- | @'UTCTime'@ parsing, from a regular @'String'@. +parseUTCrfc3339 :: String -> Maybe UTCTime +#if MIN_VERSION_time(1,5,0) +parseUTCrfc3339 = parseTimeM False defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Q%Z" +#else +parseUTCrfc3339 = parseTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Q%Z" +#endif + +-- | Force the unnecessarily lazy @'UTCTime'@ representation. +forceUTCTime :: UTCTime -> UTCTime +forceUTCTime t@(UTCTime !_day !_daytime) = t + +-------------------------------------------------------------------------------- +-- Generic instances + +-- Factored into two classes because this makes GHC optimize the +-- instances faster. This doesn't matter for builds of binary, but it +-- matters a lot for end-users who write 'instance Binary T'. See +-- also: https://ghc.haskell.org/trac/ghc/ticket/9630 + +-- | @since 0.2.0.0 +class GSerialiseEncode f where + -- | @since 0.2.0.0 + gencode :: f a -> Encoding + +-- | @since 0.2.0.0 +class GSerialiseDecode f where + -- | @since 0.2.0.0 + gdecode :: Decoder s (f a) + +-- | @since 0.2.0.0 +instance GSerialiseEncode V1 where + -- Data types without constructors are still serialised as null value + gencode _ = encodeNull + +-- | @since 0.2.0.0 +instance GSerialiseDecode V1 where + gdecode = error "V1 don't have contructors" <$ decodeNull + +-- | @since 0.2.0.0 +instance GSerialiseEncode U1 where + -- Constructors without fields are serialised as null value + gencode _ = encodeListLen 1 <> encodeWord 0 + +-- | @since 0.2.0.0 +instance GSerialiseDecode U1 where + gdecode = do + n <- decodeListLen + when (n /= 1) $ fail "expect list of length 1" + tag <- decodeWord + when (tag /= 0) $ fail "unexpected tag. Expect 0" + return U1 + +-- | @since 0.2.0.0 +instance GSerialiseEncode a => GSerialiseEncode (M1 i c a) where + -- Metadata (constructor name, etc) is skipped + gencode = gencode . unM1 + +-- | @since 0.2.0.0 +instance GSerialiseDecode a => GSerialiseDecode (M1 i c a) where + gdecode = M1 <$> gdecode + +-- | @since 0.2.0.0 +instance Serialise a => GSerialiseEncode (K1 i a) where + -- Constructor field (Could only appear in one-field & one-constructor + -- data types). In all other cases we go through GSerialise{Sum,Prod} + gencode (K1 a) = encodeListLen 2 + <> encodeWord 0 + <> encode a + +-- | @since 0.2.0.0 +instance Serialise a => GSerialiseDecode (K1 i a) where + gdecode = do + n <- decodeListLen + when (n /= 2) $ + fail "expect list of length 2" + tag <- decodeWord + when (tag /= 0) $ + fail "unexpected tag. Expects 0" + K1 <$> decode + +-- | @since 0.2.0.0 +instance (GSerialiseProd f, GSerialiseProd g) => GSerialiseEncode (f :*: g) where + -- Products are serialised as N-tuples with 0 constructor tag + gencode (f :*: g) + = encodeListLen (nFields (Proxy :: Proxy (f :*: g)) + 1) + <> encodeWord 0 + <> encodeSeq f + <> encodeSeq g + +-- | @since 0.2.0.0 +instance (GSerialiseProd f, GSerialiseProd g) => GSerialiseDecode (f :*: g) where + gdecode = do + let nF = nFields (Proxy :: Proxy (f :*: g)) + n <- decodeListLen + -- TODO FIXME: signedness of list length + when (fromIntegral n /= nF + 1) $ + fail $ "Wrong number of fields: expected="++show (nF+1)++" got="++show n + tag <- decodeWord + when (tag /= 0) $ + fail $ "unexpect tag (expect 0)" + !f <- gdecodeSeq + !g <- gdecodeSeq + return $ f :*: g + +-- | @since 0.2.0.0 +instance (GSerialiseSum f, GSerialiseSum g) => GSerialiseEncode (f :+: g) where + -- Sum types are serialised as N-tuples and first element is + -- constructor tag + gencode a = encodeListLen (numOfFields a + 1) + <> encode (conNumber a) + <> encodeSum a + +-- | @since 0.2.0.0 +instance (GSerialiseSum f, GSerialiseSum g) => GSerialiseDecode (f :+: g) where + gdecode = do + n <- decodeListLen + -- TODO FIXME: Again signedness + when (n == 0) $ + fail "Empty list encountered for sum type" + nCon <- decodeWord + trueN <- fieldsForCon (Proxy :: Proxy (f :+: g)) nCon + when (n-1 /= fromIntegral trueN ) $ + fail $ "Number of fields mismatch: expected="++show trueN++" got="++show n + decodeSum nCon + + +-- | Serialization of product types +class GSerialiseProd f where + -- | Number of fields in product type + nFields :: Proxy f -> Word + -- | Encode fields sequentially without writing header + encodeSeq :: f a -> Encoding + -- | Decode fields sequentially without reading header + gdecodeSeq :: Decoder s (f a) + +-- | @since 0.2.0.0 +instance (GSerialiseProd f, GSerialiseProd g) => GSerialiseProd (f :*: g) where + nFields _ = nFields (Proxy :: Proxy f) + nFields (Proxy :: Proxy g) + encodeSeq (f :*: g) = encodeSeq f <> encodeSeq g + gdecodeSeq = do !f <- gdecodeSeq + !g <- gdecodeSeq + return (f :*: g) + +-- | @since 0.2.0.0 +instance GSerialiseProd U1 where + -- N.B. Could only be reached when one of constructors in sum type + -- don't have parameters + nFields _ = 0 + encodeSeq _ = mempty + gdecodeSeq = return U1 + +-- | @since 0.2.0.0 +instance (Serialise a) => GSerialiseProd (K1 i a) where + -- Ordinary field + nFields _ = 1 + encodeSeq (K1 f) = encode f + gdecodeSeq = K1 <$> decode + +-- | @since 0.2.0.0 +instance (i ~ S, GSerialiseProd f) => GSerialiseProd (M1 i c f) where + -- We skip metadata + nFields _ = 1 + encodeSeq (M1 f) = encodeSeq f + gdecodeSeq = M1 <$> gdecodeSeq + +-- | Serialization of sum types +-- +-- @since 0.2.0.0 +class GSerialiseSum f where + -- | Number of constructor of given value + conNumber :: f a -> Word + -- | Number of fields of given value + numOfFields :: f a -> Word + -- | Encode field + encodeSum :: f a -> Encoding + + -- | Decode field + decodeSum :: Word -> Decoder s (f a) + -- | Number of constructors + nConstructors :: Proxy f -> Word + -- | Number of fields for given constructor number + fieldsForCon :: Proxy f -> Word -> Decoder s Word + +-- | @since 0.2.0.0 +instance (GSerialiseSum f, GSerialiseSum g) => GSerialiseSum (f :+: g) where + conNumber x = case x of + L1 f -> conNumber f + R1 g -> conNumber g + nConstructors (Proxy :: Proxy f) + numOfFields x = case x of + L1 f -> numOfFields f + R1 g -> numOfFields g + encodeSum x = case x of + L1 f -> encodeSum f + R1 g -> encodeSum g + + nConstructors _ = nConstructors (Proxy :: Proxy f) + + nConstructors (Proxy :: Proxy g) + + fieldsForCon _ n | n < nL = fieldsForCon (Proxy :: Proxy f) n + | otherwise = fieldsForCon (Proxy :: Proxy g) (n - nL) + where + nL = nConstructors (Proxy :: Proxy f) + + decodeSum nCon | nCon < nL = L1 <$> decodeSum nCon + | otherwise = R1 <$> decodeSum (nCon - nL) + where + nL = nConstructors (Proxy :: Proxy f) + +-- | @since 0.2.0.0 +instance (i ~ C, GSerialiseProd f) => GSerialiseSum (M1 i c f) where + conNumber _ = 0 + numOfFields _ = nFields (Proxy :: Proxy f) + encodeSum (M1 f) = encodeSeq f + + nConstructors _ = 1 + fieldsForCon _ 0 = return $ nFields (Proxy :: Proxy f) + fieldsForCon _ _ = fail "Bad constructor number" + decodeSum 0 = M1 <$> gdecodeSeq + decodeSum _ = fail "bad constructor number" diff --git a/src/Codec/Serialise/Decoding.hs b/src/Codec/Serialise/Decoding.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Serialise/Decoding.hs @@ -0,0 +1,77 @@ +-- | +-- Module : Codec.Serialise.Decoding +-- Copyright : (c) Duncan Coutts 2015-2017 +-- License : BSD3-style (see LICENSE.txt) +-- +-- Maintainer : duncan@community.haskell.org +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- High level API for decoding values that were encoded with the +-- "Codec.Serialise.Encoding" module, using a @'Monad'@ +-- based interface. +-- +module Codec.Serialise.Decoding + ( -- * Decode primitive operations + Decoder + , DecodeAction(..) + , getDecodeAction + + -- ** Read input tokens + , decodeWord -- :: Decoder s Word + , decodeWord8 -- :: Decoder s Word8 + , decodeWord16 -- :: Decoder s Word16 + , decodeWord32 -- :: Decoder s Word32 + , decodeWord64 -- :: Decoder s Word64 + , decodeNegWord -- :: Decoder s Word + , decodeNegWord64 -- :: Decoder s Word64 + , decodeInt -- :: Decoder s Int + , decodeInt8 -- :: Decoder s Int8 + , decodeInt16 -- :: Decoder s Int16 + , decodeInt32 -- :: Decoder s Int32 + , decodeInt64 -- :: Decoder s Int64 + , decodeInteger -- :: Decoder s Integer + , decodeFloat -- :: Decoder s Float + , decodeDouble -- :: Decoder s Double + , decodeBytes -- :: Decoder s ByteString + , decodeBytesIndef -- :: Decoder s () + , decodeString -- :: Decoder s Text + , decodeStringIndef -- :: Decoder s () + , decodeListLen -- :: Decoder s Int + , decodeListLenIndef -- :: Decoder s () + , decodeMapLen -- :: Decoder s Int + , decodeMapLenIndef -- :: Decoder s () + , decodeTag -- :: Decoder s Word + , decodeTag64 -- :: Decoder s Word64 + , decodeBool -- :: Decoder s Bool + , decodeNull -- :: Decoder s () + , decodeSimple -- :: Decoder s Word8 + + -- ** Specialised Read input token operations + , decodeWordOf -- :: Word -> Decoder s () + , decodeListLenOf -- :: Int -> Decoder s () + + -- ** Branching operations +--, decodeBytesOrIndef +--, decodeStringOrIndef + , decodeListLenOrIndef -- :: Decoder s (Maybe Int) + , decodeMapLenOrIndef -- :: Decoder s (Maybe Int) + , decodeBreakOr -- :: Decoder s Bool + + -- ** Inspecting the token type + , peekTokenType -- :: Decoder s TokenType + , peekAvailable -- :: Decoder s Int + , TokenType(..) + + -- ** Special operations +--, ignoreTerms +--, decodeTrace + + -- * Sequence operations + , decodeSequenceLenIndef -- :: ... + , decodeSequenceLenN -- :: ... + ) where + +import Codec.CBOR.Decoding + +import Prelude hiding (decodeFloat) diff --git a/src/Codec/Serialise/Encoding.hs b/src/Codec/Serialise/Encoding.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Serialise/Encoding.hs @@ -0,0 +1,52 @@ +-- | +-- Module : Codec.Serialise.Encoding +-- Copyright : (c) Duncan Coutts 2015-2017 +-- License : BSD3-style (see LICENSE.txt) +-- +-- Maintainer : duncan@community.haskell.org +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- High level API for encoding values, for later serialization into +-- CBOR binary format, using a @'Monoid'@ based interface. +-- +module Codec.Serialise.Encoding + ( -- * Encoding implementation + Encoding(..) -- :: * + , Tokens(..) -- :: * + + -- * @'Encoding'@ API for serialisation + , encodeWord -- :: Word -> Encoding + , encodeWord8 -- :: Word8 -> Encoding + , encodeWord16 -- :: Word16 -> Encoding + , encodeWord32 -- :: Word32 -> Encoding + , encodeWord64 -- :: Word64 -> Encoding + , encodeInt -- :: Int -> Encoding + , encodeInt8 -- :: Int8 -> Encoding + , encodeInt16 -- :: Int16 -> Encoding + , encodeInt32 -- :: Int32 -> Encoding + , encodeInt64 -- :: Int64 -> Encoding + , encodeInteger -- :: Integer -> Encoding + , encodeBytes -- :: B.ByteString -> Encoding + , encodeBytesIndef -- :: Encoding + , encodeString -- :: T.Text -> Encoding + , encodeStringIndef -- :: Encoding + , encodeListLen -- :: Word -> Encoding + , encodeListLenIndef -- :: Encoding + , encodeMapLen -- :: Word -> Encoding + , encodeMapLenIndef -- :: Encoding + , encodeBreak -- :: Encoding + , encodeTag -- :: Word -> Encoding + , encodeTag64 -- :: Word64 -> Encoding + , encodeBool -- :: Bool -> Encoding + , encodeUndef -- :: Encoding + , encodeNull -- :: Encoding + , encodeSimple -- :: Word8 -> Encoding + , encodeFloat16 -- :: Float -> Encoding + , encodeFloat -- :: Float -> Encoding + , encodeDouble -- :: Double -> Encoding + ) where + +import Codec.CBOR.Encoding + +import Prelude hiding (encodeFloat) diff --git a/src/Codec/Serialise/IO.hs b/src/Codec/Serialise/IO.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Serialise/IO.hs @@ -0,0 +1,20 @@ +-- | +-- Module : Codec.Serialise.IO +-- Copyright : (c) Duncan Coutts 2015-2017 +-- License : BSD3-style (see LICENSE.txt) +-- +-- Maintainer : duncan@community.haskell.org +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- High-level file-based API for serialising and deserialising values. +-- +module Codec.Serialise.IO + ( -- * @'FilePath'@ API + writeFileSerialise + , readFileDeserialise + -- * @'System.IO.Handle'@ API + , hPutSerialise + ) where + +import Codec.Serialise diff --git a/src/Codec/Serialise/Properties.hs b/src/Codec/Serialise/Properties.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Serialise/Properties.hs @@ -0,0 +1,79 @@ +-- | +-- Module : Codec.Serialise.Properties +-- Copyright : (c) Duncan Coutts 2015-2017 +-- License : BSD3-style (see LICENSE.txt) +-- +-- Maintainer : duncan@community.haskell.org +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- This module contains a set of generally useful properties, which +-- instance authors are encouraged to use in order to test their +-- instances of the @'Serialise'@ class. For example, if you have a +-- data type which you might derive or write instances for: +-- +-- @ +-- data Foo = Foo { fooInt :: Int, fooBool :: Bool } +-- deriving (Eq, Show, 'GHC.Generics.Generic') +-- -- or, alternatively +-- instance 'Serialise' Foo where +-- 'encode' = ... +-- 'decode' = ... +-- @ +-- +-- Then you can use this module to easily derive some quick +-- properties: +-- +-- @ +-- import qualified "Codec.Serialise.Properties" as Props +-- +-- fooSerialiseId :: Foo -> Bool +-- fooSerialiseId = Props.'serialiseIdentity' +-- +-- fooFlatTermId :: Foo -> Bool +-- fooFlatTermId = Props.'flatTermIdentity' +-- +-- fooHasValidFlatTerm :: Foo -> Bool +-- fooHasValidFlatTerm = Props.'hasValidFlatTerm' +-- @ +-- +-- You can then conveniently use these three functions with +-- QuickCheck, for example. +-- +module Codec.Serialise.Properties + ( -- * CBOR Properties + serialiseIdentity -- :: (Serialise a, Eq a) => a -> Bool + -- * @'FlatTerm'@ Properties + , flatTermIdentity -- :: (Serialise a, Eq a) => a -> Bool + , hasValidFlatTerm -- :: Serialise a => a -> Bool + ) where + +import Codec.CBOR.FlatTerm +import Codec.Serialise (deserialise, serialise) +import Codec.Serialise.Class + +-------------------------------------------------------------------------------- + +-- | Ensure that serializing and deserializing some value results in +-- the original value being returned. +-- +-- @since 0.2.0.0 +serialiseIdentity :: (Serialise a, Eq a) => a -> Bool +serialiseIdentity a = a == (deserialise . serialise) a + +-- | Ensure that serializing and deserializing a value with the +-- @'FlatTerm'@ form results in the original value being returned. +-- +-- @since 0.2.0.0 +flatTermIdentity :: (Serialise a, Eq a) => a -> Bool +flatTermIdentity a = Right a == (fromFlat . toFlat) a + where + toFlat = toFlatTerm . encode + fromFlat = fromFlatTerm decode + +-- | Ensure that serializing a value into a @'FlatTerm'@ gives us a +-- valid @'FlatTerm'@ back. +-- +-- @since 0.2.0.0 +hasValidFlatTerm :: Serialise a => a -> Bool +hasValidFlatTerm = validFlatTerm . toFlatTerm . encode diff --git a/src/Codec/Serialise/Tutorial.hs b/src/Codec/Serialise/Tutorial.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Serialise/Tutorial.hs @@ -0,0 +1,331 @@ +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + +-- | +-- Module : Codec.CBOR.Tutorial +-- Copyright : (c) Duncan Coutts 2015-2017 +-- License : BSD3-style (see LICENSE.txt) +-- +-- Maintainer : duncan@community.haskell.org +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- @cborg@ is a library for the serialisation of Haskell values. +-- +module Codec.Serialise.Tutorial + ( -- * Introduction + -- $introduction + + -- ** The CBOR format + -- $cbor_format + + -- * The 'Serialise' class + -- $serialise + + -- ** Encoding terms + -- $encoding + + -- ** Decoding terms + -- $decoding + + -- * Migrations + -- $migrations + + -- * Working with foreign encodings + -- | While @cborg@ is primarily designed to be a Haskell serialisation + -- library, the fact that it uses the standard CBOR encoding means that it can also + -- find uses in interacting with foreign non-@cborg@ producers and + -- consumers. In this section we will describe a few features of the library + -- which may be useful in such applications. + + -- ** Working with arbitrary terms + -- $arbitrary_terms + + -- ** Examining encodings + -- $examining_encodings + ) where + +-- These are necessary for haddock to properly hyperlink +import Codec.Serialise.Decoding +import Codec.Serialise.Class + +{- $introduction + +As in modern serialisation libraries, @cborg@ offers +instance derivation via GHC's 'GHC.Generic' mechanism, + +> import Serialise.Cborg +> import qualified Data.ByteString.Lazy as BSL +> +> data Animal = HoppingAnimal { animalName :: String, hoppingHeight :: Int } +> | WalkingAnimal { animalName :: String, walkingSpeed :: Int } +> deriving (Generic) +> +> instance Serialise Animal +> +> fredTheFrog :: Animal +> fredTheFrog = HoppingAnimal "Fred" 4 +> +> main = BSL.writeFile "hi" (serialise fredTheFrog) + +We can then later read Fred, + +> main = do +> fred <- deserialise <$> BSL.readFile "hi" +> print fred + +-} + +{- $cbor_format + +@cborg@ uses the Concise Binary Object Representation, CBOR +(IETF RFC 7049, ), as its serialised +representation. This encoding is efficient in both encoding\/decoding complexity +as well as space, and is generally machine-independent. + +The CBOR data model resembles that of JSON, having arrays, key\/value maps, +integers, floating point numbers, binary strings, and text. In addition, +CBOR allows items to be /tagged/ with a number which describes the type of data +that follows. This can be used both to identify which data constructor of a type +an encoding represents, as well as representing different versions of the same +constructor. + +=== A note on interoperability + +@cborg@ is intended primarily as a /serialisation/ library for +Haskell values. That is, a means of stably storing Haskell values for later +reading by @cborg@. While it uses the CBOR encoding format, the +library is /not/ primarily aimed to facilitate serialisation and +deserialisation across different CBOR implementations. + +If you want to use @cborg@ to serialise\/deserialise values +for\/from another CBOR implementation (either in Haskell or another language), +you should keep a few things in mind, + +1. The 'Serialise' instances for some "basic" Haskell types (e.g. 'Maybe', + 'Data.ByteString.ByteString', tuples) don't carry a tag, in contrast to common + convention. This is an intentional design decision to minimize encoding size + for types which are primitive enough that their representation can be + considered stable. + +2. The library reserves the right to change encodings in + non-backwards-compatible ways across super-major versions. For example the + library may start producing a new representation for some type. The new + version of the library will be able to decode the old and new representation, + but your different CBOR decoder would not be expecting the new representation + and would have to be updated to match. + +3. While the library tries to use standard encodings in its instances wherever possible, + these instances aren't guaranteed to implement all valid variants of the + encodings in the specification. For instance, the 'UTCTime' instance only + implements a small subset of the encodings described by the Extended Date + RFC. + +-} + +{- $serialise + +@cborg@ provides a 'Serialise' class for convenient access to serialisers and +deserialisers. Writing a serialiser can be as simple as deriving 'Generic' and +'Serialise', + +> -- with DerivingStrategies (GHC 8.2 and newer) +> data Animal = ... +> deriving stock (Generic) +> deriving anyclass (Serialise) +> +> -- older GHCs +> data MyType = ... +> deriving (Generic) +> instance Serialise MyType + +Of course, you can also write the equivalent serialisers manually. +A hand-rolled 'Serialise' instance may be desireable for a variety +of reasons, + + * Deviating from the type-guided encoding that the 'Generic' instance will + provide + + * Interfacing with other CBOR implementations + + * Enabling migrations for future changes to the type or its encoding + +A minimal hand-rolled instance will define the 'encode' and 'decode' methods, + +> instance Serialise Animal where +> encode = encodeAnimal +> decode = decodeAnimal + +Below we will describe how to write these pieces. + +-} + +{- $encoding + +For the purposes of encoding, abstract CBOR representations are embodied by the +'Serialise.Cborg.Encoding.Tokens' type. Such a representation can be efficiently +built using the 'Serialise.Cborg.Encoding.Encoding' 'Monoid'. + +For instance, to implement an encoder for the @Animal@ type above we might write, + +> encodeAnimal :: Animal -> Encoding +> encodeAnimal (HoppingAnimal name height) = +> encodeListLen 3 <> encodeTag 0 <> encode name <> encode height +> encodeAnimal (WalkingAnimal name speed) = +> encodeListLen 3 <> encodeTag 1 <> encode name <> encode speed + +Here we see that each encoding begins with a /length/, describing how many +values belonging to our @Animal@ will follow. We then encode a /tag/, which +identifies which constructor. We then encode the fields using their respective +'Serialise' instance. + +It is recommended that you not deviate from this encoding scheme, including both +the length and tag, to ensure that you have the option to migrate your types +later on. + +-} + +{- $decoding + +Decoding CBOR representations to Haskell values is done in the 'Decoder' +'Monad'. We can write a 'Decoder' for the @Animal@ type defined above as +follows, + +> decodeAnimal :: Decoder s Animal +> decodeAnimal = do +> len <- decodeListLen +> tag <- decodeTag +> case (len, tag) of +> (3, 0) -> HoppingAnimal <$> decode <*> decode +> (3, 1) -> WalkingAnimal <$> decode <*> decode +> _ -> fail "invalid Animal encoding" + +-} + +{- $migrations + +One eventuality that data serialisation schemes need to account for is the need +for changes in the data's structure. There are two types of compatibility +which we might want to strive for in our serialisers, + + * Backward compatibility, such that newer versions of the serialiser can read + older versions of an encoding + + * Forward compatibility, such that older versions of the serialiser can read + (or at least tolerate) newer versions of an encoding + +Below we will look at a few of the types of changes which we may need to make +and describe how these can be handled in a backwards-compatible manner with +@cborg@. + +=== Adding a constructor + +Say we want to add a new constructor to our @Animal@ type, @SwimmingAnimal@, + +> data Animal = HoppingAnimal { animalName :: String, hoppingHeight :: Int } +> | WalkingAnimal { animalName :: String, walkingSpeed :: Int } +> | SwimmingAnimal { numberOfFins :: Int } +> deriving (Generic) + +We can account for this in our hand-rolled serialiser by simply adding a new tag +to our encoder and decoder, + +> encodeAnimal :: Animal -> Encoding +> -- HoppingAnimal, SwimmingAnimal cases are unchanged... +> encodeAnimal (HoppingAnimal name height) = +> encodeListLen 3 <> encodeTag 0 <> encode name <> encode height +> encodeAnimal (WalkingAnimal name speed) = +> encodeListLen 3 <> encodeTag 1 <> encode name <> encode speed +> -- Here is out new case... +> encodeAnimal (SwimmingAnimal numberOfFins) = +> encodeListLen 2 <> encodeTag 2 <> encode numberOfFins +> +> decodeAnimal :: Decoder s Animal +> decodeAnimal = do +> len <- decodeListLen +> tag <- decodeTag +> case (len, tag) of +> -- these cases are unchanged... +> (3, 0) -> HoppingAnimal <$> decode <*> decode +> (3, 1) -> WalkingAnimal <$> decode <*> decode +> -- this is new... +> (2, 2) -> SwimmingAnimal <$> decode +> _ -> fail "invalid Animal encoding" + +=== Adding\/removing\/modifying fields + +Say then we want to add a new field to our @WalkingAnimal@ constructor, + +> data Animal = HoppingAnimal { animalName :: String, hoppingHeight :: Int } +> | WalkingAnimal { animalName :: String, walkingSpeed :: Int, numberOfFeet :: Int } +> | SwimmingAnimal { numberOfFins :: Int } +> deriving (Generic) + +We can account for this by representing @WalkingAnimal@ with a new encoding with +a new tag, + +> encodeAnimal :: Animal -> Encoding +> -- HoppingAnimal, SwimmingAnimal cases are unchanged... +> encodeAnimal (HoppingAnimal name height) = +> encodeListLen 3 <> encodeTag 0 <> encode name <> encode height +> encodeAnimal (WalkingAnimal name speed) = +> encodeListLen 3 <> encodeTag 1 <> encode name <> encode speed +> -- This is new... +> encodeAnimal (WalkingAnimal animalName walkingSpeed numberOfFeet) = +> encodeListLen 4 <> encodeTag 3 <> encode animalName <> encode walkingSpeed <> encode numberOfFins +> +> decodeAnimal :: Decoder s Animal +> decodeAnimal = do +> len <- decodeListLen +> tag <- decodeTag +> case (len, tag) of +> -- this cases are unchanged... +> (3, 0) -> HoppingAnimal <$> decode <*> decode +> (2, 2) -> SwimmingAnimal <$> decode +> -- this is new... +> (3, 1) -> WalkingAnimal <$> decode <*> decode <*> pure 4 +> -- ^ note the default for backwards compat +> (4, 3) -> WalkingAnimal <$> decode <*> decode +> _ -> fail "invalid Animal encoding" + +We can use this same approach to handle field removal and type changes. + +-} + +{- $arbitrary_terms + +When working with foreign encodings, it can sometimes be useful to capture a +serialised CBOR term verbatim (for instance, so you can later re-serialise it in +some later result). The 'Serialise.Cborg.Term.Term' type provides such a +representation, losslessly capturing a CBOR AST. It can be serialised and +deserialised with its 'Serialise' instance. + +-} + +{- $examining_encodings + +We can also look In addition to serialisation and deserialisation, @cborg@ +provides a variety of tools for representing arbitrary CBOR encodings in the +"Serialise.Cborg.FlatTerm" and "Serialise.Cborg.Pretty" modules. + +The 'Serialise.Cborg.FlatTerm.FlatTerm' type represents a single CBOR /term/, as +would be found in the ultimate CBOR representation. For instance, we can easily +look at the structure of our @Animal@ encoding above, + +>>> toFlatTerm $ encode $ HoppingAnimal "Fred" 42 +[TkListLen 3,TkInt 0,TkString "Fred",TkInt 42] +>>> fromFlatTerm (decode @Animal) $ toFlatTerm $ encode (HoppingAnimal "Fred" 42) +Right (HoppingAnimal {animalName = "Fred", hoppingHeight = 42}) + +This can be useful both for understanding external CBOR formats, as well as +understanding and testing your own hand-rolled encodings. + +The package also includes a pretty-printer in "Serialise.Cborg.Pretty", for +visualising the CBOR wire protocol alongside its semantic structure. For instance, + +>>> putStrLn $ Serialise.Cborg.Pretty.prettyHexEnc $ encode $ HoppingAnimal "Fred" 42 +83 # list(3) + 00 # word(0) + 64 46 72 65 64 # text("Fred") + 18 2a # int(42) + +-} diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,25 @@ +module Main + ( main -- :: IO () + ) where +import Test.Tasty (defaultMain, testGroup) + +import qualified Tests.IO as IO +import qualified Tests.CBOR as CBOR +import qualified Tests.Regress as Regress +import qualified Tests.Reference as Reference +import qualified Tests.Serialise as Serialise +import qualified Tests.Negative as Negative +import qualified Tests.Deriving as Deriving + +main :: IO () +main = Reference.loadTestCases >>= \tcs -> defaultMain $ + testGroup "CBOR tests" + [ CBOR.testTree tcs + , Reference.testTree tcs + , Serialise.testTree + , Serialise.testGenerics + , Negative.testTree + , IO.testTree + , Regress.testTree + , Deriving.testTree + ] diff --git a/tests/Tests/CBOR.hs b/tests/Tests/CBOR.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/CBOR.hs @@ -0,0 +1,287 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Tests.CBOR + ( testTree -- :: TestTree + ) where + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import Data.Word +import qualified Numeric.Half as Half + +import Codec.CBOR.Term +import Codec.CBOR.Read +import Codec.CBOR.Write + +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +import qualified Tests.Reference.Implementation as RefImpl +import qualified Tests.Reference as TestVector +import Tests.Reference (TestCase(..)) + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif +import Control.Exception (throw) + + +externalTestCase :: TestCase -> Assertion +externalTestCase TestCase { encoded, decoded = Left expectedJson } = do + let term = deserialise encoded + actualJson = TestVector.termToJson (toRefTerm term) + reencoded = serialise term + + expectedJson `TestVector.equalJson` actualJson + encoded @=? reencoded + +externalTestCase TestCase { encoded, decoded = Right expectedDiagnostic } = do + let term = deserialise encoded + actualDiagnostic = RefImpl.diagnosticNotation (toRefTerm term) + reencoded = serialise term + + expectedDiagnostic @=? actualDiagnostic + encoded @=? reencoded + +expectedDiagnosticNotation :: String -> [Word8] -> Assertion +expectedDiagnosticNotation expectedDiagnostic encoded = do + let term = deserialise (LBS.pack encoded) + actualDiagnostic = RefImpl.diagnosticNotation (toRefTerm term) + + expectedDiagnostic @=? actualDiagnostic + + +-- | The reference implementation satisfies the roundtrip property for most +-- examples (all the ones from Appendix A). It does not satisfy the roundtrip +-- property in general however, non-canonical over-long int encodings for +-- example. +-- +-- +encodedRoundtrip :: String -> [Word8] -> Assertion +encodedRoundtrip expectedDiagnostic encoded = do + let term = deserialise (LBS.pack encoded) + reencoded = LBS.unpack (serialise term) + + assertEqual ("for CBOR: " ++ expectedDiagnostic) encoded reencoded + +prop_encodeDecodeTermRoundtrip :: Term -> Bool +prop_encodeDecodeTermRoundtrip term = + (deserialise . serialise) term `eqTerm` term + +prop_encodeDecodeTermRoundtrip_splits2 :: Term -> Bool +prop_encodeDecodeTermRoundtrip_splits2 term = + and [ deserialise thedata' `eqTerm` term + | let thedata = serialise term + , thedata' <- splits2 thedata ] + +prop_encodeDecodeTermRoundtrip_splits3 :: Term -> Bool +prop_encodeDecodeTermRoundtrip_splits3 term = + and [ deserialise thedata' `eqTerm` term + | let thedata = serialise term + , thedata' <- splits3 thedata ] + +prop_encodeTermMatchesRefImpl :: RefImpl.Term -> Bool +prop_encodeTermMatchesRefImpl term = + let encoded = serialise (fromRefTerm term) + encoded' = RefImpl.serialise (RefImpl.canonicaliseTerm term) + in encoded == encoded' + +prop_encodeTermMatchesRefImpl2 :: Term -> Bool +prop_encodeTermMatchesRefImpl2 term = + let encoded = serialise term + encoded' = RefImpl.serialise (toRefTerm term) + in encoded == encoded' + +prop_decodeTermMatchesRefImpl :: RefImpl.Term -> Bool +prop_decodeTermMatchesRefImpl term0 = + let encoded = RefImpl.serialise (RefImpl.canonicaliseTerm term0) + term = RefImpl.deserialise encoded + term' = deserialise encoded + in term' `eqTerm` fromRefTerm term + +------------------------------------------------------------------------------ + +splits2 :: LBS.ByteString -> [LBS.ByteString] +splits2 bs = zipWith (\a b -> LBS.fromChunks [a,b]) (BS.inits sbs) (BS.tails sbs) + where + sbs = LBS.toStrict bs + +splits3 :: LBS.ByteString -> [LBS.ByteString] +splits3 bs = + [ LBS.fromChunks [a,b,c] + | (a,x) <- zip (BS.inits sbs) (BS.tails sbs) + , (b,c) <- zip (BS.inits x) (BS.tails x) ] + where + sbs = LBS.toStrict bs + + +serialise :: Term -> LBS.ByteString +serialise = toLazyByteString . encodeTerm + +deserialise :: LBS.ByteString -> Term +deserialise = either throw snd . deserialiseFromBytes decodeTerm + +------------------------------------------------------------------------------ + +toRefTerm :: Term -> RefImpl.Term +toRefTerm (TInt n) + | n >= 0 = RefImpl.TUInt (RefImpl.toUInt (fromIntegral n)) + | otherwise = RefImpl.TNInt (RefImpl.toUInt (fromIntegral (-1 - n))) +toRefTerm (TInteger n) -- = RefImpl.TBigInt n + | n >= 0 && n <= fromIntegral (maxBound :: Word64) + = RefImpl.TUInt (RefImpl.toUInt (fromIntegral n)) + | n < 0 && n >= -1 - fromIntegral (maxBound :: Word64) + = RefImpl.TNInt (RefImpl.toUInt (fromIntegral (-1 - n))) + | otherwise = RefImpl.TBigInt n +toRefTerm (TBytes bs) = RefImpl.TBytes (BS.unpack bs) +toRefTerm (TBytesI bs) = RefImpl.TBytess (map BS.unpack (LBS.toChunks bs)) +toRefTerm (TString st) = RefImpl.TString (T.unpack st) +toRefTerm (TStringI st) = RefImpl.TStrings (map T.unpack (LT.toChunks st)) +toRefTerm (TList ts) = RefImpl.TArray (map toRefTerm ts) +toRefTerm (TListI ts) = RefImpl.TArrayI (map toRefTerm ts) +toRefTerm (TMap ts) = RefImpl.TMap [ (toRefTerm x, toRefTerm y) + | (x,y) <- ts ] +toRefTerm (TMapI ts) = RefImpl.TMapI [ (toRefTerm x, toRefTerm y) + | (x,y) <- ts ] +toRefTerm (TTagged w t) = RefImpl.TTagged (RefImpl.toUInt (fromIntegral w)) + (toRefTerm t) +toRefTerm (TBool False) = RefImpl.TFalse +toRefTerm (TBool True) = RefImpl.TTrue +toRefTerm TNull = RefImpl.TNull +toRefTerm (TSimple 23) = RefImpl.TUndef +toRefTerm (TSimple w) = RefImpl.TSimple (fromIntegral w) +toRefTerm (THalf f) = RefImpl.TFloat16 (Half.toHalf f) +toRefTerm (TFloat f) = RefImpl.TFloat32 f +toRefTerm (TDouble f) = RefImpl.TFloat64 f + + +fromRefTerm :: RefImpl.Term -> Term +fromRefTerm (RefImpl.TUInt u) + | n <= fromIntegral (maxBound :: Int) = TInt (fromIntegral n) + | otherwise = TInteger (fromIntegral n) + where n = RefImpl.fromUInt u + +fromRefTerm (RefImpl.TNInt u) + | n <= fromIntegral (maxBound :: Int) = TInt (-1 - fromIntegral n) + | otherwise = TInteger (-1 - fromIntegral n) + where n = RefImpl.fromUInt u + +fromRefTerm (RefImpl.TBigInt n) = TInteger n +fromRefTerm (RefImpl.TBytes bs) = TBytes (BS.pack bs) +fromRefTerm (RefImpl.TBytess bs) = TBytesI (LBS.fromChunks (map BS.pack bs)) +fromRefTerm (RefImpl.TString st) = TString (T.pack st) +fromRefTerm (RefImpl.TStrings st) = TStringI (LT.fromChunks (map T.pack st)) + +fromRefTerm (RefImpl.TArray ts) = TList (map fromRefTerm ts) +fromRefTerm (RefImpl.TArrayI ts) = TListI (map fromRefTerm ts) +fromRefTerm (RefImpl.TMap ts) = TMap [ (fromRefTerm x, fromRefTerm y) + | (x,y) <- ts ] +fromRefTerm (RefImpl.TMapI ts) = TMapI [ (fromRefTerm x, fromRefTerm y) + | (x,y) <- ts ] +fromRefTerm (RefImpl.TTagged w t) = TTagged (RefImpl.fromUInt w) + (fromRefTerm t) +fromRefTerm (RefImpl.TFalse) = TBool False +fromRefTerm (RefImpl.TTrue) = TBool True +fromRefTerm RefImpl.TNull = TNull +fromRefTerm RefImpl.TUndef = TSimple 23 +fromRefTerm (RefImpl.TSimple w) = TSimple w +fromRefTerm (RefImpl.TFloat16 f) = THalf (Half.fromHalf f) +fromRefTerm (RefImpl.TFloat32 f) = TFloat f +fromRefTerm (RefImpl.TFloat64 f) = TDouble f + +-- NaNs are so annoying... +eqTerm :: Term -> Term -> Bool +eqTerm (TInt n) (TInteger n') = fromIntegral n == n' +eqTerm (TList ts) (TList ts') = and (zipWith eqTerm ts ts') +eqTerm (TListI ts) (TListI 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 (THalf f) (THalf f') | isNaN f && isNaN f' = True +eqTerm (TFloat f) (TFloat f') | isNaN f && isNaN f' = True +eqTerm (TDouble f) (TDouble 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' + + +prop_fromToRefTerm :: RefImpl.Term -> Bool +prop_fromToRefTerm term = toRefTerm (fromRefTerm term) + `RefImpl.eqTerm` RefImpl.canonicaliseTerm term + +prop_toFromRefTerm :: Term -> Bool +prop_toFromRefTerm term = fromRefTerm (toRefTerm term) `eqTerm` term + +instance Arbitrary Term where + arbitrary = fromRefTerm <$> arbitrary + + shrink (TInt n) = [ TInt n' | n' <- shrink n ] + shrink (TInteger n) = [ TInteger n' | n' <- shrink n ] + + shrink (TBytes ws) = [ TBytes (BS.pack ws') | ws' <- shrink (BS.unpack ws) ] + shrink (TBytesI wss) = [ TBytesI (LBS.fromChunks (map BS.pack wss')) + | wss' <- shrink (map BS.unpack (LBS.toChunks wss)) ] + shrink (TString cs) = [ TString (T.pack cs') | cs' <- shrink (T.unpack cs) ] + shrink (TStringI css) = [ TStringI (LT.fromChunks (map T.pack css')) + | css' <- shrink (map T.unpack (LT.toChunks css)) ] + + shrink (TList xs@[x]) = x : [ TList xs' | xs' <- shrink xs ] + shrink (TList xs) = [ TList xs' | xs' <- shrink xs ] + shrink (TListI xs@[x]) = x : [ TListI xs' | xs' <- shrink xs ] + shrink (TListI xs) = [ TListI 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 (RefImpl.reservedTag (fromIntegral w')) ] + + shrink (TBool _) = [] + shrink TNull = [] + + shrink (TSimple w) = [ TSimple w' | w' <- shrink w + , not (RefImpl.reservedSimple (fromIntegral w)) ] + shrink (THalf _f) = [] + shrink (TFloat f) = [ TFloat f' | f' <- shrink f ] + shrink (TDouble f) = [ TDouble f' | f' <- shrink f ] + +-------------------------------------------------------------------------------- +-- TestTree API + +testTree :: [TestCase] -> TestTree +testTree testCases = + testGroup "Main implementation" + [ testCase "external test vector" $ + mapM_ externalTestCase testCases + + , testCase "internal test vector" $ do + sequence_ [ do expectedDiagnosticNotation d e + encodedRoundtrip d e + | (d,e) <- TestVector.specTestVector ] + + , --localOption (QuickCheckTests 5000) $ + localOption (QuickCheckMaxSize 150) $ + testGroup "properties" + [ testProperty "from/to reference terms" prop_fromToRefTerm + , testProperty "to/from reference terms" prop_toFromRefTerm + , testProperty "rountrip de/encoding terms" prop_encodeDecodeTermRoundtrip + -- TODO FIXME: need to fix the generation of terms to give + -- better size distribution some get far too big for the + -- splits properties. + , localOption (QuickCheckMaxSize 30) $ + testProperty "decoding with all 2-chunks" prop_encodeDecodeTermRoundtrip_splits2 + , localOption (QuickCheckMaxSize 20) $ + testProperty "decoding with all 3-chunks" prop_encodeDecodeTermRoundtrip_splits3 + , testProperty "encode term matches ref impl 1" prop_encodeTermMatchesRefImpl + , testProperty "encode term matches ref impl 2" prop_encodeTermMatchesRefImpl2 + , testProperty "decoding term matches ref impl" prop_decodeTermMatchesRefImpl + ] + ] diff --git a/tests/Tests/Deriving.hs b/tests/Tests/Deriving.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Deriving.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Tests.Deriving (testTree) where + +import GHC.Generics + +import qualified Codec.Serialise as Serialise +import Codec.CBOR.FlatTerm + +import Test.Tasty +import Test.Tasty.HUnit + +-- | A unit type +data AUnit = AUnit + deriving (Generic, Eq, Show) +instance Serialise.Serialise AUnit + +testAUnit :: TestTree +testAUnit = testAgainstFile "a unit" x rep + where + x = AUnit + rep = [TkListLen 1, TkInt 0] + +-- | A simple case exercising many of the cases implemented by the generic +-- deriving mechinery +data ARecord = ARecord String Int ARecord + | ANull + deriving (Generic, Eq, Show) +instance Serialise.Serialise ARecord + +testARecord :: TestTree +testARecord = testAgainstFile "a record" x rep + where + x = ARecord "hello" 42 (ARecord "world" 52 ANull) + rep = [TkListLen 4, TkInt 0, TkString "hello", TkInt 42, + TkListLen 4, TkInt 0, TkString "world", TkInt 52, + TkListLen 1, TkInt 1 + ] + +newtype ANewtype = ANewtype Int + deriving (Generic, Eq, Show) +instance Serialise.Serialise ANewtype + +testANewtype :: TestTree +testANewtype = testAgainstFile "a newtype" x rep + where + x = ANewtype 42 + rep = [TkListLen 2, TkInt 0, TkInt 42] + +testAgainstFile :: (Eq a, Show a, Serialise.Serialise a) + => String -> a -> FlatTerm -> TestTree +testAgainstFile name x expected = + testGroup name + [ testCase "serialise" $ do + let actual = toFlatTerm $ Serialise.encode x + expected @=? actual + , testCase "deserialise" $ do + case fromFlatTerm Serialise.decode expected of + Left err -> fail err + Right actual -> x @=? actual + ] + +testTree :: TestTree +testTree = + testGroup "Stability of derived instances" + [ testAUnit + , testARecord + , testANewtype + ] diff --git a/tests/Tests/IO.hs b/tests/Tests/IO.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/IO.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE CPP #-} +module Tests.IO + ( testTree -- :: TestTree + ) where +import System.FilePath +import System.Directory (removeFile) +import Control.Exception (bracket) + +import Test.Tasty +import Test.Tasty.HUnit + +import Codec.Serialise + +-------------------------------------------------------------------------------- +-- Tests and properties + +test_encodeAndDecodeFile :: Assertion +test_encodeAndDecodeFile = + let path = ("tests" "io_test1.cbor") + in withDeleteFile path $ do + let val = Just True + writeFileSerialise path val + val' <- readFileDeserialise path :: IO (Maybe Bool) + val @=? val' + +-------------------------------------------------------------------------------- +-- TestTree API + +testTree :: TestTree +testTree = testGroup "IO tests" + [ testCase "file encode/decode roundtrip" test_encodeAndDecodeFile + ] + +-------------------------------------------------------------------------------- +-- Utilities + +-- | Run an action, and be sure to delete the specified @'FilePath'@ when +-- finished. +withDeleteFile :: FilePath -> IO a -> IO a +withDeleteFile f k = bracket (return ()) (const $ removeFile f) (const k) diff --git a/tests/Tests/Negative.hs b/tests/Tests/Negative.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Negative.hs @@ -0,0 +1,72 @@ +module Tests.Negative + ( testTree -- :: TestTree + ) where +import Data.Monoid +import Data.Version + +import Test.Tasty +import Test.Tasty.HUnit + +import Codec.Serialise +import Codec.Serialise.Encoding +import Codec.CBOR.Write as CBOR.Write + +-------------------------------------------------------------------------------- +-- Tests and properties + +testInvalidMaybe :: Assertion +testInvalidMaybe = assertIsBad "properly decoded invalid Maybe!" val + where + enc = encodeListLen 2 -- only 'ListLen 0' and 'ListLen 1' are used + val = badRoundTrip enc :: Failed (Maybe Int) + +testInvalidEither :: Assertion +testInvalidEither = assertIsBad "properly decoded invalid Either!" val + where + -- expects a list of length two, with a tag of 0 or 1 only + enc = encodeListLen 2 + <> encodeWord 2 -- invalid tag + <> encodeWord 0 + val = badRoundTrip enc :: Failed (Either Int Int) + +testInvalidVersion :: Assertion +testInvalidVersion = assertIsBad "properly decoded invalid Version!" val + where + -- expects a tag of 0 and length of 3, not 4 + enc = encodeListLen 4 + <> encodeWord 0 -- tag is zero + <> encodeWord 0 + <> encodeWord 0 + <> encodeWord 0 + val = badRoundTrip enc :: Failed Version + +-------------------------------------------------------------------------------- +-- TestTree API + +testTree :: TestTree +testTree = testGroup "Negative tests" + [ testCase "decoding invalid Maybe" testInvalidMaybe + , testCase "decoding invalid Either" testInvalidEither + , testCase "decoding invalid Version" testInvalidVersion + ] + +-------------------------------------------------------------------------------- +-- Utilities + +-- Simple utility to take an @'Encoding'@ and try to deserialise it as +-- some user specified type. Useful for writing 'bad' encoders that give +-- some bad output we attempt to deserialise. + +type Failed a = Either DeserialiseFailure a + +badRoundTrip :: Serialise a => Encoding -> Failed a +badRoundTrip enc = deserialiseOrFail (CBOR.Write.toLazyByteString enc) + +-- | Check if a @'Failed' a@ actually failed. +didFail :: Failed a -> Bool +didFail (Left _) = True +didFail (Right _) = False + +-- | Assert that a @'Failed' a@ actually failed. +assertIsBad :: String -> Failed a -> Assertion +assertIsBad msg v = assertBool msg (didFail v) diff --git a/tests/Tests/Orphanage.hs b/tests/Tests/Orphanage.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Orphanage.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +module Tests.Orphanage where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +import Data.Monoid as Monoid +#endif + +#if MIN_VERSION_base(4,9,0) +import qualified Data.Semigroup as Semigroup +#endif + +import Data.Typeable + +import Data.Ord +import Foreign.C.Types +import System.Exit (ExitCode(..)) +import GHC.Fingerprint.Type + +import Test.QuickCheck.Gen +import Test.QuickCheck.Arbitrary + +import qualified Data.Vector.Primitive as Vector.Primitive + +-------------------------------------------------------------------------------- +-- QuickCheck Orphans + +-- A _LOT_ of orphans instances for QuickCheck. Some are already in +-- git HEAD and some are still waiting as pull request +-- +-- [https://github.com/nick8325/quickcheck/pull/90] + +-- Foreign C types + +instance Arbitrary CChar where + arbitrary = CChar <$> arbitrary + shrink (CChar x) = CChar <$> shrink x + +instance Arbitrary CSChar where + arbitrary = CSChar <$> arbitrary + shrink (CSChar x) = CSChar <$> shrink x + +instance Arbitrary CUChar where + arbitrary = CUChar <$> arbitrary + shrink (CUChar x) = CUChar <$> shrink x + +instance Arbitrary CShort where + arbitrary = CShort <$> arbitrary + shrink (CShort x) = CShort <$> shrink x + +instance Arbitrary CUShort where + arbitrary = CUShort <$> arbitrary + shrink (CUShort x) = CUShort <$> shrink x + +instance Arbitrary CInt where + arbitrary = CInt <$> arbitrary + shrink (CInt x) = CInt <$> shrink x + +instance Arbitrary CUInt where + arbitrary = CUInt <$> arbitrary + shrink (CUInt x) = CUInt <$> shrink x + +instance Arbitrary CLong where + arbitrary = CLong <$> arbitrary + shrink (CLong x) = CLong <$> shrink x + +instance Arbitrary CULong where + arbitrary = CULong <$> arbitrary + shrink (CULong x) = CULong <$> shrink x + +instance Arbitrary CPtrdiff where + arbitrary = CPtrdiff <$> arbitrary + shrink (CPtrdiff x) = CPtrdiff <$> shrink x + +instance Arbitrary CSize where + arbitrary = CSize <$> arbitrary + shrink (CSize x) = CSize <$> shrink x + +instance Arbitrary CWchar where + arbitrary = CWchar <$> arbitrary + shrink (CWchar x) = CWchar <$> shrink x + +instance Arbitrary CSigAtomic where + arbitrary = CSigAtomic <$> arbitrary + shrink (CSigAtomic x) = CSigAtomic <$> shrink x + +instance Arbitrary CLLong where + arbitrary = CLLong <$> arbitrary + shrink (CLLong x) = CLLong <$> shrink x + +instance Arbitrary CULLong where + arbitrary = CULLong <$> arbitrary + shrink (CULLong x) = CULLong <$> shrink x + +instance Arbitrary CIntPtr where + arbitrary = CIntPtr <$> arbitrary + shrink (CIntPtr x) = CIntPtr <$> shrink x + +instance Arbitrary CUIntPtr where + arbitrary = CUIntPtr <$> arbitrary + shrink (CUIntPtr x) = CUIntPtr <$> shrink x + +instance Arbitrary CIntMax where + arbitrary = CIntMax <$> arbitrary + shrink (CIntMax x) = CIntMax <$> shrink x + +instance Arbitrary CUIntMax where + arbitrary = CUIntMax <$> arbitrary + shrink (CUIntMax x) = CUIntMax <$> shrink x + +instance Arbitrary CClock where + arbitrary = CClock <$> arbitrary + shrink (CClock x) = CClock <$> shrink x + +instance Arbitrary CTime where + arbitrary = CTime <$> arbitrary + shrink (CTime x) = CTime <$> shrink x + +instance Arbitrary CUSeconds where + arbitrary = CUSeconds <$> arbitrary + shrink (CUSeconds x) = CUSeconds <$> shrink x + +instance Arbitrary CSUSeconds where + arbitrary = CSUSeconds <$> arbitrary + shrink (CSUSeconds x) = CSUSeconds <$> shrink x + +instance Arbitrary CFloat where + arbitrary = CFloat <$> arbitrary + shrink (CFloat x) = CFloat <$> shrink x + +instance Arbitrary CDouble where + arbitrary = CDouble <$> arbitrary + shrink (CDouble x) = CDouble <$> shrink x + +-- Miscellaneous types from base + +#if MIN_VERSION_base(4,9,0) +instance Arbitrary a => Arbitrary (Semigroup.Min a) where + arbitrary = fmap Semigroup.Min arbitrary + shrink = map Semigroup.Min . shrink . Semigroup.getMin + +instance Arbitrary a => Arbitrary (Semigroup.Max a) where + arbitrary = fmap Semigroup.Max arbitrary + shrink = map Semigroup.Max . shrink . Semigroup.getMax + +instance Arbitrary a => Arbitrary (Semigroup.First a) where + arbitrary = fmap Semigroup.First arbitrary + shrink = map Semigroup.First . shrink . Semigroup.getFirst + +instance Arbitrary a => Arbitrary (Semigroup.Last a) where + arbitrary = fmap Semigroup.Last arbitrary + shrink = map Semigroup.Last . shrink . Semigroup.getLast + +instance Arbitrary a => Arbitrary (Semigroup.Option a) where + arbitrary = fmap Semigroup.Option arbitrary + shrink = map Semigroup.Option . shrink . Semigroup.getOption + +instance Arbitrary a => Arbitrary (Semigroup.WrappedMonoid a) where + arbitrary = fmap Semigroup.WrapMonoid arbitrary + shrink = map Semigroup.WrapMonoid . shrink . Semigroup.unwrapMonoid +#endif + +instance Arbitrary a => Arbitrary (Down a) where + arbitrary = fmap Down arbitrary + shrink = map Down . shrink . (\(Down a) -> a) + +instance Arbitrary ExitCode where + arbitrary = frequency [(1, return ExitSuccess), (3, fmap ExitFailure arbitrary)] + + shrink (ExitFailure x) = ExitSuccess : [ ExitFailure x' | x' <- shrink x ] + shrink _ = [] + +#if !MIN_VERSION_base(4,8,0) +deriving instance Typeable Const +deriving instance Typeable ZipList +deriving instance Typeable Down +deriving instance Typeable Monoid.Sum +deriving instance Typeable Monoid.All +deriving instance Typeable Monoid.Any +deriving instance Typeable Monoid.Product +deriving instance Typeable Monoid.Dual +deriving instance Typeable Fingerprint + +deriving instance Show a => Show (Const a b) +deriving instance Eq a => Eq (Const a b) +#endif + +instance (Vector.Primitive.Prim a, Arbitrary a + ) => Arbitrary (Vector.Primitive.Vector a) where + arbitrary = Vector.Primitive.fromList <$> arbitrary + +#if MIN_VERSION_base(4,7,0) +instance Arbitrary (Proxy a) where + arbitrary = return Proxy +#endif + +instance Arbitrary Fingerprint where + arbitrary = Fingerprint <$> arbitrary <*> arbitrary diff --git a/tests/Tests/Reference.hs b/tests/Tests/Reference.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Reference.hs @@ -0,0 +1,295 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +module Tests.Reference + ( TestCase(..) -- :: * + , termToJson -- :: + , equalJson -- :: + , loadTestCases -- :: + , specTestVector -- :: + , testTree -- :: TestTree + ) where + +import Test.Tasty +import Test.Tasty.QuickCheck + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Base64 as Base64 +import qualified Data.ByteString.Base64.URL as Base64url +import qualified Data.ByteString.Base16 as Base16 +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Vector as V +import Data.Scientific (fromFloatDigits, toRealFloat) +import Data.Aeson as Aeson +import Control.Applicative +import Control.Monad +import Data.Word +import qualified Numeric.Half as Half + +import Test.Tasty.HUnit + +import Tests.Reference.Implementation as CBOR + + +data TestCase = TestCase { + encoded :: !LBS.ByteString, + decoded :: !(Either Aeson.Value String), + roundTrip :: !Bool + } + deriving Show + +instance FromJSON TestCase where + parseJSON = + withObject "cbor test" $ \obj -> do + encoded64 <- T.encodeUtf8 <$> obj .: "cbor" + encoded <- either (fail "invalid base64") return $ + Base64.decode encoded64 + encoded16 <- T.encodeUtf8 <$> obj .: "hex" + let encoded' = fst (Base16.decode encoded16) + when (encoded /= encoded') $ + fail "hex and cbor encoding mismatch in input" + roundTrip <- obj .: "roundtrip" + decoded <- Left <$> obj .: "decoded" + <|> Right <$> obj .: "diagnostic" + return $! TestCase { + encoded = LBS.fromStrict encoded, + roundTrip, + decoded + } + +loadTestCases :: IO [TestCase] +loadTestCases = do + content <- LBS.readFile "tests/test-vectors/appendix_a.json" + either fail return (Aeson.eitherDecode' content) + +externalTestCase :: TestCase -> Assertion +externalTestCase TestCase { encoded, decoded = Left expectedJson } = do + let term = deserialise encoded + actualJson = termToJson term + reencoded = serialise term + + expectedJson `equalJson` actualJson + encoded @=? reencoded + +externalTestCase TestCase { encoded, decoded = Right expectedDiagnostic } = do + let term = deserialise encoded + actualDiagnostic = diagnosticNotation term + reencoded = serialise term + + expectedDiagnostic @=? actualDiagnostic + encoded @=? reencoded + +equalJson :: Aeson.Value -> Aeson.Value -> Assertion +equalJson (Aeson.Number expected) (Aeson.Number actual) + | toRealFloat expected == promoteDouble (toRealFloat actual) + = return () + where + -- This is because the expected JSON output is always using double precision + -- where as Aeson's Scientific type preserves the precision of the input. + -- So for tests using Float, we're more precise than the reference values. + promoteDouble :: Float -> Double + promoteDouble = realToFrac + +equalJson expected actual = expected @=? actual + + +termToJson :: CBOR.Term -> Aeson.Value +termToJson (TUInt n) = Aeson.Number (fromIntegral (fromUInt n)) +termToJson (TNInt n) = Aeson.Number (-1 - fromIntegral (fromUInt n)) +termToJson (TBigInt n) = Aeson.Number (fromIntegral n) +termToJson (TBytes ws) = Aeson.String (bytesToBase64Text ws) +termToJson (TBytess wss) = Aeson.String (bytesToBase64Text (concat wss)) +termToJson (TString cs) = Aeson.String (T.pack cs) +termToJson (TStrings css) = Aeson.String (T.pack (concat css)) +termToJson (TArray ts) = Aeson.Array (V.fromList (map termToJson ts)) +termToJson (TArrayI ts) = Aeson.Array (V.fromList (map termToJson ts)) +termToJson (TMap kvs) = Aeson.object [ (T.pack k, termToJson v) + | (TString k,v) <- kvs ] +termToJson (TMapI kvs) = Aeson.object [ (T.pack k, termToJson v) + | (TString k,v) <- kvs ] +termToJson (TTagged _ t) = termToJson t +termToJson TTrue = Aeson.Bool True +termToJson TFalse = Aeson.Bool False +termToJson TNull = Aeson.Null +termToJson TUndef = Aeson.Null -- replacement value +termToJson (TSimple _) = Aeson.Null -- replacement value +termToJson (TFloat16 f) = Aeson.Number (fromFloatDigits (Half.fromHalf f)) +termToJson (TFloat32 f) = Aeson.Number (fromFloatDigits f) +termToJson (TFloat64 f) = Aeson.Number (fromFloatDigits f) + +bytesToBase64Text :: [Word8] -> T.Text +bytesToBase64Text = T.decodeLatin1 . Base64url.encode . BS.pack + +expectedDiagnosticNotation :: String -> [Word8] -> Assertion +expectedDiagnosticNotation expectedDiagnostic encoded = do + let Just (term, []) = runDecoder decodeTerm encoded + actualDiagnostic = diagnosticNotation term + + expectedDiagnostic @=? actualDiagnostic + +-- | The reference implementation satisfies the roundtrip property for most +-- examples (all the ones from Appendix A). It does not satisfy the roundtrip +-- property in general however, non-canonical over-long int encodings for +-- example. +-- +-- +encodedRoundtrip :: String -> [Word8] -> Assertion +encodedRoundtrip expectedDiagnostic encoded = do + let Just (term, []) = runDecoder decodeTerm encoded + reencoded = encodeTerm term + + assertEqual ("for CBOR: " ++ expectedDiagnostic) encoded reencoded + +-- | The examples from the CBOR spec RFC7049 Appendix A. +-- The diagnostic notation and encoded bytes. +-- +specTestVector :: [(String, [Word8])] +specTestVector = + [ ("0", [0x00]) + , ("1", [0x01]) + , ("10", [0x0a]) + , ("23", [0x17]) + , ("24", [0x18, 0x18]) + , ("25", [0x18, 0x19]) + , ("100", [0x18, 0x64]) + , ("1000", [0x19, 0x03, 0xe8]) + , ("1000000", [0x1a, 0x00, 0x0f, 0x42, 0x40]) + , ("1000000000000", [0x1b, 0x00, 0x00, 0x00, 0xe8, 0xd4, 0xa5, 0x10, 0x00]) + + , ("18446744073709551615", [0x1b, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff]) + , ("18446744073709551616", [0xc2, 0x49, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00]) + , ("-18446744073709551616", [0x3b, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff]) + , ("-18446744073709551617", [0xc3, 0x49, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00]) + + , ("-1", [0x20]) + , ("-10", [0x29]) + , ("-100", [0x38, 0x63]) + , ("-1000", [0x39, 0x03, 0xe7]) + + , ("0.0", [0xf9, 0x00, 0x00]) + , ("-0.0", [0xf9, 0x80, 0x00]) + , ("1.0", [0xf9, 0x3c, 0x00]) + , ("1.1", [0xfb, 0x3f, 0xf1, 0x99, 0x99, 0x99, 0x99, 0x99, 0x9a]) + , ("1.5", [0xf9, 0x3e, 0x00]) + , ("65504.0", [0xf9, 0x7b, 0xff]) + , ("100000.0", [0xfa, 0x47, 0xc3, 0x50, 0x00]) + , ("3.4028234663852886e38", [0xfa, 0x7f, 0x7f, 0xff, 0xff]) + , ("1.0e300", [0xfb, 0x7e, 0x37, 0xe4, 0x3c, 0x88, 0x00, 0x75, 0x9c]) + , ("5.960464477539063e-8", [0xf9, 0x00, 0x01]) + , ("0.00006103515625", [0xf9, 0x04, 0x00]) + , ("-4.0", [0xf9, 0xc4, 0x00]) + , ("-4.1", [0xfb, 0xc0, 0x10, 0x66, 0x66, 0x66, 0x66, 0x66, 0x66]) + + , ("Infinity", [0xf9, 0x7c, 0x00]) + , ("NaN", [0xf9, 0x7e, 0x00]) + , ("-Infinity", [0xf9, 0xfc, 0x00]) + , ("Infinity", [0xfa, 0x7f, 0x80, 0x00, 0x00]) + , ("NaN", [0xfa, 0x7f, 0xc0, 0x00, 0x00]) + , ("-Infinity", [0xfa, 0xff, 0x80, 0x00, 0x00]) + , ("Infinity", [0xfb, 0x7f, 0xf0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00]) + , ("NaN", [0xfb, 0x7f, 0xf8, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00]) + , ("-Infinity", [0xfb, 0xff, 0xf0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00]) + + , ("false", [0xf4]) + , ("true", [0xf5]) + , ("null", [0xf6]) + , ("undefined", [0xf7]) + , ("simple(16)", [0xf0]) + , ("simple(24)", [0xf8, 0x18]) + , ("simple(255)", [0xf8, 0xff]) + + , ("0(\"2013-03-21T20:04:00Z\")", + [0xc0, 0x74, 0x32, 0x30, 0x31, 0x33, 0x2d, 0x30, 0x33, 0x2d, 0x32, 0x31, + 0x54, 0x32, 0x30, 0x3a, 0x30, 0x34, 0x3a, 0x30, 0x30, 0x5a]) + , ("1(1363896240)", [0xc1, 0x1a, 0x51, 0x4b, 0x67, 0xb0]) + , ("1(1363896240.5)", [0xc1, 0xfb, 0x41, 0xd4, 0x52, 0xd9, 0xec, 0x20, 0x00, 0x00]) + , ("23(h'01020304')", [0xd7, 0x44, 0x01, 0x02, 0x03, 0x04]) + , ("24(h'6449455446')", [0xd8, 0x18, 0x45, 0x64, 0x49, 0x45, 0x54, 0x46]) + , ("32(\"http://www.example.com\")", + [0xd8, 0x20, 0x76, 0x68, 0x74, 0x74, 0x70, 0x3a, 0x2f, 0x2f, 0x77, 0x77, + 0x77, 0x2e, 0x65, 0x78, 0x61, 0x6d, 0x70, 0x6c, 0x65, 0x2e, 0x63, 0x6f, 0x6d]) + + , ("h''", [0x40]) + , ("h'01020304'", [0x44, 0x01, 0x02, 0x03, 0x04]) + , ("\"\"", [0x60]) + , ("\"a\"", [0x61, 0x61]) + , ("\"IETF\"", [0x64, 0x49, 0x45, 0x54, 0x46]) + , ("\"\\\"\\\\\"", [0x62, 0x22, 0x5c]) + , ("\"\\252\"", [0x62, 0xc3, 0xbc]) + , ("\"\\27700\"", [0x63, 0xe6, 0xb0, 0xb4]) + , ("\"\\65873\"", [0x64, 0xf0, 0x90, 0x85, 0x91]) + + , ("[]", [0x80]) + , ("[1, 2, 3]", [0x83, 0x01, 0x02, 0x03]) + , ("[1, [2, 3], [4, 5]]", [0x83, 0x01, 0x82, 0x02, 0x03, 0x82, 0x04, 0x05]) + , ("[1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25]", + [0x98, 0x19, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08, 0x09, 0x0a, + 0x0b, 0x0c, 0x0d, 0x0e, 0x0f, 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, + 0x17, 0x18, 0x18, 0x18, 0x19]) + + , ("{}", [0xa0]) + , ("{1: 2, 3: 4}", [0xa2, 0x01, 0x02, 0x03, 0x04]) + , ("{\"a\": 1, \"b\": [2, 3]}", [0xa2, 0x61, 0x61, 0x01, 0x61, 0x62, 0x82, 0x02, 0x03]) + , ("[\"a\", {\"b\": \"c\"}]", [0x82, 0x61, 0x61, 0xa1, 0x61, 0x62, 0x61, 0x63]) + , ("{\"a\": \"A\", \"b\": \"B\", \"c\": \"C\", \"d\": \"D\", \"e\": \"E\"}", + [0xa5, 0x61, 0x61, 0x61, 0x41, 0x61, 0x62, 0x61, 0x42, 0x61, 0x63, 0x61, + 0x43, 0x61, 0x64, 0x61, 0x44, 0x61, 0x65, 0x61, 0x45]) + + , ("(_ h'0102', h'030405')", [0x5f, 0x42, 0x01, 0x02, 0x43, 0x03, 0x04, 0x05, 0xff]) + , ("(_ \"strea\", \"ming\")", [0x7f, 0x65, 0x73, 0x74, 0x72, 0x65, 0x61, 0x64, 0x6d, 0x69, 0x6e, 0x67, 0xff]) + + , ("[_ ]", [0x9f, 0xff]) + , ("[_ 1, [2, 3], [_ 4, 5]]", [0x9f, 0x01, 0x82, 0x02, 0x03, 0x9f, 0x04, 0x05, 0xff, 0xff]) + , ("[_ 1, [2, 3], [4, 5]]", [0x9f, 0x01, 0x82, 0x02, 0x03, 0x82, 0x04, 0x05, 0xff]) + , ("[1, [2, 3], [_ 4, 5]]", [0x83, 0x01, 0x82, 0x02, 0x03, 0x9f, 0x04, 0x05, 0xff]) + , ("[1, [_ 2, 3], [4, 5]]", [0x83, 0x01, 0x9f, 0x02, 0x03, 0xff, 0x82, 0x04, 0x05]) + , ("[_ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25]", + [0x9f, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08, 0x09, 0x0a, 0x0b, + 0x0c, 0x0d, 0x0e, 0x0f, 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, + 0x18, 0x18, 0x18, 0x19, 0xff]) + , ("{_ \"a\": 1, \"b\": [_ 2, 3]}", [0xbf, 0x61, 0x61, 0x01, 0x61, 0x62, 0x9f, 0x02, 0x03, 0xff, 0xff]) + + , ("[\"a\", {_ \"b\": \"c\"}]", [0x82, 0x61, 0x61, 0xbf, 0x61, 0x62, 0x61, 0x63, 0xff]) + , ("{_ \"Fun\": true, \"Amt\": -2}", [0xbf, 0x63, 0x46, 0x75, 0x6e, 0xf5, 0x63, 0x41, 0x6d, 0x74, 0x21, 0xff]) + ] + +-- TODO FIXME: test redundant encodings e.g. +-- bigint with zero-length bytestring +-- bigint with leading zeros +-- bigint using indefinate bytestring encoding +-- larger than necessary ints, lengths, tags, simple etc + +-------------------------------------------------------------------------------- +-- TestTree API + +testTree :: [TestCase] -> TestTree +testTree testCases = + testGroup "Reference implementation" + [ testCase "external test vector" $ + mapM_ externalTestCase testCases + + , testCase "internal test vector" $ do + sequence_ [ do expectedDiagnosticNotation d e + encodedRoundtrip d e + | (d,e) <- specTestVector ] + + , testGroup "properties" + [ testProperty "encoding/decoding initial byte" prop_InitialByte + , testProperty "encoding/decoding additional info" prop_AdditionalInfo + , testProperty "encoding/decoding token header" prop_TokenHeader + , testProperty "encoding/decoding token header 2" prop_TokenHeader2 + , testProperty "encoding/decoding tokens" prop_Token + , --localOption (QuickCheckTests 1000) $ + localOption (QuickCheckMaxSize 150) $ + testProperty "encoding/decoding terms" prop_Term + ] + + , testGroup "internal properties" + [ testProperty "Integer to/from bytes" prop_integerToFromBytes + , testProperty "Word16 to/from network byte order" prop_word16ToFromNet + , testProperty "Word32 to/from network byte order" prop_word32ToFromNet + , testProperty "Word64 to/from network byte order" prop_word64ToFromNet + , testProperty "Numeric.Half to/from Float" prop_halfToFromFloat + ] + ] diff --git a/tests/Tests/Reference/Implementation.hs b/tests/Tests/Reference/Implementation.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Reference/Implementation.hs @@ -0,0 +1,1058 @@ +{-# LANGUAGE CPP, BangPatterns, MagicHash, UnboxedTuples, RankNTypes, ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +----------------------------------------------------------------------------- +-- | +-- Module : Codec.CBOR +-- Copyright : 2013 Simon Meier , +-- 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 + diff --git a/tests/Tests/Regress.hs b/tests/Tests/Regress.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Regress.hs @@ -0,0 +1,23 @@ +module Tests.Regress + ( testTree -- :: TestTree + ) where + +import Test.Tasty + +import qualified Tests.Regress.Issue13 as Issue13 +import qualified Tests.Regress.Issue67 as Issue67 +import qualified Tests.Regress.Issue80 as Issue80 +import qualified Tests.Regress.Issue106 as Issue106 +import qualified Tests.Regress.FlatTerm as FlatTerm + +-------------------------------------------------------------------------------- +-- Tests and properties + +testTree :: TestTree +testTree = testGroup "Regression tests" + [ FlatTerm.testTree + , Issue13.testTree + , Issue67.testTree + , Issue80.testTree + , Issue106.testTree + ] diff --git a/tests/Tests/Regress/FlatTerm.hs b/tests/Tests/Regress/FlatTerm.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Regress/FlatTerm.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE CPP #-} +module Tests.Regress.FlatTerm + ( testTree -- :: TestTree + ) where + +import Data.Int +#if !MIN_VERSION_base(4,8,0) +import Data.Word +#endif + +import Test.Tasty +import Test.Tasty.HUnit + +import Codec.CBOR.Encoding +import Codec.CBOR.Decoding +import Codec.CBOR.FlatTerm + +-------------------------------------------------------------------------------- +-- Tests and properties + +-- | Test an edge case in the FlatTerm implementation: when encoding a word +-- larger than @'maxBound' :: 'Int'@, we store it as an @'Integer'@, and +-- need to remember to handle this case when we decode. +largeWordTest :: Either String Word +largeWordTest = fromFlatTerm decodeWord $ toFlatTerm (encodeWord largeWord) + +largeWord :: Word +largeWord = fromIntegral (maxBound :: Int) + 1 + +-- | Test an edge case in the FlatTerm implementation: when encoding an +-- Int64 that is less than @'minBound' :: 'Int'@, make sure we use an +-- @'Integer'@ to store the result, because sticking it into an @'Int'@ +-- will result in overflow otherwise. +smallInt64Test :: Either String Int64 +smallInt64Test = fromFlatTerm decodeInt64 $ toFlatTerm (encodeInt64 smallInt64) + +smallInt64 :: Int64 +smallInt64 = fromIntegral (minBound :: Int) - 1 + +-------------------------------------------------------------------------------- +-- TestTree API + +testTree :: TestTree +testTree = testGroup "FlatTerm regressions" + [ testCase "Decoding of large-ish words" (Right largeWord @=? largeWordTest) + , testCase "Encoding of Int64s on 32bit" (Right smallInt64 @=? smallInt64Test) + ] diff --git a/tests/Tests/Regress/Issue106.hs b/tests/Tests/Regress/Issue106.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Regress/Issue106.hs @@ -0,0 +1,16 @@ +module Tests.Regress.Issue106 ( testTree ) where + +import Data.Word (Word) -- needed for GHC 7.8.4 +import qualified Codec.Serialise as Serialise +import qualified Codec.CBOR.Pretty as CBOR +import Test.Tasty +import Test.Tasty.HUnit + +repro :: String +repro = + CBOR.prettyHexEnc $ Serialise.encode (5 :: Word) + +testTree :: TestTree +testTree = + testGroup "Issue 106 - Pretty-printing of Word" + [ testCase "simple reproduction case" ("\n05 # word(5)" @=? repro) ] diff --git a/tests/Tests/Regress/Issue13.hs b/tests/Tests/Regress/Issue13.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Regress/Issue13.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE CPP #-} + +-- Issue #13: unsafe usage of a ForeignPtr leads to undefined behavior, +-- as we get handed a stale pointer. +module Tests.Regress.Issue13 + ( testTree -- :: TestTree + ) where + +import Data.Monoid ((<>)) +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>), (<*>)) +#endif + +import qualified Data.Text as T +import Test.Tasty +import Test.QuickCheck +import Test.Tasty.QuickCheck +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL + +import Codec.Serialise +import Codec.CBOR.Decoding (decodeListLen, decodeWord) +import Codec.CBOR.Encoding (encodeListLen, encodeWord) + +-------------------------------------------------------------------------------- +-- Tests and properties + +newtype MyText = MyText T.Text deriving (Show, Eq) + +instance Arbitrary MyText where + arbitrary = MyText <$> (T.pack <$> arbitrary) + +instance Serialise MyText where + encode (MyText t) = encode t + decode = MyText <$> decode + +data Value + = VNum Integer + | VTerms [MyText] + deriving (Show, Eq) + +instance Serialise Value where + encode (VNum num) = encodeListLen 2 <> encodeWord 0 <> encode num + encode (VTerms tset) = encodeListLen 2 <> encodeWord 8 <> encodeList tset + decode = do + marker <- (,) <$> decodeListLen <*> decodeWord + case marker of + (2, 0) -> VNum <$> decode + (2, 8) -> VTerms <$> decodeList + _ -> fail "Incorrect CBOR value" + +instance Arbitrary Value where + arbitrary = oneof [ + VNum <$> arbitrary + , VTerms <$> arbitrary + ] + +prop_chunkByte :: [Value] -> Bool +prop_chunkByte v = (deserialise . tokenize . serialise) v == v + where + tokenize = BL.fromChunks . map (\a -> BS.pack [a]) . BS.unpack . BS.concat . BL.toChunks + +prop_longData :: [Value] -> Bool +prop_longData v = deserialise (serialise v) == v + +-------------------------------------------------------------------------------- +-- TestTree API + +testTree :: TestTree +testTree = + testGroup "Issue 13 - tests for incorrect lazy access" + [ testProperty "from/to 1-byte chunks" prop_chunkByte + , testProperty "from/to long data" prop_longData + ] diff --git a/tests/Tests/Regress/Issue67.hs b/tests/Tests/Regress/Issue67.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Regress/Issue67.hs @@ -0,0 +1,80 @@ +-- Avoid some warnings in case the LLVM backend isn't being used +{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-unused-imports #-} +{-# LANGUAGE CPP #-} + +-- Issue #67: Invalid compilation with LLVM backend. +-- +-- Reported in the wild, and cribbed from https://github.com/fpco/serial-bench +module Tests.Regress.Issue67 + ( testTree -- :: TestTree + ) where + +import Data.Int +import Data.Monoid ((<>)) +import Data.Word +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>), (<*>)) +#endif + +import qualified Data.ByteString.Lazy as L +import qualified Data.Vector as V +import Codec.Serialise +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck +import Test.Tasty.HUnit + +-------------------------------------------------------------------------------- +-- Tests and properties + +data SomeData = SomeData !Int64 !Word8 !Double + deriving (Eq, Show) + +instance Serialise SomeData where + decode = SomeData <$> decode <*> decode <*> decode + {-# INLINE decode #-} + + encode (SomeData a b c) = encode a <> encode b <> encode c + {-# INLINE encode #-} + +newtype ArbSomeData = ArbSomeData { toSomeData :: SomeData } + deriving (Show, Eq) + +instance Arbitrary ArbSomeData where + arbitrary = fmap ArbSomeData $ SomeData + <$> arbitrary + <*> arbitrary + <*> arbitrary + +-------------------------------------------------------------------------------- +-- TestTree API + +to :: V.Vector SomeData -> L.ByteString +to = serialise + +from :: L.ByteString -> Maybe (V.Vector SomeData) +from = Just . deserialise + +repro1 :: Bool +repro1 = + let v = V.fromList [SomeData 53169 70 55.3817683321392] + in from (to v) == Just v + +prop_vectorRoundtrip :: [ArbSomeData] -> Bool +prop_vectorRoundtrip list = + let v = V.fromList (map toSomeData list) + in from (to v) == Just v + +testTree :: TestTree +testTree = +#if defined(__GLASGOW_HASKELL_LLVM__) + testGroup "Issue 67 - LLVM bogons" + [ testCase "simple reproduction case" (True @=? repro1) + , testProperty "vector roundtrip works" prop_vectorRoundtrip + ] +#else + testGroup "Issue 67 - LLVM bogons (NO LLVM - SKIPPING)" + [ testCase "simple reproduction case (SKIPPED)" (True @=? True) + , testCase "vector roundtrip works (SKIPPED)" (True @=? True) + ] +#endif diff --git a/tests/Tests/Regress/Issue80.hs b/tests/Tests/Regress/Issue80.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Regress/Issue80.hs @@ -0,0 +1,24 @@ +module Tests.Regress.Issue80 ( testTree ) where + +import qualified Data.Vector.Storable as S +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import qualified Codec.Serialise as Serialise +import Test.Tasty +import Test.Tasty.HUnit + +repro :: Bool +repro = + let evilChunker bs i = + -- Split strict bytestring into chunks and return as lazy one + let (b1, b2) = BS.splitAt i bs in BL.fromChunks [b1, b2] + -- Test case + value = [S.replicate 128 (0 :: Double)] + serialised = (BS.concat . BL.toChunks . Serialise.serialise) value + deserialised = Serialise.deserialise . evilChunker serialised + in all (\i -> value == deserialised i) [1 .. BS.length serialised - 1] + +testTree :: TestTree +testTree = + testGroup "Issue 80 - Vector chunkingd" + [ testCase "simple reproduction case" (True @=? repro) ] diff --git a/tests/Tests/Serialise.hs b/tests/Tests/Serialise.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Serialise.hs @@ -0,0 +1,368 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Tests.Serialise + ( testTree -- :: TestTree + , testGenerics -- :: TestTree + ) where + +#if MIN_VERSION_base(4,8,0) +import Data.Functor.Identity +import Numeric.Natural +#endif + +#if MIN_VERSION_base(4,9,0) +import Data.List.NonEmpty ( NonEmpty ) +import qualified Data.Semigroup as Semigroup +#endif + +import Data.Complex +import Data.Int +import Data.Fixed +import Data.Monoid as Monoid +import Data.Ord +import Data.Ratio +import Data.Time +import Data.Word +import GHC.Float (float2Double) +import Data.Version + +import Data.Typeable +import Control.Applicative +import Foreign.C.Types + +import Test.QuickCheck hiding (Fixed(..)) +import Test.Tasty +import Test.Tasty.QuickCheck hiding (Fixed(..)) +import Test.QuickCheck.Instances () +import Test.Tasty.HUnit +import GHC.Generics (Generic) +import qualified Data.Text as Text +import qualified Data.Text.Lazy as Text.Lazy +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BS.Lazy +import System.Exit (ExitCode(..)) + +import Codec.CBOR.FlatTerm (toFlatTerm, fromFlatTerm) +import Codec.Serialise +import Codec.Serialise.Encoding +import Codec.Serialise.Decoding +import qualified Codec.Serialise.Properties as Props + +import qualified Data.HashMap.Strict as HashMap +import qualified Data.HashSet as HashSet +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet +import qualified Data.Map as Map +import qualified Data.Sequence as Sequence +import qualified Data.Set as Set +import qualified Data.Tree as Tree +import qualified Data.Vector as Vector +import qualified Data.Vector.Unboxed as Vector.Unboxed +import qualified Data.Vector.Storable as Vector.Storable +import qualified Data.Vector.Primitive as Vector.Primitive +import GHC.Fingerprint.Type (Fingerprint(..)) + +import Tests.Orphanage() + +-------------------------------------------------------------------------------- +-- Tests and properties + +-- | Simple proxy type, used as a witness. +data T a = T + +-- | Ensure that serializing and deserializing a term results in the original +-- term. +prop_serialiseId :: (Serialise a, Eq a) => T a -> a -> Bool +prop_serialiseId _ = Props.serialiseIdentity + +-- | Ensure that serializing and deserializing a term (into @'FlatTerm'@ form) +-- results in the original term. +prop_flatTermId :: (Serialise a, Eq a) => T a -> a -> Bool +prop_flatTermId _ = Props.flatTermIdentity + +-- | Ensure that serializing a term into a @'FlatTerm'@ always gives us a +-- valid @'FlatTerm'@ back. +prop_validFlatTerm :: Serialise a => T a -> a -> Bool +prop_validFlatTerm _ = Props.hasValidFlatTerm + +format :: (Typeable a, Show a, Serialise a) => a -> Tokens -> TestTree +format a toks + = testCase (show (typeOf a) ++ ": " ++ show a) + $ toks @=? toks' + where + Encoding f = encode a + toks' = f TkEnd + +-------------------------------------------------------------------------------- +-- Corner case or specific properties to test + +-- | Ensure that when we encode a Float but decode as a Double, we get the same +-- value. +prop_encodeFloatToDouble :: Float -> Bool +prop_encodeFloatToDouble x = Right dbl == fromFlatTerm dec ft + where + dbl = float2Double x + + dec = decode :: Decoder s Double + ft = toFlatTerm (encode x) + +-------------------------------------------------------------------------------- +-- Ensure we can decode UTCTimes when using tag 1 (offset from epoch) + +prop_decodeTag1UTCTimeInteger :: TestTree +prop_decodeTag1UTCTimeInteger = testCase "Decode tag 1 UTCTime (Integer)" $ + Right mar21 @=? fromFlatTerm dec (toFlatTerm (Encoding toks)) + where + toks e = TkTag 1 $ TkInteger 1363896240 $ e + mar21 = UTCTime (fromGregorian 2013 3 21) (timeOfDayToTime (TimeOfDay 20 4 0)) + dec = decode :: Decoder s UTCTime + +prop_decodeTag1UTCTimeDouble :: TestTree +prop_decodeTag1UTCTimeDouble = testCase "Decode tag 1 UTCTime (Double)" $ + Right mar21 @=? fromFlatTerm dec (toFlatTerm (Encoding toks)) + where + toks e = TkTag 1 $ TkFloat64 1363896240.5 $ e + mar21 = UTCTime (fromGregorian 2013 3 21) (timeOfDayToTime (TimeOfDay 20 4 0.5)) + dec = decode :: Decoder s UTCTime + +-------------------------------------------------------------------------------- +-- TestTree API + +testTree :: TestTree +testTree = testGroup "Serialise class" + [ testGroup "Corner cases" + [ testProperty "decode float to double" prop_encodeFloatToDouble + , prop_decodeTag1UTCTimeInteger + , prop_decodeTag1UTCTimeDouble + ] + , testGroup "Simple instance invariants" + [ mkTest (T :: T ()) + , mkTest (T :: T Bool) + , mkTest (T :: T Int) + , mkTest (T :: T Int8) + , mkTest (T :: T Int16) + , mkTest (T :: T Int32) + , mkTest (T :: T Int64) + , mkTest (T :: T Word) + , mkTest (T :: T Word8) + , mkTest (T :: T Word16) + , mkTest (T :: T Word32) + , mkTest (T :: T Word64) + , mkTest (T :: T Integer) + , mkTest (T :: T Float) + , mkTest (T :: T Double) + , mkTest (T :: T [()]) +#if MIN_VERSION_base(4,9,0) + , mkTest (T :: T (NonEmpty ())) + , mkTest (T :: T (Semigroup.Min ())) + , mkTest (T :: T (Semigroup.Max ())) + , mkTest (T :: T (Semigroup.First ())) + , mkTest (T :: T (Semigroup.Last ())) + , mkTest (T :: T (Semigroup.Option ())) + , mkTest (T :: T (Semigroup.WrappedMonoid ())) +#endif +#if MIN_VERSION_base(4,7,0) + , mkTest (T :: T (Fixed E0)) + , mkTest (T :: T (Fixed E1)) + , mkTest (T :: T (Fixed E2)) + , mkTest (T :: T (Fixed E3)) + , mkTest (T :: T (Fixed E6)) + , mkTest (T :: T (Fixed E9)) + , mkTest (T :: T (Fixed E12)) + , mkTest (T :: T (Proxy ())) +#endif + , mkTest (T :: T Char) + , mkTest (T :: T CChar) + , mkTest (T :: T CSChar) + , mkTest (T :: T CUChar) + , mkTest (T :: T CShort) + , mkTest (T :: T CUShort) + , mkTest (T :: T CInt) + , mkTest (T :: T CUInt) + , mkTest (T :: T CLong) + , mkTest (T :: T CULong) + , mkTest (T :: T CPtrdiff) + , mkTest (T :: T CSize) + , mkTest (T :: T CWchar) + , mkTest (T :: T CSigAtomic) + , mkTest (T :: T CLLong) + , mkTest (T :: T CULLong) + , mkTest (T :: T CIntPtr) + , mkTest (T :: T CUIntPtr) + , mkTest (T :: T CIntMax) + , mkTest (T :: T CUIntMax) + , mkTest (T :: T CClock) + , mkTest (T :: T CTime) + , mkTest (T :: T CUSeconds) + , mkTest (T :: T CSUSeconds) + , mkTest (T :: T CFloat) + , mkTest (T :: T CDouble) + , mkTest (T :: T (Int, Char)) + , mkTest (T :: T (Int, Char, Bool)) + , mkTest (T :: T (Int, Char, Bool, String)) + , mkTest (T :: T (Int, Char, Bool, String, ())) + , mkTest (T :: T (Int, Char, Bool, String, (), Maybe Char)) + , mkTest (T :: T (Int, Char, Bool, String, (), Maybe Char, Maybe ())) + , mkTest (T :: T (Maybe Int)) + , mkTest (T :: T (Either String Int)) + , mkTest (T :: T String) + , mkTest (T :: T Text.Text) + , mkTest (T :: T Text.Lazy.Text) + , mkTest (T :: T BS.ByteString) + , mkTest (T :: T BS.Lazy.ByteString) + , mkTest (T :: T [Int]) + , mkTest (T :: T UTCTime) + , mkTest (T :: T Version) + , mkTest (T :: T Fingerprint) + , mkTest (T :: T ExitCode) + , mkTest (T :: T (Ratio Integer)) + , mkTest (T :: T (Complex Double)) + , mkTest (T :: T (Const Int ())) + , mkTest (T :: T (ZipList Int)) + , mkTest (T :: T (ZipList Char)) + , mkTest (T :: T Ordering) + , mkTest (T :: T (Down Int64)) + , mkTest (T :: T (Dual (Maybe (Sum Int)))) + , mkTest (T :: T All) + , mkTest (T :: T Any) +#if MIN_VERSION_base(4,8,0) + , mkTest (T :: T (Alt Maybe Int)) + , mkTest (T :: T (Identity ())) + , mkTest (T :: T Natural) +#endif + , mkTest (T :: T (Sum Int)) + , mkTest (T :: T (Product Int)) + , mkTest (T :: T (Map.Map Int String)) + , mkTest (T :: T (Sequence.Seq Int)) + , mkTest (T :: T (Set.Set Int)) + , mkTest (T :: T IntSet.IntSet) + , mkTest (T :: T (IntMap.IntMap String)) + , mkTest (T :: T (HashMap.HashMap Int String)) + , mkTest (T :: T (HashSet.HashSet Int)) + , mkTest (T :: T (Tree.Tree (Int, String, ()))) + , mkTest (T :: T (Vector.Vector Int)) + , mkTest (T :: T (Vector.Unboxed.Vector (Int,Bool))) + , mkTest (T :: T (Vector.Storable.Vector Int)) + , mkTest (T :: T (Vector.Primitive.Vector Int)) + -- generics: + , mkTest (T :: T Unit) + , mkTest (T :: T P1) + , mkTest (T :: T P2) + , mkTest (T :: T P3) + , mkTest (T :: T C4) + , mkTest (T :: T (List Int)) + ] + ] + +testGenerics :: TestTree +testGenerics = testGroup "Format of Generics encoding" + [ format + Unit + (TkListLen 1 $ TkWord 0 $ TkEnd) + , format + (P1 12) + (TkListLen 2 $ TkWord 0 $ TkInt 12 $ TkEnd) + , format + (N1 12) + (TkListLen 2 $ TkWord 0 $ TkInt 12 $ TkEnd) + , format + (P2 12 0.5) + (TkListLen 3 $ TkWord 0 $ TkInt 12 $ TkFloat32 0.5 $ TkEnd) + , format + (P3 12 0.5 "asdf") + (TkListLen 4 $ TkWord 0 $ TkInt 12 $ TkFloat32 0.5 $ TkString "asdf" $ TkEnd) + , format + (C1 12) + (TkListLen 2 $ TkWord 0 $ TkInt 12 $ TkEnd) + , format + (C2 12 0.5) + (TkListLen 3 $ TkWord 1 $ TkInt 12 $ TkFloat32 0.5 $ TkEnd) + , format + (C3 12 0.5 "asdf") + (TkListLen 4 $ TkWord 2 $ TkInt 12 $ TkFloat32 0.5 $ TkString "asdf" $ TkEnd) + , format + C4 + (TkListLen 1 $ TkWord 3 $ TkEnd) + , format + (Cons "foo" (Cons "bar" Nil) :: List String) + (TkListLen 3 $ TkWord 0 $ TkString "foo" $ + TkListLen 3 $ TkWord 0 $ TkString "bar" $ + TkListLen 1 $ TkWord 1 $ + TkEnd) + ] + +-------------------------------------------------------------------------------- +-- Extra machinery + +-- A simple alias to make the following properties more convenient to write +type BasicType a = (Arbitrary a, Typeable a, Serialise a, Eq a, Show a) + +mkTest :: forall a. BasicType a => T a -> TestTree +mkTest t = testGroup ("type: " ++ show (typeOf (undefined :: a))) + [ testProperty "cbor roundtrip" (prop_serialiseId t) + , testProperty "flat roundtrip" (prop_flatTermId t) + , testProperty "flat term is valid" (prop_validFlatTerm t) + ] + + +-------------------------------------------------------------------------------- +-- Generic data types + +data Unit = Unit + deriving (Show,Eq,Typeable,Generic) +data P1 = P1 Int + deriving (Show,Eq,Typeable,Generic) +newtype N1 = N1 Int + deriving (Show,Eq,Typeable,Generic) +data P2 = P2 Int Float + deriving (Show,Eq,Typeable,Generic) +data P3 = P3 Int Float String + deriving (Show,Eq,Typeable,Generic) + +data C4 = C1 Int + | C2 Int Float + | C3 Int Float String + | C4 + deriving (Show,Eq,Typeable,Generic) + +data List a = Cons a (List a) + | Nil + deriving (Show,Eq,Typeable,Generic) + +instance Serialise Unit +instance Serialise P1 +instance Serialise N1 +instance Serialise P2 +instance Serialise P3 +instance Serialise C4 +instance Serialise a => Serialise (List a) + + +instance Arbitrary Unit where + arbitrary = pure Unit + +instance Arbitrary P1 where + arbitrary = P1 <$> arbitrary +instance Arbitrary N1 where + arbitrary = N1 <$> arbitrary +instance Arbitrary P2 where + arbitrary = P2 <$> arbitrary <*> arbitrary +instance Arbitrary P3 where + arbitrary = P3 <$> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary C4 where + arbitrary = oneof [ C1 <$> arbitrary + , C2 <$> arbitrary <*> arbitrary + , C3 <$> arbitrary <*> arbitrary <*> arbitrary + , pure C4 + ] + +instance Arbitrary a => Arbitrary (List a) where + arbitrary = cnv <$> arbitrary + where + cnv :: [a] -> List a + cnv = foldr Cons Nil diff --git a/tests/test-vectors/README.md b/tests/test-vectors/README.md new file mode 100644 --- /dev/null +++ b/tests/test-vectors/README.md @@ -0,0 +1,27 @@ +test-vectors +============ + +This repo collects some simple test vectors in machine-processable form. + +appendix_a.json +--------------- + +All examples in Appendix A of RFC 7049, encoded as a JSON array. + +Each element of the test vector is a map (JSON object) with the keys: + +- cbor: a base-64 encoded CBOR data item +- hex: the same CBOR data item in hex encoding +- roundtrip: a boolean that indicates whether a generic CBOR encoder + would _typically_ produce identical CBOR on re-encoding the decoded + data item (your mileage may vary) +- decoded: the decoded data item if it can be represented in JSON +- diagnostic: the representation of the data item in CBOR diagnostic notation, otherwise + +To make use of the cases that need diagnostic notation, a diagnostic +notation printer is usually all that is needed: decode the CBOR, print +the decoded data item in diagnostic notation, and compare. + +(Note that the diagnostic notation uses full decoration for the +indefinite length byte string, while the decoded indefinite length +text string represented in JSON necessarily doesn't.) diff --git a/tests/test-vectors/appendix_a.json b/tests/test-vectors/appendix_a.json new file mode 100644 --- /dev/null +++ b/tests/test-vectors/appendix_a.json @@ -0,0 +1,636 @@ +[ + { + "cbor": "AA==", + "hex": "00", + "roundtrip": true, + "decoded": 0 + }, + { + "cbor": "AQ==", + "hex": "01", + "roundtrip": true, + "decoded": 1 + }, + { + "cbor": "Cg==", + "hex": "0a", + "roundtrip": true, + "decoded": 10 + }, + { + "cbor": "Fw==", + "hex": "17", + "roundtrip": true, + "decoded": 23 + }, + { + "cbor": "GBg=", + "hex": "1818", + "roundtrip": true, + "decoded": 24 + }, + { + "cbor": "GBk=", + "hex": "1819", + "roundtrip": true, + "decoded": 25 + }, + { + "cbor": "GGQ=", + "hex": "1864", + "roundtrip": true, + "decoded": 100 + }, + { + "cbor": "GQPo", + "hex": "1903e8", + "roundtrip": true, + "decoded": 1000 + }, + { + "cbor": "GgAPQkA=", + "hex": "1a000f4240", + "roundtrip": true, + "decoded": 1000000 + }, + { + "cbor": "GwAAAOjUpRAA", + "hex": "1b000000e8d4a51000", + "roundtrip": true, + "decoded": 1000000000000 + }, + { + "cbor": "G///////////", + "hex": "1bffffffffffffffff", + "roundtrip": true, + "decoded": 18446744073709551615 + }, + { + "cbor": "wkkBAAAAAAAAAAA=", + "hex": "c249010000000000000000", + "roundtrip": true, + "decoded": 18446744073709551616 + }, + { + "cbor": "O///////////", + "hex": "3bffffffffffffffff", + "roundtrip": true, + "decoded": -18446744073709551616 + }, + { + "cbor": "w0kBAAAAAAAAAAA=", + "hex": "c349010000000000000000", + "roundtrip": true, + "decoded": -18446744073709551617 + }, + { + "cbor": "IA==", + "hex": "20", + "roundtrip": true, + "decoded": -1 + }, + { + "cbor": "KQ==", + "hex": "29", + "roundtrip": true, + "decoded": -10 + }, + { + "cbor": "OGM=", + "hex": "3863", + "roundtrip": true, + "decoded": -100 + }, + { + "cbor": "OQPn", + "hex": "3903e7", + "roundtrip": true, + "decoded": -1000 + }, + { + "cbor": "+QAA", + "hex": "f90000", + "roundtrip": true, + "decoded": 0.0 + }, + { + "cbor": "+YAA", + "hex": "f98000", + "roundtrip": true, + "decoded": -0.0 + }, + { + "cbor": "+TwA", + "hex": "f93c00", + "roundtrip": true, + "decoded": 1.0 + }, + { + "cbor": "+z/xmZmZmZma", + "hex": "fb3ff199999999999a", + "roundtrip": true, + "decoded": 1.1 + }, + { + "cbor": "+T4A", + "hex": "f93e00", + "roundtrip": true, + "decoded": 1.5 + }, + { + "cbor": "+Xv/", + "hex": "f97bff", + "roundtrip": true, + "decoded": 65504.0 + }, + { + "cbor": "+kfDUAA=", + "hex": "fa47c35000", + "roundtrip": true, + "decoded": 100000.0 + }, + { + "cbor": "+n9///8=", + "hex": "fa7f7fffff", + "roundtrip": true, + "decoded": 3.4028234663852886e+38 + }, + { + "cbor": "+3435DyIAHWc", + "hex": "fb7e37e43c8800759c", + "roundtrip": true, + "decoded": 1.0e+300 + }, + { + "cbor": "+QAB", + "hex": "f90001", + "roundtrip": true, + "decoded": 5.960464477539063e-08 + }, + { + "cbor": "+QQA", + "hex": "f90400", + "roundtrip": true, + "decoded": 6.103515625e-05 + }, + { + "cbor": "+cQA", + "hex": "f9c400", + "roundtrip": true, + "decoded": -4.0 + }, + { + "cbor": "+8AQZmZmZmZm", + "hex": "fbc010666666666666", + "roundtrip": true, + "decoded": -4.1 + }, + { + "cbor": "+XwA", + "hex": "f97c00", + "roundtrip": true, + "diagnostic": "Infinity" + }, + { + "cbor": "+X4A", + "hex": "f97e00", + "roundtrip": true, + "diagnostic": "NaN" + }, + { + "cbor": "+fwA", + "hex": "f9fc00", + "roundtrip": true, + "diagnostic": "-Infinity" + }, + { + "cbor": "+n+AAAA=", + "hex": "fa7f800000", + "roundtrip": false, + "diagnostic": "Infinity" + }, + { + "cbor": "+n/AAAA=", + "hex": "fa7fc00000", + "roundtrip": false, + "diagnostic": "NaN" + }, + { + "cbor": "+v+AAAA=", + "hex": "faff800000", + "roundtrip": false, + "diagnostic": "-Infinity" + }, + { + "cbor": "+3/wAAAAAAAA", + "hex": "fb7ff0000000000000", + "roundtrip": false, + "diagnostic": "Infinity" + }, + { + "cbor": "+3/4AAAAAAAA", + "hex": "fb7ff8000000000000", + "roundtrip": false, + "diagnostic": "NaN" + }, + { + "cbor": "+//wAAAAAAAA", + "hex": "fbfff0000000000000", + "roundtrip": false, + "diagnostic": "-Infinity" + }, + { + "cbor": "9A==", + "hex": "f4", + "roundtrip": true, + "decoded": false + }, + { + "cbor": "9Q==", + "hex": "f5", + "roundtrip": true, + "decoded": true + }, + { + "cbor": "9g==", + "hex": "f6", + "roundtrip": true, + "decoded": null + }, + { + "cbor": "9w==", + "hex": "f7", + "roundtrip": true, + "diagnostic": "undefined" + }, + { + "cbor": "8A==", + "hex": "f0", + "roundtrip": true, + "diagnostic": "simple(16)" + }, + { + "cbor": "+Bg=", + "hex": "f818", + "roundtrip": true, + "diagnostic": "simple(24)" + }, + { + "cbor": "+P8=", + "hex": "f8ff", + "roundtrip": true, + "diagnostic": "simple(255)" + }, + { + "cbor": "wHQyMDEzLTAzLTIxVDIwOjA0OjAwWg==", + "hex": "c074323031332d30332d32315432303a30343a30305a", + "roundtrip": true, + "diagnostic": "0(\"2013-03-21T20:04:00Z\")" + }, + { + "cbor": "wRpRS2ew", + "hex": "c11a514b67b0", + "roundtrip": true, + "diagnostic": "1(1363896240)" + }, + { + "cbor": "wftB1FLZ7CAAAA==", + "hex": "c1fb41d452d9ec200000", + "roundtrip": true, + "diagnostic": "1(1363896240.5)" + }, + { + "cbor": "10QBAgME", + "hex": "d74401020304", + "roundtrip": true, + "diagnostic": "23(h'01020304')" + }, + { + "cbor": "2BhFZElFVEY=", + "hex": "d818456449455446", + "roundtrip": true, + "diagnostic": "24(h'6449455446')" + }, + { + "cbor": "2CB2aHR0cDovL3d3dy5leGFtcGxlLmNvbQ==", + "hex": "d82076687474703a2f2f7777772e6578616d706c652e636f6d", + "roundtrip": true, + "diagnostic": "32(\"http://www.example.com\")" + }, + { + "cbor": "QA==", + "hex": "40", + "roundtrip": true, + "diagnostic": "h''" + }, + { + "cbor": "RAECAwQ=", + "hex": "4401020304", + "roundtrip": true, + "diagnostic": "h'01020304'" + }, + { + "cbor": "YA==", + "hex": "60", + "roundtrip": true, + "decoded": "" + }, + { + "cbor": "YWE=", + "hex": "6161", + "roundtrip": true, + "decoded": "a" + }, + { + "cbor": "ZElFVEY=", + "hex": "6449455446", + "roundtrip": true, + "decoded": "IETF" + }, + { + "cbor": "YiJc", + "hex": "62225c", + "roundtrip": true, + "decoded": "\"\\" + }, + { + "cbor": "YsO8", + "hex": "62c3bc", + "roundtrip": true, + "decoded": "ü" + }, + { + "cbor": "Y+awtA==", + "hex": "63e6b0b4", + "roundtrip": true, + "decoded": "水" + }, + { + "cbor": "ZPCQhZE=", + "hex": "64f0908591", + "roundtrip": true, + "decoded": "𐅑" + }, + { + "cbor": "gA==", + "hex": "80", + "roundtrip": true, + "decoded": [ + + ] + }, + { + "cbor": "gwECAw==", + "hex": "83010203", + "roundtrip": true, + "decoded": [ + 1, + 2, + 3 + ] + }, + { + "cbor": "gwGCAgOCBAU=", + "hex": "8301820203820405", + "roundtrip": true, + "decoded": [ + 1, + [ + 2, + 3 + ], + [ + 4, + 5 + ] + ] + }, + { + "cbor": "mBkBAgMEBQYHCAkKCwwNDg8QERITFBUWFxgYGBk=", + "hex": "98190102030405060708090a0b0c0d0e0f101112131415161718181819", + "roundtrip": true, + "decoded": [ + 1, + 2, + 3, + 4, + 5, + 6, + 7, + 8, + 9, + 10, + 11, + 12, + 13, + 14, + 15, + 16, + 17, + 18, + 19, + 20, + 21, + 22, + 23, + 24, + 25 + ] + }, + { + "cbor": "oA==", + "hex": "a0", + "roundtrip": true, + "decoded": { + } + }, + { + "cbor": "ogECAwQ=", + "hex": "a201020304", + "roundtrip": true, + "diagnostic": "{1: 2, 3: 4}" + }, + { + "cbor": "omFhAWFiggID", + "hex": "a26161016162820203", + "roundtrip": true, + "decoded": { + "a": 1, + "b": [ + 2, + 3 + ] + } + }, + { + "cbor": "gmFhoWFiYWM=", + "hex": "826161a161626163", + "roundtrip": true, + "decoded": [ + "a", + { + "b": "c" + } + ] + }, + { + "cbor": "pWFhYUFhYmFCYWNhQ2FkYURhZWFF", + "hex": "a56161614161626142616361436164614461656145", + "roundtrip": true, + "decoded": { + "a": "A", + "b": "B", + "c": "C", + "d": "D", + "e": "E" + } + }, + { + "cbor": "X0IBAkMDBAX/", + "hex": "5f42010243030405ff", + "roundtrip": false, + "diagnostic": "(_ h'0102', h'030405')" + }, + { + "cbor": "f2VzdHJlYWRtaW5n/w==", + "hex": "7f657374726561646d696e67ff", + "roundtrip": false, + "decoded": "streaming" + }, + { + "cbor": "n/8=", + "hex": "9fff", + "roundtrip": false, + "decoded": [ + + ] + }, + { + "cbor": "nwGCAgOfBAX//w==", + "hex": "9f018202039f0405ffff", + "roundtrip": false, + "decoded": [ + 1, + [ + 2, + 3 + ], + [ + 4, + 5 + ] + ] + }, + { + "cbor": "nwGCAgOCBAX/", + "hex": "9f01820203820405ff", + "roundtrip": false, + "decoded": [ + 1, + [ + 2, + 3 + ], + [ + 4, + 5 + ] + ] + }, + { + "cbor": "gwGCAgOfBAX/", + "hex": "83018202039f0405ff", + "roundtrip": false, + "decoded": [ + 1, + [ + 2, + 3 + ], + [ + 4, + 5 + ] + ] + }, + { + "cbor": "gwGfAgP/ggQF", + "hex": "83019f0203ff820405", + "roundtrip": false, + "decoded": [ + 1, + [ + 2, + 3 + ], + [ + 4, + 5 + ] + ] + }, + { + "cbor": "nwECAwQFBgcICQoLDA0ODxAREhMUFRYXGBgYGf8=", + "hex": "9f0102030405060708090a0b0c0d0e0f101112131415161718181819ff", + "roundtrip": false, + "decoded": [ + 1, + 2, + 3, + 4, + 5, + 6, + 7, + 8, + 9, + 10, + 11, + 12, + 13, + 14, + 15, + 16, + 17, + 18, + 19, + 20, + 21, + 22, + 23, + 24, + 25 + ] + }, + { + "cbor": "v2FhAWFinwID//8=", + "hex": "bf61610161629f0203ffff", + "roundtrip": false, + "decoded": { + "a": 1, + "b": [ + 2, + 3 + ] + } + }, + { + "cbor": "gmFhv2FiYWP/", + "hex": "826161bf61626163ff", + "roundtrip": false, + "decoded": [ + "a", + { + "b": "c" + } + ] + }, + { + "cbor": "v2NGdW71Y0FtdCH/", + "hex": "bf6346756ef563416d7421ff", + "roundtrip": false, + "decoded": { + "Fun": true, + "Amt": -2 + } + } +]