diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 --- a/.travis.yml +++ /dev/null @@ -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 diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,8 +1,9 @@ # winery ![logo](https://github.com/fumieval/winery/blob/master/art/logo256px.png?raw=true) -[![Build Status](https://travis-ci.org/fumieval/winery.svg?branch=master)](https://travis-ci.org/fumieval/winery) +![Haskell CI](https://github.com/fumieval/winery/workflows/Haskell%20CI/badge.svg) [![Hackage](https://img.shields.io/hackage/v/winery.svg)](https://hackage.haskell.org/package/winery) +[![Discord](https://img.shields.io/discord/664807830116892674?color=%237095ec&label=Discord&style=plastic)](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) diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/benchmarks/bench.hs b/benchmarks/bench.hs --- a/benchmarks/bench.hs +++ b/benchmarks/bench.hs @@ -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" + ] ] diff --git a/src/Codec/Winery.hs b/src/Codec/Winery.hs --- a/src/Codec/Winery.hs +++ b/src/Codec/Winery.hs @@ -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 diff --git a/src/Codec/Winery/Base.hs b/src/Codec/Winery/Base.hs --- a/src/Codec/Winery/Base.hs +++ b/src/Codec/Winery/Base.hs @@ -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 diff --git a/src/Codec/Winery/Class.hs b/src/Codec/Winery/Class.hs --- a/src/Codec/Winery/Class.hs +++ b/src/Codec/Winery/Class.hs @@ -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) diff --git a/src/Codec/Winery/Query.hs b/src/Codec/Winery/Query.hs --- a/src/Codec/Winery/Query.hs +++ b/src/Codec/Winery/Query.hs @@ -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] diff --git a/src/Codec/Winery/Query/Parser.hs b/src/Codec/Winery/Query/Parser.hs --- a/src/Codec/Winery/Query/Parser.hs +++ b/src/Codec/Winery/Query/Parser.hs @@ -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 ] diff --git a/src/Data/Winery.hs b/src/Data/Winery.hs deleted file mode 100644 --- a/src/Data/Winery.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Data.Winery {-# DEPRECATED "Use Codec.Winery instead" #-} - ( module Codec.Winery ) - where - -import Codec.Winery diff --git a/src/Data/Winery/Test.hs b/src/Data/Winery/Test.hs deleted file mode 100644 --- a/src/Data/Winery/Test.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Data.Winery.Test {-# DEPRECATED "Use Codec.Winery instead" #-} - ( module Codec.Winery.Test ) - where - -import Codec.Winery.Test diff --git a/winery.cabal b/winery.cabal --- a/winery.cabal +++ b/winery.cabal @@ -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: <> @@ -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