winery 0.2.1 → 0.3
raw patch · 5 files changed
+106/−37 lines, 5 filesdep +semigroupsdep +timedep ~megaparsec
Dependencies added: semigroups, time
Dependency ranges changed: megaparsec
Files
- ChangeLog.md +6/−0
- src/Data/Winery.hs +58/−14
- src/Data/Winery/Internal/Builder.hs +7/−0
- src/Data/Winery/Term.hs +5/−0
- winery.cabal +30/−23
ChangeLog.md view
@@ -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
src/Data/Winery.hs view
@@ -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
src/Data/Winery/Internal/Builder.hs view
@@ -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
src/Data/Winery/Term.hs view
@@ -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)
winery.cabal view
@@ -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 <https://github.com/fumieval/winery#readme> 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