winery 1.1 → 1.1.1
raw patch · 5 files changed
+123/−56 lines, 5 files
Files
- ChangeLog.md +4/−0
- README.md +4/−0
- src/Codec/Winery.hs +70/−40
- src/Codec/Winery/Internal.hs +44/−15
- winery.cabal +1/−1
ChangeLog.md view
@@ -1,3 +1,7 @@+## 1.1.1++* Changed the internal representation of `Decoder`+ ## 1.1 * Renamed `Data.Winery` to `Codec.Winery`
README.md view
@@ -1,5 +1,9 @@ # winery ++[](https://travis-ci.org/fumieval/winery)+[](https://hackage.haskell.org/package/winery)+ winery is a serialisation library focusing on __performance__, __compactness__ and __compatibility__. The primary feature is that metadata (types, field names, etc) are packed into one schema.
src/Codec/Winery.hs view
@@ -83,17 +83,21 @@ -- * Generic implementations (for old GHC / custom instances) , GSerialiseRecord , gschemaGenRecord- , GEncodeProduct , gtoBuilderRecord , gextractorRecord , gdecodeCurrentRecord , GSerialiseVariant+ , GConstructorCount+ , GEncodeVariant+ , GDecodeVariant , gschemaGenVariant , gtoBuilderVariant , gextractorVariant+ , gdecodeCurrentVariant+ , GEncodeProduct+ , GDecodeProduct , gschemaGenProduct , gtoBuilderProduct- , gdecodeCurrentVariant , gextractorProduct , gdecodeCurrentProduct , decodeCurrentDefault@@ -284,7 +288,7 @@ {-# INLINE bundleRecordDefault #-} -- | A bundle of generic implementations for variants-bundleVariant :: (GSerialiseVariant (Rep a), Generic a, Typeable a)+bundleVariant :: (GSerialiseVariant (Rep a), GConstructorCount (Rep a), GEncodeVariant (Rep a), GDecodeVariant (Rep a), Generic a, Typeable a) => (Extractor a -> Extractor a) -- extractor modifier -> BundleSerialise a bundleVariant f = BundleSerialise@@ -394,7 +398,7 @@ m <- bootstrapSchema ver >>= getDecoder return $ flip evalDecoder bs $ do sch <- m- State $ \bs' -> ((sch, bs'), mempty)+ Decoder $ \bs' i -> DecoderResult (B.length bs') (sch, B.drop i bs') Nothing -> Left EmptyInput -- | Serialise a schema.@@ -612,7 +616,7 @@ s -> unexpectedSchema "Serialise Text" s decodeCurrent = do len <- decodeVarInt- T.decodeUtf8With T.lenientDecode <$> State (B.splitAt len)+ T.decodeUtf8With T.lenientDecode <$> getBytes len -- | Encoded in variable-length quantity. newtype VarInt a = VarInt { getVarInt :: a } deriving (Show, Read, Eq, Ord, Enum@@ -668,9 +672,7 @@ TBytes bs -> bs t -> throw $ InvalidTerm t s -> unexpectedSchema "Serialise ByteString" s- decodeCurrent = do- len <- decodeVarInt- State (B.splitAt len)+ decodeCurrent = decodeVarInt >>= getBytes instance Serialise BL.ByteString where schemaGen _ = pure SBytes@@ -1153,7 +1155,7 @@ -- /"The one so like the other as could not be distinguish'd but by names."/ newtype WineryVariant a = WineryVariant { unWineryVariant :: a } -instance (GSerialiseVariant (Rep a), Generic a, Typeable a) => Serialise (WineryVariant a) where+instance (GConstructorCount (Rep a), GSerialiseVariant (Rep a), GEncodeVariant (Rep a), GDecodeVariant (Rep a), Generic a, Typeable a) => Serialise (WineryVariant a) where schemaGen _ = gschemaGenVariant (Proxy @ a) toBuilder = gtoBuilderVariant . unWineryVariant extractor = WineryVariant <$> gextractorVariant@@ -1164,8 +1166,8 @@ gschemaGenVariant _ = SVariant . V.fromList <$> variantSchema (Proxy @ (Rep a)) -- | Generic implementation of 'toBuilder' for an ADT.-gtoBuilderVariant :: (GSerialiseVariant (Rep a), Generic a) => a -> BB.Builder-gtoBuilderVariant = variantEncoder 0 . from+gtoBuilderVariant :: forall a. (GConstructorCount (Rep a), GEncodeVariant (Rep a), Generic a) => a -> BB.Builder+gtoBuilderVariant = variantEncoder (variantCount (Proxy :: Proxy (Rep a))) 0 . from {-# INLINE gtoBuilderVariant #-} -- | Generic implementation of 'extractor' for an ADT.@@ -1184,58 +1186,86 @@ rep = "gextractorVariant :: Extractor " <> viaShow (typeRep (Proxy @ a)) -gdecodeCurrentVariant :: (GSerialiseVariant (Rep a), Generic a) => Decoder a-gdecodeCurrentVariant = decodeVarInt >>= maybe (throw InvalidTag) (fmap to) . (decs V.!?)- where- decs = V.fromList variantDecoder+gdecodeCurrentVariant :: forall a. (GConstructorCount (Rep a), GEncodeVariant (Rep a), GDecodeVariant (Rep a), Generic a) => Decoder a+gdecodeCurrentVariant = decodeVarInt >>= fmap to . variantDecoder (variantCount (Proxy :: Proxy (Rep a)))+{-# INLINE gdecodeCurrentVariant #-} -class GSerialiseVariant f where+class GConstructorCount f where variantCount :: proxy f -> Int++instance (GConstructorCount f, GConstructorCount g) => GConstructorCount (f :+: g) where+ variantCount _ = variantCount (Proxy @ f) + variantCount (Proxy @ g)+ {-# INLINE variantCount #-}++instance GConstructorCount (C1 i f) where+ variantCount _ = 1+ {-# INLINE variantCount #-}++instance GConstructorCount f => GConstructorCount (D1 i f) where+ variantCount _ = variantCount (Proxy @ f)+ {-# INLINE variantCount #-}++class GDecodeVariant f where+ variantDecoder :: Int -> Int -> Decoder (f x)++instance (GDecodeVariant f, GDecodeVariant g) => GDecodeVariant (f :+: g) where+ variantDecoder len i+ | i < len' = L1 <$> variantDecoder len' i+ | otherwise = R1 <$> variantDecoder (len - len') (i - len')+ where+ len' = unsafeShiftR len 1+ {-# INLINE variantDecoder #-}++instance GDecodeProduct f => GDecodeVariant (C1 i f) where+ variantDecoder _ _ = M1 <$> productDecoder+ {-# INLINE variantDecoder #-}++instance GDecodeVariant f => GDecodeVariant (D1 i f) where+ variantDecoder len i = M1 <$> variantDecoder len i+ {-# INLINE variantDecoder #-}++class GEncodeVariant f where+ variantEncoder :: Int -> Int -> f x -> BB.Builder++instance (GEncodeVariant f, GEncodeVariant g) => GEncodeVariant (f :+: g) where+ variantEncoder len i (L1 f) = variantEncoder (unsafeShiftR len 1) i f+ variantEncoder len i (R1 g) = variantEncoder (len - len') (i + len') g+ where+ len' = unsafeShiftR len 1+ {-# INLINE variantEncoder #-}++instance (GEncodeProduct f) => GEncodeVariant (C1 i f) where+ variantEncoder _ !i (M1 a) = varInt i <> productEncoder a+ {-# INLINE variantEncoder #-}++instance GEncodeVariant f => GEncodeVariant (D1 i f) where+ variantEncoder len i (M1 a) = variantEncoder len i a+ {-# INLINE variantEncoder #-}++class GSerialiseVariant f where variantSchema :: proxy f -> SchemaGen [(T.Text, Schema)]- variantEncoder :: Int -> f x -> BB.Builder variantExtractor :: [(T.Text, Schema -> Strategy' (Term -> f x))]- variantDecoder :: [Decoder (f x)] instance (GSerialiseVariant f, GSerialiseVariant g) => GSerialiseVariant (f :+: g) where- variantCount _ = variantCount (Proxy @ f) + variantCount (Proxy @ g) variantSchema _ = (++) <$> variantSchema (Proxy @ f) <*> variantSchema (Proxy @ g)- variantEncoder i (L1 f) = variantEncoder i f- variantEncoder i (R1 g) = variantEncoder (i + variantCount (Proxy @ f)) g variantExtractor = fmap (fmap (fmap (fmap (fmap L1)))) variantExtractor ++ fmap (fmap (fmap (fmap (fmap R1)))) variantExtractor- variantDecoder = fmap (fmap L1) variantDecoder ++ fmap (fmap R1) variantDecoder -instance (GSerialiseProduct f, GEncodeProduct f, GDecodeProduct f, KnownSymbol name) => GSerialiseVariant (C1 ('MetaCons name fixity 'False) f) where- variantCount _ = 1+instance (GSerialiseProduct f, KnownSymbol name) => GSerialiseVariant (C1 ('MetaCons name fixity 'False) f) where variantSchema _ = do s <- productSchema (Proxy @ f) return [(T.pack $ symbolVal (Proxy @ name), SProduct $ V.fromList s)]- variantEncoder i (M1 a) = varInt i <> productEncoder a variantExtractor = [(T.pack $ symbolVal (Proxy @ name), fmap (fmap M1) . extractorProduct') ]- variantDecoder = [M1 <$> productDecoder] -instance (GSerialiseRecord f, GEncodeProduct f, GDecodeProduct f, KnownSymbol name) => GSerialiseVariant (C1 ('MetaCons name fixity 'True) f) where- variantCount _ = 1+instance (GSerialiseRecord f, KnownSymbol name) => GSerialiseVariant (C1 ('MetaCons name fixity 'True) f) where variantSchema _ = do s <- recordSchema (Proxy @ f) return [(T.pack $ symbolVal (Proxy @ name), SRecord $ V.fromList s)]- variantEncoder i (M1 a) = varInt i <> productEncoder a variantExtractor = [(T.pack $ symbolVal (Proxy @ name), fmap (fmap M1) . extractorRecord' "" Nothing) ]- variantDecoder = [M1 <$> productDecoder] -instance (GSerialiseVariant f) => GSerialiseVariant (S1 c f) where- variantCount _ = variantCount (Proxy @ f)- variantSchema _ = variantSchema (Proxy @ f)- variantEncoder i (M1 a) = variantEncoder i a- variantExtractor = fmap (fmap (fmap (fmap M1))) <$> variantExtractor- variantDecoder = fmap M1 <$> variantDecoder- instance (GSerialiseVariant f) => GSerialiseVariant (D1 c f) where- variantCount _ = variantCount (Proxy @ f) variantSchema _ = variantSchema (Proxy @ f)- variantEncoder i (M1 a) = variantEncoder i a variantExtractor = fmap (fmap (fmap (fmap M1))) <$> variantExtractor- variantDecoder = fmap M1 <$> variantDecoder instance Serialise Ordering where schemaGen = gschemaGenVariant
src/Codec/Winery/Internal.hs view
@@ -22,7 +22,8 @@ module Codec.Winery.Internal ( unsignedVarInt , varInt- , Decoder+ , Decoder(..)+ , DecoderResult(..) , evalDecoder , State(..) , evalState@@ -32,6 +33,7 @@ , getWord16 , getWord32 , getWord64+ , getBytes , DecodeException(..) , indexDefault , unsafeIndexV@@ -135,18 +137,34 @@ instance MonadFix (State s) where mfix f = State $ \s -> fix $ \ ~(a, _) -> runState (f a) s +data DecoderResult a = DecoderResult {-# UNPACK #-} !Int a deriving Functor+ -- | The Decoder monad-type Decoder = State B.ByteString+newtype Decoder a = Decoder { unDecoder :: B.ByteString -> Int -> DecoderResult a }+ deriving Functor +instance Applicative Decoder where+ pure a = Decoder $ \_ i -> DecoderResult i a+ {-# INLINE pure #-}+ Decoder m <*> Decoder n = Decoder $ \bs i -> case m bs i of+ DecoderResult j f -> f <$> n bs j+ {-# INLINE (<*>) #-}+instance Monad Decoder where+ Decoder m >>= k = Decoder $ \bs i -> case m bs i of+ DecoderResult j a -> unDecoder (k a) bs j+ {-# INLINE (>>=) #-}+ -- | Run a 'Decoder' evalDecoder :: Decoder a -> B.ByteString -> a-evalDecoder = evalState+evalDecoder m bs = case unDecoder m bs 0 of+ DecoderResult _ a -> a {-# INLINE evalDecoder #-} getWord8 :: Decoder Word8-getWord8 = State $ \bs -> case B.uncons bs of- Nothing -> throw InsufficientInput- Just (x, bs') -> (x, bs')+getWord8 = Decoder $ \(B.PS fp ofs len) i -> if i >= len+ then throw InsufficientInput+ else DecoderResult (i + 1)+ $! B.accursedUnutterablePerformIO $ withForeignPtr fp $ \p -> peekByteOff p (ofs + i) {-# INLINE getWord8 #-} -- | Exceptions thrown by a 'Decoder'@@ -189,22 +207,33 @@ {-# SPECIALISE decodeVarIntFinite :: Decoder Int #-} getWord16 :: Decoder Word16-getWord16 = State $ \(B.PS fp ofs len) -> if len >= 2- then (B.accursedUnutterablePerformIO $ withForeignPtr fp- $ \ptr -> fromLE16 <$> peekByteOff ptr ofs, B.PS fp (ofs + 2) (len - 2))+getWord16 = Decoder $ \(B.PS fp ofs len) i -> if i + 2 <= len+ then DecoderResult (i + 2)+ $ B.accursedUnutterablePerformIO $ withForeignPtr fp+ $ \ptr -> fromLE16 <$> peekByteOff ptr (ofs + i) else throw InsufficientInput+{-# INLINE getWord16 #-} getWord32 :: Decoder Word32-getWord32 = State $ \(B.PS fp ofs len) -> if len >= 4- then (B.accursedUnutterablePerformIO $ withForeignPtr fp- $ \ptr -> fromLE32 <$> peekByteOff ptr ofs, B.PS fp (ofs + 4) (len - 4))+getWord32 = Decoder $ \(B.PS fp ofs len) i -> if i + 4 <= len+ then DecoderResult (i + 4)+ $ B.accursedUnutterablePerformIO $ withForeignPtr fp+ $ \ptr -> fromLE32 <$> peekByteOff ptr (ofs + i) else throw InsufficientInput+{-# INLINE getWord32 #-} getWord64 :: Decoder Word64-getWord64 = State $ \(B.PS fp ofs len) -> if len >= 8- then (B.accursedUnutterablePerformIO $ withForeignPtr fp- $ \ptr -> fromLE64 <$> peekByteOff ptr ofs, B.PS fp (ofs + 8) (len - 8))+getWord64 = Decoder $ \(B.PS fp ofs len) i -> if i + 8 <= len+ then DecoderResult (i + 8)+ $ B.accursedUnutterablePerformIO $ withForeignPtr fp+ $ \ptr -> fromLE64 <$> peekByteOff ptr (ofs + i) else throw InsufficientInput+{-# INLINE getWord64 #-}++getBytes :: Int -> Decoder B.ByteString+getBytes len = Decoder $ \bs i -> DecoderResult (i + len)+ $ B.take len $ B.drop i bs+{-# INLINE getBytes #-} unsafeIndexV :: U.Unbox a => String -> U.Vector a -> Int -> a unsafeIndexV err xs i
winery.cabal view
@@ -1,7 +1,7 @@ cabal-version: 1.12 name: winery-version: 1.1+version: 1.1.1 synopsis: A compact, well-typed seralisation format for Haskell values description: <<https://i.imgur.com/lTosHnE.png>>