diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,14 @@ # Revision history for serialise +## 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 diff --git a/bench/versus/Macro/Load.hs b/bench/versus/Macro/Load.hs --- a/bench/versus/Macro/Load.hs +++ b/bench/versus/Macro/Load.hs @@ -8,7 +8,6 @@ import Text.ParserCombinators.ReadP as ReadP hiding (get) import qualified Text.ParserCombinators.ReadP as Parse import qualified Text.PrettyPrint as Disp -import qualified Data.Char as Char (isDigit, isAlphaNum, isSpace) import Text.PrettyPrint hiding (braces, (<>)) import Data.List @@ -19,6 +18,7 @@ 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) @@ -151,6 +151,8 @@ 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) @@ -1200,7 +1202,7 @@ Just ke -> return ke Nothing -> - fail ("Can't parse " ++ show extension ++ " as KnownExtension") + Fail.fail ("Can't parse " ++ show extension ++ " as KnownExtension") classifyExtension :: String -> Extension classifyExtension string @@ -1844,6 +1846,9 @@ (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) @@ -1986,7 +1991,7 @@ `catchParseError` \parseError -> case parseError of TabsError _ -> parseFail parseError _ | versionOk -> parseFail parseError - | otherwise -> fail message + | otherwise -> Fail.fail message where versionOk = cabalVersionNeeded <= cabalVersion message = "This package requires at least Cabal version " ++ display cabalVersionNeeded @@ -2296,7 +2301,7 @@ checkCondTreeFlags definedFlags ct = do let fv = nub $ freeVars ct unless (all (`elem` definedFlags) fv) $ - fail $ "These flags are used without having been defined: " + Fail.fail $ "These flags are used without having been defined: " ++ intercalate ", " [ n | FlagName n <- fv \\ definedFlags ] findIndentTabs :: String -> [(Int,Int)] diff --git a/serialise.cabal b/serialise.cabal --- a/serialise.cabal +++ b/serialise.cabal @@ -1,5 +1,5 @@ name: serialise -version: 0.2.1.0 +version: 0.2.2.0 synopsis: A binary serialisation library for Haskell values. description: This package (formerly @binary-serialise-cbor@) provides pure, efficient @@ -29,6 +29,8 @@ 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.1 extra-source-files: ChangeLog.md @@ -62,14 +64,14 @@ build-depends: array >= 0.4 && < 0.6, - base >= 4.6 && < 5.0, + base >= 4.7 && < 5.0, bytestring >= 0.10.4 && < 0.11, cborg == 0.2.*, containers >= 0.5 && < 0.7, ghc-prim >= 0.3.1.0 && < 0.6, half >= 0.2.2.3 && < 0.4, hashable >= 1.2 && < 2.0, - primitive >= 0.5 && < 0.7, + primitive >= 0.5 && < 0.8, text >= 1.1 && < 1.3, unordered-containers >= 0.2 && < 0.3, vector >= 0.10 && < 0.13 @@ -83,7 +85,7 @@ old-locale if impl(ghc >= 8.0) - ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances + ghc-options: -Wcompat -Wnoncanonical-monad-instances -------------------------------------------------------------------------------- -- Tests @@ -114,7 +116,7 @@ Tests.GeneralisedUTF8 build-depends: - base >= 4.6 && < 5.0, + base >= 4.7 && < 5.0, bytestring >= 0.10.4 && < 0.11, directory >= 1.0 && < 1.4, filepath >= 1.0 && < 1.5, @@ -122,11 +124,11 @@ time >= 1.4 && < 1.10, containers >= 0.5 && < 0.7, unordered-containers >= 0.2 && < 0.3, - primitive >= 0.5 && < 0.7, + primitive >= 0.5 && < 0.8, cborg, serialise, - QuickCheck >= 2.9 && < 2.13, - tasty >= 0.11 && < 1.2, + QuickCheck >= 2.9 && < 2.14, + tasty >= 0.11 && < 1.3, tasty-hunit >= 0.9 && < 0.11, tasty-quickcheck >= 0.8 && < 0.11, quickcheck-instances >= 0.3.12 && < 0.4, @@ -151,7 +153,7 @@ Instances.Time build-depends: - base >= 4.6 && < 5.0, + base >= 4.7 && < 5.0, binary >= 0.7 && < 0.11, bytestring >= 0.10.4 && < 0.11, vector >= 0.10 && < 0.13, @@ -195,7 +197,7 @@ SimpleVersus build-depends: - base >= 4.6 && < 5.0, + base >= 4.7 && < 5.0, binary >= 0.7 && < 0.11, bytestring >= 0.10.4 && < 0.11, ghc-prim >= 0.3.1.0 && < 0.6, @@ -208,8 +210,8 @@ criterion >= 1.0 && < 1.6, cereal >= 0.5.2.0 && < 0.6, cereal-vector >= 0.2 && < 0.3, - store >= 0.4 && < 0.6, - semigroups == 0.18.* + semigroups >= 0.18 && < 0.20, + store >= 0.7.1 && < 0.8 benchmark versus type: exitcode-stdio-1.0 @@ -242,11 +244,12 @@ build-depends: array >= 0.4 && < 0.6, - base >= 4.6 && < 5.0, + base >= 4.7 && < 5.0, binary >= 0.7 && < 0.11, bytestring >= 0.10.4 && < 0.11, directory >= 1.0 && < 1.4, ghc-prim >= 0.3.1.0 && < 0.6, + fail >= 4.9.0.0 && < 4.10, text >= 1.1 && < 1.3, vector >= 0.10 && < 0.13, cborg, @@ -262,8 +265,8 @@ zlib >= 0.5 && < 0.7, pretty >= 1.0 && < 1.2, criterion >= 1.0 && < 1.6, - store >= 0.4 && < 0.6, - semigroups == 0.18.* + store >= 0.7.1 && < 0.8, + semigroups if flag(newtime15) build-depends: diff --git a/src/Codec/Serialise/Class.hs b/src/Codec/Serialise/Class.hs --- a/src/Codec/Serialise/Class.hs +++ b/src/Codec/Serialise/Class.hs @@ -28,6 +28,9 @@ , GSerialiseSum(..) , encodeVector , decodeVector + , encodeContainerSkel + , encodeMapSkel + , decodeMapSkel ) where import Control.Applicative @@ -856,9 +859,10 @@ encode (Tree.Node r sub) = encodeListLen 2 <> encode r <> encode sub decode = decodeListLenOf 2 *> (Tree.Node <$> decode <*> decode) -encodeContainerSkel :: (Word -> Encoding) - -> (container -> Int) - -> (accumFunc -> Encoding -> container -> Encoding) +-- | 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 @@ -996,8 +1000,9 @@ encode = encodeSetSkel HashSet.size HashSet.foldr decode = decodeSetSkel HashSet.fromList +-- | A helper function for encoding maps. encodeMapSkel :: (Serialise k, Serialise v) - => (m -> Int) + => (m -> Int) -- ^ obtain the length -> ((k -> v -> Encoding -> Encoding) -> Encoding -> m -> Encoding) -> m -> Encoding @@ -1009,8 +1014,9 @@ (\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) + => ([(k,v)] -> m) -- ^ fromList -> Decoder s m decodeMapSkel fromList = do n <- decodeMapLen @@ -1146,6 +1152,12 @@ 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 decode = do len <- decodeListLen @@ -1163,6 +1175,12 @@ 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 _ -> fail "Data.Serialise.Binary.CBOR.getRuntimeRep: invalid tag" -- | @since 0.2.0.0 @@ -1210,11 +1228,11 @@ case tag of 0 | len == 1 -> return $! SomeTypeRep (typeRep :: TypeRep Type) - 1 | len == 2 -> do + 1 | len == 3 -> do !con <- decode !ks <- decode return $! SomeTypeRep $ mkTrCon con ks - 2 | len == 2 -> do + 2 | len == 3 -> do SomeTypeRep f <- decodeSomeTypeRep SomeTypeRep x <- decodeSomeTypeRep case typeRepKind f of @@ -1233,7 +1251,7 @@ [ "Applied type: " ++ show f , "To argument: " ++ show x ] - 3 | len == 2 -> do + 3 | len == 3 -> do SomeTypeRep arg <- decodeSomeTypeRep SomeTypeRep res <- decodeSomeTypeRep case typeRepKind arg `eqTypeRep` (typeRep :: TypeRep Type) of @@ -1242,7 +1260,9 @@ Just HRefl -> return $! SomeTypeRep $ Fun arg res Nothing -> failure "Kind mismatch" [] Nothing -> failure "Kind mismatch" [] - _ -> failure "unexpected tag" [] + _ -> failure "unexpected tag" + [ "Tag: " ++ show tag + , "Len: " ++ show len ] where failure description info = fail $ unlines $ [ "Codec.CBOR.Class.decodeSomeTypeRep: "++description ] diff --git a/tests/Tests/Orphanage.hs b/tests/Tests/Orphanage.hs --- a/tests/Tests/Orphanage.hs +++ b/tests/Tests/Orphanage.hs @@ -1,10 +1,13 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} +#if MIN_VERSION_base(4,10,0) +{-# LANGUAGE TypeApplications #-} +#endif module Tests.Orphanage where -#if !MIN_VERSION_base(4,8,0) && !MIN_VERSION_QuickCheck(2,10,0) +#if !MIN_VERSION_base(4,8,0) import Control.Applicative import Data.Monoid as Monoid #endif @@ -13,10 +16,14 @@ 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 Data.Typeable import Foreign.C.Types import System.Exit (ExitCode(..)) @@ -26,8 +33,11 @@ import Test.QuickCheck.Arbitrary import qualified Data.Vector.Primitive as Vector.Primitive --- import qualified Data.ByteString.Short as BSS +#if !MIN_VERSION_quickcheck_instances(0,3,17) +import qualified Data.ByteString.Short as BSS +#endif + -------------------------------------------------------------------------------- -- QuickCheck Orphans @@ -180,21 +190,6 @@ shrink _ = [] #endif -#if !MIN_VERSION_base(4,8,0) -deriving instance Typeable Const -deriving instance Typeable ZipList -deriving instance Typeable Down -deriving instance Typeable Monoid.Sum -deriving instance Typeable Monoid.All -deriving instance Typeable Monoid.Any -deriving instance Typeable Monoid.Product -deriving instance Typeable Monoid.Dual -deriving instance Typeable Fingerprint - -deriving instance Show a => Show (Const a b) -deriving instance Eq a => Eq (Const a b) -#endif - #if !MIN_VERSION_quickcheck_instances(0,3,17) instance Arbitrary BSS.ShortByteString where arbitrary = BSS.pack <$> arbitrary @@ -211,3 +206,10 @@ 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 diff --git a/tests/Tests/Serialise.hs b/tests/Tests/Serialise.hs --- a/tests/Tests/Serialise.hs +++ b/tests/Tests/Serialise.hs @@ -19,6 +19,10 @@ 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 @@ -177,6 +181,9 @@ , 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 ())) @@ -407,7 +414,7 @@ cnv = foldr Cons Nil newtype BytesByteArray = BytesBA CBOR.BA.ByteArray - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Typeable) instance Serialise BytesByteArray where encode (BytesBA ba) = encodeByteArray $ CBOR.BA.toSliced ba @@ -417,7 +424,7 @@ arbitrary = BytesBA . fromList <$> arbitrary newtype Utf8ByteArray = Utf8BA CBOR.BA.ByteArray - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Typeable) instance Serialise Utf8ByteArray where encode (Utf8BA ba) = encodeUtf8ByteArray $ CBOR.BA.toSliced ba diff --git a/tests/Tests/Serialise/Canonical.hs b/tests/Tests/Serialise/Canonical.hs --- a/tests/Tests/Serialise/Canonical.hs +++ b/tests/Tests/Serialise/Canonical.hs @@ -1,7 +1,13 @@ +{-# 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