winery 1.1.3 → 1.2
raw patch · 13 files changed
+145/−209 lines, 13 files
Files
- .travis.yml +0/−115
- ChangeLog.md +17/−0
- README.md +3/−1
- app/Main.hs +2/−2
- benchmarks/bench.hs +40/−0
- src/Codec/Winery.hs +23/−9
- src/Codec/Winery/Base.hs +7/−26
- src/Codec/Winery/Class.hs +42/−38
- src/Codec/Winery/Query.hs +8/−4
- src/Codec/Winery/Query/Parser.hs +1/−0
- src/Data/Winery.hs +0/−5
- src/Data/Winery/Test.hs +0/−5
- winery.cabal +2/−4
− .travis.yml
@@ -1,115 +0,0 @@-# This Travis job script has been generated by a script via-#-# haskell-ci 'winery.cabal' '--output' '.travis.yml'-#-# For more information, see https://github.com/haskell-CI/haskell-ci-#-# version: 0.2.1-#-language: c-dist: xenial--git:- submodules: false # whether to recursively clone submodules--cache:- directories:- - $HOME/.cabal/packages- - $HOME/.cabal/store--before_cache:- - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log- # remove files that are regenerated by 'cabal update'- - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.*- - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json- - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache- - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar- - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx-- - rm -rfv $CABALHOME/packages/head.hackage--matrix:- include:- - compiler: ghc-head- addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-head","cabal-install-head"]}}- env: GHCHEAD=true- - compiler: "ghc-8.6.3"- addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.6.3], sources: [hvr-ghc]}}- - compiler: "ghc-8.4.4"- addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.4.4], sources: [hvr-ghc]}}- allow_failures:- - compiler: ghc-head--before_install:- - HC=/opt/ghc/bin/${CC}- - HCPKG=${HC/ghc/ghc-pkg}- - unset CC- - CABAL=/opt/ghc/bin/cabal- - CABALHOME=$HOME/.cabal- - export PATH="$CABALHOME/bin:$PATH"- - ROOTDIR=$(pwd)- - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') ))- - echo $HCNUMVER--install:- - ${CABAL} --version- - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"- - TEST=--enable-tests- - BENCH=--enable-benchmarks- - GHCHEAD=${GHCHEAD-false}- - travis_retry ${CABAL} update -v- - sed -i.bak 's/^jobs:/-- jobs:/' $CABALHOME/config- - rm -fv cabal.project cabal.project.local- - grep -Ev -- '^\s*--' $CABALHOME/config | grep -Ev '^\s*$'- - rm -f cabal.project- - touch cabal.project- - "printf 'packages: \".\"\\n' >> cabal.project"- - "printf 'write-ghc-environment-files: always\\n' >> cabal.project"- - touch cabal.project.local- - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(winery)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"- - cat cabal.project || true- - cat cabal.project.local || true- - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi- - rm -f cabal.project.freeze- - ${CABAL} new-freeze -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dry- - "cat \"cabal.project.freeze\" | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"- - rm "cabal.project.freeze"- - ${CABAL} new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all- - ${CABAL} new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all- - rm -rf .ghc.environment.* "."/dist- - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)--# Here starts the actual work to be performed for the package under test;-# any command which exits with a non-zero exit code causes the build to fail.-script:- # test that source-distributions can be generated- - ${CABAL} new-sdist all- - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/- - cd ${DISTDIR} || false- - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;- - rm -f cabal.project- - touch cabal.project- - "printf 'packages: \"winery-*/*.cabal\"\\n' >> cabal.project"- - "printf 'write-ghc-environment-files: always\\n' >> cabal.project"- - touch cabal.project.local- - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(winery)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"- - cat cabal.project || true- - cat cabal.project.local || true- # this builds all libraries and executables (without tests/benchmarks)- - ${CABAL} new-build -w ${HC} --disable-tests --disable-benchmarks all-- # build & run tests, build benchmarks- - ${CABAL} new-build -w ${HC} ${TEST} ${BENCH} all- - if [ "x$TEST" = "x--enable-tests" ]; then ${CABAL} new-test -w ${HC} ${TEST} ${BENCH} all; fi-- # cabal check- - (cd winery-* && ${CABAL} check)-- # haddock- - ${CABAL} new-haddock -w ${HC} ${TEST} ${BENCH} all-- # Build without installed constraints for packages in global-db- - rm -f cabal.project.local; ${CABAL} new-build -w ${HC} --disable-tests --disable-benchmarks all;--# REGENDATA ["winery.cabal","--output",".travis.yml"]-# EOF
ChangeLog.md view
@@ -1,3 +1,20 @@+## 1.2++* Removed `Plan` and `mkPlan`+* Added `mkExtractor`+* `unwrapExtractor` is deprecated+* Removed `Data.Winery`++## 1.1.3++* Added `schemaToBuilder`+* Added `TestGen` and `Tested` instances for `Maybe a`++## 1.1.2++* Added `encodeTerm`+* Split the `Codec.Winery` module+ ## 1.1.1 * Changed the internal representation of `Decoder`
README.md view
@@ -1,8 +1,9 @@ # winery -[](https://travis-ci.org/fumieval/winery)+ [](https://hackage.haskell.org/package/winery)+[](https://discord.gg/DG93Tgs) winery is a serialisation library focusing on __performance__, __compactness__ and __compatibility__. The primary feature is that metadata (types, field names,@@ -136,6 +137,7 @@ * `.[]` enumerate all the elements in a list * `.[i]` get the i-th element * `.[i:j]` enumerate i-th to j-th items+* `.N` n-th element of a product * `.foo` Get a field named `foo` * `F | G` compose queries (left to right)
app/Main.hs view
@@ -61,12 +61,12 @@ let p | outputJSON o = pretty . T.decodeUtf8 . BL.toStrict . JSON.encode | otherwise = pretty- let getDec = getRight . getDecoderBy (Q.runQuery q (Extractor (pure (pure . p))))+ let getDec = getRight . getDecoderBy (Q.runQuery q $ Extractor $ const $ pure (pure . p)) printer <- case separateSchema o of Just mpath -> do bs <- maybe (getLengthPrefixed h) B.readFile mpath- sch <- getRight $ deserialise bs+ sch <- getRight $ deserialiseSchema bs when (printSchema o) $ putDoc $ pretty sch <> hardline dec <- getDec sch return $ mapM_ putTerm . evalDecoder dec
benchmarks/bench.hs view
@@ -1,5 +1,10 @@ {-# LANGUAGE DeriveGeneric, OverloadedStrings, ScopedTypeVariables #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeApplications #-} {-# OPTIONS -Wno-orphans #-}+module Main (main) where+ import Control.DeepSeq import qualified Data.Aeson as J import qualified Data.ByteString.Lazy as BL@@ -11,6 +16,10 @@ import Data.Text (Text) import qualified Data.Text.Encoding as TE import qualified Data.Serialize as C+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as VU+import qualified Data.Vector.Storable as VS+import qualified Data.Vector.Generic as VG import GHC.Generics (Generic) import Gauge.Main import qualified Codec.Serialise as CBOR@@ -68,6 +77,13 @@ store <- B.readFile "benchmarks/data.store" let serialisedInts = serialiseOnly [floor (2**x) :: Int | x <- [0 :: Double, 0.5..62]]++ intVec :: VG.Vector v Int => Int -> v Int+ intVec n = VG.replicate n 7++ vecSizes :: [Int]+ vecSizes = [5, 50, 500, 5000]+ deepseq values $ defaultMain [ bgroup "serialise/list" [ bench "winery" $ nf serialise values@@ -85,6 +101,17 @@ , bench "store" $ nf S.encode aValue , bench "aeson" $ nf (BL.toStrict . J.encode) aValue ]+ , bgroup "serialise/Vector" $+ let vecGroup+ :: forall v. (VG.Vector v Int, NFData (v Int), Serialise (v Int))+ => String -> Benchmark+ vecGroup lbl = bgroup lbl $ flip fmap vecSizes $ \n ->+ bench (show n) $ nf serialiseOnly (intVec @v n)+ in [ vecGroup @V.Vector "boxed"+ , vecGroup @VS.Vector "storable"+ , vecGroup @VU.Vector "unboxed"+ ]+ , bgroup "deserialise" [ bench "winery" $ nf (fromRight undefined . deserialise :: B.ByteString -> [TestRec]) winery , bench "binary" $ nf (B.decode . BL.fromStrict :: B.ByteString -> [TestRec]) binary@@ -96,4 +123,17 @@ , bgroup "deserialise/Int" [ bench "winery" $ nf (evalDecoder decodeCurrent :: B.ByteString -> [Int]) serialisedInts ]++ , bgroup "deserialise/Vector" $+ let vecGroup+ :: forall v. (VG.Vector v Int, NFData (v Int), Serialise (v Int))+ => String -> Benchmark+ vecGroup lbl = bgroup lbl $ flip fmap vecSizes $ \n ->+ bench (show n) $ nf+ (evalDecoder decodeCurrent :: B.ByteString -> v Int)+ (serialiseOnly $ intVec @v n)+ in [ vecGroup @V.Vector "boxed"+ , vecGroup @VS.Vector "storable"+ , vecGroup @VU.Vector "unboxed"+ ] ]
src/Codec/Winery.hs view
@@ -56,6 +56,7 @@ , extractFieldBy , extractConstructor , extractConstructorBy+ , extractProductItemBy , extractVoid , ExtractException(..) -- * Variable-length quantity@@ -66,8 +67,6 @@ , unexpectedSchema , SchemaGen , getSchema- , Plan(..)- , mkPlan -- * DerivingVia , WineryRecord(..) , WineryVariant(..)@@ -214,7 +213,7 @@ -- | Get a decoder from a `Extractor` and a schema. getDecoderBy :: Extractor a -> Schema -> Either WineryException (Decoder a) getDecoderBy (Extractor plan) sch = (\f -> f <$> decodeTerm sch)- <$> unPlan plan sch `unStrategy` StrategyEnv 0 []+ <$> plan sch `unStrategy` StrategyEnv 0 [] {-# INLINE getDecoderBy #-} -- | Serialise a value along with its schema.@@ -291,7 +290,7 @@ -- | Build an extractor from a 'Subextractor'. buildExtractor :: Typeable a => Subextractor a -> Extractor a-buildExtractor (Subextractor e) = Extractor $ mkPlan $ unwrapExtractor e+buildExtractor (Subextractor e) = mkExtractor $ runExtractor e {-# INLINE buildExtractor #-} -- | An extractor for individual fields. This distinction is required for@@ -308,10 +307,10 @@ -- | Extract a field using the supplied 'Extractor'. extractFieldBy :: Extractor a -> T.Text -> Subextractor a-extractFieldBy (Extractor g) name = Subextractor $ Extractor $ Plan $ \case+extractFieldBy (Extractor g) name = Subextractor $ Extractor $ \case SRecord schs -> case lookupWithIndexV name schs of Just (i, sch) -> do- m <- unPlan g sch+ m <- g sch return $ \case TRecord xs -> maybe (error msg) (m . snd) $ xs V.!? i t -> throw $ InvalidTerm t@@ -321,13 +320,28 @@ rep = "extractFieldBy ... " <> dquotes (pretty name) msg = "Codec.Winery.extractFieldBy ... " <> show name <> ": impossible" +-- | Extract a field using the supplied 'Extractor'.+extractProductItemBy :: Extractor a -> Int -> Subextractor a+extractProductItemBy (Extractor g) i = Subextractor $ Extractor $ \case+ SProduct schs -> case schs V.!? i of+ Just sch -> do+ m <- g sch+ return $ \case+ TProduct xs -> maybe (error msg) m $ xs V.!? i+ t -> throw $ InvalidTerm t+ _ -> throwStrategy $ ProductTooSmall i+ s -> throwStrategy $ UnexpectedSchema rep "a record" s+ where+ rep = "extractProductItemBy ... " <> dquotes (pretty i)+ msg = "Codec.Winery.extractProductItemBy ... " <> show i <> ": impossible"+ -- | Tries to extract a specific constructor of a variant. Useful for -- implementing backward-compatible extractors. extractConstructorBy :: Typeable a => (Extractor a, T.Text, a -> r) -> Subextractor r -> Subextractor r-extractConstructorBy (d, name, f) cont = Subextractor $ Extractor $ Plan $ \case+extractConstructorBy (d, name, f) cont = Subextractor $ Extractor $ \case SVariant schs0 -> Strategy $ \decs -> do let run :: Extractor x -> Schema -> Either WineryException (Term -> x)- run e s = unwrapExtractor e s `unStrategy` decs+ run e s = runExtractor e s `unStrategy` decs case lookupWithIndexV name schs0 of Just (i, s) -> do (j, dec) <- fmap ((,) i) $ run d $ case s of@@ -354,7 +368,7 @@ -- | No constructors remaining. extractVoid :: Typeable r => Subextractor r-extractVoid = Subextractor $ Extractor $ mkPlan $ \case+extractVoid = Subextractor $ mkExtractor $ \case SVariant schs0 | V.null schs0 -> return $ throw . InvalidTerm s -> throwStrategy $ UnexpectedSchema "extractVoid" "no constructors" s
src/Codec/Winery/Base.hs view
@@ -30,7 +30,6 @@ , Strategy' , StrategyBind(..) , StrategyEnv(..)- , Plan(..) , unwrapExtractor , WineryException(..) , prettyWineryException@@ -246,16 +245,16 @@ -- This is also 'Alternative', meaning that fallback plans may be added. -- -- /"Don't get set into one form, adapt it and build your own, and let it grow, be like water."/-newtype Extractor a = Extractor { getExtractor :: Plan (Term -> a) }+newtype Extractor a = Extractor { runExtractor :: Schema -> Strategy' (Term -> a) } deriving Functor instance Applicative Extractor where- pure = Extractor . pure . pure- Extractor f <*> Extractor x = Extractor $ (<*>) <$> f <*> x+ pure = Extractor . pure . pure . pure+ Extractor f <*> Extractor x = Extractor $ \s -> (<*>) <$> f s <*> x s instance Alternative Extractor where- empty = Extractor empty- Extractor f <|> Extractor g = Extractor $ f <|> g+ empty = Extractor $ const empty+ Extractor f <|> Extractor g = Extractor $ liftA2 (<|>) f g data StrategyBind = DynDecoder !Dynamic -- ^ A fixpoint of a decoder | BoundSchema !Int !Schema@@ -265,29 +264,11 @@ type Strategy' = Strategy WineryException StrategyEnv --- | Plan is a monad for computations which interpret 'Schema'.-newtype Plan a = Plan { unPlan :: Schema -> Strategy' a }- deriving Functor--instance Applicative Plan where- pure = Plan . const . pure- m <*> k = Plan $ \sch -> Strategy $ \decs -> case unStrategy (unPlan m sch) decs of- Right f -> f <$> unStrategy (unPlan k sch) decs- Left e -> Left e--instance Monad Plan where- m >>= k = Plan $ \sch -> Strategy $ \decs -> case unStrategy (unPlan m sch) decs of- Right a -> unStrategy (unPlan (k a) sch) decs- Left e -> Left e--instance Alternative Plan where- empty = Plan $ const empty- Plan a <|> Plan b = Plan $ \s -> a s <|> b s- -- | Run an 'Extractor'. unwrapExtractor :: Extractor a -> Schema -> Strategy' (Term -> a)-unwrapExtractor (Extractor m) = unPlan m+unwrapExtractor (Extractor m) = m {-# INLINE unwrapExtractor #-}+{-# DEPRECATED unwrapExtractor "Use runExtractor instead" #-} -- | Exceptions thrown when by an extractor data WineryException = UnexpectedSchema !(Doc AnsiStyle) !(Doc AnsiStyle) !Schema
src/Codec/Winery/Class.hs view
@@ -27,7 +27,7 @@ , getSchema , schema , unexpectedSchema- , mkPlan+ , mkExtractor , extractListBy , gschemaGenRecord , gtoBuilderRecord@@ -224,20 +224,24 @@ unexpectedSchema subject actual = throwStrategy $ UnexpectedSchema subject (pretty $ schema (Proxy @ a)) actual --- | Construct a plan, expanding fixpoints and let bindings.-mkPlan :: forall a. Typeable a => (Schema -> Strategy' (Term -> a)) -> Plan (Term -> a)-mkPlan k = Plan $ \sch -> Strategy $ \(StrategyEnv ofs decs) -> case sch of+mkExtractor :: Typeable a => (Schema -> Strategy' (Term -> a)) -> Extractor a+mkExtractor = Extractor . recursiveStrategy+{-# INLINE mkExtractor #-}++-- | Handle (recursive) schema bindings.+recursiveStrategy :: forall a. Typeable a => (Schema -> Strategy' (Term -> a)) -> Schema -> Strategy' (Term -> a)+recursiveStrategy k sch = Strategy $ \(StrategyEnv ofs decs) -> case sch of SVar i | point : _ <- drop i decs -> case point of- BoundSchema ofs' sch' -> unPlan (mkPlan k) sch' `unStrategy` StrategyEnv ofs' (drop (ofs - ofs') decs)+ BoundSchema ofs' sch' -> recursiveStrategy k sch' `unStrategy` StrategyEnv ofs' (drop (ofs - ofs') decs) DynDecoder dyn -> case fromDynamic dyn of Nothing -> Left $ TypeMismatch i (typeRep (Proxy @ (Term -> a))) (dynTypeRep dyn) Just a -> Right a | otherwise -> Left $ UnboundVariable i- SFix s -> mfix $ \a -> unPlan (mkPlan k) s `unStrategy` StrategyEnv (ofs + 1) (DynDecoder (toDyn a) : decs)- SLet s t -> unPlan (mkPlan k) t `unStrategy` StrategyEnv (ofs + 1) (BoundSchema ofs s : decs)+ SFix s -> mfix $ \a -> recursiveStrategy k s `unStrategy` StrategyEnv (ofs + 1) (DynDecoder (toDyn a) : decs)+ SLet s t -> recursiveStrategy k t `unStrategy` StrategyEnv (ofs + 1) (BoundSchema ofs s : decs) s -> k s `unStrategy` StrategyEnv ofs decs instance Serialise Tag where@@ -264,7 +268,7 @@ toBuilder False = BB.word8 0 toBuilder True = BB.word8 1 {-# INLINE toBuilder #-}- extractor = Extractor $ mkPlan $ \case+ extractor = mkExtractor $ \case SBool -> pure $ \case TBool b -> b t -> throw $ InvalidTerm t@@ -275,7 +279,7 @@ schemaGen _ = pure SWord8 toBuilder = BB.word8 {-# INLINE toBuilder #-}- extractor = Extractor $ mkPlan $ \case+ extractor = mkExtractor $ \case SWord8 -> pure $ \case TWord8 i -> i t -> throw $ InvalidTerm t@@ -286,7 +290,7 @@ schemaGen _ = pure SWord16 toBuilder = BB.word16LE {-# INLINE toBuilder #-}- extractor = Extractor $ mkPlan $ \case+ extractor = mkExtractor $ \case SWord16 -> pure $ \case TWord16 i -> i t -> throw $ InvalidTerm t@@ -297,7 +301,7 @@ schemaGen _ = pure SWord32 toBuilder = BB.word32LE {-# INLINE toBuilder #-}- extractor = Extractor $ mkPlan $ \case+ extractor = mkExtractor $ \case SWord32 -> pure $ \case TWord32 i -> i t -> throw $ InvalidTerm t@@ -308,7 +312,7 @@ schemaGen _ = pure SWord64 toBuilder = BB.word64LE {-# INLINE toBuilder #-}- extractor = Extractor $ mkPlan $ \case+ extractor = mkExtractor $ \case SWord64 -> pure $ \case TWord64 i -> i t -> throw $ InvalidTerm t@@ -319,7 +323,7 @@ schemaGen _ = pure SWord64 toBuilder = BB.word64LE . fromIntegral {-# INLINE toBuilder #-}- extractor = Extractor $ mkPlan $ \case+ extractor = mkExtractor $ \case SWord64 -> pure $ \case TWord64 i -> fromIntegral i t -> throw $ InvalidTerm t@@ -330,7 +334,7 @@ schemaGen _ = pure SInt8 toBuilder = BB.word8 . fromIntegral {-# INLINE toBuilder #-}- extractor = Extractor $ mkPlan $ \case+ extractor = mkExtractor $ \case SInt8 -> pure $ \case TInt8 i -> i t -> throw $ InvalidTerm t@@ -341,7 +345,7 @@ schemaGen _ = pure SInt16 toBuilder = BB.word16LE . fromIntegral {-# INLINE toBuilder #-}- extractor = Extractor $ mkPlan $ \case+ extractor = mkExtractor $ \case SInt16 -> pure $ \case TInt16 i -> i t -> throw $ InvalidTerm t@@ -352,7 +356,7 @@ schemaGen _ = pure SInt32 toBuilder = BB.word32LE . fromIntegral {-# INLINE toBuilder #-}- extractor = Extractor $ mkPlan $ \case+ extractor = mkExtractor $ \case SInt32 -> pure $ \case TInt32 i -> i t -> throw $ InvalidTerm t@@ -363,7 +367,7 @@ schemaGen _ = pure SInt64 toBuilder = BB.word64LE . fromIntegral {-# INLINE toBuilder #-}- extractor = Extractor $ mkPlan $ \case+ extractor = mkExtractor $ \case SInt64 -> pure $ \case TInt64 i -> i t -> throw $ InvalidTerm t@@ -374,7 +378,7 @@ schemaGen _ = pure SInteger toBuilder = toBuilder . VarInt {-# INLINE toBuilder #-}- extractor = Extractor $ mkPlan $ \case+ extractor = mkExtractor $ \case SInteger -> pure $ \case TInteger i -> fromIntegral i t -> throw $ InvalidTerm t@@ -385,7 +389,7 @@ schemaGen _ = pure SFloat toBuilder = BB.floatLE {-# INLINE toBuilder #-}- extractor = Extractor $ mkPlan $ \case+ extractor = mkExtractor $ \case SFloat -> pure $ \case TFloat x -> x t -> throw $ InvalidTerm t@@ -396,7 +400,7 @@ schemaGen _ = pure SDouble toBuilder = BB.doubleLE {-# INLINE toBuilder #-}- extractor = Extractor $ mkPlan $ \case+ extractor = mkExtractor $ \case SDouble -> pure $ \case TDouble x -> x t -> throw $ InvalidTerm t@@ -407,7 +411,7 @@ schemaGen _ = pure SText toBuilder = toBuilder . T.encodeUtf8 {-# INLINE toBuilder #-}- extractor = Extractor $ mkPlan $ \case+ extractor = mkExtractor $ \case SText -> pure $ \case TText t -> t t -> throw $ InvalidTerm t@@ -424,7 +428,7 @@ schemaGen _ = pure SInteger toBuilder = varInt . getVarInt {-# INLINE toBuilder #-}- extractor = Extractor $ mkPlan $ \case+ extractor = mkExtractor $ \case SInteger -> pure $ \case TInteger i -> fromIntegral i t -> throw $ InvalidTerm t@@ -448,7 +452,7 @@ schemaGen _ = pure SChar toBuilder = toBuilder . fromEnum {-# INLINE toBuilder #-}- extractor = Extractor $ mkPlan $ \case+ extractor = mkExtractor $ \case SChar -> pure $ \case TChar c -> c t -> throw $ InvalidTerm t@@ -465,7 +469,7 @@ schemaGen _ = pure SBytes toBuilder bs = varInt (B.length bs) <> BB.byteString bs {-# INLINE toBuilder #-}- extractor = Extractor $ mkPlan $ \case+ extractor = mkExtractor $ \case SBytes -> pure $ \case TBytes bs -> bs t -> throw $ InvalidTerm t@@ -487,7 +491,7 @@ schemaGen _ = pure SUTCTime toBuilder = toBuilder . utcTimeToPOSIXSeconds {-# INLINE toBuilder #-}- extractor = Extractor $ Plan $ \case+ extractor = mkExtractor $ \case SUTCTime -> pure $ \case TUTCTime bs -> bs t -> throw $ InvalidTerm t@@ -504,9 +508,9 @@ -- | Extract a list or an array of values. extractListBy :: Typeable a => Extractor a -> Extractor (V.Vector a)-extractListBy (Extractor plan) = Extractor $ mkPlan $ \case+extractListBy (Extractor plan) = mkExtractor $ \case SVector s -> do- getItem <- unPlan plan s+ getItem <- plan s return $ \case TVector xs -> V.map getItem xs t -> throw $ InvalidTerm t@@ -607,7 +611,7 @@ schemaGen _ = schemaGen (Proxy @ (Integer, Int)) toBuilder s = toBuilder (coefficient s, base10Exponent s) {-# INLINE toBuilder #-}- extractor = Extractor $ Plan $ \s -> case s of+ extractor = mkExtractor $ \s -> case s of SWord8 -> f (fromIntegral :: Word8 -> Scientific) s SWord16 -> f (fromIntegral :: Word16 -> Scientific) s SWord32 -> f (fromIntegral :: Word32 -> Scientific) s@@ -621,7 +625,7 @@ SDouble -> f (realToFrac :: Double -> Scientific) s _ -> f (uncurry scientific) s where- f c = unwrapExtractor (c <$> extractor)+ f c = runExtractor (c <$> extractor) decodeCurrent = scientific <$> decodeCurrent <*> decodeCurrent instance (Serialise a, Serialise b) => Serialise (a, b) where@@ -711,7 +715,7 @@ instance Serialise Void where schemaGen _ = pure $ SVariant V.empty toBuilder = mempty- extractor = Extractor $ Plan $ const $ throwStrategy "No extractor for Void"+ extractor = Extractor $ const $ throwStrategy "No extractor for Void" decodeCurrent = error "No decodeCurrent for Void" --------------------------------------------------------------------------------@@ -725,13 +729,13 @@ gtoBuilderRecord = productEncoder . from {-# INLINE gtoBuilderRecord #-} -data FieldDecoder i a = FieldDecoder !i !(Maybe a) !(Plan (Term -> a))+data FieldDecoder i a = FieldDecoder !i !(Maybe a) !(Schema -> Strategy' (Term -> a)) -- | Generic implementation of 'extractor' for a record. gextractorRecord :: forall a. (GSerialiseRecord (Rep a), Generic a, Typeable a) => Maybe a -- ^ default value (optional) -> Extractor a-gextractorRecord def = Extractor $ mkPlan+gextractorRecord def = mkExtractor $ fmap (fmap (to .)) $ extractorRecord' ("gextractorRecord :: Extractor " <> viaShow (typeRep (Proxy @ a))) (from <$> def)@@ -747,7 +751,7 @@ Nothing -> case def' of Just d -> Right (const d) Nothing -> Left $ FieldNotFound rep name (map fst $ V.toList schs)- Just (i, sch) -> case p `unPlan` sch `unStrategy` decs of+ Just (i, sch) -> case p sch `unStrategy` decs of Right getItem -> Right $ \case TRecord xs -> maybe (error (show rep)) (getItem . snd) $ xs V.!? i t -> throw $ InvalidTerm t@@ -821,7 +825,7 @@ recordExtractor def = TransFusion $ \k -> fmap (fmap (M1 . K1)) $ k $ FieldDecoder (T.pack $ selName (M1 undefined :: M1 i c (K1 i a) x)) (unK1 . unM1 <$> def)- (getExtractor extractor)+ (runExtractor extractor) {-# INLINE recordExtractor #-} instance (GSerialiseRecord f) => GSerialiseRecord (C1 c f) where@@ -843,7 +847,7 @@ instance (Serialise a) => GSerialiseProduct (K1 i a) where productSchema _ = pure <$> getSchema (Proxy @ a) productExtractor = Compose $ State $ \i ->- ( TransFusion $ \k -> fmap (fmap K1) $ k $ FieldDecoder i Nothing (getExtractor extractor)+ ( TransFusion $ \k -> fmap (fmap K1) $ k $ FieldDecoder i Nothing (runExtractor extractor) , i + 1) instance GSerialiseProduct f => GSerialiseProduct (M1 i c f) where@@ -865,7 +869,7 @@ -- | Generic implementation of 'extractor' for a record. gextractorProduct :: forall a. (GSerialiseProduct (Rep a), Generic a, Typeable a) => Extractor a-gextractorProduct = Extractor $ mkPlan $ fmap (to .) . extractorProduct'+gextractorProduct = mkExtractor $ fmap (to .) . extractorProduct' {-# INLINE gextractorProduct #-} -- | Generic implementation of 'extractor' for a record.@@ -880,7 +884,7 @@ let go :: FieldDecoder Int x -> Either WineryException (Term -> x) go (FieldDecoder i _ p) = do getItem <- if i < length schs- then unPlan p (schs V.! i) `unStrategy` recs+ then p (schs V.! i) `unStrategy` recs else Left $ ProductTooSmall $ length schs return $ \case TProduct xs -> getItem $ maybe (throw $ InvalidTerm (TProduct xs)) id@@ -905,7 +909,7 @@ -- | Generic implementation of 'extractor' for an ADT. gextractorVariant :: forall a. (GSerialiseVariant (Rep a), Generic a, Typeable a) => Extractor a-gextractorVariant = Extractor $ mkPlan $ \case+gextractorVariant = mkExtractor $ \case SVariant schs0 -> Strategy $ \decs -> do ds' <- traverse (\(name, sch) -> case lookup name variantExtractor of Nothing -> Left $ FieldNotFound rep name (map fst $ V.toList schs0)
src/Codec/Winery/Query.hs view
@@ -16,6 +16,7 @@ , list , range , field+ , productItem , con , select) where @@ -48,7 +49,7 @@ -- | Throw an error. invalid :: WineryException -> Query a b-invalid = Query . const . Extractor . Plan . const . throwStrategy+invalid = Query . const . Extractor . const . throwStrategy -- | Takes a list and traverses on it. list :: Typeable a => Query a a@@ -61,6 +62,9 @@ $ V.backpermute v (V.enumFromTo (i `mod` V.length v) (j `mod` V.length v))) . extractListBy +productItem :: Typeable a => Int -> Query a a+productItem i = Query $ \d -> buildExtractor $ extractProductItemBy d i+ -- | Takes a record and extracts the specified field. field :: Typeable a => T.Text -> Query a a field name = Query $ \d -> buildExtractor $ extractFieldBy d name@@ -71,7 +75,7 @@ -- | Propagate values if the supplied 'Query' doesn't return False. select :: Query a Bool -> Query a a-select qp = Query $ \d -> Extractor $ Plan $ \sch -> do- p <- unwrapExtractor (runQuery qp d) sch- dec <- unwrapExtractor d sch+select qp = Query $ \d -> Extractor $ \sch -> do+ p <- runExtractor (runQuery qp d) sch+ dec <- runExtractor d sch return $ \bs -> [x | and $ p bs, x <- dec bs]
src/Codec/Winery/Query/Parser.hs view
@@ -55,6 +55,7 @@ j <- optional (symbol ":" >> L.decimal) _ <- char ']' return $ range (maybe 0 id i) (maybe (-1) id j)+ , productItem <$> L.decimal , field <$> name , return id ]
− src/Data/Winery.hs
@@ -1,5 +0,0 @@-module Data.Winery {-# DEPRECATED "Use Codec.Winery instead" #-}- ( module Codec.Winery )- where--import Codec.Winery
− src/Data/Winery/Test.hs
@@ -1,5 +0,0 @@-module Data.Winery.Test {-# DEPRECATED "Use Codec.Winery instead" #-}- ( module Codec.Winery.Test )- where--import Codec.Winery.Test
winery.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.0 name: winery-version: 1.1.3+version: 1.2 synopsis: A compact, well-typed seralisation format for Haskell values description: <<https://i.imgur.com/lTosHnE.png>>@@ -19,7 +19,6 @@ extra-source-files: README.md ChangeLog.md- .travis.yml art/logo.png art/logo.svg @@ -36,8 +35,6 @@ Codec.Winery.Query Codec.Winery.Query.Parser Codec.Winery.Test- Data.Winery- Data.Winery.Test hs-source-dirs: src ghc-options: -Wall -O2 -Wcompat@@ -120,4 +117,5 @@ , bytestring , deepseq , directory+ , vector default-language: Haskell2010