packages feed

serialise (empty) → 0.1.0.0

raw patch · 61 files changed

+11342/−0 lines, 61 filesdep +QuickCheckdep +aesondep +arraysetup-changed

Dependencies added: QuickCheck, aeson, array, base, base16-bytestring, base64-bytestring, binary, bytestring, cborg, cereal, cereal-vector, containers, criterion, deepseq, directory, filepath, ghc-prim, half, hashable, old-locale, pretty, primitive, quickcheck-instances, scientific, serialise, store, tar, tasty, tasty-hunit, tasty-quickcheck, text, time, unordered-containers, vector, zlib

Files

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