diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,9 @@ +# 0.3 + +* Supported `UTCTime` +* Added an instance for lazy `ByteString` +* Added `toEncodingWithSchema` + # 0.2 * Renamed `extract*With` to `extract*By` for consistency diff --git a/src/Data/Winery.hs b/src/Data/Winery.hs --- a/src/Data/Winery.hs +++ b/src/Data/Winery.hs @@ -19,6 +19,7 @@ , DecodeException(..) , schema -- * Standalone serialisation + , toEncodingWithSchema , serialise , deserialise , deserialiseBy @@ -73,6 +74,7 @@ import Control.Monad.Trans.State import Control.Monad.Reader import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL import qualified Data.Winery.Internal.Builder as BB import Data.Bits import Data.Dynamic @@ -100,12 +102,22 @@ import qualified Data.Vector.Unboxed as UV import Data.Text.Prettyprint.Doc hiding ((<>), SText, SChar) import Data.Text.Prettyprint.Doc.Render.Terminal +import Data.Time.Clock +import Data.Time.Clock.POSIX import Data.Typeable import GHC.Generics import System.IO import Unsafe.Coerce -data Schema = SSchema !Word8 +data Schema = SFix Schema -- ^ binds a fixpoint + | SSelf !Word8 -- ^ @SSelf n@ refers to the n-th innermost fixpoint + | SList !Schema + | SArray !(VarInt Int) !Schema -- fixed size + | SProduct [Schema] + | SProductFixed [(VarInt Int, Schema)] -- fixed size + | SRecord [(T.Text, Schema)] + | SVariant [(T.Text, [Schema])] + | SSchema !Word8 | SUnit | SBool | SChar @@ -122,14 +134,7 @@ | SDouble | SBytes | SText - | SList !Schema - | SArray !(VarInt Int) !Schema -- fixed size - | SProduct [Schema] - | SProductFixed [(VarInt Int, Schema)] -- fixed size - | SRecord [(T.Text, Schema)] - | SVariant [(T.Text, [Schema])] - | SFix Schema -- ^ binds a fixpoint - | SSelf !Word8 -- ^ @SSelf n@ refers to the n-th innermost fixpoint + | SUTCTime deriving (Show, Read, Eq, Generic) instance Pretty Schema where @@ -151,6 +156,7 @@ SDouble -> "Double" SBytes -> "ByteString" SText -> "Text" + SUTCTime -> "UTCTime" SList s -> "[" <> pretty s <> "]" SArray _ s -> "[" <> pretty s <> "]" SProduct ss -> tupled $ map pretty ss @@ -243,17 +249,20 @@ -- | Serialise a value along with its schema. serialise :: Serialise a => a -> B.ByteString -serialise a = BB.toByteString $ mappend (BB.word8 currentSchemaVersion) - $ toEncoding (schema [a], a) +serialise a = BB.toByteString $ toEncodingWithSchema a {-# INLINE serialise #-} -- | Serialise a value along with its schema. writeFileSerialise :: Serialise a => FilePath -> a -> IO () writeFileSerialise path a = withFile path WriteMode - $ \h -> BB.hPutEncoding h $ mappend (BB.word8 currentSchemaVersion) - $ toEncoding (schema [a], a) + $ \h -> BB.hPutEncoding h $ toEncodingWithSchema a {-# INLINE writeFileSerialise #-} +toEncodingWithSchema :: Serialise a => a -> Encoding +toEncodingWithSchema a = mappend (BB.word8 currentSchemaVersion) + $ toEncoding (schema [a], a) +{-# INLINE toEncodingWithSchema #-} + splitSchema :: B.ByteString -> Either StrategyError (Schema, B.ByteString) splitSchema bs_ = case B.uncons bs_ of Just (ver, bs) -> do @@ -286,7 +295,7 @@ | otherwise = schemaVia p ts currentSchemaVersion :: Word8 -currentSchemaVersion = 1 +currentSchemaVersion = 2 bootstrapSchema :: Word8 -> Either StrategyError Schema bootstrapSchema 1 = Right $ SFix $ SVariant [("SSchema",[SWord8]) @@ -315,6 +324,20 @@ ,("SFix",[SSelf 0]) ,("SSelf",[SWord8]) ] +bootstrapSchema 2 = Right $ SFix $ SVariant [ + ("SFix",[SSelf 0]) + ,("SSelf",[SWord8]) + ,("SList",[SSelf 0]) + ,("SArray",[SInteger,SSelf 0]) + ,("SProduct",[SList (SSelf 0)]) + ,("SProductFixed",[SList (SProduct [SInteger,SSelf 0])]) + ,("SRecord",[SList (SProduct [SText,SSelf 0])]) + ,("SVariant",[SList (SProduct [SText,SList (SSelf 0)])]) + ,("SSchema",[SWord8]) + ,("SUnit",[]),("SBool",[]),("SChar",[]),("SWord8",[]),("SWord16",[]) + ,("SWord32",[]),("SWord64",[]),("SInt8",[]),("SInt16",[]),("SInt32",[]) + ,("SInt64",[]),("SInteger",[]),("SFloat",[]),("SDouble",[]),("SBytes",[]) + ,("SText",[]),("SUTCTime",[])] bootstrapSchema n = Left $ "Unsupported version: " <> pretty n unexpectedSchema :: forall a. Serialise a => Doc AnsiStyle -> Schema -> Strategy (Decoder a) @@ -502,12 +525,33 @@ SBytes -> pure id s -> unexpectedSchema "Serialise ByteString" s +instance Serialise BL.ByteString where + schemaVia _ _ = SBytes + toEncoding = foldMap BB.bytes . BL.toChunks + deserialiser = Deserialiser $ Plan $ \case + SBytes -> pure BL.fromStrict + s -> unexpectedSchema "Serialise ByteString" s + instance Serialise Encoding where schemaVia _ _ = SBytes toEncoding = id deserialiser = Deserialiser $ Plan $ \case SBytes -> pure BB.bytes s -> unexpectedSchema "Serialise Encoding" s + +instance Serialise UTCTime where + schemaVia _ _ = SUTCTime + toEncoding = toEncoding . utcTimeToPOSIXSeconds + deserialiser = Deserialiser $ Plan $ \case + SUTCTime -> unwrapDeserialiser + (posixSecondsToUTCTime <$> deserialiser) + (schema (Proxy :: Proxy Double)) + s -> unexpectedSchema "Serialise UTCTime" s + +instance Serialise NominalDiffTime where + schemaVia _ = schemaVia (Proxy :: Proxy Double) + toEncoding = toEncoding . (realToFrac :: NominalDiffTime -> Double) + deserialiser = (realToFrac :: Double -> NominalDiffTime) <$> deserialiser instance Serialise a => Serialise [a] where schemaVia _ ts = case constantSize (Proxy :: Proxy a) of diff --git a/src/Data/Winery/Internal/Builder.hs b/src/Data/Winery/Internal/Builder.hs --- a/src/Data/Winery/Internal/Builder.hs +++ b/src/Data/Winery/Internal/Builder.hs @@ -12,6 +12,7 @@ , word64 , bytes , varInt + , unsignedVarInt ) where import Data.Bits @@ -115,6 +116,12 @@ bytes :: B.ByteString -> Encoding bytes bs = Encoding (B.length bs) $ LBytes bs {-# INLINE bytes #-} + +unsignedVarInt :: (Bits a, Integral a) => a -> Encoding +unsignedVarInt n + | n < 0x80 = word8 (fromIntegral n) + | otherwise = uvarInt 1 (LWord8 (fromIntegral n `setBit` 7)) (unsafeShiftR n 7) +{-# SPECIALISE unsignedVarInt :: Int -> Encoding #-} varInt :: (Bits a, Integral a) => a -> Encoding varInt n diff --git a/src/Data/Winery/Term.hs b/src/Data/Winery/Term.hs --- a/src/Data/Winery/Term.hs +++ b/src/Data/Winery/Term.hs @@ -14,6 +14,7 @@ import Data.Word import qualified Data.Vector.Unboxed as V import qualified Data.HashMap.Strict as HM +import Data.Time.Clock -- | Common representation for any winery data. -- Handy for prettyprinting winery-serialised data. @@ -33,6 +34,7 @@ | TDouble !Double | TBytes !B.ByteString | TText !T.Text + | TUTCTime !UTCTime | TList [Term] | TProduct [Term] | TRecord [(T.Text, Term)] @@ -56,6 +58,7 @@ toJSON (TDouble x) = toJSON x toJSON (TBytes bs) = toJSON (B.unpack bs) toJSON (TText t) = toJSON t + toJSON (TUTCTime t) = toJSON t toJSON (TList xs) = toJSON xs toJSON (TProduct xs) = toJSON xs toJSON (TRecord xs) = toJSON $ HM.fromList xs @@ -87,6 +90,7 @@ SDouble -> p s TDouble SBytes -> p s TBytes Data.Winery.SText -> p s TText + SUTCTime -> p s TUTCTime SArray siz sch -> fmap TList <$> extractListBy (go points) `unwrapDeserialiser` SArray siz sch SList sch -> fmap TList <$> extractListBy (go points) `unwrapDeserialiser` SList sch SProduct schs -> do @@ -145,3 +149,4 @@ pretty (TRecord xs) = align $ encloseSep "{ " " }" ", " [group $ nest 2 $ vsep [pretty k <+> "=", pretty v] | (k, v) <- xs] pretty (TVariant tag []) = pretty tag pretty (TVariant tag xs) = group $ nest 2 $ vsep $ pretty tag : map pretty xs + pretty (TUTCTime t) = pretty (show t) diff --git a/winery.cabal b/winery.cabal --- a/winery.cabal +++ b/winery.cabal @@ -1,11 +1,11 @@ --- This file has been generated from package.yaml by hpack version 0.20.0. +-- This file has been generated from package.yaml by hpack version 0.28.2. -- -- see: https://github.com/sol/hpack -- --- hash: 93787e5525d90ec1aeb81d521ead44d1b77000046d92228940a76c519e23d0ca +-- hash: 4ead2da6a0b01af505f6701a2dc47a578d28bf11bc94f86dd7d2a8a9965f23e2 name: winery -version: 0.2.1 +version: 0.3 synopsis: Sustainable serialisation library description: Please see the README on Github at category: Data, Codec, Parsing, Serialization @@ -18,7 +18,6 @@ license-file: LICENSE build-type: Simple cabal-version: >= 1.10 - extra-source-files: ChangeLog.md README.md @@ -28,6 +27,15 @@ location: https://github.com/fumieval/winery library + exposed-modules: + Data.Winery + Data.Winery.Term + Data.Winery.Internal + Data.Winery.Internal.Builder + Data.Winery.Query + Data.Winery.Query.Parser + other-modules: + Paths_winery hs-source-dirs: src ghc-options: -Wall -O2 @@ -38,28 +46,23 @@ , containers , cpu , hashable - , megaparsec + , megaparsec >=6.0.0 , mtl , prettyprinter , prettyprinter-ansi-terminal , scientific + , semigroups , text + , time , transformers , unordered-containers , vector - exposed-modules: - Data.Winery - Data.Winery.Term - Data.Winery.Internal - Data.Winery.Internal.Builder - Data.Winery.Query - Data.Winery.Query.Parser - other-modules: - Paths_winery default-language: Haskell2010 executable winery main-is: Main.hs + other-modules: + Paths_winery hs-source-dirs: app build-depends: @@ -69,23 +72,25 @@ , containers , cpu , hashable - , megaparsec + , megaparsec >=6.0.0 , mtl , prettyprinter , prettyprinter-ansi-terminal , scientific + , semigroups , text + , time , transformers , unordered-containers , vector , winery - other-modules: - Paths_winery default-language: Haskell2010 test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs + other-modules: + Paths_winery hs-source-dirs: test build-depends: @@ -96,23 +101,25 @@ , containers , cpu , hashable - , megaparsec + , megaparsec >=6.0.0 , mtl , prettyprinter , prettyprinter-ansi-terminal , scientific + , semigroups , text + , time , transformers , unordered-containers , vector , winery - other-modules: - Paths_winery default-language: Haskell2010 benchmark bench-winery type: exitcode-stdio-1.0 main-is: bench.hs + other-modules: + Paths_winery hs-source-dirs: benchmarks ghc-options: -O2 @@ -128,17 +135,17 @@ , directory , gauge , hashable - , megaparsec + , megaparsec >=6.0.0 , mtl , prettyprinter , prettyprinter-ansi-terminal , scientific + , semigroups , serialise , text + , time , transformers , unordered-containers , vector , winery - other-modules: - Paths_winery default-language: Haskell2010