serialise-0.2.3.0/0000755000000000000000000000000007346545000012023 5ustar0000000000000000serialise-0.2.3.0/ChangeLog.md0000755000000000000000000000124307346545000014177 0ustar0000000000000000# Revision history for serialise ## 0.2.3.0 -- 2020-05-10 * Bounds bumps and GHC 8.10 compatibility ## 0.2.2.0 -- 2019-12-29 * Export `encodeContainerSkel`, `encodeMapSkel` and `decodeMapSkel` from `Codec.Serialise.Class` * Fix `Serialise` instances for `TypeRep` and `SomeTypeRep` (#216) * Bounds bumps and GHC 8.8 compatibility ## 0.2.1.0 -- 2018-10-11 * Bounds bumps and GHC 8.6 compatibility ## 0.2.0.0 -- 2017-11-30 * Improved robustness in presence of invalid UTF-8 strings * Add encoders and decoders for `ByteArray` * Export `GSerialiseProd(..) and GSerialiseSum(..)` ## 0.1.0.0 -- 2017-06-28 * First version. Released on an unsuspecting world. serialise-0.2.3.0/LICENSE.txt0000644000000000000000000000276407346545000013657 0ustar0000000000000000Copyright (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. serialise-0.2.3.0/Setup.hs0000644000000000000000000000005607346545000013460 0ustar0000000000000000import Distribution.Simple main = defaultMain serialise-0.2.3.0/bench/instances/Instances/0000755000000000000000000000000007346545000017020 5ustar0000000000000000serialise-0.2.3.0/bench/instances/Instances/Float.hs0000644000000000000000000000144607346545000020426 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module Instances.Float ( benchmarks -- :: [Benchmark] ) where import Criterion.Main import Codec.Serialise import Control.DeepSeq (force) import qualified Data.ByteString.Lazy as BSL benchmarks :: [Benchmark] benchmarks = [ bench "serialise Float" (whnf (BSL.length . serialise) fakesF) , bench "deserialise Float" (nf (deserialise :: BSL.ByteString -> [Float]) serialF) , bench "serialise Double" (whnf (BSL.length . serialise) fakesD) , bench "deserialise Double" (nf (deserialise :: BSL.ByteString -> [Double]) serialD) ] where fakesF = force (replicate 100 (3.14159 :: Float)) fakesD = force (replicate 100 (3.14159 :: Double)) serialF = force (serialise fakesF) serialD = force (serialise fakesD) serialise-0.2.3.0/bench/instances/Instances/Integer.hs0000644000000000000000000000321107346545000020746 0ustar0000000000000000{-# 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 serialise-0.2.3.0/bench/instances/Instances/Time.hs0000644000000000000000000000135507346545000020256 0ustar0000000000000000{-# 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) serialise-0.2.3.0/bench/instances/Instances/Vector.hs0000644000000000000000000000465607346545000020631 0ustar0000000000000000{-# 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 #-} serialise-0.2.3.0/bench/instances/0000755000000000000000000000000007346545000015071 5ustar0000000000000000serialise-0.2.3.0/bench/instances/Main.hs0000644000000000000000000000104707346545000016313 0ustar0000000000000000module Main ( main -- :: IO () ) where import Criterion.Main (bgroup, defaultMain) import qualified Instances.Float as Float import qualified Instances.Integer as Integer import qualified Instances.Time as Time import qualified Instances.Vector as Vector -------------------------------------------------------------------------------- main :: IO () main = defaultMain [ bgroup "float" Float.benchmarks , bgroup "integer" Integer.benchmarks , bgroup "time" Time.benchmarks , bgroup "vector" Vector.benchmarks ] serialise-0.2.3.0/bench/micro/0000755000000000000000000000000007346545000014213 5ustar0000000000000000serialise-0.2.3.0/bench/micro/Main.hs0000644000000000000000000000075207346545000015437 0ustar0000000000000000{-# 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 ] serialise-0.2.3.0/bench/micro/Micro.hs0000644000000000000000000001224007346545000015617 0ustar0000000000000000{-# 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 serialise-0.2.3.0/bench/micro/Micro/0000755000000000000000000000000007346545000015264 5ustar0000000000000000serialise-0.2.3.0/bench/micro/Micro/CBOR.hs0000644000000000000000000000347207346545000016353 0ustar0000000000000000{-# 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 #if ! MIN_VERSION_base(4,11,0) import Data.Monoid #endif 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 serialise-0.2.3.0/bench/micro/Micro/DeepSeq.hs0000644000000000000000000000031007346545000017140 0ustar0000000000000000{-# 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` () serialise-0.2.3.0/bench/micro/Micro/Load.hs0000644000000000000000000000056007346545000016500 0ustar0000000000000000{-# 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 serialise-0.2.3.0/bench/micro/Micro/MemSize.hs0000644000000000000000000000071607346545000017175 0ustar0000000000000000{-# 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 serialise-0.2.3.0/bench/micro/Micro/PkgAesonGeneric.hs0000644000000000000000000000054607346545000020631 0ustar0000000000000000{-# 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 serialise-0.2.3.0/bench/micro/Micro/PkgAesonTH.hs0000644000000000000000000000062307346545000017564 0ustar0000000000000000{-# 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 serialise-0.2.3.0/bench/micro/Micro/PkgBinary.hs0000644000000000000000000000053607346545000017512 0ustar0000000000000000{-# 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 serialise-0.2.3.0/bench/micro/Micro/PkgCereal.hs0000644000000000000000000000060007346545000017451 0ustar0000000000000000{-# 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 serialise-0.2.3.0/bench/micro/Micro/PkgStore.hs0000644000000000000000000000056107346545000017360 0ustar0000000000000000{-# 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 serialise-0.2.3.0/bench/micro/Micro/ReadShow.hs0000644000000000000000000000054007346545000017333 0ustar0000000000000000{-# 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 serialise-0.2.3.0/bench/micro/Micro/Types.hs0000644000000000000000000000023407346545000016723 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} module Micro.Types (Tree(..)) where import GHC.Generics data Tree = Leaf | Fork Tree Tree deriving (Eq, Ord, Generic) serialise-0.2.3.0/bench/micro/SimpleVersus.hs0000644000000000000000000000443507346545000017216 0ustar0000000000000000{-# 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 serialise-0.2.3.0/bench/versus/0000755000000000000000000000000007346545000014431 5ustar0000000000000000serialise-0.2.3.0/bench/versus/Macro.hs0000644000000000000000000001220307346545000016024 0ustar0000000000000000module 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 serialise-0.2.3.0/bench/versus/Macro/0000755000000000000000000000000007346545000015472 5ustar0000000000000000serialise-0.2.3.0/bench/versus/Macro/CBOR.hs0000644000000000000000000004446507346545000016570 0ustar0000000000000000{-# 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 #if ! MIN_VERSION_base(4,11,0) import Data.Monoid #endif 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 serialise-0.2.3.0/bench/versus/Macro/DeepSeq.hs0000644000000000000000000001600107346545000017352 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Macro.DeepSeq where import Macro.Types import Control.DeepSeq #if MIN_VERSION_deepseq(1,4,3) hiding (rnf1, rnf2) #endif 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 serialise-0.2.3.0/bench/versus/Macro/Load.hs0000644000000000000000000031717507346545000016723 0ustar0000000000000000{-# 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 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 qualified Control.Monad.Fail as Fail 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,11,0) import Prelude hiding ((<>)) #endif import Data.Semigroup hiding (option) #if !MIN_VERSION_base(4,8,0) import Control.Applicative (Applicative(..)) import Data.Monoid hiding ((<>)) #endif #if !MIN_VERSION_base(4,9,0) instance Semigroup Doc where a <> b = mappend a b #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' instance Fail.MonadFail ParseResult where fail s = ParseFailed (FromString s Nothing) catchParseError :: ParseResult a -> (PError -> ParseResult a) -> ParseResult a p@(ParseOk _ _) `catchParseError` _ = p ParseFailed e `catchParseError` k = k e parseFail :: PError -> ParseResult a parseFail = ParseFailed runP :: LineNo -> String -> ReadP a -> String -> ParseResult a runP line fieldname p s = case [ x | (x,"") <- results ] of [a] -> ParseOk (utf8Warnings line fieldname s) a -- TODO FIXME: what is this double parse thing all about? Can't we -- just do the all isSpace test the first time? [] -> case [ x | (x,ys) <- results, all isSpace ys ] of [a] -> ParseOk (utf8Warnings line fieldname s) a [] -> ParseFailed (NoParse fieldname line) _ -> ParseFailed (AmbiguousParse fieldname line) _ -> ParseFailed (AmbiguousParse fieldname line) where results = readP_to_S p s -- | Parser with simple error reporting newtype ReadE a = ReadE {_runReadE :: String -> Either ErrorMsg a} type ErrorMsg = String instance Functor ReadE where fmap f (ReadE p) = ReadE $ \txt -> case p txt of Right a -> Right (f a) Left err -> Left err utf8Warnings :: LineNo -> String -> String -> [PWarning] utf8Warnings line fieldname s = take 1 [ UTFWarning n fieldname | (n,l) <- zip [line..] (lines s) , '\xfffd' `elem` l ] syntaxError :: LineNo -> String -> ParseResult a syntaxError n s = ParseFailed $ FromString s (Just n) tabsError :: LineNo -> ParseResult a tabsError ln = ParseFailed $ TabsError ln warning :: String -> ParseResult () warning s = ParseOk [PWarning s] () -- | Field descriptor. The parameter @a@ parameterizes over where the field's -- value is stored in. data FieldDescr a = FieldDescr { fieldName :: String , _fieldGet :: a -> Doc , _fieldSet :: LineNo -> String -> a -> ParseResult a -- ^ @fieldSet n str x@ Parses the field value from the given input -- string @str@ and stores the result in @x@ if the parse was -- successful. Otherwise, reports an error on line number @n@. } field :: String -> (a -> Doc) -> ReadP a -> FieldDescr a field name showF readF = FieldDescr name showF (\line val _st -> runP line name readF val) -- Lift a field descriptor storing into an 'a' to a field descriptor storing -- into a 'b'. liftField :: (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b liftField get set (FieldDescr name showF parseF) = FieldDescr name (showF . get) (\line str b -> do a <- parseF line str (get b) return (set a b)) -- Parser combinator for simple fields. Takes a field name, a pretty printer, -- a parser function, an accessor, and a setter, returns a FieldDescr over the -- compoid structure. simpleField :: String -> (a -> Doc) -> ReadP a -> (b -> a) -> (a -> b -> b) -> FieldDescr b simpleField name showF readF get set = liftField get set $ field name showF readF commaListField :: String -> (a -> Doc) -> ReadP a -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b commaListField name showF readF get set = liftField get set' $ field name (fsep . punctuate comma . map showF) (parseCommaList readF) where set' xs b = set (get b ++ xs) b spaceListField :: String -> (a -> Doc) -> ReadP a -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b spaceListField name showF readF get set = liftField get set' $ field name (fsep . map showF) (parseSpaceList readF) where set' xs b = set (get b ++ xs) b listField :: String -> (a -> Doc) -> ReadP a -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b listField name showF readF get set = liftField get set' $ field name (fsep . map showF) (parseOptCommaList readF) where set' xs b = set (get b ++ xs) b optsField :: String -> CompilerFlavor -> (b -> [(CompilerFlavor,[String])]) -> ([(CompilerFlavor,[String])] -> b -> b) -> FieldDescr b optsField name flavor get set = liftField (fromMaybe [] . lookup flavor . get) (\opts b -> set (reorder (update flavor opts (get b))) b) $ field name (hsep . map text) (sepBy parseTokenQ' (munch1 isSpace)) where update _ opts l | all null opts = l --empty opts as if no opts update f opts [] = [(f,opts)] update f opts ((f',opts'):rest) | f == f' = (f, opts' ++ opts) : rest | otherwise = (f',opts') : update f opts rest reorder = sortBy (compare `on` fst) boolField :: String -> (b -> Bool) -> (Bool -> b -> b) -> FieldDescr b boolField name get set = liftField get set (FieldDescr name showF readF) where showF = text . show readF line str _ | str == "True" = ParseOk [] True | str == "False" = ParseOk [] False | lstr == "true" = ParseOk [caseWarning] True | lstr == "false" = ParseOk [caseWarning] False | otherwise = ParseFailed (NoParse name line) where lstr = lowercase str caseWarning = PWarning $ "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'." type UnrecFieldParser a = (String,String) -> a -> Maybe a -- | A default unrecognized field parser which simply returns Nothing, -- i.e. ignores all unrecognized fields, so warnings will be generated. warnUnrec :: UnrecFieldParser a warnUnrec _ _ = Nothing ------------------------------------------------------------------------------ -- The data type for our three syntactic categories data Field = F LineNo String String -- ^ A regular @: @ field | Section LineNo String String [Field] -- ^ A section with a name and possible parameter. The syntactic -- structure is: -- -- @ -- { -- * -- } -- @ | IfBlock LineNo String [Field] [Field] -- ^ A conditional block with an optional else branch: -- -- @ -- if { -- * -- } else { -- * -- } -- @ deriving (Show ,Eq) -- for testing lineNo :: Field -> LineNo lineNo (F n _ _) = n lineNo (Section n _ _ _) = n lineNo (IfBlock n _ _ _) = n fName :: Field -> String fName (F _ n _) = n fName (Section _ n _ _) = n fName _ = error "fname: not a field or section" readFields :: String -> ParseResult [Field] readFields input = ifelse =<< mapM (mkField 0) =<< mkTree tokens where ls = (lines . normaliseLineEndings) input tokens = (concatMap tokeniseLine . trimLines) ls normaliseLineEndings :: String -> String normaliseLineEndings [] = [] normaliseLineEndings ('\r':'\n':s) = '\n' : normaliseLineEndings s -- windows normaliseLineEndings ('\r':s) = '\n' : normaliseLineEndings s -- old osx normaliseLineEndings ( c :s) = c : normaliseLineEndings s -- attach line number and determine indentation trimLines :: [String] -> [(LineNo, Indent, HasTabs, String)] trimLines ls = [ (lineno, indent, hastabs, trimTrailing l') | (lineno, l) <- zip [1..] ls , let (sps, l') = span isSpace l indent = length sps hastabs = '\t' `elem` sps , validLine l' ] where validLine ('-':'-':_) = False -- Comment validLine [] = False -- blank line validLine _ = True -- | We parse generically based on indent level and braces '{' '}'. To do that -- we split into lines and then '{' '}' tokens and other spans within a line. data Token = -- | The 'Line' token is for bits that /start/ a line, eg: -- -- > "\n blah blah { blah" -- -- tokenises to: -- -- > [Line n 2 False "blah blah", OpenBracket, Span n "blah"] -- -- so lines are the only ones that can have nested layout, since they -- have a known indentation level. -- -- eg: we can't have this: -- -- > if ... { -- > } else -- > other -- -- because other cannot nest under else, since else doesn't start a line -- so cannot have nested layout. It'd have to be: -- -- > if ... { -- > } -- > else -- > other -- -- but that's not so common, people would normally use layout or -- brackets not both in a single @if else@ construct. -- -- > if ... { foo : bar } -- > else -- > other -- -- this is ok Line LineNo Indent HasTabs String | Span LineNo String -- ^ span in a line, following brackets | OpenBracket LineNo | CloseBracket LineNo type Indent = Int type HasTabs = Bool -- | Tokenise a single line, splitting on '{' '}' and the spans inbetween. -- Also trims leading & trailing space on those spans within the line. tokeniseLine :: (LineNo, Indent, HasTabs, String) -> [Token] tokeniseLine (n0, i, t, l) = case split n0 l of (Span _ l':ss) -> Line n0 i t l' :ss cs -> cs where split _ "" = [] split n s = case span (\c -> c /='}' && c /= '{') s of ("", '{' : s') -> OpenBracket n : split n s' (w , '{' : s') -> mkspan n w (OpenBracket n : split n s') ("", '}' : s') -> CloseBracket n : split n s' (w , '}' : s') -> mkspan n w (CloseBracket n : split n s') (w , _) -> mkspan n w [] mkspan n s ss | null s' = ss | otherwise = Span n s' : ss where s' = trimTrailing (trimLeading s) trimLeading, trimTrailing :: String -> String trimLeading = dropWhile isSpace trimTrailing = reverse . dropWhile isSpace . reverse type SyntaxTree = Tree (LineNo, HasTabs, String) -- | Parse the stream of tokens into a tree of them, based on indent \/ layout mkTree :: [Token] -> ParseResult [SyntaxTree] mkTree toks = layout 0 [] toks >>= \(trees, trailing) -> case trailing of [] -> return trees OpenBracket n:_ -> syntaxError n "mismatched backets, unexpected {" CloseBracket n:_ -> syntaxError n "mismatched backets, unexpected }" -- the following two should never happen: Span n l :_ -> syntaxError n $ "unexpected span: " ++ show l Line n _ _ l :_ -> syntaxError n $ "unexpected line: " ++ show l -- | Parse the stream of tokens into a tree of them, based on indent -- This parse state expect to be in a layout context, though possibly -- nested within a braces context so we may still encounter closing braces. layout :: Indent -- ^ indent level of the parent\/previous line -> [SyntaxTree] -- ^ accumulating param, trees in this level -> [Token] -- ^ remaining tokens -> ParseResult ([SyntaxTree], [Token]) -- ^ collected trees on this level and trailing tokens layout _ a [] = return (reverse a, []) layout i a (s@(Line _ i' _ _):ss) | i' < i = return (reverse a, s:ss) layout i a (Line n _ t l:OpenBracket n':ss) = do (sub, ss') <- braces n' [] ss layout i (Node (n,t,l) sub:a) ss' layout i a (Span n l:OpenBracket n':ss) = do (sub, ss') <- braces n' [] ss layout i (Node (n,False,l) sub:a) ss' -- look ahead to see if following lines are more indented, giving a sub-tree layout i a (Line n i' t l:ss) = do lookahead <- layout (i'+1) [] ss case lookahead of ([], _) -> layout i (Node (n,t,l) [] :a) ss (ts, ss') -> layout i (Node (n,t,l) ts :a) ss' layout _ _ ( OpenBracket n :_) = syntaxError n "unexpected '{'" layout _ a (s@(CloseBracket _):ss) = return (reverse a, s:ss) layout _ _ ( Span n l : _) = syntaxError n $ "unexpected span: " ++ show l -- | Parse the stream of tokens into a tree of them, based on explicit braces -- This parse state expects to find a closing bracket. braces :: LineNo -- ^ line of the '{', used for error messages -> [SyntaxTree] -- ^ accumulating param, trees in this level -> [Token] -- ^ remaining tokens -> ParseResult ([SyntaxTree],[Token]) -- ^ collected trees on this level and trailing tokens braces m a (Line n _ t l:OpenBracket n':ss) = do (sub, ss') <- braces n' [] ss braces m (Node (n,t,l) sub:a) ss' braces m a (Span n l:OpenBracket n':ss) = do (sub, ss') <- braces n' [] ss braces m (Node (n,False,l) sub:a) ss' braces m a (Line n i t l:ss) = do lookahead <- layout (i+1) [] ss case lookahead of ([], _) -> braces m (Node (n,t,l) [] :a) ss (ts, ss') -> braces m (Node (n,t,l) ts :a) ss' braces m a (Span n l:ss) = braces m (Node (n,False,l) []:a) ss braces _ a (CloseBracket _:ss) = return (reverse a, ss) braces n _ [] = syntaxError n $ "opening brace '{'" ++ "has no matching closing brace '}'" braces _ _ (OpenBracket n:_) = syntaxError n "unexpected '{'" -- | Convert the parse tree into the Field AST -- Also check for dodgy uses of tabs in indentation. mkField :: Int -> SyntaxTree -> ParseResult Field mkField d (Node (n,t,_) _) | d >= 1 && t = tabsError n mkField d (Node (n,_,l) ts) = case span (\c -> isAlphaNum c || c == '-') l of ([], _) -> syntaxError n $ "unrecognised field or section: " ++ show l (name, rest) -> case trimLeading rest of (':':rest') -> do let followingLines = concatMap Tree.flatten ts tabs = not (null [()| (_,True,_) <- followingLines ]) if tabs && d >= 1 then tabsError n else return $ F n (map toLower name) (fieldValue rest' followingLines) rest' -> do ts' <- mapM (mkField (d+1)) ts return (Section n (map toLower name) rest' ts') where fieldValue firstLine followingLines = let firstLine' = trimLeading firstLine followingLines' = map (\(_,_,s) -> stripDot s) followingLines allLines | null firstLine' = followingLines' | otherwise = firstLine' : followingLines' in intercalate "\n" allLines stripDot "." = "" stripDot s = s -- | Convert if/then/else 'Section's to 'IfBlock's ifelse :: [Field] -> ParseResult [Field] ifelse [] = return [] ifelse (Section n "if" cond thenpart :Section _ "else" as elsepart:fs) | null cond = syntaxError n "'if' with missing condition" | null thenpart = syntaxError n "'then' branch of 'if' is empty" | not (null as) = syntaxError n "'else' takes no arguments" | null elsepart = syntaxError n "'else' branch of 'if' is empty" | otherwise = do tp <- ifelse thenpart ep <- ifelse elsepart fs' <- ifelse fs return (IfBlock n cond tp ep:fs') ifelse (Section n "if" cond thenpart:fs) | null cond = syntaxError n "'if' with missing condition" | null thenpart = syntaxError n "'then' branch of 'if' is empty" | otherwise = do tp <- ifelse thenpart fs' <- ifelse fs return (IfBlock n cond tp []:fs') ifelse (Section n "else" _ _:_) = syntaxError n "stray 'else' with no preceding 'if'" ifelse (Section n s a fs':fs) = do fs'' <- ifelse fs' fs''' <- ifelse fs return (Section n s a fs'' : fs''') ifelse (f:fs) = do fs' <- ifelse fs return (f : fs') ------------------------------------------------------------------------------ -- |parse a module Macro.name parseModuleNameQ :: ReadP ModuleName parseModuleNameQ = parseQuoted parse <++ parse parseFilePathQ :: ReadP FilePath parseFilePathQ = parseTokenQ -- removed until normalise is no longer broken, was: -- liftM normalise parseTokenQ betweenSpaces :: ReadP a -> ReadP a betweenSpaces act = do skipSpaces res <- act skipSpaces return res parseBuildTool :: ReadP Dependency parseBuildTool = do name <- parseBuildToolNameQ ver <- betweenSpaces $ parseVersionRangeQ <++ return AnyVersion return $ Dependency name ver parseBuildToolNameQ :: ReadP PackageName parseBuildToolNameQ = parseQuoted parseBuildToolName <++ parseBuildToolName -- like parsePackageName but accepts symbols in components parseBuildToolName :: ReadP PackageName parseBuildToolName = do ns <- sepBy1 component (ReadP.char '-') return (PackageName (intercalate "-" ns)) where component = do cs <- munch1 (\c -> isAlphaNum c || c == '+' || c == '_') if all isDigit cs then pfail else return cs -- pkg-config allows versions and other letters in package names, -- eg "gtk+-2.0" is a valid pkg-config package _name_. -- It then has a package version number like 2.10.13 parsePkgconfigDependency :: ReadP Dependency parsePkgconfigDependency = do name <- munch1 (\c -> isAlphaNum c || c `elem` "+-._") ver <- betweenSpaces $ parseVersionRangeQ <++ return AnyVersion return $ Dependency (PackageName name) ver parseVersionRangeQ :: ReadP VersionRange parseVersionRangeQ = parseQuoted parse <++ parse parseTestedWithQ :: ReadP (CompilerFlavor,VersionRange) parseTestedWithQ = parseQuoted tw <++ tw where tw :: ReadP (CompilerFlavor,VersionRange) tw = do compiler <- parseCompilerFlavorCompat version <- betweenSpaces $ parse <++ return AnyVersion return (compiler,version) parseCompilerFlavorCompat :: Parse.ReadP CompilerFlavor parseCompilerFlavorCompat = do comp <- Parse.munch1 Char.isAlphaNum when (all Char.isDigit comp) Parse.pfail case lookup comp compilerMap of Just compiler -> return compiler Nothing -> return (OtherCompiler comp) where compilerMap = [ (show compiler, compiler) | compiler <- knownCompilerFlavors , compiler /= YHC ] knownCompilerFlavors :: [CompilerFlavor] knownCompilerFlavors = [GHC, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC] parseLicenseQ :: ReadP License parseLicenseQ = parseQuoted parse <++ parse parseLanguageQ :: ReadP Language parseLanguageQ = parseQuoted parse <++ parse parseExtensionQ :: ReadP Extension parseExtensionQ = parseQuoted parse <++ parse parseHaskellString :: ReadP String parseHaskellString = readS_to_P reads parseTokenQ :: ReadP String parseTokenQ = parseHaskellString <++ munch1 (\x -> not (isSpace x) && x /= ',') parseTokenQ' :: ReadP String parseTokenQ' = parseHaskellString <++ munch1 (not . isSpace) parseSepList :: ReadP b -> ReadP a -- ^The parser for the stuff between commas -> ReadP [a] parseSepList sepr p = sepBy p separator where separator = betweenSpaces sepr parseSpaceList :: ReadP a -- ^The parser for the stuff between commas -> ReadP [a] parseSpaceList p = sepBy p skipSpaces parseCommaList :: ReadP a -- ^The parser for the stuff between commas -> ReadP [a] parseCommaList = parseSepList (ReadP.char ',') parseOptCommaList :: ReadP a -- ^The parser for the stuff between commas -> ReadP [a] parseOptCommaList = parseSepList (optional (ReadP.char ',')) parseQuoted :: ReadP a -> ReadP a parseQuoted = between (ReadP.char '"') (ReadP.char '"') parseFreeText :: ReadP.ReadP String parseFreeText = ReadP.munch (const True) ident :: Parse.ReadP String ident = Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-') lowercase :: String -> String lowercase = map Char.toLower -- -------------------------------------------- -- ** Pretty printing showFilePath :: FilePath -> Doc showFilePath = showToken showToken :: String -> Doc showToken str | not (any dodgy str) && not (null str) = text str | otherwise = text (show str) where dodgy c = isSpace c || c == ',' showTestedWith :: (CompilerFlavor,VersionRange) -> Doc showTestedWith (compiler, version) = text (show compiler) <+> disp version -- | Pretty-print free-format text, ensuring that it is vertically aligned, -- and with blank lines replaced by dots for correct re-parsing. showFreeText :: String -> Doc showFreeText "" = empty showFreeText ('\n' :r) = text " " $+$ text "." $+$ showFreeText r showFreeText s = vcat [text (if null l then "." else l) | l <- lines_ s] -- | 'lines_' breaks a string up into a list of strings at newline -- characters. The resulting strings do not contain newlines. lines_ :: String -> [String] lines_ [] = [""] lines_ s = let (l, s') = break (== '\n') s in l : case s' of [] -> [] (_:s'') -> lines_ s'' class Text a where disp :: a -> Disp.Doc parse :: Parse.ReadP a display :: Text a => a -> String display = Disp.renderStyle style . disp where style = Disp.Style { Disp.mode = Disp.PageMode, Disp.lineLength = 79, Disp.ribbonsPerLine = 1.0 } simpleParse :: Text a => String -> Maybe a simpleParse str = case [ p | (p, s) <- Parse.readP_to_S parse str , all Char.isSpace s ] of [] -> Nothing (p:_) -> Just p -- ----------------------------------------------------------------------------- -- Instances for types from the base package instance Text Bool where disp = Disp.text . show parse = Parse.choice [ (Parse.string "True" Parse.+++ Parse.string "true") >> return True , (Parse.string "False" Parse.+++ Parse.string "false") >> return False ] instance Text Version where disp (Version branch _tags) -- Death to version tags!! = Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int branch)) parse = do branch <- Parse.sepBy1 digits (Parse.char '.') tags <- Parse.many (Parse.char '-' >> Parse.munch1 Char.isAlphaNum) return (Version branch tags) -- TODO FIXME: should we ignore the tags? where digits = do first <- Parse.satisfy Char.isDigit if first == '0' then return 0 else do rest <- Parse.munch Char.isDigit return (read (first : rest)) -- ----------------------------------------------------------------------------- instance Text InstalledPackageId where disp (InstalledPackageId str) = text str parse = InstalledPackageId `fmap` Parse.munch1 abi_char where abi_char c = Char.isAlphaNum c || c `elem` ":-_." instance Text ModuleName where disp (ModuleName ms) = Disp.hcat (intersperse (Disp.char '.') (map Disp.text ms)) parse = do ms <- Parse.sepBy1 component (Parse.char '.') return (ModuleName ms) where component = do c <- Parse.satisfy Char.isUpper cs <- Parse.munch validModuleChar return (c:cs) validModuleChar :: Char -> Bool validModuleChar c = Char.isAlphaNum c || c == '_' || c == '\'' instance Text PackageName where disp (PackageName n) = Disp.text n parse = do ns <- Parse.sepBy1 component (Parse.char '-') return (PackageName (intercalate "-" ns)) where component = do cs <- Parse.munch1 Char.isAlphaNum if all Char.isDigit cs then Parse.pfail else return cs -- each component must contain an alphabetic character, to avoid -- ambiguity in identifiers like foo-1 (the 1 is the version number). instance Text PackageId where disp (PackageId n v) = case v of Version [] _ -> disp n -- if no version, don't show version. _ -> disp n <> Disp.char '-' <> disp v parse = do n <- parse v <- (Parse.char '-' >> parse) <++ return (Version [] []) return (PackageId n v) instance Text VersionRange where disp = fst . foldVersionRange' -- precedence: ( Disp.text "-any" , 0 :: Int) (\v -> (Disp.text "==" <> disp v , 0)) (\v -> (Disp.char '>' <> disp v , 0)) (\v -> (Disp.char '<' <> disp v , 0)) (\v -> (Disp.text ">=" <> disp v , 0)) (\v -> (Disp.text "<=" <> disp v , 0)) (\v _ -> (Disp.text "==" <> dispWild v , 0)) (\(r1, p1) (r2, p2) -> (punct 2 p1 r1 <+> Disp.text "||" <+> punct 2 p2 r2 , 2)) (\(r1, p1) (r2, p2) -> (punct 1 p1 r1 <+> Disp.text "&&" <+> punct 1 p2 r2 , 1)) (\(r, p) -> (Disp.parens r, p)) where dispWild (Version b _) = Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int b)) <> Disp.text ".*" punct p p' | p < p' = Disp.parens | otherwise = id parse = expr where expr = do Parse.skipSpaces t <- term Parse.skipSpaces (do _ <- Parse.string "||" Parse.skipSpaces e <- expr return (UnionVersionRanges t e) +++ return t) term = do f <- factor Parse.skipSpaces (do _ <- Parse.string "&&" Parse.skipSpaces t <- term return (IntersectVersionRanges f t) +++ return f) factor = Parse.choice $ parens expr : parseAnyVersion : parseWildcardRange : map parseRangeOp rangeOps parseAnyVersion = Parse.string "-any" >> return AnyVersion parseWildcardRange = do _ <- Parse.string "==" Parse.skipSpaces branch <- Parse.sepBy1 digits (Parse.char '.') _ <- Parse.char '.' _ <- Parse.char '*' return (WildcardVersion (Version branch [])) parens p = Parse.between (Parse.char '(' >> Parse.skipSpaces) (Parse.char ')' >> Parse.skipSpaces) (do a <- p Parse.skipSpaces return (VersionRangeParens a)) digits = do first <- Parse.satisfy Char.isDigit if first == '0' then return 0 else do rest <- Parse.munch Char.isDigit return (read (first : rest)) parseRangeOp (s,f) = Parse.string s >> Parse.skipSpaces >> fmap f parse rangeOps = [ ("<", EarlierVersion), ("<=", orEarlierVersion), (">", LaterVersion), (">=", orLaterVersion), ("==", ThisVersion) ] orLaterVersion :: Version -> VersionRange orLaterVersion v = UnionVersionRanges (ThisVersion v) (LaterVersion v) orEarlierVersion :: Version -> VersionRange orEarlierVersion v = UnionVersionRanges (ThisVersion v) (EarlierVersion v) foldVersionRange :: a -- ^ @\"-any\"@ version -> (Version -> a) -- ^ @\"== v\"@ -> (Version -> a) -- ^ @\"> v\"@ -> (Version -> a) -- ^ @\"< v\"@ -> (a -> a -> a) -- ^ @\"_ || _\"@ union -> (a -> a -> a) -- ^ @\"_ && _\"@ intersection -> VersionRange -> a foldVersionRange anyv this later earlier union intersect = fold where fold AnyVersion = anyv fold (ThisVersion v) = this v fold (LaterVersion v) = later v fold (EarlierVersion v) = earlier v fold (WildcardVersion v) = fold (wildcard v) fold (UnionVersionRanges v1 v2) = union (fold v1) (fold v2) fold (IntersectVersionRanges v1 v2) = intersect (fold v1) (fold v2) fold (VersionRangeParens v) = fold v wildcard v = IntersectVersionRanges (orLaterVersion v) (EarlierVersion (wildcardUpperBound v)) foldVersionRange' :: a -- ^ @\"-any\"@ version -> (Version -> a) -- ^ @\"== v\"@ -> (Version -> a) -- ^ @\"> v\"@ -> (Version -> a) -- ^ @\"< v\"@ -> (Version -> a) -- ^ @\">= v\"@ -> (Version -> a) -- ^ @\"<= v\"@ -> (Version -> Version -> a) -- ^ @\"== v.*\"@ wildcard. The -- function is passed the -- inclusive lower bound and the -- exclusive upper bounds of the -- range defined by the wildcard. -> (a -> a -> a) -- ^ @\"_ || _\"@ union -> (a -> a -> a) -- ^ @\"_ && _\"@ intersection -> (a -> a) -- ^ @\"(_)\"@ parentheses -> VersionRange -> a foldVersionRange' anyv this later earlier orLater orEarlier wildcard union intersect parens = fold where fold AnyVersion = anyv fold (ThisVersion v) = this v fold (LaterVersion v) = later v fold (EarlierVersion v) = earlier v fold (UnionVersionRanges (ThisVersion v) (LaterVersion v')) | v==v' = orLater v fold (UnionVersionRanges (LaterVersion v) (ThisVersion v')) | v==v' = orLater v fold (UnionVersionRanges (ThisVersion v) (EarlierVersion v')) | v==v' = orEarlier v fold (UnionVersionRanges (EarlierVersion v) (ThisVersion v')) | v==v' = orEarlier v fold (WildcardVersion v) = wildcard v (wildcardUpperBound v) fold (UnionVersionRanges v1 v2) = union (fold v1) (fold v2) fold (IntersectVersionRanges v1 v2) = intersect (fold v1) (fold v2) fold (VersionRangeParens v) = parens (fold v) wildcardUpperBound :: Version -> Version wildcardUpperBound (Version lowerBound ts) = Version upperBound ts where upperBound = init lowerBound ++ [last lowerBound + 1] asVersionIntervals :: VersionRange -> [VersionInterval] asVersionIntervals = versionIntervals . toVersionIntervals newtype VersionIntervals = VersionIntervals [VersionInterval] deriving (Eq, Show) -- | Inspect the list of version intervals. -- versionIntervals :: VersionIntervals -> [VersionInterval] versionIntervals (VersionIntervals is) = is type VersionInterval = (LowerBound, UpperBound) data LowerBound = LowerBound Version !Bound deriving (Eq, Show) data UpperBound = NoUpperBound | UpperBound Version !Bound deriving (Eq, Show) data Bound = ExclusiveBound | InclusiveBound deriving (Eq, Show) minLowerBound :: LowerBound minLowerBound = LowerBound (Version [0] []) InclusiveBound isVersion0 :: Version -> Bool isVersion0 (Version [0] _) = True isVersion0 _ = False instance Ord LowerBound where LowerBound ver bound <= LowerBound ver' bound' = case compare ver ver' of LT -> True EQ -> not (bound == ExclusiveBound && bound' == InclusiveBound) GT -> False instance Ord UpperBound where _ <= NoUpperBound = True NoUpperBound <= UpperBound _ _ = False UpperBound ver bound <= UpperBound ver' bound' = case compare ver ver' of LT -> True EQ -> not (bound == InclusiveBound && bound' == ExclusiveBound) GT -> False invariant :: VersionIntervals -> Bool invariant (VersionIntervals intervals) = all validInterval intervals && all doesNotTouch' adjacentIntervals where doesNotTouch' :: (VersionInterval, VersionInterval) -> Bool doesNotTouch' ((_,u), (l',_)) = doesNotTouch u l' adjacentIntervals :: [(VersionInterval, VersionInterval)] adjacentIntervals | null intervals = [] | otherwise = zip intervals (tail intervals) checkInvariant :: VersionIntervals -> VersionIntervals checkInvariant is = assert (invariant is) is validVersion :: Version -> Bool validVersion (Version [] _) = False validVersion (Version vs _) = all (>=0) vs validInterval :: (LowerBound, UpperBound) -> Bool validInterval i@(l, u) = validLower l && validUpper u && nonEmpty i where validLower (LowerBound v _) = validVersion v validUpper NoUpperBound = True validUpper (UpperBound v _) = validVersion v -- Check an interval is non-empty -- nonEmpty :: VersionInterval -> Bool nonEmpty (_, NoUpperBound ) = True nonEmpty (LowerBound l lb, UpperBound u ub) = (l < u) || (l == u && lb == InclusiveBound && ub == InclusiveBound) -- Check an upper bound does not intersect, or even touch a lower bound: -- -- ---| or ---) but not ---] or ---) or ---] -- |--- (--- (--- [--- [--- -- doesNotTouch :: UpperBound -> LowerBound -> Bool doesNotTouch NoUpperBound _ = False doesNotTouch (UpperBound u ub) (LowerBound l lb) = u < l || (u == l && ub == ExclusiveBound && lb == ExclusiveBound) -- | Check an upper bound does not intersect a lower bound: -- -- ---| or ---) or ---] or ---) but not ---] -- |--- (--- (--- [--- [--- -- doesNotIntersect :: UpperBound -> LowerBound -> Bool doesNotIntersect NoUpperBound _ = False doesNotIntersect (UpperBound u ub) (LowerBound l lb) = u < l || (u == l && not (ub == InclusiveBound && lb == InclusiveBound)) toVersionIntervals :: VersionRange -> VersionIntervals toVersionIntervals = foldVersionRange ( chkIvl (minLowerBound, NoUpperBound)) (\v -> chkIvl (LowerBound v InclusiveBound, UpperBound v InclusiveBound)) (\v -> chkIvl (LowerBound v ExclusiveBound, NoUpperBound)) (\v -> if isVersion0 v then VersionIntervals [] else chkIvl (minLowerBound, UpperBound v ExclusiveBound)) unionVersionIntervals intersectVersionIntervals where chkIvl interval = checkInvariant (VersionIntervals [interval]) unionVersionIntervals :: VersionIntervals -> VersionIntervals -> VersionIntervals unionVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) = checkInvariant (VersionIntervals (union is0 is'0)) where union is [] = is union [] is' = is' union (i:is) (i':is') = case unionInterval i i' of Left Nothing -> i : union is (i' :is') Left (Just i'') -> union is (i'':is') Right Nothing -> i' : union (i :is) is' Right (Just i'') -> union (i'':is) is' unionInterval :: VersionInterval -> VersionInterval -> Either (Maybe VersionInterval) (Maybe VersionInterval) unionInterval (lower , upper ) (lower', upper') -- Non-intersecting intervals with the left interval ending first | upper `doesNotTouch` lower' = Left Nothing -- Non-intersecting intervals with the right interval first | upper' `doesNotTouch` lower = Right Nothing -- Complete or partial overlap, with the left interval ending first | upper <= upper' = lowerBound `seq` Left (Just (lowerBound, upper')) -- Complete or partial overlap, with the left interval ending first | otherwise = lowerBound `seq` Right (Just (lowerBound, upper)) where lowerBound = min lower lower' intersectVersionIntervals :: VersionIntervals -> VersionIntervals -> VersionIntervals intersectVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) = checkInvariant (VersionIntervals (intersect is0 is'0)) where intersect _ [] = [] intersect [] _ = [] intersect (i:is) (i':is') = case intersectInterval i i' of Left Nothing -> intersect is (i':is') Left (Just i'') -> i'' : intersect is (i':is') Right Nothing -> intersect (i:is) is' Right (Just i'') -> i'' : intersect (i:is) is' intersectInterval :: VersionInterval -> VersionInterval -> Either (Maybe VersionInterval) (Maybe VersionInterval) intersectInterval (lower , upper ) (lower', upper') -- Non-intersecting intervals with the left interval ending first | upper `doesNotIntersect` lower' = Left Nothing -- Non-intersecting intervals with the right interval first | upper' `doesNotIntersect` lower = Right Nothing -- Complete or partial overlap, with the left interval ending first | upper <= upper' = lowerBound `seq` Left (Just (lowerBound, upper)) -- Complete or partial overlap, with the right interval ending first | otherwise = lowerBound `seq` Right (Just (lowerBound, upper')) where lowerBound = max lower lower' instance Text Dependency where disp (Dependency name ver) = disp name <+> disp ver parse = do name <- parse Parse.skipSpaces ver <- parse <++ return AnyVersion Parse.skipSpaces return (Dependency name ver) instance Text License where disp (GPL version) = Disp.text "GPL" <> dispOptVersion version disp (LGPL version) = Disp.text "LGPL" <> dispOptVersion version disp (AGPL version) = Disp.text "AGPL" <> dispOptVersion version disp (Apache version) = Disp.text "Apache" <> dispOptVersion version disp (UnknownLicense other) = Disp.text other disp other = Disp.text (show other) parse = do name <- Parse.munch1 (\c -> Char.isAlphaNum c && c /= '-') version <- Parse.option Nothing (Parse.char '-' >> fmap Just parse) return $! case (name, version :: Maybe Version) of ("GPL", _ ) -> GPL version ("LGPL", _ ) -> LGPL version ("AGPL", _ ) -> AGPL version ("BSD3", Nothing) -> BSD3 ("BSD4", Nothing) -> BSD4 ("MIT", Nothing) -> MIT ("Apache", _ ) -> Apache version ("PublicDomain", Nothing) -> PublicDomain ("AllRightsReserved", Nothing) -> AllRightsReserved ("OtherLicense", Nothing) -> OtherLicense _ -> UnknownLicense $ name ++ maybe "" (('-':) . display) version dispOptVersion :: Maybe Version -> Disp.Doc dispOptVersion Nothing = Disp.empty dispOptVersion (Just v) = Disp.char '-' <> disp v instance Text CompilerFlavor where disp (OtherCompiler name) = Disp.text name disp (HaskellSuite name) = Disp.text name disp NHC = Disp.text "nhc98" disp other = Disp.text (lowercase (show other)) parse = do comp <- Parse.munch1 Char.isAlphaNum when (all Char.isDigit comp) Parse.pfail return (classifyCompilerFlavor comp) classifyCompilerFlavor :: String -> CompilerFlavor classifyCompilerFlavor s = fromMaybe (OtherCompiler s) $ lookup (lowercase s) compilerMap where compilerMap = [ (display compiler, compiler) | compiler <- knownCompilerFlavors ] knownCompilerFlavors :: [CompilerFlavor] knownCompilerFlavors = [GHC, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC] instance Text Language where disp (UnknownLanguage other) = Disp.text other disp other = Disp.text (show other) parse = do lang <- Parse.munch1 Char.isAlphaNum return (classifyLanguage lang) classifyLanguage :: String -> Language classifyLanguage = \str -> case lookup str langTable of Just lang -> lang Nothing -> UnknownLanguage str where langTable = [ (show lang, lang) | lang <- knownLanguages ] knownLanguages :: [Language] knownLanguages = [Haskell98, Haskell2010] instance Text Extension where disp (UnknownExtension other) = Disp.text other disp (EnableExtension ke) = Disp.text (show ke) disp (DisableExtension ke) = Disp.text ("No" ++ show ke) parse = do extension <- Parse.munch1 Char.isAlphaNum return (classifyExtension extension) instance Text KnownExtension where disp ke = Disp.text (show ke) parse = do extension <- Parse.munch1 Char.isAlphaNum case classifyKnownExtension extension of Just ke -> return ke Nothing -> Fail.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' instance Fail.MonadFail m => Fail.MonadFail (StT s m) where fail s = StT (\_ -> Fail.fail 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.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.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 = mappendLibrary instance Semigroup Library where a <> b = mappendLibrary a b mappendLibrary :: Library -> Library -> Library mappendLibrary 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 = mappendExecutable instance Semigroup Executable where a <> b = mappendExecutable a b mappendExecutable :: Executable -> Executable -> Executable mappendExecutable 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 = mappendTestSuite instance Semigroup TestSuite where a <> b = mappendTestSuite a b mappendTestSuite :: TestSuite -> TestSuite -> TestSuite mappendTestSuite 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 = mappendTestSuiteInterface instance Semigroup TestSuiteInterface where a <> b = mappendTestSuiteInterface a b mappendTestSuiteInterface :: TestSuiteInterface -> TestSuiteInterface -> TestSuiteInterface mappendTestSuiteInterface a (TestSuiteUnsupported _) = a mappendTestSuiteInterface _ b = b emptyTestSuite :: TestSuite emptyTestSuite = mempty instance Monoid Benchmark where mempty = Benchmark { benchmarkName = mempty, benchmarkInterface = mempty, benchmarkBuildInfo = mempty, benchmarkEnabled = False } mappend = mappendBenchmark mappendBenchmark :: Benchmark -> Benchmark -> Benchmark mappendBenchmark 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 = mappendBenchmarkInterface mappendBenchmarkInterface :: BenchmarkInterface -> BenchmarkInterface -> BenchmarkInterface mappendBenchmarkInterface a (BenchmarkUnsupported _) = a mappendBenchmarkInterface _ 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 = mappendBuildInfo mappendBuildInfo :: BuildInfo -> BuildInfo -> BuildInfo mappendBuildInfo 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 instance Semigroup Benchmark where a <> b = mappendBenchmark a b instance Semigroup BenchmarkInterface where a <> b = mappendBenchmarkInterface a b instance Semigroup BuildInfo where a <> b = mappendBuildInfo a b -- | 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" serialise-0.2.3.0/bench/versus/Macro/MemSize.hs0000644000000000000000000002177107346545000017407 0ustar0000000000000000{-# 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 serialise-0.2.3.0/bench/versus/Macro/PkgAesonGeneric.hs0000644000000000000000000000445007346545000021035 0ustar0000000000000000{-# 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 serialise-0.2.3.0/bench/versus/Macro/PkgAesonTH.hs0000644000000000000000000000326207346545000017774 0ustar0000000000000000{-# 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 serialise-0.2.3.0/bench/versus/Macro/PkgBinary.hs0000644000000000000000000000305107346545000017713 0ustar0000000000000000{-# 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 serialise-0.2.3.0/bench/versus/Macro/PkgCereal.hs0000644000000000000000000000345507346545000017672 0ustar0000000000000000{-# 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 serialise-0.2.3.0/bench/versus/Macro/PkgStore.hs0000644000000000000000000000240007346545000017560 0ustar0000000000000000{-# 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 serialise-0.2.3.0/bench/versus/Macro/ReadShow.hs0000644000000000000000000000520207346545000017541 0ustar0000000000000000{-# 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 serialise-0.2.3.0/bench/versus/Macro/Types.hs0000644000000000000000000003224107346545000017134 0ustar0000000000000000{-# 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) serialise-0.2.3.0/bench/versus/Main.hs0000644000000000000000000000070107346545000015647 0ustar0000000000000000module 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 ] serialise-0.2.3.0/bench/versus/Mini.hs0000644000000000000000000000355407346545000015670 0ustar0000000000000000module 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") serialise-0.2.3.0/bench/versus/Utils.hs0000644000000000000000000001013107346545000016061 0ustar0000000000000000{-# 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-0.2.3.0/serialise.cabal0000644000000000000000000002027207346545000014772 0ustar0000000000000000name: serialise version: 0.2.3.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 without custom tools. . An implementation of the standard bijection between CBOR and JSON is provided by the [cborg-json](/package/cborg-json) package. Also see [cbor-tool](/package/cbor-tool) for a convenient command-line utility for working with CBOR data. 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 tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.3, GHC == 8.10.1 extra-source-files: ChangeLog.md source-repository head type: git location: https://github.com/well-typed/cborg.git -------------------------------------------------------------------------------- -- Flags flag newtime15 default: True 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 Codec.Serialise.Internal.GeneralisedUTF8 build-depends: array >= 0.4 && < 0.6, base >= 4.7 && < 4.15, bytestring >= 0.10.4 && < 0.11, cborg == 0.2.*, containers >= 0.5 && < 0.7, ghc-prim >= 0.3.1.0 && < 0.7, half >= 0.2.2.3 && < 0.4, hashable >= 1.2 && < 2.0, primitive >= 0.5 && < 0.8, 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.11 else build-depends: time >= 1.4 && < 1.5, old-locale if impl(ghc >= 8.0) ghc-options: -Wcompat -Wnoncanonical-monad-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=-N2" other-modules: Tests.IO Tests.Negative Tests.Orphanage Tests.Serialise Tests.Serialise.Canonical Tests.Regress Tests.Regress.Issue13 Tests.Regress.Issue67 Tests.Regress.Issue80 Tests.Regress.Issue106 Tests.Regress.Issue135 Tests.Deriving Tests.GeneralisedUTF8 build-depends: base >= 4.7 && < 4.15, bytestring >= 0.10.4 && < 0.11, directory >= 1.0 && < 1.4, filepath >= 1.0 && < 1.5, text >= 1.1 && < 1.3, time >= 1.4 && < 1.11, containers >= 0.5 && < 0.7, unordered-containers >= 0.2 && < 0.3, primitive >= 0.5 && < 0.8, cborg, serialise, QuickCheck >= 2.9 && < 2.15, tasty >= 0.11 && < 1.4, tasty-hunit >= 0.9 && < 0.11, tasty-quickcheck >= 0.8 && < 0.11, 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.Float Instances.Integer Instances.Vector Instances.Time build-depends: base >= 4.7 && < 4.15, binary >= 0.7 && < 0.11, bytestring >= 0.10.4 && < 0.11, vector >= 0.10 && < 0.13, cborg, serialise, deepseq >= 1.0 && < 1.5, criterion >= 1.0 && < 1.6 if flag(newtime15) build-depends: time >= 1.5 && < 1.11 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.7 && < 4.15, binary >= 0.7 && < 0.11, bytestring >= 0.10.4 && < 0.11, ghc-prim >= 0.3.1.0 && < 0.7, vector >= 0.10 && < 0.13, cborg, serialise, aeson >= 0.7 && < 1.5, deepseq >= 1.0 && < 1.5, criterion >= 1.0 && < 1.6, cereal >= 0.5.2.0 && < 0.6, cereal-vector >= 0.2 && < 0.3, semigroups >= 0.18 && < 0.20, store >= 0.7.1 && < 0.8 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.7 && < 4.15, binary >= 0.7 && < 0.11, bytestring >= 0.10.4 && < 0.11, directory >= 1.0 && < 1.4, ghc-prim >= 0.3.1.0 && < 0.7, fail >= 4.9.0.0 && < 4.10, text >= 1.1 && < 1.3, vector >= 0.10 && < 0.13, cborg, serialise, filepath >= 1.0 && < 1.5, containers >= 0.5 && < 0.7, deepseq >= 1.0 && < 1.5, aeson >= 0.7 && < 1.5, cereal >= 0.5.2.0 && < 0.6, half >= 0.2.2.3 && < 0.4, tar >= 0.4 && < 0.6, zlib >= 0.5 && < 0.7, pretty >= 1.0 && < 1.2, criterion >= 1.0 && < 1.6, store >= 0.7.1 && < 0.8, semigroups if flag(newtime15) build-depends: time >= 1.5 && < 1.11 else build-depends: time >= 1.4 && < 1.5, old-locale serialise-0.2.3.0/src/Codec/0000755000000000000000000000000007346545000013627 5ustar0000000000000000serialise-0.2.3.0/src/Codec/Serialise.hs0000644000000000000000000001464207346545000016112 0ustar0000000000000000{-# 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.Serialise.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 serialise-0.2.3.0/src/Codec/Serialise/0000755000000000000000000000000007346545000015547 5ustar0000000000000000serialise-0.2.3.0/src/Codec/Serialise/Class.hs0000644000000000000000000014767507346545000017174 0ustar0000000000000000{-# 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(..) , GSerialiseProd(..) , GSerialiseSum(..) , encodeVector , decodeVector , encodeContainerSkel , encodeMapSkel , decodeMapSkel ) where import Control.Applicative import Control.Monad import Data.Char 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.ByteString.Short.Internal as BSS 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.Primitive.ByteArray as Prim 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 import Codec.Serialise.Internal.GeneralisedUTF8 import qualified Codec.CBOR.ByteArray as BA import qualified Codec.CBOR.ByteArray.Sliced as BAS -------------------------------------------------------------------------------- -- 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 -- Here we've taken great pains to ensure that surrogate characters, which -- are not representable in UTF-8 yet still admitted by Char, -- round-trip properly. We scan the encoded characters during encoding -- looking for surrogates; if we find any we encode the string as a -- a list of code-points encoded as words. This is slow, but should be rare. encode c | isSurrogate c = encodeWord (fromIntegral $ ord c) | otherwise = encodeString (Text.singleton c) decode = do ty <- peekTokenType case ty of TypeUInt -> chr . fromIntegral <$> decodeWord TypeString -> do t <- decodeString if Text.length t == 1 then return $! Text.head t else fail "expected a single char, found a string" _ -> fail "expected a word or string" -- For [Char]/String we have a special encoding encodeList cs = case encodeGenUTF8 cs of (ba, ConformantUTF8) -> encodeUtf8ByteArray ba (ba, GeneralisedUTF8) -> encodeByteArray ba decodeList = do ty <- peekTokenType case ty of TypeBytes -> decodeGenUTF8 . BA.unBA <$> decodeByteArray TypeString -> do txt <- decodeString return (Text.unpack txt) -- unpack lazily _ -> fail "expected a list or string" -- | @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 -- | @since 0.2.0.0 instance Serialise BSS.ShortByteString where encode sbs@(BSS.SBS ba) = encodeByteArray $ BAS.SBA (Prim.ByteArray ba) 0 (BSS.length sbs) decode = do BA.BA (Prim.ByteArray ba) <- decodeByteArray return $ BSS.SBS ba 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) -- | Patch functions together to obtain an 'Encoding' for a container. encodeContainerSkel :: (Word -> Encoding) -- ^ encoder of the length -> (container -> Int) -- ^ length -> (accumFunc -> Encoding -> container -> Encoding) -- ^ foldr -> 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 -- | A helper function for encoding maps. encodeMapSkel :: (Serialise k, Serialise v) => (m -> Int) -- ^ obtain the length -> ((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 #-} -- | A utility function to construct a 'Decoder' for maps. decodeMapSkel :: (Serialise k, Serialise v) => ([(k,v)] -> m) -- ^ fromList -> 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 #if MIN_VERSION_base(4,13,0) Int8Rep -> encodeListLen 1 <> encodeWord 12 Int16Rep -> encodeListLen 1 <> encodeWord 13 Word8Rep -> encodeListLen 1 <> encodeWord 14 Word16Rep -> encodeListLen 1 <> encodeWord 15 #endif #if MIN_VERSION_base(4,14,0) Int32Rep -> encodeListLen 1 <> encodeWord 16 Word32Rep -> encodeListLen 1 <> encodeWord 17 #endif 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 #if MIN_VERSION_base(4,13,0) 12 | len == 1 -> pure Int8Rep 13 | len == 1 -> pure Int16Rep 14 | len == 1 -> pure Word8Rep 15 | len == 1 -> pure Word16Rep #endif #if MIN_VERSION_base(4,14,0) 16 | len == 1 -> pure Int32Rep 17 | len == 1 -> pure Word32Rep #endif _ -> 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 == 3 -> do !con <- decode !ks <- decode return $! SomeTypeRep $ mkTrCon con ks 2 | len == 3 -> 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 == 3 -> 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" [ "Tag: " ++ show tag , "Len: " ++ show len ] 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 -- | @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" , " Deserialised 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" serialise-0.2.3.0/src/Codec/Serialise/Decoding.hs0000644000000000000000000000525007346545000017621 0ustar0000000000000000-- | -- 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 () , decodeByteArray -- :: Decoder s ByteArray , decodeString -- :: Decoder s Text , decodeStringIndef -- :: Decoder s () , decodeUtf8ByteArray -- :: Decoder s ByteArray , 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) serialise-0.2.3.0/src/Codec/Serialise/Encoding.hs0000644000000000000000000000434707346545000017641 0ustar0000000000000000-- | -- 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 , encodeByteArray -- :: ByteArray -> Encoding , encodeString -- :: T.Text -> Encoding , encodeStringIndef -- :: Encoding , encodeUtf8ByteArray -- :: ByteArray -> 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) serialise-0.2.3.0/src/Codec/Serialise/IO.hs0000644000000000000000000000101007346545000016402 0ustar0000000000000000-- | -- 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 serialise-0.2.3.0/src/Codec/Serialise/Internal/0000755000000000000000000000000007346545000017323 5ustar0000000000000000serialise-0.2.3.0/src/Codec/Serialise/Internal/GeneralisedUTF8.hs0000644000000000000000000001167607346545000022563 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} module Codec.Serialise.Internal.GeneralisedUTF8 ( encodeGenUTF8 , UTF8Encoding(..) , decodeGenUTF8 -- * Utilities , isSurrogate , isValid ) where import Control.Monad.ST import Data.Bits import Data.Char import Data.Word import qualified Codec.CBOR.ByteArray.Sliced as BAS import Data.Primitive.ByteArray data UTF8Encoding = ConformantUTF8 | GeneralisedUTF8 deriving (Show, Eq) -- | Is a 'Char' a UTF-16 surrogate? isSurrogate :: Char -> Bool isSurrogate c = c >= '\xd800' && c <= '\xdfff' -- | Encode a string as (generalized) UTF-8. In addition to the encoding, we -- return a flag indicating whether the encoded string contained any surrogate -- characters, in which case the output is generalized UTF-8. encodeGenUTF8 :: String -> (BAS.SlicedByteArray, UTF8Encoding) encodeGenUTF8 st = runST $ do -- We slightly over-allocate such that we won't need to copy in the -- ASCII-only case. ba <- newByteArray (length st + 4) go ba ConformantUTF8 0 st where go :: MutableByteArray s -> UTF8Encoding -> Int -> [Char] -> ST s (BAS.SlicedByteArray, UTF8Encoding) go ba !enc !off [] = do ba' <- unsafeFreezeByteArray ba return (BAS.SBA ba' 0 off, enc) go ba enc off (c:cs) | off + 4 >= cap = do -- We ran out of room; reallocate and copy ba' <- newByteArray (cap + cap `div` 2 + 1) copyMutableByteArray ba' 0 ba 0 off go ba' enc off (c:cs) | c >= '\x10000' = do writeByteArray ba (off+0) (0xf0 .|. (0x07 .&. shiftedByte 18)) writeByteArray ba (off+1) (0x80 .|. (0x3f .&. shiftedByte 12)) writeByteArray ba (off+2) (0x80 .|. (0x3f .&. shiftedByte 6)) writeByteArray ba (off+3) (0x80 .|. (0x3f .&. shiftedByte 0)) go ba enc (off+4) cs | c >= '\x0800' = do writeByteArray ba (off+0) (0xe0 .|. (0x0f .&. shiftedByte 12)) writeByteArray ba (off+1) (0x80 .|. (0x3f .&. shiftedByte 6)) writeByteArray ba (off+2) (0x80 .|. (0x3f .&. shiftedByte 0)) -- Is this a surrogate character? let enc' | isSurrogate c = GeneralisedUTF8 | otherwise = enc go ba enc' (off+3) cs | c >= '\x0080' = do writeByteArray ba (off+0) (0xc0 .|. (0x1f .&. shiftedByte 6)) writeByteArray ba (off+1) (0x80 .|. (0x3f .&. shiftedByte 0)) go ba enc (off+2) cs | c <= '\x007f' = do writeByteArray ba off (fromIntegral n :: Word8) go ba enc (off+1) cs | otherwise = error "encodeGenUTF8: Impossible" where cap = sizeofMutableByteArray ba n = ord c shiftedByte :: Int -> Word8 shiftedByte shft = fromIntegral $ n `shiftR` shft decodeGenUTF8 :: ByteArray -> String decodeGenUTF8 ba = go 0 where !len = sizeofByteArray ba index :: Int -> Int index i = fromIntegral (ba `indexByteArray` i :: Word8) go !off | off == len = [] | n0 .&. 0xf8 == 0xf0 = let n1 = index (off + 1) n2 = index (off + 2) n3 = index (off + 3) c = chr $ (n0 .&. 0x07) `shiftL` 18 .|. (n1 .&. 0x3f) `shiftL` 12 .|. (n2 .&. 0x3f) `shiftL` 6 .|. (n3 .&. 0x3f) in c : go (off + 4) | n0 .&. 0xf0 == 0xe0 = let n1 = index (off + 1) n2 = index (off + 2) c = chr $ (n0 .&. 0x0f) `shiftL` 12 .|. (n1 .&. 0x3f) `shiftL` 6 .|. (n2 .&. 0x3f) in c : go (off + 3) | n0 .&. 0xe0 == 0xc0 = let n1 = index (off + 1) c = chr $ (n0 .&. 0x1f) `shiftL` 6 .|. (n1 .&. 0x3f) in c : go (off + 2) | otherwise = let c = chr $ (n0 .&. 0x7f) in c : go (off + 1) where !n0 = index off -- | Is the given byte sequence valid under the given encoding? isValid :: UTF8Encoding -> [Word8] -> Bool isValid encoding = go where go [] = True go (b0:bs) | inRange 0x00 0x7f b0 = go bs go (b0:b1:bs) | inRange 0xc2 0xdf b0 , inRange 0x80 0xbf b1 = go bs go (0xe0:b1:b2:bs) | inRange 0xa0 0xbf b1 , inRange 0x80 0xbf b2 = go bs go (0xed:b1:_) -- surrogate range | encoding == ConformantUTF8 , inRange 0xa0 0xbf b1 = False go (b0:b1:b2:bs) | inRange 0xe1 0xef b0 , inRange 0x80 0xbf b1 , inRange 0x80 0xbf b2 = go bs go (0xf0:b1:b2:b3:bs) | inRange 0x90 0xbf b1 , inRange 0x80 0xbf b2 , inRange 0x80 0xbf b3 = go bs go (b0:b1:b2:b3:bs) | inRange 0xf1 0xf3 b0 , inRange 0x80 0xbf b1 , inRange 0x80 0xbf b2 , inRange 0x80 0xbf b3 = go bs go (0xf4:b1:b2:b3:bs) | inRange 0x80 0x8f b1 , inRange 0x80 0xbf b2 , inRange 0x80 0xbf b3 = go bs go _ = False inRange :: Ord a => a -> a -> a -> Bool inRange lower upper x = lower <= x && x <= upper serialise-0.2.3.0/src/Codec/Serialise/Properties.hs0000644000000000000000000000475507346545000020252 0ustar0000000000000000-- | -- 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 serialise-0.2.3.0/src/Codec/Serialise/Tutorial.hs0000644000000000000000000002732707346545000017721 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-unused-imports #-} -- | -- Module : Codec.Serialise.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 Codec.Serialise > import qualified Data.ByteString.Lazy as BSL > > data Animal = HoppingAnimal { animalName :: String, hoppingHeight :: Int } > | WalkingAnimal { animalName :: String, walkingSpeed :: Int } > deriving (Generic) > > instance Serialise Animal > > fredTheFrog :: Animal > fredTheFrog = HoppingAnimal "Fred" 4 > > main = BSL.writeFile "hi" (serialise fredTheFrog) We can then later read Fred, > main = do > fred <- deserialise <$> BSL.readFile "hi" > print fred -} {- $cbor_format @cborg@ uses the Concise Binary Object Representation, CBOR (IETF RFC 7049, ), as its serialised representation. This encoding is efficient in both encoding\/decoding complexity as well as space, and is generally machine-independent. The CBOR data model resembles that of JSON, having arrays, key\/value maps, integers, floating point numbers, binary strings, and text. In addition, CBOR allows items to be /tagged/ with a number which describes the type of data that follows. This can be used both to identify which data constructor of a type an encoding represents, as well as representing different versions of the same constructor. === A note on interoperability @cborg@ is intended primarily as a /serialisation/ library for Haskell values. That is, a means of stably storing Haskell values for later reading by @cborg@. While it uses the CBOR encoding format, the library is /not/ primarily aimed to facilitate serialisation and deserialisation across different CBOR implementations. If you want to use @cborg@ to serialise\/deserialise values for\/from another CBOR implementation (either in Haskell or another language), you should keep a few things in mind, 1. The 'Serialise' instances for some "basic" Haskell types (e.g. 'Maybe', 'Data.ByteString.ByteString', tuples) don't carry a tag, in contrast to common convention. This is an intentional design decision to minimize encoding size for types which are primitive enough that their representation can be considered stable. 2. The library reserves the right to change encodings in non-backwards-compatible ways across super-major versions. For example the library may start producing a new representation for some type. The new version of the library will be able to decode the old and new representation, but your different CBOR decoder would not be expecting the new representation and would have to be updated to match. 3. While the library tries to use standard encodings in its instances wherever possible, these instances aren't guaranteed to implement all valid variants of the encodings in the specification. For instance, the 'UTCTime' instance only implements a small subset of the encodings described by the Extended Date RFC. -} {- $serialise @cborg@ provides a 'Serialise' class for convenient access to serialisers and deserialisers. Writing a serialiser can be as simple as deriving 'Generic' and 'Serialise', > -- with DerivingStrategies (GHC 8.2 and newer) > data Animal = ... > deriving stock (Generic) > deriving anyclass (Serialise) > > -- older GHCs > data MyType = ... > deriving (Generic) > instance Serialise MyType Of course, you can also write the equivalent serialisers manually. A hand-rolled 'Serialise' instance may be desireable for a variety of reasons, * Deviating from the type-guided encoding that the 'Generic' instance will provide * Interfacing with other CBOR implementations * Enabling migrations for future changes to the type or its encoding A minimal hand-rolled instance will define the 'encode' and 'decode' methods, > instance Serialise Animal where > encode = encodeAnimal > decode = decodeAnimal Below we will describe how to write these pieces. -} {- $encoding For the purposes of encoding, abstract CBOR representations are embodied by the 'Codec.CBOR.Encoding.Tokens' type. Such a representation can be efficiently built using the 'Codec.CBOR.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 <> encodeWord 0 <> encode name <> encode height > encodeAnimal (WalkingAnimal name speed) = > encodeListLen 3 <> encodeWord 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. Also note that the recommended encoding represents Haskell constructor indexes as CBOR words, not CBOR tags. -} {- $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 <- decodeWord > 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 <> encodeWord 0 <> encode name <> encode height > encodeAnimal (WalkingAnimal name speed) = > encodeListLen 3 <> encodeWord 1 <> encode name <> encode speed > -- Here is out new case... > encodeAnimal (SwimmingAnimal numberOfFins) = > encodeListLen 2 <> encodeWord 2 <> encode numberOfFins > > decodeAnimal :: Decoder s Animal > decodeAnimal = do > len <- decodeListLen > tag <- decodeWord > 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 <> encodeWord 0 <> encode name <> encode height > encodeAnimal (SwimmingAnimal numberOfFins) = > encodeListLen 2 <> encodeWord 2 <> encode numberOfFins > -- This is new... > encodeAnimal (WalkingAnimal animalName walkingSpeed numberOfFeet) = > encodeListLen 4 <> encodeWord 3 <> encode animalName <> encode walkingSpeed <> encode numberOfFeet > > decodeAnimal :: Decoder s Animal > decodeAnimal = do > len <- decodeListLen > tag <- decodeWord > case (len, tag) of > -- these 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 <*> 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 'Codec.CBOR.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 "Codec.CBOR.FlatTerm" and "Codec.CBOR.Pretty" modules. The 'Codec.CBOR.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 "Codec.CBOR.Pretty", for visualising the CBOR wire protocol alongside its semantic structure. For instance, >>> putStrLn $ Codec.CBOR.Pretty.prettyHexEnc $ encode $ HoppingAnimal "Fred" 42 83 # list(3) 00 # word(0) 64 46 72 65 64 # text("Fred") 18 2a # int(42) -} serialise-0.2.3.0/tests/0000755000000000000000000000000007346545000013165 5ustar0000000000000000serialise-0.2.3.0/tests/Main.hs0000644000000000000000000000115207346545000014404 0ustar0000000000000000module Main ( main -- :: IO () ) where import Test.Tasty (defaultMain, testGroup) import qualified Tests.IO as IO import qualified Tests.Regress as Regress import qualified Tests.Serialise as Serialise import qualified Tests.Negative as Negative import qualified Tests.Deriving as Deriving import qualified Tests.GeneralisedUTF8 as GeneralisedUTF8 main :: IO () main = defaultMain $ testGroup "CBOR tests" [ Serialise.testTree , Serialise.testGenerics , Negative.testTree , IO.testTree , Regress.testTree , Deriving.testTree , GeneralisedUTF8.testTree ] serialise-0.2.3.0/tests/Tests/0000755000000000000000000000000007346545000014267 5ustar0000000000000000serialise-0.2.3.0/tests/Tests/Deriving.hs0000644000000000000000000000362107346545000016374 0ustar0000000000000000{-# 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 ] serialise-0.2.3.0/tests/Tests/GeneralisedUTF8.hs0000644000000000000000000000164707346545000017524 0ustar0000000000000000module Tests.GeneralisedUTF8 where import GHC.Exts import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.ByteString as BS import Test.Tasty import Test.Tasty.QuickCheck import qualified Codec.CBOR.ByteArray as BA import Codec.Serialise.Internal.GeneralisedUTF8 testEncoder :: String -> Property testEncoder s = case encodeGenUTF8 s of (ba, enc) -> toList ba === BS.unpack (T.encodeUtf8 $ T.pack s) .&&. enc === correctEnc where correctEnc | any isSurrogate s = GeneralisedUTF8 | otherwise = ConformantUTF8 testDecoder :: String -> Property testDecoder s = decodeGenUTF8 ba === s where BA.BA ba = BA.fromByteString $ T.encodeUtf8 $ T.pack s testTree :: TestTree testTree = testGroup "Generalised UTF-8 codec" [ testProperty "encoder" testEncoder , testProperty "decoder" testDecoder ] serialise-0.2.3.0/tests/Tests/IO.hs0000644000000000000000000000225507346545000015136 0ustar0000000000000000{-# 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) serialise-0.2.3.0/tests/Tests/Negative.hs0000644000000000000000000000457307346545000016376 0ustar0000000000000000{-# LANGUAGE CPP #-} module Tests.Negative ( testTree -- :: TestTree ) where #if ! MIN_VERSION_base(4,11,0) import Data.Monoid #endif 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) serialise-0.2.3.0/tests/Tests/Orphanage.hs0000644000000000000000000001437607346545000016542 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE StandaloneDeriving #-} #if MIN_VERSION_base(4,10,0) {-# LANGUAGE TypeApplications #-} #endif 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) && !MIN_VERSION_QuickCheck(2,10,0) import qualified Data.Semigroup as Semigroup #endif #if MIN_VERSION_base(4,10,0) import Data.Proxy import qualified Type.Reflection as Refl #endif import GHC.Fingerprint.Type import Data.Ord #if !MIN_VERSION_QuickCheck(2,10,0) import Foreign.C.Types import System.Exit (ExitCode(..)) import Test.QuickCheck.Gen #endif import Test.QuickCheck.Arbitrary import qualified Data.Vector.Primitive as Vector.Primitive #if !MIN_VERSION_quickcheck_instances(0,3,17) import qualified Data.ByteString.Short as BSS #endif -------------------------------------------------------------------------------- -- 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 #if !MIN_VERSION_QuickCheck(2,10,0) 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 #endif -- Miscellaneous types from base #if MIN_VERSION_base(4,9,0) && !MIN_VERSION_QuickCheck(2,10,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) #if !MIN_VERSION_QuickCheck(2,10,0) instance Arbitrary ExitCode where arbitrary = frequency [(1, return ExitSuccess), (3, fmap ExitFailure arbitrary)] shrink (ExitFailure x) = ExitSuccess : [ ExitFailure x' | x' <- shrink x ] shrink _ = [] #endif #if !MIN_VERSION_quickcheck_instances(0,3,17) instance Arbitrary BSS.ShortByteString where arbitrary = BSS.pack <$> arbitrary #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) && !MIN_VERSION_QuickCheck(2,10,0) instance Arbitrary (Proxy a) where arbitrary = return Proxy #endif instance Arbitrary Fingerprint where arbitrary = Fingerprint <$> arbitrary <*> arbitrary #if MIN_VERSION_base(4,10,0) data Kind a = Type a instance Arbitrary Refl.SomeTypeRep where arbitrary = return (Refl.someTypeRep $ Proxy @([Either (Maybe Int) (Proxy ('Type String))])) #endif serialise-0.2.3.0/tests/Tests/Regress.hs0000644000000000000000000000116107346545000016234 0ustar0000000000000000module 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.Issue135 as Issue135 -------------------------------------------------------------------------------- -- Tests and properties testTree :: TestTree testTree = testGroup "Regression tests" [ Issue13.testTree , Issue67.testTree , Issue80.testTree , Issue106.testTree , Issue135.testTree ] serialise-0.2.3.0/tests/Tests/Regress/0000755000000000000000000000000007346545000015701 5ustar0000000000000000serialise-0.2.3.0/tests/Tests/Regress/Issue106.hs0000644000000000000000000000076607346545000017565 0ustar0000000000000000module 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) ] serialise-0.2.3.0/tests/Tests/Regress/Issue13.hs0000644000000000000000000000440707346545000017476 0ustar0000000000000000{-# 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 ] serialise-0.2.3.0/tests/Tests/Regress/Issue135.hs0000644000000000000000000000217607346545000017564 0ustar0000000000000000-- Issue #135: Ensure that surrogate characters round-trip -- module Tests.Regress.Issue135 ( testTree -- :: TestTree ) where import Codec.Serialise import Test.Tasty import Test.Tasty.QuickCheck import Test.Tasty.HUnit newtype StringWithSurrogates = StringWithSurrogates String deriving (Show) instance Arbitrary StringWithSurrogates where arbitrary = fmap StringWithSurrogates $ listOf1 $ oneof [choose ('\xd800', '\xdfff'), arbitrary] prop_surrogateRoundtrip :: StringWithSurrogates -> Property prop_surrogateRoundtrip (StringWithSurrogates s) = s === deserialise (serialise s) roundTrips :: (Eq a, Serialise a) => a -> Bool roundTrips x = x == deserialise (serialise x) testTree :: TestTree testTree = testGroup "Issue 135 - surrogate characters round-trip" [ testCase "simple reproduction case" (True @=? all (\c -> c == deserialise (serialise c)) ['\xdc80'..'\xdcff']) , testCase "all Chars round-trip" ([] @=? filter (not . roundTrips) ['\x0000'..'\x10ffff']) , testProperty "surrogates round-trip" prop_surrogateRoundtrip ] serialise-0.2.3.0/tests/Tests/Regress/Issue67.hs0000644000000000000000000000446307346545000017511 0ustar0000000000000000-- 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 serialise-0.2.3.0/tests/Tests/Regress/Issue80.hs0000644000000000000000000000164507346545000017503 0ustar0000000000000000module 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) ] serialise-0.2.3.0/tests/Tests/Serialise.hs0000644000000000000000000003524307346545000016552 0ustar0000000000000000{-# 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 #if MIN_VERSION_base(4,10,0) import qualified Type.Reflection as Refl #endif import Data.Char (ord) 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.Exts (IsList(..)) 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.Encoding 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 qualified Data.ByteString.Short as BSS import qualified Data.ByteString.Short.Internal as BSS import System.Exit (ExitCode(..)) import qualified Codec.CBOR.ByteArray as CBOR.BA 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 Data.Primitive.ByteArray as Prim import Tests.Orphanage() import Tests.Serialise.Canonical -------------------------------------------------------------------------------- -- 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 (Canonical Int)) , mkTest (T :: T (Canonical Int8)) , mkTest (T :: T (Canonical Int16)) , mkTest (T :: T (Canonical Int32)) , mkTest (T :: T (Canonical Int64)) , mkTest (T :: T (Canonical Word)) , mkTest (T :: T (Canonical Word8)) , mkTest (T :: T (Canonical Word16)) , mkTest (T :: T (Canonical Word32)) , mkTest (T :: T (Canonical Word64)) , mkTest (T :: T Integer) , mkTest (T :: T Float) , mkTest (T :: T Double) , mkTest (T :: T (Canonical Integer)) , mkTest (T :: T (Canonical Float)) , mkTest (T :: T (Canonical Double)) , mkTest (T :: T [()]) #if MIN_VERSION_base(4,10,0) , mkTest (T :: T (Refl.SomeTypeRep)) #endif #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 BSS.ShortByteString) , mkTest (T :: T BytesByteArray) , mkTest (T :: T Utf8ByteArray) , 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 $ tkStr "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 $ tkStr "asdf" $ TkEnd) , format C4 (TkListLen 1 $ TkWord 3 $ TkEnd) , format (Cons "foo" (Cons "bar" Nil) :: List String) (TkListLen 3 $ TkWord 0 $ tkStr "foo" $ TkListLen 3 $ TkWord 0 $ tkStr "bar" $ TkListLen 1 $ TkWord 1 $ TkEnd) ] where tkStr = TkUtf8ByteArray . fromList . map (fromIntegral . ord) -------------------------------------------------------------------------------- -- 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) ] -------------------------------------------------------------------------------- -- Various data types -- Wrapper for CUSeconds with Arbitrary instance that works on x86_32. newtype CUSeconds_ = CUSeconds_ CUSeconds deriving (Eq, Show, Typeable) instance Arbitrary CUSeconds_ where arbitrary = CUSeconds_ . CUSeconds <$> arbitraryBoundedIntegral instance Serialise CUSeconds_ where encode (CUSeconds_ s) = encode s decode = CUSeconds_ <$> decode -------------------------------------------------------------------------------- -- 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 newtype BytesByteArray = BytesBA CBOR.BA.ByteArray deriving (Eq, Ord, Show, Typeable) instance Serialise BytesByteArray where encode (BytesBA ba) = encodeByteArray $ CBOR.BA.toSliced ba decode = BytesBA <$> decodeByteArray instance Arbitrary BytesByteArray where arbitrary = BytesBA . fromList <$> arbitrary newtype Utf8ByteArray = Utf8BA CBOR.BA.ByteArray deriving (Eq, Ord, Show, Typeable) instance Serialise Utf8ByteArray where encode (Utf8BA ba) = encodeUtf8ByteArray $ CBOR.BA.toSliced ba decode = Utf8BA <$> decodeUtf8ByteArray instance Arbitrary Utf8ByteArray where arbitrary = do BSS.SBS ba <- BSS.toShort . Text.encodeUtf8 <$> arbitrary return $ Utf8BA $ CBOR.BA.BA $ Prim.ByteArray ba serialise-0.2.3.0/tests/Tests/Serialise/0000755000000000000000000000000007346545000016207 5ustar0000000000000000serialise-0.2.3.0/tests/Tests/Serialise/Canonical.hs0000644000000000000000000000632207346545000020435 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveDataTypeable #-} module Tests.Serialise.Canonical where #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif import Data.Bits import Data.Int import Data.Typeable import Data.Word import Test.QuickCheck import Codec.CBOR.Decoding import Codec.CBOR.Encoding as E import Codec.Serialise.Class newtype Canonical a = Canonical { fromCanonical :: a } deriving (Typeable, Eq, Show) -- | Generate "proper" big integers (as standard Arbitrary Integer instance -- doesn't really do that) to test canonicity. instance Arbitrary (Canonical Integer) where arbitrary = do c <- choose (1, 5) neg <- arbitrary Canonical . (if neg then negate else id) . foldr combine 0 <$> vectorOf c arbitrary where combine :: Word64 -> Integer -> Integer combine v acc = (acc `shiftL` finiteBitSize v) + toInteger v deriving instance Arbitrary (Canonical Word) deriving instance Arbitrary (Canonical Word8) deriving instance Arbitrary (Canonical Word16) deriving instance Arbitrary (Canonical Word32) deriving instance Arbitrary (Canonical Word64) deriving instance Arbitrary (Canonical Int) deriving instance Arbitrary (Canonical Int8) deriving instance Arbitrary (Canonical Int16) deriving instance Arbitrary (Canonical Int32) deriving instance Arbitrary (Canonical Int64) deriving instance Arbitrary (Canonical Float) deriving instance Arbitrary (Canonical Double) ---------------------------------------- instance Serialise (Canonical Word) where encode = encodeWord . fromCanonical decode = Canonical <$> decodeWordCanonical instance Serialise (Canonical Word8) where encode = encodeWord8 . fromCanonical decode = Canonical <$> decodeWord8Canonical instance Serialise (Canonical Word16) where encode = encodeWord16 . fromCanonical decode = Canonical <$> decodeWord16Canonical instance Serialise (Canonical Word32) where encode = encodeWord32 . fromCanonical decode = Canonical <$> decodeWord32Canonical instance Serialise (Canonical Word64) where encode = encodeWord64 . fromCanonical decode = Canonical <$> decodeWord64Canonical instance Serialise (Canonical Int) where encode = encodeInt . fromCanonical decode = Canonical <$> decodeIntCanonical instance Serialise (Canonical Int8) where encode = encodeInt8 . fromCanonical decode = Canonical <$> decodeInt8Canonical instance Serialise (Canonical Int16) where encode = encodeInt16 . fromCanonical decode = Canonical <$> decodeInt16Canonical instance Serialise (Canonical Int32) where encode = encodeInt32 . fromCanonical decode = Canonical <$> decodeInt32Canonical instance Serialise (Canonical Int64) where encode = encodeInt64 . fromCanonical decode = Canonical <$> decodeInt64Canonical instance Serialise (Canonical Integer) where encode = encodeInteger . fromCanonical decode = Canonical <$> decodeIntegerCanonical instance Serialise (Canonical Float) where encode = E.encodeFloat . fromCanonical decode = Canonical <$> decodeFloatCanonical instance Serialise (Canonical Double) where encode = encodeDouble . fromCanonical decode = Canonical <$> decodeDoubleCanonical