diff --git a/.travis.yml b/.travis.yml new file mode 100644 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,115 @@ +# 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,18 +1,30 @@ -# 1 +## 1.1 +* Renamed `Data.Winery` to `Codec.Winery` + +## 1.0.2 + +* `bootstrapSchema` returns `UnsupportedSchemaVersion` rather than an error + +## 1.0.1 + +* Added `bundleSerialise` + +## 1 + * Changed the encoding more compact * Decoders are now stateful * Significantly improved the performance * `decodeCurrent` is now a method of `Serialise` * Added `STag` -# 0.3 +## 0.3 * Supported `UTCTime` * Added an instance for lazy `ByteString` * Added `toEncodingWithSchema` -# 0.2 +## 0.2 * Renamed `extract*With` to `extract*By` for consistency * Added `hPut` @@ -20,15 +32,15 @@ * Added `-J` option to `winery` which exports a JSON * Decoder now throws `DecodeException` rather than error calls -# 0.1.1 +## 0.1.1 * Add `Data.Winery.Query` * The command line tool supports a simple query language -# 0.1 +## 0.1 Overhauled the encoding; Sorry, incompatible with 0 -# 0 +## 0 Initial release diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -7,9 +7,9 @@ import qualified Data.ByteString.Lazy as BL import Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc.Render.Terminal -import qualified Data.Winery.Query as Q -import Data.Winery.Query.Parser -import Data.Winery +import qualified Codec.Winery.Query as Q +import Codec.Winery.Query.Parser +import Codec.Winery import System.Console.GetOpt import System.Environment import System.Exit diff --git a/art/logo.png b/art/logo.png new file mode 100644 Binary files /dev/null and b/art/logo.png differ diff --git a/art/logo.svg b/art/logo.svg new file mode 100644 --- /dev/null +++ b/art/logo.svg @@ -0,0 +1,1 @@ +logoSINCE 2018 diff --git a/benchmarks/bench.hs b/benchmarks/bench.hs --- a/benchmarks/bench.hs +++ b/benchmarks/bench.hs @@ -6,7 +6,7 @@ import qualified Data.ByteString as B import qualified Data.Binary as B import Data.Either -import Data.Winery +import Codec.Winery import Data.Text (Text) import qualified Data.Text.Encoding as TE import qualified Data.Serialize as C diff --git a/src/Codec/Winery.hs b/src/Codec/Winery.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Winery.hs @@ -0,0 +1,1291 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeApplications #-} +#if __GLASGOW_HASKELL__ < 806 +{-# LANGUAGE TypeInType #-} +#endif +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +---------------------------------------------------------------------------- +-- | +-- Module : Codec.Winery +-- Copyright : (c) Fumiaki Kinoshita 2019 +-- License : BSD3 +-- Stability : Provisional +-- +-- Maintainer : Fumiaki Kinoshita +-- +----------------------------------------------------------------------------- +module Codec.Winery + ( Schema + , SchemaP(..) + , Tag(..) + , Serialise(..) + , testSerialise + , DecodeException(..) + , schema + -- * Standalone serialisation + , toBuilderWithSchema + , serialise + , deserialise + , deserialiseBy + , deserialiseTerm + , splitSchema + , writeFileSerialise + -- * Separate serialisation + , serialiseSchema + , deserialiseSchema + , Extractor(..) + , unwrapExtractor + , Decoder + , evalDecoder + , serialiseOnly + , getDecoder + , getDecoderBy + -- * Decoding combinators + , Term(..) + , Subextractor(..) + , buildExtractor + , extractListBy + , extractField + , extractFieldBy + , extractConstructor + , extractConstructorBy + , extractVoid + , ExtractException(..) + -- * Variable-length quantity + , VarInt(..) + -- * Internal + , WineryException(..) + , prettyWineryException + , unexpectedSchema + , SchemaGen + , getSchema + , Plan(..) + , mkPlan + -- * DerivingVia + , WineryRecord(..) + , WineryVariant(..) + , WineryProduct(..) + -- * Generic implementations (for old GHC / custom instances) + , GSerialiseRecord + , gschemaGenRecord + , GEncodeProduct + , gtoBuilderRecord + , gextractorRecord + , gdecodeCurrentRecord + , GSerialiseVariant + , gschemaGenVariant + , gtoBuilderVariant + , gextractorVariant + , gschemaGenProduct + , gtoBuilderProduct + , gdecodeCurrentVariant + , gextractorProduct + , gdecodeCurrentProduct + , decodeCurrentDefault + -- * Bundles + , BundleSerialise(..) + , bundleRecord + , bundleRecordDefault + , bundleVariant + -- * Preset schema + , bootstrapSchema + )where + +import Control.Applicative +import Control.Exception +import Control.Monad.Reader +import qualified Data.ByteString as B +import qualified Data.ByteString.FastBuilder as BB +import qualified Data.ByteString.Lazy as BL +import Data.Bits +import Data.Complex +import Data.Dynamic +import Data.Fixed +import Data.Functor.Compose +import Data.Functor.Identity +import Data.List (elemIndex) +import Data.Monoid as M +import Data.Proxy +import Data.Ratio +import Data.Scientific (Scientific, scientific, coefficient, base10Exponent) +import Data.Semigroup as S +import Data.Hashable (Hashable) +import qualified Data.HashMap.Strict as HM +import Data.Int +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import qualified Data.Map as M +import Data.Ord +import Data.Word +import Codec.Winery.Base as W +import Codec.Winery.Internal +import qualified Data.Sequence as Seq +import qualified Data.Set as S +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T +import qualified Data.Vector as V +import qualified Data.Vector.Storable as SV +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 Data.Void +import Unsafe.Coerce +import GHC.Float (castWord32ToFloat, castWord64ToDouble) +import GHC.Natural +import GHC.Generics +import GHC.TypeLits +import System.IO +import qualified Test.QuickCheck as QC + +-- | Deserialiser for a 'Term'. +-- +-- /"I will read anything rather than work."/ +decodeTerm :: Schema -> Decoder Term +decodeTerm = go [] where + go points = \case + SBool -> TBool <$> decodeCurrent + W.SChar -> TChar <$> decodeCurrent + SWord8 -> TWord8 <$> getWord8 + SWord16 -> TWord16 <$> getWord16 + SWord32 -> TWord32 <$> getWord32 + SWord64 -> TWord64 <$> getWord64 + SInt8 -> TInt8 <$> decodeCurrent + SInt16 -> TInt16 <$> decodeCurrent + SInt32 -> TInt32 <$> decodeCurrent + SInt64 -> TInt64 <$> decodeCurrent + SInteger -> TInteger <$> decodeVarInt + SFloat -> TFloat <$> decodeCurrent + SDouble -> TDouble <$> decodeCurrent + SBytes -> TBytes <$> decodeCurrent + W.SText -> TText <$> decodeCurrent + SUTCTime -> TUTCTime <$> decodeCurrent + SVector sch -> do + n <- decodeVarInt + TVector <$> V.replicateM n (go points sch) + SProduct schs -> TProduct <$> traverse (go points) schs + SRecord schs -> TRecord <$> traverse (\(k, s) -> (,) k <$> go points s) schs + SVariant schs -> do + let !decoders = V.map (\(name, sch) -> let !m = go points sch in (name, m)) schs + tag <- decodeVarInt + let (name, dec) = maybe (throw InvalidTag) id $ decoders V.!? tag + TVariant tag name <$> dec + SVar i -> indexDefault (throw InvalidTag) points i + SFix s' -> fix $ \a -> go (a : points) s' + STag _ s -> go points s + SLet s t -> go (go points s : points) t + +-- | Deserialise a 'serialise'd 'B.Bytestring'. +deserialiseTerm :: B.ByteString -> Either WineryException (Schema, Term) +deserialiseTerm bs_ = do + (sch, bs) <- splitSchema bs_ + return (sch, decodeTerm sch `evalDecoder` bs) + +-- | This may be thrown if illegal 'Term' is passed to an extractor. +data ExtractException = InvalidTerm !Term deriving Show +instance Exception ExtractException + +-- | Serialisable datatype +-- +class Typeable a => Serialise a where + -- | Obtain the schema of the datatype. + schemaGen :: Proxy a -> SchemaGen Schema + schemaGen = bundleSchemaGen bundleSerialise + {-# INLINE schemaGen #-} + + -- | Serialise a value. + toBuilder :: a -> BB.Builder + toBuilder = bundleToBuilder bundleSerialise + {-# INLINE toBuilder #-} + + -- | A value of 'Extractor a' interprets a schema and builds a function from + -- 'Term' to @a@. This must be equivalent to 'decodeCurrent' when the schema + -- is the current one. + -- + -- If @'extractor' s@ returns a function, the function must return a + -- non-bottom for any 'Term' @'decodeTerm' s@ returns. + -- + -- It must not return a function if an unsupported schema is supplied. + -- + -- @getDecoderBy extractor (schema (Proxy @ a))@ must be @Right d@ + -- where @d@ is equivalent to 'decodeCurrent'. + -- + extractor :: Extractor a + extractor = bundleExtractor bundleSerialise + {-# INLINE extractor #-} + + -- | Decode a value with the current schema. + -- + -- @'decodeCurrent' `evalDecoder` 'toBuilder' x@ ≡ x + decodeCurrent :: Decoder a + decodeCurrent = bundleDecodeCurrent bundleSerialise + {-# INLINE decodeCurrent #-} + + -- | Instead of the four methods above, you can supply a bundle. + bundleSerialise :: BundleSerialise a + bundleSerialise = BundleSerialise + { bundleSchemaGen = schemaGen + , bundleToBuilder = toBuilder + , bundleExtractor = extractor + , bundleDecodeCurrent = decodeCurrent + } + + {-# MINIMAL schemaGen, toBuilder, extractor, decodeCurrent | bundleSerialise #-} + +-- | A bundle of 'Serialise' methods +data BundleSerialise a = BundleSerialise + { bundleSchemaGen :: Proxy a -> SchemaGen Schema + , bundleToBuilder :: a -> BB.Builder + , bundleExtractor :: Extractor a + , bundleDecodeCurrent :: Decoder a + } + +-- | A bundle of generic implementations for records +bundleRecord :: (GEncodeProduct (Rep a), GSerialiseRecord (Rep a), GDecodeProduct (Rep a), Generic a, Typeable a) + => (Extractor a -> Extractor a) -- extractor modifier + -> BundleSerialise a +bundleRecord f = BundleSerialise + { bundleSchemaGen = gschemaGenRecord + , bundleToBuilder = gtoBuilderRecord + , bundleExtractor = f $ gextractorRecord Nothing + , bundleDecodeCurrent = gdecodeCurrentRecord + } +{-# INLINE bundleRecord #-} + +-- | A bundle of generic implementations for records, with a default value +bundleRecordDefault :: (GEncodeProduct (Rep a), GSerialiseRecord (Rep a), GDecodeProduct (Rep a), Generic a, Typeable a) + => a -- default value + -> (Extractor a -> Extractor a) -- extractor modifier + -> BundleSerialise a +bundleRecordDefault def f = BundleSerialise + { bundleSchemaGen = gschemaGenRecord + , bundleToBuilder = gtoBuilderRecord + , bundleExtractor = f $ gextractorRecord $ Just def + , bundleDecodeCurrent = gdecodeCurrentRecord + } +{-# INLINE bundleRecordDefault #-} + +-- | A bundle of generic implementations for variants +bundleVariant :: (GSerialiseVariant (Rep a), Generic a, Typeable a) + => (Extractor a -> Extractor a) -- extractor modifier + -> BundleSerialise a +bundleVariant f = BundleSerialise + { bundleSchemaGen = gschemaGenVariant + , bundleToBuilder = gtoBuilderVariant + , bundleExtractor = f $ gextractorVariant + , bundleDecodeCurrent = gdecodeCurrentVariant + } +{-# INLINE bundleVariant #-} + +-- | Check the integrity of a Serialise instance. +-- +-- /"No tears in the writer, no tears in the reader. No surprise in the writer, no surprise in the reader."/ +testSerialise :: forall a. (Eq a, Show a, Serialise a) => a -> QC.Property +testSerialise x = case getDecoderBy extractor (schema (Proxy @ a)) of + Left e -> QC.counterexample (show e) False + Right f -> QC.counterexample "extractor" (evalDecoder f b QC.=== x) + QC..&&. QC.counterexample "decodeCurrent" (evalDecoder decodeCurrent b QC.=== x) + where + b = serialiseOnly x + +-- | 'decodeCurrent' in terms of 'extractor'; note that it's very slow. +decodeCurrentDefault :: forall a. Serialise a => Decoder a +decodeCurrentDefault = case getDecoderBy extractor (schema (Proxy @ a)) of + Left err -> error $ "decodeCurrentDefault: failed to get a decoder from the current schema" + ++ show err + Right a -> a + +-- | Schema generator +newtype SchemaGen a = SchemaGen { unSchemaGen :: S.Set TypeRep -> (S.Set TypeRep, [TypeRep] -> a) } + +instance Functor SchemaGen where + fmap f m = SchemaGen $ \s -> case unSchemaGen m s of + (rep, k) -> (rep, f . k) + +instance Applicative SchemaGen where + pure a = SchemaGen $ const (S.empty, const a) + m <*> n = SchemaGen $ \s -> case unSchemaGen m s of + (rep, f) -> case unSchemaGen n s of + (rep', g) -> (mappend rep rep', f <*> g) + +-- | Obtain a schema on 'SchemaGen', binding a fixpoint when necessary. +-- If you are hand-rolling a definition of 'schemaGen', you should call this +-- instead of 'schemaGen'. +getSchema :: forall proxy a. Serialise a => proxy a -> SchemaGen Schema +getSchema p = SchemaGen $ \seen -> if S.member rep seen + then (S.singleton rep, \xs -> case elemIndex rep xs of + Just i -> SVar i + Nothing -> error $ "getSchema: impossible " ++ show (rep, seen, xs)) + -- request a fixpoint for rep when it detects a recursion + else case unSchemaGen (schemaGen (Proxy @ a)) (S.insert rep seen) of + (reps, f) + | S.member rep reps -> (reps, \xs -> SFix $ f (rep : xs)) + | otherwise -> (reps, f) + where + rep = typeRep p + +-- | Obtain the schema of the datatype. +-- +-- /"Tell me what you drink, and I will tell you what you are."/ +schema :: forall proxy a. Serialise a => proxy a -> Schema +schema p = case unSchemaGen (schemaGen (Proxy @ a)) (S.singleton rep) of + (reps, f) + | S.member rep reps -> SFix $ f [rep] + | otherwise -> f [] + where + rep = typeRep p + +-- | Obtain a decoder from a schema. +-- +-- /"A reader lives a thousand lives before he dies... The man who never reads lives only one."/ +getDecoder :: forall a. Serialise a => Schema -> Either WineryException (Decoder a) +getDecoder sch + | sch == schema (Proxy @ a) = Right decodeCurrent + | otherwise = getDecoderBy extractor sch +{-# INLINE getDecoder #-} + +-- | 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 [] +{-# INLINE getDecoderBy #-} + +-- | Serialise a value along with its schema. +-- +-- /"Write the vision, and make it plain upon tables, that he may run that readeth it."/ +serialise :: Serialise a => a -> B.ByteString +serialise = BL.toStrict . BB.toLazyByteString . toBuilderWithSchema +{-# INLINE serialise #-} + +-- | 'serialise' then write it to a file. +writeFileSerialise :: Serialise a => FilePath -> a -> IO () +writeFileSerialise path a = withBinaryFile path WriteMode + $ \h -> BB.hPutBuilder h $ toBuilderWithSchema a +{-# INLINE writeFileSerialise #-} + +-- | Serialise a value with the schema. +toBuilderWithSchema :: forall a. Serialise a => a -> BB.Builder +toBuilderWithSchema a = mappend (BB.word8 currentSchemaVersion) + $ toBuilder (schema (Proxy @ a), a) +{-# INLINE toBuilderWithSchema #-} + +-- | Split a 'Schema' from a 'B.ByteString'. +splitSchema :: B.ByteString -> Either WineryException (Schema, B.ByteString) +splitSchema bs_ = case B.uncons bs_ of + Just (ver, bs) -> do + m <- bootstrapSchema ver >>= getDecoder + return $ flip evalDecoder bs $ do + sch <- m + State $ \bs' -> ((sch, bs'), mempty) + Nothing -> Left EmptyInput + +-- | Serialise a schema. +serialiseSchema :: Schema -> B.ByteString +serialiseSchema = BL.toStrict . BB.toLazyByteString + . mappend (BB.word8 currentSchemaVersion) . toBuilder + +-- | Deserialise a 'serialise'd 'B.Bytestring'. +-- +-- /"Old wood to burn! Old wine to drink! Old friends to trust! Old authors to read!"/ +deserialise :: Serialise a => B.ByteString -> Either WineryException a +deserialise bs_ = do + (sch, bs) <- splitSchema bs_ + dec <- getDecoder sch + return $ evalDecoder dec bs +{-# INLINE deserialise #-} + +-- | Deserialise a 'serialise'd 'B.Bytestring' using an 'Extractor'. +deserialiseBy :: Extractor a -> B.ByteString -> Either WineryException a +deserialiseBy e bs_ = do + (sch, bs) <- splitSchema bs_ + dec <- getDecoderBy e sch + return $ evalDecoder dec bs + +-- | Deserialise a schema. +deserialiseSchema :: B.ByteString -> Either WineryException Schema +deserialiseSchema bs_ = case B.uncons bs_ of + Just (ver, bs) -> do + m <- bootstrapSchema ver >>= getDecoder + return $ evalDecoder m bs + Nothing -> Left EmptyInput + +-- | Serialise a value without its schema. +-- +-- /"Any unsaved progress will be lost."/ +serialiseOnly :: Serialise a => a -> B.ByteString +serialiseOnly = BL.toStrict . BB.toLazyByteString . toBuilder +{-# INLINE serialiseOnly #-} + +unexpectedSchema :: forall f a. Serialise a => Doc AnsiStyle -> Schema -> Strategy' (f a) +unexpectedSchema subject actual = throwStrategy + $ UnexpectedSchema subject (pretty $ schema (Proxy @ a)) actual + +instance Serialise Tag where + schemaGen = gschemaGenVariant + toBuilder = gtoBuilderVariant + extractor = gextractorVariant + decodeCurrent = gdecodeCurrentVariant + +instance Serialise Schema where + schemaGen = gschemaGenVariant + toBuilder = gtoBuilderVariant + extractor = gextractorVariant + decodeCurrent = gdecodeCurrentVariant + +instance Serialise () where + schemaGen _ = pure $ SProduct [] + toBuilder = mempty + {-# INLINE toBuilder #-} + extractor = pure () + decodeCurrent = pure () + +instance Serialise Bool where + schemaGen _ = pure SBool + toBuilder False = BB.word8 0 + toBuilder True = BB.word8 1 + {-# INLINE toBuilder #-} + extractor = Extractor $ mkPlan $ \case + SBool -> pure $ \case + TBool b -> b + t -> throw $ InvalidTerm t + s -> unexpectedSchema "Serialise Bool" s + decodeCurrent = (/=0) <$> getWord8 + +instance Serialise Word8 where + schemaGen _ = pure SWord8 + toBuilder = BB.word8 + {-# INLINE toBuilder #-} + extractor = Extractor $ mkPlan $ \case + SWord8 -> pure $ \case + TWord8 i -> i + t -> throw $ InvalidTerm t + s -> unexpectedSchema "Serialise Word8" s + decodeCurrent = getWord8 + +instance Serialise Word16 where + schemaGen _ = pure SWord16 + toBuilder = BB.word16LE + {-# INLINE toBuilder #-} + extractor = Extractor $ mkPlan $ \case + SWord16 -> pure $ \case + TWord16 i -> i + t -> throw $ InvalidTerm t + s -> unexpectedSchema "Serialise Word16" s + decodeCurrent = getWord16 + +instance Serialise Word32 where + schemaGen _ = pure SWord32 + toBuilder = BB.word32LE + {-# INLINE toBuilder #-} + extractor = Extractor $ mkPlan $ \case + SWord32 -> pure $ \case + TWord32 i -> i + t -> throw $ InvalidTerm t + s -> unexpectedSchema "Serialise Word32" s + decodeCurrent = getWord32 + +instance Serialise Word64 where + schemaGen _ = pure SWord64 + toBuilder = BB.word64LE + {-# INLINE toBuilder #-} + extractor = Extractor $ mkPlan $ \case + SWord64 -> pure $ \case + TWord64 i -> i + t -> throw $ InvalidTerm t + s -> unexpectedSchema "Serialise Word64" s + decodeCurrent = getWord64 + +instance Serialise Word where + schemaGen _ = pure SWord64 + toBuilder = BB.word64LE . fromIntegral + {-# INLINE toBuilder #-} + extractor = Extractor $ mkPlan $ \case + SWord64 -> pure $ \case + TWord64 i -> fromIntegral i + t -> throw $ InvalidTerm t + s -> unexpectedSchema "Serialise Word" s + decodeCurrent = fromIntegral <$> getWord64 + +instance Serialise Int8 where + schemaGen _ = pure SInt8 + toBuilder = BB.word8 . fromIntegral + {-# INLINE toBuilder #-} + extractor = Extractor $ mkPlan $ \case + SInt8 -> pure $ \case + TInt8 i -> i + t -> throw $ InvalidTerm t + s -> unexpectedSchema "Serialise Int8" s + decodeCurrent = fromIntegral <$> getWord8 + +instance Serialise Int16 where + schemaGen _ = pure SInt16 + toBuilder = BB.word16LE . fromIntegral + {-# INLINE toBuilder #-} + extractor = Extractor $ mkPlan $ \case + SInt16 -> pure $ \case + TInt16 i -> i + t -> throw $ InvalidTerm t + s -> unexpectedSchema "Serialise Int16" s + decodeCurrent = fromIntegral <$> getWord16 + +instance Serialise Int32 where + schemaGen _ = pure SInt32 + toBuilder = BB.word32LE . fromIntegral + {-# INLINE toBuilder #-} + extractor = Extractor $ mkPlan $ \case + SInt32 -> pure $ \case + TInt32 i -> i + t -> throw $ InvalidTerm t + s -> unexpectedSchema "Serialise Int32" s + decodeCurrent = fromIntegral <$> getWord32 + +instance Serialise Int64 where + schemaGen _ = pure SInt64 + toBuilder = BB.word64LE . fromIntegral + {-# INLINE toBuilder #-} + extractor = Extractor $ mkPlan $ \case + SInt64 -> pure $ \case + TInt64 i -> i + t -> throw $ InvalidTerm t + s -> unexpectedSchema "Serialise Int64" s + decodeCurrent = fromIntegral <$> getWord64 + +instance Serialise Int where + schemaGen _ = pure SInteger + toBuilder = toBuilder . VarInt + {-# INLINE toBuilder #-} + extractor = Extractor $ mkPlan $ \case + SInteger -> pure $ \case + TInteger i -> fromIntegral i + t -> throw $ InvalidTerm t + s -> unexpectedSchema "Serialise Int" s + decodeCurrent = decodeVarIntFinite + +instance Serialise Float where + schemaGen _ = pure SFloat + toBuilder = BB.floatLE + {-# INLINE toBuilder #-} + extractor = Extractor $ mkPlan $ \case + SFloat -> pure $ \case + TFloat x -> x + t -> throw $ InvalidTerm t + s -> unexpectedSchema "Serialise Float" s + decodeCurrent = castWord32ToFloat <$> getWord32 + +instance Serialise Double where + schemaGen _ = pure SDouble + toBuilder = BB.doubleLE + {-# INLINE toBuilder #-} + extractor = Extractor $ mkPlan $ \case + SDouble -> pure $ \case + TDouble x -> x + t -> throw $ InvalidTerm t + s -> unexpectedSchema "Serialise Double" s + decodeCurrent = castWord64ToDouble <$> getWord64 + +instance Serialise T.Text where + schemaGen _ = pure SText + toBuilder = toBuilder . T.encodeUtf8 + {-# INLINE toBuilder #-} + extractor = Extractor $ mkPlan $ \case + SText -> pure $ \case + TText t -> t + t -> throw $ InvalidTerm t + s -> unexpectedSchema "Serialise Text" s + decodeCurrent = do + len <- decodeVarInt + T.decodeUtf8With T.lenientDecode <$> State (B.splitAt len) + +-- | Encoded in variable-length quantity. +newtype VarInt a = VarInt { getVarInt :: a } deriving (Show, Read, Eq, Ord, Enum + , Bounded, Num, Real, Integral, Bits, Typeable) + +instance (Typeable a, Bits a, Integral a) => Serialise (VarInt a) where + schemaGen _ = pure SInteger + toBuilder = varInt . getVarInt + {-# INLINE toBuilder #-} + extractor = Extractor $ mkPlan $ \case + SInteger -> pure $ \case + TInteger i -> fromIntegral i + t -> throw $ InvalidTerm t + s -> unexpectedSchema "Serialise (VarInt a)" s + decodeCurrent = VarInt <$> decodeVarInt + +instance Serialise Integer where + schemaGen _ = pure SInteger + toBuilder = toBuilder . VarInt + {-# INLINE toBuilder #-} + extractor = getVarInt <$> extractor + decodeCurrent = getVarInt <$> decodeCurrent + +instance Serialise Natural where + schemaGen _ = pure SInteger + toBuilder = toBuilder . toInteger + extractor = naturalFromInteger <$> extractor + decodeCurrent = naturalFromInteger <$> decodeCurrent + +instance Serialise Char where + schemaGen _ = pure SChar + toBuilder = toBuilder . fromEnum + {-# INLINE toBuilder #-} + extractor = Extractor $ mkPlan $ \case + SChar -> pure $ \case + TChar c -> c + t -> throw $ InvalidTerm t + s -> unexpectedSchema "Serialise Char" s + decodeCurrent = toEnum <$> decodeVarInt + +instance Serialise a => Serialise (Maybe a) where + schemaGen = gschemaGenVariant + toBuilder = gtoBuilderVariant + extractor = gextractorVariant + decodeCurrent = gdecodeCurrentVariant + +instance Serialise B.ByteString where + schemaGen _ = pure SBytes + toBuilder bs = varInt (B.length bs) <> BB.byteString bs + {-# INLINE toBuilder #-} + extractor = Extractor $ mkPlan $ \case + SBytes -> pure $ \case + TBytes bs -> bs + t -> throw $ InvalidTerm t + s -> unexpectedSchema "Serialise ByteString" s + decodeCurrent = do + len <- decodeVarInt + State (B.splitAt len) + +instance Serialise BL.ByteString where + schemaGen _ = pure SBytes + toBuilder = toBuilder . BL.toStrict + {-# INLINE toBuilder #-} + extractor = BL.fromStrict <$> extractor + decodeCurrent = BL.fromStrict <$> decodeCurrent + +-- | time-1.9.1 +nanosecondsToNominalDiffTime :: Int64 -> NominalDiffTime +nanosecondsToNominalDiffTime = unsafeCoerce . MkFixed . (*1000) . fromIntegral + +instance Serialise UTCTime where + schemaGen _ = pure SUTCTime + toBuilder = toBuilder . utcTimeToPOSIXSeconds + {-# INLINE toBuilder #-} + extractor = Extractor $ Plan $ \case + SUTCTime -> pure $ \case + TUTCTime bs -> bs + t -> throw $ InvalidTerm t + s -> unexpectedSchema "Serialise UTCTime" s + decodeCurrent = posixSecondsToUTCTime <$> decodeCurrent + +instance Serialise NominalDiffTime where + schemaGen _ = pure SInt64 + toBuilder x = case unsafeCoerce x of + MkFixed p -> toBuilder (fromIntegral (p `div` 1000) :: Int64) + {-# INLINE toBuilder #-} + extractor = nanosecondsToNominalDiffTime <$> extractor + decodeCurrent = nanosecondsToNominalDiffTime <$> decodeCurrent + +instance Serialise a => Serialise [a] where + schemaGen _ = SVector <$> getSchema (Proxy @ a) + toBuilder xs = varInt (length xs) + <> foldMap toBuilder xs + {-# INLINE toBuilder #-} + extractor = V.toList <$> extractListBy extractor + decodeCurrent = do + n <- decodeVarInt + replicateM n decodeCurrent + +instance Serialise a => Serialise (V.Vector a) where + schemaGen _ = SVector <$> getSchema (Proxy @ a) + toBuilder xs = varInt (V.length xs) + <> foldMap toBuilder xs + {-# INLINE toBuilder #-} + extractor = extractListBy extractor + decodeCurrent = do + n <- decodeVarInt + V.replicateM n decodeCurrent + +instance (SV.Storable a, Serialise a) => Serialise (SV.Vector a) where + schemaGen _ = SVector <$> getSchema (Proxy @ a) + toBuilder = toBuilder . (SV.convert :: SV.Vector a -> V.Vector a) + {-# INLINE toBuilder #-} + extractor = SV.convert <$> extractListBy extractor + decodeCurrent = do + n <- decodeVarInt + SV.replicateM n decodeCurrent + +instance (UV.Unbox a, Serialise a) => Serialise (UV.Vector a) where + schemaGen _ = SVector <$> getSchema (Proxy @ a) + toBuilder = toBuilder . (UV.convert :: UV.Vector a -> V.Vector a) + {-# INLINE toBuilder #-} + extractor = UV.convert <$> extractListBy extractor + decodeCurrent = do + n <- decodeVarInt + UV.replicateM n decodeCurrent + +-- | Extract a list or an array of values. +extractListBy :: Typeable a => Extractor a -> Extractor (V.Vector a) +extractListBy (Extractor plan) = Extractor $ mkPlan $ \case + SVector s -> do + getItem <- unPlan plan s + return $ \case + TVector xs -> V.map getItem xs + t -> throw $ InvalidTerm t + s -> throwStrategy $ UnexpectedSchema "extractListBy ..." "[a]" s +{-# INLINE extractListBy #-} + +instance (Ord k, Serialise k, Serialise v) => Serialise (M.Map k v) where + schemaGen _ = schemaGen (Proxy @ [(k, v)]) + toBuilder m = toBuilder (M.size m) + <> M.foldMapWithKey (curry toBuilder) m + {-# INLINE toBuilder #-} + extractor = M.fromList <$> extractor + decodeCurrent = M.fromList <$> decodeCurrent + +instance (Eq k, Hashable k, Serialise k, Serialise v) => Serialise (HM.HashMap k v) where + schemaGen _ = schemaGen (Proxy @ [(k, v)]) + toBuilder m = toBuilder (HM.size m) + <> HM.foldrWithKey (\k v r -> toBuilder (k, v) <> r) mempty m + {-# INLINE toBuilder #-} + extractor = HM.fromList <$> extractor + decodeCurrent = HM.fromList <$> decodeCurrent + +instance (Serialise v) => Serialise (IM.IntMap v) where + schemaGen _ = schemaGen (Proxy @ [(Int, v)]) + toBuilder m = toBuilder (IM.size m) + <> IM.foldMapWithKey (curry toBuilder) m + {-# INLINE toBuilder #-} + extractor = IM.fromList <$> extractor + decodeCurrent = IM.fromList <$> decodeCurrent + +instance (Ord a, Serialise a) => Serialise (S.Set a) where + schemaGen _ = schemaGen (Proxy @ [a]) + toBuilder s = toBuilder (S.size s) <> foldMap toBuilder s + {-# INLINE toBuilder #-} + extractor = S.fromList <$> extractor + decodeCurrent = S.fromList <$> decodeCurrent + +instance Serialise IS.IntSet where + schemaGen _ = schemaGen (Proxy @ [Int]) + toBuilder s = toBuilder (IS.size s) <> IS.foldr (mappend . toBuilder) mempty s + {-# INLINE toBuilder #-} + extractor = IS.fromList <$> extractor + decodeCurrent = IS.fromList <$> decodeCurrent + +instance Serialise a => Serialise (Seq.Seq a) where + schemaGen _ = schemaGen (Proxy @ [a]) + toBuilder s = toBuilder (length s) <> foldMap toBuilder s + {-# INLINE toBuilder #-} + extractor = Seq.fromList <$> extractor + decodeCurrent = Seq.fromList <$> decodeCurrent + +instance (Integral a, Serialise a) => Serialise (Ratio a) where + schemaGen _ = schemaGen (Proxy @ (a, a)) + toBuilder x = toBuilder (numerator x, denominator x) + {-# INLINE toBuilder #-} + extractor = uncurry (%) <$> extractor + decodeCurrent = uncurry (%) <$> decodeCurrent + +instance Serialise Scientific where + schemaGen _ = schemaGen (Proxy @ (Integer, Int)) + toBuilder s = toBuilder (coefficient s, base10Exponent s) + {-# INLINE toBuilder #-} + extractor = Extractor $ Plan $ \s -> case s of + SWord8 -> f (fromIntegral :: Word8 -> Scientific) s + SWord16 -> f (fromIntegral :: Word16 -> Scientific) s + SWord32 -> f (fromIntegral :: Word32 -> Scientific) s + SWord64 -> f (fromIntegral :: Word64 -> Scientific) s + SInt8 -> f (fromIntegral :: Int8 -> Scientific) s + SInt16 -> f (fromIntegral :: Int16 -> Scientific) s + SInt32 -> f (fromIntegral :: Int32 -> Scientific) s + SInt64 -> f (fromIntegral :: Int64 -> Scientific) s + SInteger -> f fromInteger s + SFloat -> f (realToFrac :: Float -> Scientific) s + SDouble -> f (realToFrac :: Double -> Scientific) s + _ -> f (uncurry scientific) s + where + f c = unwrapExtractor (c <$> extractor) + decodeCurrent = decodeCurrentDefault + +-- | Build an extractor from a 'Subextractor'. +buildExtractor :: Typeable a => Subextractor a -> Extractor a +buildExtractor (Subextractor e) = Extractor $ mkPlan $ unwrapExtractor e +{-# INLINE buildExtractor #-} + +-- | An extractor for individual fields. This distinction is required for +-- handling recursions correctly. +-- +-- Recommended extension: ApplicativeDo +newtype Subextractor a = Subextractor { unSubextractor :: Extractor a } + deriving (Functor, Applicative, Alternative) + +-- | Extract a field of a record. +extractField :: Serialise a => T.Text -> Subextractor a +extractField = extractFieldBy extractor +{-# INLINE extractField #-} + +-- | Extract a field using the supplied 'Extractor'. +extractFieldBy :: Extractor a -> T.Text -> Subextractor a +extractFieldBy (Extractor g) name = Subextractor $ Extractor $ Plan $ \case + SRecord schs -> case lookupWithIndexV name schs of + Just (i, sch) -> do + m <- unPlan g sch + return $ \case + TRecord xs -> maybe (error msg) (m . snd) $ xs V.!? i + t -> throw $ InvalidTerm t + _ -> throwStrategy $ FieldNotFound rep name (map fst $ V.toList schs) + s -> throwStrategy $ UnexpectedSchema rep "a record" s + where + rep = "extractFieldBy ... " <> dquotes (pretty name) + msg = "Codec.Winery.extractFieldBy ... " <> show name <> ": impossible" + +-- | 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 + SVar i + | point : _ <- drop i decs -> case point of + BoundSchema ofs' sch' -> unPlan (mkPlan 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) + s -> k s `unStrategy` StrategyEnv ofs decs + +instance (Serialise a, Serialise b) => Serialise (a, b) where + schemaGen = gschemaGenProduct + toBuilder = gtoBuilderProduct + extractor = gextractorProduct + decodeCurrent = gdecodeCurrentProduct + +instance (Serialise a, Serialise b, Serialise c) => Serialise (a, b, c) where + schemaGen = gschemaGenProduct + toBuilder = gtoBuilderProduct + extractor = gextractorProduct + decodeCurrent = gdecodeCurrentProduct + +instance (Serialise a, Serialise b, Serialise c, Serialise d) => Serialise (a, b, c, d) where + schemaGen = gschemaGenProduct + toBuilder = gtoBuilderProduct + extractor = gextractorProduct + decodeCurrent = gdecodeCurrentProduct + +instance (Serialise a, Serialise b, Serialise c, Serialise d, Serialise e) => Serialise (a, b, c, d, e) where + schemaGen = gschemaGenProduct + toBuilder = gtoBuilderProduct + extractor = gextractorProduct + decodeCurrent = gdecodeCurrentProduct + +instance (Serialise a, Serialise b, Serialise c, Serialise d, Serialise e, Serialise f) => Serialise (a, b, c, d, e, f) where + schemaGen = gschemaGenProduct + toBuilder = gtoBuilderProduct + extractor = gextractorProduct + decodeCurrent = gdecodeCurrentProduct + +instance (Serialise a, Serialise b) => Serialise (Either a b) where + schemaGen = gschemaGenVariant + toBuilder = gtoBuilderVariant + extractor = gextractorVariant + decodeCurrent = gdecodeCurrentVariant + +-- | 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 + SVariant schs0 -> Strategy $ \decs -> do + let run :: Extractor x -> Schema -> Either WineryException (Term -> x) + run e s = unwrapExtractor e s `unStrategy` decs + case lookupWithIndexV name schs0 of + Just (i, s) -> do + (j, dec) <- fmap ((,) i) $ run d $ case s of + SProduct [s'] -> s' + s' -> s' + let rest = SVariant $ V.filter ((/=name) . fst) schs0 + k <- run (unSubextractor cont) rest + return $ \case + TVariant tag _ v + | tag == j -> f $ dec v + t -> k t + _ -> run (unSubextractor cont) (SVariant schs0) + s -> throwStrategy $ UnexpectedSchema rep "a variant" s + where + rep = "extractConstructorBy ... " <> dquotes (pretty name) + +-- | Tries to match on a constructor. If it doesn't match (or constructor +-- doesn't exist at all), leave it to the successor. +-- +-- @extractor = ("Just", Just) `extractConstructor` ("Nothing", \() -> Nothing) `extractConstructor` extractVoid@ +extractConstructor :: (Serialise a) => (T.Text, a -> r) -> Subextractor r -> Subextractor r +extractConstructor (name, f) = extractConstructorBy (extractor, name, f) +{-# INLINE extractConstructor #-} + +-- | No constructors remaining. +extractVoid :: Typeable r => Subextractor r +extractVoid = Subextractor $ Extractor $ mkPlan $ \case + SVariant schs0 + | V.null schs0 -> return $ throw . InvalidTerm + s -> throwStrategy $ UnexpectedSchema "extractVoid" "no constructors" s + +infixr 1 `extractConstructorBy` +infixr 1 `extractConstructor` + +-- | Generic implementation of 'schemaGen' for a record. +gschemaGenRecord :: forall proxy a. (GSerialiseRecord (Rep a), Generic a, Typeable a) => proxy a -> SchemaGen Schema +gschemaGenRecord _ = SRecord . V.fromList <$> recordSchema (Proxy @ (Rep a)) + +-- | Generic implementation of 'toBuilder' for a record. +gtoBuilderRecord :: (GEncodeProduct (Rep a), Generic a) => a -> BB.Builder +gtoBuilderRecord = productEncoder . from +{-# INLINE gtoBuilderRecord #-} + +data FieldDecoder i a = FieldDecoder !i !(Maybe a) !(Plan (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 + $ fmap (fmap (to .)) $ extractorRecord' + ("gextractorRecord :: Extractor " <> viaShow (typeRep (Proxy @ a))) + (from <$> def) + +-- | Generic implementation of 'extractor' for a record. +extractorRecord' :: (GSerialiseRecord f) + => Doc AnsiStyle + -> Maybe (f x) -- ^ default value (optional) + -> Schema -> Strategy' (Term -> f x) +extractorRecord' rep def (SRecord schs) = Strategy $ \decs -> do + let go :: FieldDecoder T.Text x -> Either WineryException (Term -> x) + go (FieldDecoder name def' p) = case lookupWithIndexV name schs of + 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 + Right getItem -> Right $ \case + TRecord xs -> maybe (error (show rep)) (getItem . snd) $ xs V.!? i + t -> throw $ InvalidTerm t + Left e -> Left e + unTransFusion (recordExtractor def) go +extractorRecord' rep _ s = throwStrategy $ UnexpectedSchema rep "a record" s +{-# INLINE gextractorRecord #-} + +-- | Synonym for 'gdecodeCurrentProduct' +gdecodeCurrentRecord :: (GDecodeProduct (Rep a), Generic a) => Decoder a +gdecodeCurrentRecord = to <$> productDecoder +{-# INLINE gdecodeCurrentRecord #-} + +-- | The 'Serialise' instance is generically defined for records. +-- +-- /"Remember thee! Yea, from the table of my memory I'll wipe away all trivial fond records."/ +newtype WineryRecord a = WineryRecord { unWineryRecord :: a } + +instance (GEncodeProduct (Rep a), GSerialiseRecord (Rep a), GDecodeProduct (Rep a), Generic a, Typeable a) => Serialise (WineryRecord a) where + schemaGen _ = gschemaGenRecord (Proxy @ a) + toBuilder = gtoBuilderRecord . unWineryRecord + extractor = WineryRecord <$> gextractorRecord Nothing + decodeCurrent = WineryRecord <$> gdecodeCurrentRecord + +-- | Encode all the fields +class GEncodeProduct f where + productEncoder :: f x -> BB.Builder + +instance GEncodeProduct U1 where + productEncoder _ = mempty + {-# INLINE productEncoder #-} + +instance (GEncodeProduct f, GEncodeProduct g) => GEncodeProduct (f :*: g) where + productEncoder (f :*: g) = productEncoder f <> productEncoder g + {-# INLINE productEncoder #-} + +instance Serialise a => GEncodeProduct (S1 c (K1 i a)) where + productEncoder (M1 (K1 a)) = toBuilder a + {-# INLINE productEncoder #-} + +instance GEncodeProduct f => GEncodeProduct (C1 c f) where + productEncoder (M1 a) = productEncoder a + {-# INLINE productEncoder #-} + +instance GEncodeProduct f => GEncodeProduct (D1 c f) where + productEncoder (M1 a) = productEncoder a + {-# INLINE productEncoder #-} + +class GDecodeProduct f where + productDecoder :: Decoder (f x) + +instance GDecodeProduct U1 where + productDecoder = pure U1 + +instance Serialise a => GDecodeProduct (K1 i a) where + productDecoder = K1 <$> decodeCurrent + {-# INLINE productDecoder #-} + +instance GDecodeProduct f => GDecodeProduct (M1 i c f) where + productDecoder = M1 <$> productDecoder + {-# INLINE productDecoder #-} + +instance (GDecodeProduct f, GDecodeProduct g) => GDecodeProduct (f :*: g) where + productDecoder = (:*:) <$> productDecoder <*> productDecoder + {-# INLINE productDecoder #-} + +class GSerialiseRecord f where + recordSchema :: proxy f -> SchemaGen [(T.Text, Schema)] + recordExtractor :: Maybe (f x) -> TransFusion (FieldDecoder T.Text) ((->) Term) (Term -> f x) + +instance (GSerialiseRecord f, GSerialiseRecord g) => GSerialiseRecord (f :*: g) where + recordSchema _ = (++) <$> recordSchema (Proxy @ f) <*> recordSchema (Proxy @ g) + recordExtractor def = (\f g -> (:*:) <$> f <*> g) + <$> recordExtractor ((\(x :*: _) -> x) <$> def) + <*> recordExtractor ((\(_ :*: x) -> x) <$> def) + {-# INLINE recordExtractor #-} + +instance (Serialise a, Selector c) => GSerialiseRecord (S1 c (K1 i a)) where + recordSchema _ = do + s <- getSchema (Proxy @ a) + pure [(T.pack $ selName (M1 undefined :: M1 i c (K1 i a) x), s)] + 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) + {-# INLINE recordExtractor #-} + +instance (GSerialiseRecord f) => GSerialiseRecord (C1 c f) where + recordSchema _ = recordSchema (Proxy @ f) + recordExtractor def = fmap M1 <$> recordExtractor (unM1 <$> def) + +instance (GSerialiseRecord f) => GSerialiseRecord (D1 c f) where + recordSchema _ = recordSchema (Proxy @ f) + recordExtractor def = fmap M1 <$> recordExtractor (unM1 <$> def) + +class GSerialiseProduct f where + productSchema :: proxy f -> SchemaGen [Schema] + productExtractor :: Compose (State Int) (TransFusion (FieldDecoder Int) ((->) Term)) (Term -> f x) + +instance GSerialiseProduct U1 where + productSchema _ = pure [] + productExtractor = pure (pure U1) + +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) + , i + 1) + +instance GSerialiseProduct f => GSerialiseProduct (M1 i c f) where + productSchema _ = productSchema (Proxy @ f) + productExtractor = fmap M1 <$> productExtractor + +instance (GSerialiseProduct f, GSerialiseProduct g) => GSerialiseProduct (f :*: g) where + productSchema _ = (++) <$> productSchema (Proxy @ f) <*> productSchema (Proxy @ g) + productExtractor = liftA2 (:*:) <$> productExtractor <*> productExtractor + +-- | Serialise a value as a product (omits field names). +-- +-- /"I get ideas about what's essential when packing my suitcase."/ +newtype WineryProduct a = WineryProduct { unWineryProduct :: a } + +instance (GEncodeProduct (Rep a), GSerialiseProduct (Rep a), GDecodeProduct (Rep a), Generic a, Typeable a) => Serialise (WineryProduct a) where + schemaGen _ = gschemaGenProduct (Proxy @ a) + toBuilder = gtoBuilderProduct . unWineryProduct + extractor = WineryProduct <$> gextractorProduct + decodeCurrent = WineryProduct <$> gdecodeCurrentProduct + +gschemaGenProduct :: forall proxy a. (Generic a, GSerialiseProduct (Rep a)) => proxy a -> SchemaGen Schema +gschemaGenProduct _ = SProduct . V.fromList <$> productSchema (Proxy @ (Rep a)) +{-# INLINE gschemaGenProduct #-} + +gtoBuilderProduct :: (Generic a, GEncodeProduct (Rep a)) => a -> BB.Builder +gtoBuilderProduct = productEncoder . from +{-# INLINE gtoBuilderProduct #-} + +-- | 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' +{-# INLINE gextractorProduct #-} + +-- | Generic implementation of 'extractor' for a record. +gdecodeCurrentProduct :: forall a. (GDecodeProduct (Rep a), Generic a) + => Decoder a +gdecodeCurrentProduct = to <$> productDecoder +{-# INLINE gdecodeCurrentProduct #-} + +extractorProduct' :: GSerialiseProduct f => Schema -> Strategy' (Term -> f x) +extractorProduct' sch + | Just schs <- strip sch = Strategy $ \recs -> do + 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 + else Left $ ProductTooSmall $ length schs + return $ \case + TProduct xs -> getItem $ maybe (throw $ InvalidTerm (TProduct xs)) id + $ xs V.!? i + t -> throw $ InvalidTerm t + unTransFusion (getCompose productExtractor `evalState` 0) go + where + strip (SProduct xs) = Just xs + strip (SRecord xs) = Just $ V.map snd xs + strip _ = Nothing +extractorProduct' sch = throwStrategy $ UnexpectedSchema "extractorProduct'" "a product" sch + +-- | The 'Serialise' instance is generically defined for variants. +-- +-- /"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 + schemaGen _ = gschemaGenVariant (Proxy @ a) + toBuilder = gtoBuilderVariant . unWineryVariant + extractor = WineryVariant <$> gextractorVariant + decodeCurrent = WineryVariant <$> gdecodeCurrentVariant + +-- | Generic implementation of 'schemaGen' for an ADT. +gschemaGenVariant :: forall proxy a. (GSerialiseVariant (Rep a), Typeable a, Generic a) => proxy a -> SchemaGen Schema +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 +{-# INLINE gtoBuilderVariant #-} + +-- | Generic implementation of 'extractor' for an ADT. +gextractorVariant :: forall a. (GSerialiseVariant (Rep a), Generic a, Typeable a) + => Extractor a +gextractorVariant = Extractor $ mkPlan $ \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) + Just f -> f sch `unStrategy` decs) schs0 + return $ \case + TVariant i _ v -> to $ maybe (throw InvalidTag) ($ v) $ ds' V.!? i + t -> throw $ InvalidTerm t + s -> throwStrategy $ UnexpectedSchema rep "a variant" s + where + 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 + +class GSerialiseVariant f where + variantCount :: proxy f -> Int + 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 + 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 + 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 + toBuilder = gtoBuilderVariant + extractor = gextractorVariant + decodeCurrent = gdecodeCurrentVariant + +deriving instance Serialise a => Serialise (Identity a) +deriving instance (Serialise a, Typeable b, Typeable k) => Serialise (Const a (b :: k)) + +deriving instance Serialise Any +deriving instance Serialise All +deriving instance Serialise a => Serialise (Down a) +deriving instance Serialise a => Serialise (Product a) +deriving instance Serialise a => Serialise (Sum a) +deriving instance Serialise a => Serialise (Dual a) +deriving instance Serialise a => Serialise (M.Last a) +deriving instance Serialise a => Serialise (M.First a) +deriving instance Serialise a => Serialise (S.Last a) +deriving instance Serialise a => Serialise (S.First a) +deriving instance Serialise a => Serialise (ZipList a) +deriving instance Serialise a => Serialise (Option a) +deriving instance Serialise a => Serialise (Max a) +deriving instance Serialise a => Serialise (Min a) +deriving instance (Typeable k, Typeable f, Typeable a, Serialise (f a)) => Serialise (Alt f (a :: k)) +deriving instance (Typeable j, Typeable k, Typeable f, Typeable g, Typeable a, Serialise (f (g a))) => Serialise (Compose f (g :: j -> k) (a :: j)) +#if MIN_VERSION_base(4,12,0) +deriving instance (Typeable k, Typeable f, Typeable a, Serialise (f a)) => Serialise (Ap f (a :: k)) +#endif + +instance (Typeable k, Typeable a, Typeable b, a ~ b) => Serialise ((a :: k) :~: b) where + schemaGen _ = pure $ SProduct [] + toBuilder = mempty + extractor = pure Refl + decodeCurrent = pure Refl + +instance (Serialise a, Serialise b) => Serialise (Arg a b) where + schemaGen = gschemaGenProduct + toBuilder = gtoBuilderProduct + extractor = gextractorProduct + decodeCurrent = gdecodeCurrentProduct + +instance Serialise a => Serialise (Complex a) where + schemaGen = gschemaGenProduct + toBuilder = gtoBuilderProduct + extractor = gextractorProduct + decodeCurrent = gdecodeCurrentProduct + +instance Serialise Void where + schemaGen _ = pure $ SVariant V.empty + toBuilder = mempty + extractor = Extractor $ Plan $ const $ throwStrategy "No extractor for Void" + decodeCurrent = error "No decodeCurrent for Void" diff --git a/src/Codec/Winery/Base.hs b/src/Codec/Winery/Base.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Winery/Base.hs @@ -0,0 +1,302 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveTraversable #-} +---------------------------------------------------------------------------- +-- | +-- Module : Codec.Winery.Base +-- Copyright : (c) Fumiaki Kinoshita 2019 +-- License : BSD3 +-- Stability : Provisional +-- +-- Maintainer : Fumiaki Kinoshita +-- +-- Basic types +-- +----------------------------------------------------------------------------- +module Codec.Winery.Base + ( Tag(..) + , Schema + , SchemaP(..) + , currentSchemaVersion + , bootstrapSchema + , Term(..) + , Extractor(..) + , Strategy' + , StrategyBind(..) + , StrategyEnv(..) + , Plan(..) + , unwrapExtractor + , WineryException(..) + , prettyWineryException) + where + +import Control.Applicative +import Control.Exception +import Data.Aeson as J +import qualified Data.ByteString as B +import Data.Dynamic +import qualified Data.HashMap.Strict as HM +import Data.Int +import Data.String +import qualified Data.Text as T +import Data.Text.Prettyprint.Doc hiding ((<>), SText, SChar) +import Data.Text.Prettyprint.Doc.Render.Terminal +import Data.Time +import Data.Typeable +import qualified Data.Vector as V +import Codec.Winery.Internal +import Data.Word +import GHC.Generics (Generic) +import GHC.Exts (IsList(..)) + +-- | Tag is an extra value that can be attached to a schema. +data Tag = TagInt !Int + | TagStr !T.Text + | TagList ![Tag] + deriving (Show, Read, Eq, Generic) + +instance IsString Tag where + fromString = TagStr . fromString + +instance IsList Tag where + type Item Tag = Tag + fromList = TagList + toList (TagList xs) = xs + toList _ = [] + +instance Pretty Tag where + pretty (TagInt i) = pretty i + pretty (TagStr s) = pretty s + pretty (TagList xs) = list (map pretty xs) + +-- | The current version of the schema +currentSchemaVersion :: Word8 +currentSchemaVersion = 4 + +-- | A schema preserves structure of a datatype, allowing users to inspect +-- the data regardless of the current implementation. +-- +-- /"Yeah, it’s just a memento. Just, you know, from the first time we met."/ +type Schema = SchemaP Int + +-- | The basic schema datatype +data SchemaP a = SFix !(SchemaP a) -- ^ binds a fixpoint + | SVar !a -- ^ @SVar n@ refers to the n-th innermost fixpoint + | SVector !(SchemaP a) + | SProduct !(V.Vector (SchemaP a)) + | SRecord !(V.Vector (T.Text, SchemaP a)) + | SVariant !(V.Vector (T.Text, SchemaP a)) + | SBool + | SChar + | SWord8 + | SWord16 + | SWord32 + | SWord64 + | SInt8 + | SInt16 + | SInt32 + | SInt64 + | SInteger + | SFloat + | SDouble + | SBytes + | SText + | SUTCTime -- ^ nanoseconds from POSIX epoch + | STag !Tag !(SchemaP a) + | SLet !(SchemaP a) !(SchemaP a) + deriving (Show, Read, Eq, Generic, Functor, Foldable, Traversable) + +instance Pretty a => Pretty (SchemaP a) where + pretty = \case + SProduct [] -> "()" + SBool -> "Bool" + SChar -> "Char" + SWord8 -> "Word8" + SWord16 -> "Word16" + SWord32 -> "Word32" + SWord64 -> "Word64" + SInt8 -> "Int8" + SInt16 -> "Int16" + SInt32 -> "Int32" + SInt64 -> "Int64" + SInteger -> "Integer" + SFloat -> "Float" + SDouble -> "Double" + SBytes -> "ByteString" + SText -> "Text" + SUTCTime -> "UTCTime" + SVector s -> "[" <> pretty s <> "]" + SProduct ss -> tupled $ map pretty (V.toList ss) + SRecord ss -> align $ encloseSep "{ " " }" ", " [group $ nest 2 $ sep [pretty k, "::" <+> pretty v] | (k, v) <- V.toList ss] + SVariant ss -> align $ encloseSep "" "" (flatAlt "| " " | ") + [ nest 2 $ sep $ pretty k : case vs of + SProduct xs -> map pretty $ V.toList xs + SRecord xs -> [pretty (SRecord xs)] + s -> [pretty s] | (k, vs) <- V.toList ss] + SFix sch -> group $ nest 2 $ sep ["μ", enclose "{ " " }" $ pretty sch] + SVar i -> "$" <> pretty i + STag t s -> nest 2 $ sep [pretty t <> ":", pretty s] + SLet s t -> sep ["let" <+> pretty s, pretty t] + +-- | Obtain the schema of the schema corresponding to the specified version. +bootstrapSchema :: Word8 -> Either WineryException Schema +bootstrapSchema 4 = Right + $ SFix $ SVariant [("SFix",SProduct [SVar 0]),("SVar",SProduct [SInteger]),("SVector",SProduct [SVar 0]),("SProduct",SProduct [SVector (SVar 0)]),("SRecord",SProduct [SVector (SProduct [SText,SVar 0])]),("SVariant",SProduct [SVector (SProduct [SText,SVar 0])]),("SBool",SProduct []),("SChar",SProduct []),("SWord8",SProduct []),("SWord16",SProduct []),("SWord32",SProduct []),("SWord64",SProduct []),("SInt8",SProduct []),("SInt16",SProduct []),("SInt32",SProduct []),("SInt64",SProduct []),("SInteger",SProduct []),("SFloat",SProduct []),("SDouble",SProduct []),("SBytes",SProduct []),("SText",SProduct []),("SUTCTime",SProduct []),("STag",SProduct [SFix (SVariant [("TagInt",SProduct [SInteger]),("TagStr",SProduct [SText]),("TagList",SProduct [SVector (SVar 0)])]),SVar 0]),("SLet",SProduct [SVar 0,SVar 0])] +bootstrapSchema n = Left $ UnsupportedSchemaVersion n + +-- | Common representation for any winery data. +-- Handy for prettyprinting winery-serialised data. +data Term = TBool !Bool + | TChar !Char + | TWord8 !Word8 + | TWord16 !Word16 + | TWord32 !Word32 + | TWord64 !Word64 + | TInt8 !Int8 + | TInt16 !Int16 + | TInt32 !Int32 + | TInt64 !Int64 + | TInteger !Integer + | TFloat !Float + | TDouble !Double + | TBytes !B.ByteString + | TText !T.Text + | TUTCTime !UTCTime + | TVector !(V.Vector Term) + | TProduct !(V.Vector Term) + | TRecord !(V.Vector (T.Text, Term)) + | TVariant !Int !T.Text Term + deriving Show + +instance J.ToJSON Term where + toJSON (TBool b) = J.toJSON b + toJSON (TChar c) = J.toJSON c + toJSON (TWord8 w) = J.toJSON w + toJSON (TWord16 w) = J.toJSON w + toJSON (TWord32 w) = J.toJSON w + toJSON (TWord64 w) = J.toJSON w + toJSON (TInt8 w) = J.toJSON w + toJSON (TInt16 w) = J.toJSON w + toJSON (TInt32 w) = J.toJSON w + toJSON (TInt64 w) = J.toJSON w + toJSON (TInteger w) = J.toJSON w + toJSON (TFloat x) = J.toJSON x + toJSON (TDouble x) = J.toJSON x + toJSON (TBytes bs) = J.toJSON (B.unpack bs) + toJSON (TText t) = J.toJSON t + toJSON (TUTCTime t) = J.toJSON t + toJSON (TVector xs) = J.toJSON xs + toJSON (TProduct xs) = J.toJSON xs + toJSON (TRecord xs) = J.toJSON $ HM.fromList $ V.toList xs + toJSON (TVariant _ "Just" x) = J.toJSON x + toJSON (TVariant _ "Nothing" _) = J.Null + toJSON (TVariant _ t x) = J.object ["tag" J..= J.toJSON t, "contents" J..= J.toJSON x] + +instance Pretty Term where + pretty (TWord8 i) = pretty i + pretty (TWord16 i) = pretty i + pretty (TWord32 i) = pretty i + pretty (TWord64 i) = pretty i + pretty (TInt8 i) = pretty i + pretty (TInt16 i) = pretty i + pretty (TInt32 i) = pretty i + pretty (TInt64 i) = pretty i + pretty (TInteger i) = pretty i + pretty (TBytes s) = pretty $ show s + pretty (TText s) = pretty s + pretty (TVector xs) = list $ map pretty (V.toList xs) + pretty (TBool x) = pretty x + pretty (TChar x) = pretty x + pretty (TFloat x) = pretty x + pretty (TDouble x) = pretty x + pretty (TProduct xs) = tupled $ map pretty (V.toList xs) + pretty (TRecord xs) = align $ encloseSep "{ " " }" ", " [group $ nest 2 $ vsep [pretty k <+> "=", pretty v] | (k, v) <- V.toList xs] + pretty (TVariant _ tag (TProduct xs)) = group $ nest 2 $ sep $ pretty tag : map pretty (V.toList xs) + pretty (TVariant _ tag x) = group $ nest 2 $ sep [pretty tag, pretty x] + pretty (TUTCTime t) = pretty (show t) + +-- | 'Extractor' is a 'Plan' that creates a function to extract a value from Term. +-- +-- The 'Applicative' instance can be used to build a user-defined extractor. +-- 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) } + deriving Functor + +instance Applicative Extractor where + pure = Extractor . pure . pure + Extractor f <*> Extractor x = Extractor $ (<*>) <$> f <*> x + +instance Alternative Extractor where + empty = Extractor empty + Extractor f <|> Extractor g = Extractor $ f <|> g + +data StrategyBind = DynDecoder !Dynamic -- ^ A fixpoint of a decoder + | BoundSchema !Int !Schema + -- ^ schema bound by 'SLet'. 'Int' is a basis of the variables + +data StrategyEnv = StrategyEnv !Int ![StrategyBind] + +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 +{-# INLINE unwrapExtractor #-} + +-- | Exceptions thrown when by an extractor +data WineryException = UnexpectedSchema !(Doc AnsiStyle) !(Doc AnsiStyle) !Schema + | FieldNotFound !(Doc AnsiStyle) !T.Text ![T.Text] + | TypeMismatch !Int !TypeRep !TypeRep + | ProductTooSmall !Int + | UnboundVariable !Int + | EmptyInput + | WineryMessage !(Doc AnsiStyle) + | UnsupportedSchemaVersion !Word8 + deriving Show + +instance Exception WineryException + +instance IsString WineryException where + fromString = WineryMessage . fromString + +-- | Pretty-print 'WineryException' +prettyWineryException :: WineryException -> Doc AnsiStyle +prettyWineryException = \case + UnexpectedSchema subject expected actual -> annotate bold subject + <+> "expects" <+> annotate (color Green <> bold) expected + <+> "but got " <+> pretty actual + FieldNotFound rep x xs -> rep <> ": field or constructor " <> pretty x <> " not found in " <> pretty xs + TypeMismatch i s t -> "A type mismatch in variable" + <+> pretty i <> ":" + <+> "expected" <> viaShow s + <+> "but got " <> viaShow t + ProductTooSmall i -> "The product is too small; expecting " <> pretty i + UnboundVariable i -> "Unbound variable: " <> pretty i + EmptyInput -> "Unexpected empty string" + UnsupportedSchemaVersion i -> "Unsupported schema version: " <> pretty i + WineryMessage a -> a diff --git a/src/Codec/Winery/Internal.hs b/src/Codec/Winery/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Winery/Internal.hs @@ -0,0 +1,265 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +---------------------------------------------------------------------------- +-- | +-- Module : Codec.Winery.Internal +-- Copyright : (c) Fumiaki Kinoshita 2019 +-- License : BSD3 +-- Stability : Experimental +-- +-- Maintainer : Fumiaki Kinoshita +-- +-- Internal functions and datatypes +-- +----------------------------------------------------------------------------- +module Codec.Winery.Internal + ( unsignedVarInt + , varInt + , Decoder + , evalDecoder + , State(..) + , evalState + , decodeVarInt + , decodeVarIntFinite + , getWord8 + , getWord16 + , getWord32 + , getWord64 + , DecodeException(..) + , indexDefault + , unsafeIndexV + , lookupWithIndexV + , Strategy(..) + , throwStrategy + , TransFusion(..) + )where + +import Control.Applicative +import Control.Exception +import Control.Monad +import Control.Monad.Fix +import qualified Data.ByteString as B +import qualified Data.ByteString.FastBuilder as BB +import qualified Data.ByteString.Internal as B +import qualified Data.ByteString.Builder.Prim.Internal as BPI +import Data.Bits +import Data.Monoid ((<>)) +import Data.String +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector as V +import Data.Word +import Foreign.ForeignPtr +import Foreign.Storable +import Foreign.Ptr +import System.Endian + +unsignedVarInt :: (Bits a, Integral a) => a -> BB.Builder +unsignedVarInt n + | n < 0x80 = BB.word8 (fromIntegral n) + | otherwise = BB.word8 (fromIntegral n `setBit` 7) <> uvarInt (unsafeShiftR n 7) +{-# INLINE unsignedVarInt #-} + +varInt :: (Bits a, Integral a) => a -> BB.Builder +varInt n + | n < 0 = case negate n of + n' + | n' < 0x40 -> BB.word8 (fromIntegral n' `setBit` 6) + | otherwise -> BB.word8 (0xc0 .|. fromIntegral n') <> uvarInt (unsafeShiftR n' 6) + | n < 0x40 = BB.word8 (fromIntegral n) + | otherwise = BB.word8 (fromIntegral n `setBit` 7 `clearBit` 6) <> uvarInt (unsafeShiftR n 6) +{-# RULES "varInt/Int" varInt = varIntFinite #-} +{-# INLINEABLE[1] varInt #-} + +varIntFinite :: Int -> BB.Builder +varIntFinite = BB.primBounded (BPI.boudedPrim 10 writeIntFinite) + +writeWord8 :: Word8 -> Ptr Word8 -> IO (Ptr Word8) +writeWord8 w p = do + poke p w + return $! plusPtr p 1 + +writeIntFinite :: Int -> Ptr Word8 -> IO (Ptr Word8) +writeIntFinite !n + | n < 0 = case negate n of + n' + | n' < 0x40 -> writeWord8 (fromIntegral n' `setBit` 6) + | otherwise -> + writeWord8 (0xc0 .|. fromIntegral n') >=> + writeUnsignedFinite pure (unsafeShiftR n' 6) + | n < 0x40 = writeWord8 (fromIntegral n) + | otherwise = writeWord8 (fromIntegral n `setBit` 7 `clearBit` 6) >=> + writeUnsignedFinite pure (unsafeShiftR n 6) +{-# INLINE writeIntFinite #-} + +writeUnsignedFinite :: (Ptr Word8 -> IO r) -> Int -> Ptr Word8 -> IO r +writeUnsignedFinite k = go + where + go m + | m < 0x80 = writeWord8 (fromIntegral m) >=> k + | otherwise = writeWord8 (setBit (fromIntegral m) 7) >=> go (unsafeShiftR m 7) +{-# INLINE writeUnsignedFinite #-} + +uvarInt :: (Bits a, Integral a) => a -> BB.Builder +uvarInt = go where + go m + | m < 0x80 = BB.word8 (fromIntegral m) + | otherwise = BB.word8 (setBit (fromIntegral m) 7) <> go (unsafeShiftR m 7) +{-# INLINE uvarInt #-} + +-- | A state monad. The reason being not @State@ from transformers is to +-- allow coercion for newtype deriving and DerivingVia. +newtype State s a = State { runState :: s -> (a, s) } + deriving Functor + +evalState :: State s a -> s -> a +evalState m = fst . runState m +{-# INLINE evalState #-} + +instance Applicative (State s) where + pure a = State $ \s -> (a, s) + m <*> k = State $ \s -> case runState m s of + (f, s') -> case runState k s' of + (a, s'') -> (f a, s'') + +instance Monad (State s) where + m >>= k = State $ \s -> case runState m s of + (a, s') -> runState (k a) s' + +instance MonadFix (State s) where + mfix f = State $ \s -> fix $ \ ~(a, _) -> runState (f a) s + +-- | The Decoder monad +type Decoder = State B.ByteString + +-- | Run a 'Decoder' +evalDecoder :: Decoder a -> B.ByteString -> a +evalDecoder = evalState +{-# INLINE evalDecoder #-} + +getWord8 :: Decoder Word8 +getWord8 = State $ \bs -> case B.uncons bs of + Nothing -> throw InsufficientInput + Just (x, bs') -> (x, bs') +{-# INLINE getWord8 #-} + +-- | Exceptions thrown by a 'Decoder' +data DecodeException = InsufficientInput + | IntegerOverflow + | InvalidTag deriving (Eq, Show, Read) +instance Exception DecodeException + +decodeVarIntBase :: (Num a, Bits a) => Decoder a -> Decoder a +decodeVarIntBase body = getWord8 >>= \case + n | testBit n 7 -> do + m <- body + if testBit n 6 + then return $! negate $ unsafeShiftL m 6 .|. fromIntegral n .&. 0x3f + else return $! unsafeShiftL m 6 .|. clearBit (fromIntegral n) 7 + | testBit n 6 -> return $ negate $ fromIntegral $ clearBit n 6 + | otherwise -> return $ fromIntegral n +{-# INLINE decodeVarIntBase #-} + +decodeVarInt :: (Num a, Bits a) => Decoder a +decodeVarInt = decodeVarIntBase $ getWord8 >>= go + where + go n + | testBit n 7 = do + m <- getWord8 >>= go + return $! unsafeShiftL m 7 .|. clearBit (fromIntegral n) 7 + | otherwise = return $ fromIntegral n +{-# INLINE decodeVarInt #-} + +decodeVarIntFinite :: forall a. (Num a, FiniteBits a) => Decoder a +decodeVarIntFinite = decodeVarIntBase $ getWord8 >>= go 7 + where + go w n + | testBit n 7 = do + m <- getWord8 >>= go (w + 7) + return $! unsafeShiftL m 7 .|. clearBit (fromIntegral n) 7 + | w + 7 - countLeadingZeros n < finiteBitSize (0 :: a) = return $ fromIntegral n + | otherwise = throw IntegerOverflow +{-# INLINABLE[1] decodeVarIntFinite #-} +{-# 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)) + else throw InsufficientInput + +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)) + else throw InsufficientInput + +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)) + else throw InsufficientInput + +unsafeIndexV :: U.Unbox a => String -> U.Vector a -> Int -> a +unsafeIndexV err xs i + | i >= U.length xs || i < 0 = error err + | otherwise = U.unsafeIndex xs i +{-# INLINE unsafeIndexV #-} + +lookupWithIndexV :: Eq k => k -> V.Vector (k, v) -> Maybe (Int, v) +lookupWithIndexV k v = (\i -> (i, snd $ V.unsafeIndex v i)) + <$> V.findIndex ((k==) . fst) v +{-# INLINE lookupWithIndexV #-} + +indexDefault :: a -> [a] -> Int -> a +indexDefault err xs i = case drop i xs of + x : _ -> x + _ -> err + +-- | A monad with @Reader [r]@ and @Either WineryException@ combined, used internally +-- to build an extractor. +-- @r@ is used to share environment such as extractors for fixpoints. +newtype Strategy e r a = Strategy { unStrategy :: r -> Either e a } + deriving Functor + +instance Applicative (Strategy e r) where + pure = return + (<*>) = ap + +instance Monad (Strategy e r) where + return = Strategy . const . Right + m >>= k = Strategy $ \decs -> case unStrategy m decs of + Right a -> unStrategy (k a) decs + Left e -> Left e + +instance IsString e => Alternative (Strategy e r) where + empty = Strategy $ const $ Left "empty" + Strategy a <|> Strategy b = Strategy $ \decs -> case a decs of + Left _ -> b decs + Right x -> Right x + +instance MonadFix (Strategy e r) where + mfix f = Strategy $ \r -> mfix $ \a -> unStrategy (f a) r + {-# INLINE mfix #-} + +throwStrategy :: e -> Strategy e r a +throwStrategy = Strategy . const . Left + +-- | A Bazaar (chain of indexed store comonad)-like structure which instead +-- works for natural transformations. +newtype TransFusion f g a = TransFusion { unTransFusion :: forall h. Applicative h => (forall x. f x -> h (g x)) -> h a } + +instance Functor (TransFusion f g) where + fmap f (TransFusion m) = TransFusion $ \k -> fmap f (m k) + {-# INLINE fmap #-} + +instance Applicative (TransFusion f g) where + pure a = TransFusion $ \_ -> pure a + TransFusion a <*> TransFusion b = TransFusion $ \k -> a k <*> b k + {-# INLINE (<*>) #-} diff --git a/src/Codec/Winery/Query.hs b/src/Codec/Winery/Query.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Winery/Query.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE DeriveFunctor #-} +---------------------------------------------------------------------------- +-- | +-- Module : Codec.Winery.Query +-- Copyright : (c) Fumiaki Kinoshita 2019 +-- License : BSD3 +-- Stability : Experimental +-- +-- Maintainer : Fumiaki Kinoshita +-- +-- Building blocks for winery queries. +-- +----------------------------------------------------------------------------- +module Codec.Winery.Query (Query(..) + , invalid + , list + , range + , field + , con + , select) where + +import Prelude hiding ((.), id) +import Control.Applicative +import Control.Category +import Codec.Winery +import Codec.Winery.Internal +import Data.Typeable +import qualified Data.Text as T +import qualified Data.Vector as V + +-- | Query is a transformation between 'Extractor's. +-- Like jq, this returns a list of values. +newtype Query a b = Query + { runQuery :: Extractor [a] -> Extractor [b] } + deriving Functor + +instance Category Query where + id = Query id + Query f . Query g = Query $ f . g + +instance Applicative (Query a) where + pure a = Query $ const $ pure [a] + Query f <*> Query g = Query $ \d -> (<*>) <$> f d <*> g d + +instance Alternative (Query a) where + empty = Query $ const $ pure [] + Query f <|> Query g = Query $ \d -> (++) <$> f d <*> g d + +-- | Throw an error. +invalid :: WineryException -> Query a b +invalid = Query . const . Extractor . Plan . const . throwStrategy + +-- | Takes a list and traverses on it. +list :: Typeable a => Query a a +list = Query $ fmap concat . extractListBy + +-- | Takes a list and enumerates elements in the specified range. +-- Like Python's array slicing, negative numbers counts from the last element. +range :: Typeable a => Int -> Int -> Query a a +range i j = Query $ fmap (\v -> foldMap id + $ V.backpermute v (V.enumFromTo (i `mod` V.length v) (j `mod` V.length v))) + . extractListBy + +-- | Takes a record and extracts the specified field. +field :: Typeable a => T.Text -> Query a a +field name = Query $ \d -> buildExtractor $ extractFieldBy d name + +-- | Takes a variant and returns a value when the constructor matches. +con :: Typeable a => T.Text -> Query a a +con name = Query $ \d -> buildExtractor $ extractConstructorBy (d, name, id) (pure []) + +-- | 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 + 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 new file mode 100644 --- /dev/null +++ b/src/Codec/Winery/Query/Parser.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GADTs #-} +---------------------------------------------------------------------------- +-- | +-- Module : Codec.Winery.Query.Parser +-- Copyright : (c) Fumiaki Kinoshita 2019 +-- License : BSD3 +-- Stability : Experimental +-- +-- Maintainer : Fumiaki Kinoshita +-- +-- The language for winery queries +-- +-- See the Pretty-printing section of README.md for examples. +-- +----------------------------------------------------------------------------- +module Codec.Winery.Query.Parser (parseQuery) where + +import Prelude hiding ((.), id) +import Control.Category +import Codec.Winery.Query +import Text.Megaparsec +import Text.Megaparsec.Char +import qualified Text.Megaparsec.Char.Lexer as L +import qualified Data.Text as T +import Data.Text.Prettyprint.Doc (Doc, hsep) +import Data.Typeable +import Data.Void + +type Parser = Parsec Void T.Text + +symbol :: T.Text -> Parser T.Text +symbol = L.symbol space + +name :: Parser T.Text +name = fmap T.pack (some (alphaNumChar <|> oneOf ("_\'" :: [Char])) "field name") + +parseQuery :: Typeable a => Parser (Query (Doc a) (Doc a)) +parseQuery = foldr (.) id <$> sepBy1 parseTerms (symbol "|") + +-- | Space-separated list of terms translate to a tabular output, applying the +-- queries in parallel +parseTerms :: Typeable a => Parser (Query (Doc a) (Doc a)) +parseTerms = fmap hsep . sequenceA <$> sepBy1 parseTerm space + +parseTerm :: Typeable a => Parser (Query (Doc a) (Doc a)) +parseTerm = L.lexeme space $ choice + [ char '.' >> choice + [ do + _ <- char '[' + i <- optional L.decimal + j <- optional (symbol ":" >> L.decimal) + _ <- char ']' + return $ range (maybe 0 id i) (maybe (-1) id j) + , field <$> name + , return id + ] + ] diff --git a/src/Codec/Winery/Test.hs b/src/Codec/Winery/Test.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Winery/Test.hs @@ -0,0 +1,249 @@ +{-# LANGUAGE Rank2Types, ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +---------------------------------------------------------------------------- +-- | +-- Module : Codec.Winery.Test +-- Copyright : (c) Fumiaki Kinoshita 2019 +-- License : BSD3 +-- Stability : Experimental +-- +-- Maintainer : Fumiaki Kinoshita +-- +-- A test framework that allows you to test all related Serialise instances +-- with automatically-generated test cases +-- +----------------------------------------------------------------------------- +module Codec.Winery.Test + ( -- * Generating tests + TestGen(..) + , printTests + -- * Test cases + , Tested(..) + , testCase + -- * Running tests + , allTests + , mergeTests + ) where + +import Test.HUnit +import qualified Data.Map as M +import qualified Data.HashMap.Strict as HM +import qualified Data.ByteString as B +import Data.Functor.Identity +import Data.Hashable +import Data.Proxy +import qualified Data.Sequence as S +import Data.Typeable +import Codec.Winery +import Data.Word +import Data.Void +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as UV +import GHC.Generics +import Text.Show +import qualified Data.Text as T + +-- | Construct a test case. +testCase :: (Show a, Eq a, Serialise a) + => Schema -- ^ the schema + -> B.ByteString -- ^ serialised + -> a -- ^ expected + -> Test +testCase sch bs expected = case getDecoder sch of + Left err -> TestCase $ assertFailure (show err) + Right f -> expected ~=? evalDecoder f bs + +-- | Merge multiple tests into one. +mergeTests :: M.Map TypeRep [Test] -> Test +mergeTests = TestList . concatMap (\(k, v) -> map (show k ~:) v) . M.toList + +-- | Gather all test cases involved in the specified type. +allTests :: forall a. (TestGen a, Tested a) => M.Map TypeRep [Test] +allTests = M.insertWith (++) (typeRep (Proxy @ a)) (testCases @ a) (inheritedTests (Proxy @ a)) + +-- | Types with concrete test cases. +-- +-- /"Doubt is useful, it keeps faith a living thing. After all, you cannot know +-- the strength of your faith until it has been tested."/ +class TestGen a => Tested a where + -- | List of test cases for the type. + testCases :: [Test] + +-- these are already covered by the QuickCheck tests from winery +instance Tested Void where testCases = [] +instance Tested Bool where testCases = [] +instance Tested Int where testCases = [] +instance Tested Word8 where testCases = [] +instance Tested Word16 where testCases = [] +instance Tested Word32 where testCases = [] +instance Tested Word64 where testCases = [] +instance Tested Float where testCases = [] +instance Tested Double where testCases = [] +instance Tested () where testCases = [] +instance Tested Char where testCases = [] +instance Tested T.Text where testCases = [] +instance Tested B.ByteString where testCases = [] +instance Tested a => Tested (Identity a) where + testCases = testCases @ a +instance Tested a => Tested (S.Seq a) where testCases = [] +instance Tested a => Tested [a] where testCases = [] +instance (Tested a, Tested b) => Tested (Either a b) where testCases = [] +instance (Tested a, Tested b) => Tested (a, b) where testCases = [] +instance (Tested a, Tested b, Tested c) => Tested (a, b, c) where testCases = [] +instance (Tested a, Tested b, Tested c, Tested d) => Tested (a, b, c, d) where testCases = [] +instance Tested a => Tested (V.Vector a) where testCases = [] +instance (UV.Unbox a, Tested a) => Tested (UV.Vector a) where testCases = [] +instance (Hashable k, Tested k, Tested a) => Tested (HM.HashMap k a) where testCases = [] +instance (Ord k, Tested k, Tested a) => Tested (M.Map k a) where testCases = [] + +-- | Generate test cases and print them to the standard output. +printTests :: forall a. (TestGen a, Serialise a, Show a) => IO () +printTests = putStrLn $ showTests (genTestCases :: [a]) + +showTests :: (Serialise a, Show a) => [a] -> String +showTests xs = showListWith ppTest xs "" + +ppTest :: (Serialise a, Show a) => a -> ShowS +ppTest a = showString "testCase " + . showsPrec 11 (schema [a]) + . showChar ' ' + . showsPrec 11 (serialiseOnly a) + . showChar ' ' + . showsPrec 11 a + +-- | A class to provide test values and gather tests for its components. +-- It is recommended to use the generic default methods. +class Typeable a => TestGen a where + -- | A list of values that can be used as test cases. + -- It should contain at least one value as long as there is a non-bottom value + -- in the type. + genTestCases :: [a] + + -- | Inherited set of test cases for each type it involves. + inheritedTests :: Proxy a -> M.Map TypeRep [Test] + + default genTestCases :: (Generic a, GTestGen (Rep a)) => [a] + genTestCases = fmap to ggenTestCases + + default inheritedTests :: (GTestGen (Rep a)) => Proxy a -> M.Map TypeRep [Test] + inheritedTests _ = ginheritedTests (Proxy @ (Rep a)) + +class GTestGen f where + ggenTestCases :: [f x] + ginheritedTests :: proxy f -> M.Map TypeRep [Test] + +instance GTestGen V1 where + ggenTestCases = mempty + ginheritedTests _ = mempty + +instance GTestGen U1 where + ggenTestCases = [U1] + ginheritedTests _ = mempty + +instance GTestGen f => GTestGen (Rec1 f) where + ggenTestCases = fmap Rec1 ggenTestCases + ginheritedTests _ = ginheritedTests (Proxy @ f) + +instance (Tested c, TestGen c) => GTestGen (K1 i c) where + ggenTestCases = fmap K1 genTestCases + ginheritedTests _ = allTests @ c + +instance GTestGen f => GTestGen (M1 i c f) where + ggenTestCases = fmap M1 ggenTestCases + ginheritedTests _ = ginheritedTests (Proxy @ f) + +instance (GTestGen f, GTestGen g) => GTestGen (f :+: g) where + ggenTestCases = fmap L1 ggenTestCases ++ fmap R1 ggenTestCases + ginheritedTests _ = ginheritedTests (Proxy @ f) + `mappend` ginheritedTests (Proxy @ g) + +instance (GTestGen f, GTestGen g) => GTestGen (f :*: g) where + ggenTestCases = ((:*:) <$> ggenTestCases <*> xs) + ++ ((:*:) <$> take 1 ggenTestCases <*> ys) + where + (xs, ys) = splitAt 1 ggenTestCases + ginheritedTests _ = ginheritedTests (Proxy @ f) + `mappend` ginheritedTests (Proxy @ g) + +deriving instance TestGen a => TestGen (Identity a) +instance TestGen () +instance TestGen Bool +instance (Tested a, Tested b) => TestGen (a, b) +instance (Tested a, Tested b, Tested c) => TestGen (a, b, c) +instance (Tested a, Tested b, Tested c, Tested d) => TestGen (a, b, c, d) +instance (Tested a, Tested b) => TestGen (Either a b) + +instance Tested a => TestGen [a] where + genTestCases = [[]] + inheritedTests _ = allTests @ a + +instance Tested a => TestGen (S.Seq a) where + genTestCases = [mempty] + inheritedTests _ = allTests @ a + +instance Tested a => TestGen (V.Vector a) where + genTestCases = [V.empty] + inheritedTests _ = allTests @ a + +instance (UV.Unbox a, Tested a) => TestGen (UV.Vector a) where + genTestCases = [UV.empty] + inheritedTests _ = allTests @ a + +instance (Hashable k, Tested k, Tested a) => TestGen (HM.HashMap k a) where + genTestCases = HM.singleton <$> genTestCases <*> genTestCases + inheritedTests _ = allTests @ k `mappend` allTests @ a + +instance (Ord k, Tested k, Tested a) => TestGen (M.Map k a) where + genTestCases = [M.empty] + inheritedTests _ = allTests @ k `mappend` allTests @ a + +instance TestGen Void where + genTestCases = [] + inheritedTests = mempty + +instance TestGen Int where + genTestCases = [42] + inheritedTests = mempty + +instance TestGen Word8 where + genTestCases = [42] + inheritedTests = mempty + +instance TestGen Word16 where + genTestCases = [42] + inheritedTests = mempty + +instance TestGen Word32 where + genTestCases = [42] + inheritedTests = mempty + +instance TestGen Word64 where + genTestCases = [42] + inheritedTests = mempty + +instance TestGen Float where + genTestCases = [pi] + inheritedTests = mempty + +instance TestGen Double where + genTestCases = [pi] + inheritedTests = mempty + +instance TestGen Char where + genTestCases = ['X'] + inheritedTests = mempty + +instance TestGen T.Text where + genTestCases = [mempty] + inheritedTests = mempty + +instance TestGen B.ByteString where + genTestCases = [mempty] + inheritedTests = mempty diff --git a/src/Data/Winery.hs b/src/Data/Winery.hs --- a/src/Data/Winery.hs +++ b/src/Data/Winery.hs @@ -1,1273 +1,5 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeApplications #-} -#if __GLASGOW_HASKELL__ < 806 -{-# LANGUAGE TypeInType #-} -#endif -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE StandaloneDeriving #-} ----------------------------------------------------------------------------- --- | --- Module : Data.Winery --- Copyright : (c) Fumiaki Kinoshita 2019 --- License : BSD3 --- Stability : Provisional --- --- Maintainer : Fumiaki Kinoshita --- --- The standard interface of winery serialisation library --- ------------------------------------------------------------------------------ -module Data.Winery - ( Schema - , SchemaP(..) - , Tag(..) - , Serialise(..) - , testSerialise - , DecodeException(..) - , schema - -- * Standalone serialisation - , toBuilderWithSchema - , serialise - , deserialise - , deserialiseBy - , deserialiseTerm - , splitSchema - , writeFileSerialise - -- * Separate serialisation - , serialiseSchema - , deserialiseSchema - , Extractor(..) - , unwrapExtractor - , Decoder - , evalDecoder - , serialiseOnly - , getDecoder - , getDecoderBy - -- * Decoding combinators - , Term(..) - , Subextractor(..) - , buildExtractor - , extractListBy - , extractField - , extractFieldBy - , extractConstructor - , extractConstructorBy - , extractVoid - , ExtractException(..) - -- * Variable-length quantity - , VarInt(..) - -- * Internal - , WineryException(..) - , prettyWineryException - , unexpectedSchema - , SchemaGen - , getSchema - , Plan(..) - , mkPlan - -- * DerivingVia - , WineryRecord(..) - , WineryVariant(..) - , WineryProduct(..) - -- * Generic implementations (for old GHC / custom instances) - , GSerialiseRecord - , gschemaGenRecord - , GEncodeProduct - , gtoBuilderRecord - , gextractorRecord - , gdecodeCurrentRecord - , GSerialiseVariant - , gschemaGenVariant - , gtoBuilderVariant - , gextractorVariant - , gschemaGenProduct - , gtoBuilderProduct - , gdecodeCurrentVariant - , gextractorProduct - , gdecodeCurrentProduct - -- * Bundles - , BundleSerialise(..) - , bundleRecord - , bundleRecordDefault - , bundleVariant - -- * Preset schema - , bootstrapSchema - )where - -import Control.Applicative -import Control.Exception -import Control.Monad.Reader -import qualified Data.ByteString as B -import qualified Data.ByteString.FastBuilder as BB -import qualified Data.ByteString.Lazy as BL -import Data.Bits -import Data.Complex -import Data.Dynamic -import Data.Fixed -import Data.Functor.Compose -import Data.Functor.Identity -import Data.List (elemIndex) -import Data.Monoid as M -import Data.Proxy -import Data.Ratio -import Data.Scientific (Scientific, scientific, coefficient, base10Exponent) -import Data.Semigroup as S -import Data.Hashable (Hashable) -import qualified Data.HashMap.Strict as HM -import Data.Int -import qualified Data.IntMap as IM -import qualified Data.IntSet as IS -import qualified Data.Map as M -import Data.Ord -import Data.Word -import Data.Winery.Base as W -import Data.Winery.Internal -import qualified Data.Sequence as Seq -import qualified Data.Set as S -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Encoding.Error as T -import qualified Data.Vector as V -import qualified Data.Vector.Storable as SV -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 Data.Void -import Unsafe.Coerce -import GHC.Float (castWord32ToFloat, castWord64ToDouble) -import GHC.Natural -import GHC.Generics -import GHC.TypeLits -import System.IO -import qualified Test.QuickCheck as QC - --- | Deserialiser for a 'Term'. --- --- /"I will read anything rather than work."/ -decodeTerm :: Schema -> Decoder Term -decodeTerm = go [] where - go points = \case - SBool -> TBool <$> decodeCurrent - W.SChar -> TChar <$> decodeCurrent - SWord8 -> TWord8 <$> getWord8 - SWord16 -> TWord16 <$> getWord16 - SWord32 -> TWord32 <$> getWord32 - SWord64 -> TWord64 <$> getWord64 - SInt8 -> TInt8 <$> decodeCurrent - SInt16 -> TInt16 <$> decodeCurrent - SInt32 -> TInt32 <$> decodeCurrent - SInt64 -> TInt64 <$> decodeCurrent - SInteger -> TInteger <$> decodeVarInt - SFloat -> TFloat <$> decodeCurrent - SDouble -> TDouble <$> decodeCurrent - SBytes -> TBytes <$> decodeCurrent - W.SText -> TText <$> decodeCurrent - SUTCTime -> TUTCTime <$> decodeCurrent - SVector sch -> do - n <- decodeVarInt - TVector <$> V.replicateM n (go points sch) - SProduct schs -> TProduct <$> traverse (go points) schs - SRecord schs -> TRecord <$> traverse (\(k, s) -> (,) k <$> go points s) schs - SVariant schs -> do - let !decoders = V.map (\(name, sch) -> let !m = go points sch in (name, m)) schs - tag <- decodeVarInt - let (name, dec) = maybe (throw InvalidTag) id $ decoders V.!? tag - TVariant tag name <$> dec - SVar i -> indexDefault (throw InvalidTag) points i - SFix s' -> fix $ \a -> go (a : points) s' - STag _ s -> go points s - SLet s t -> go (go points s : points) t - --- | Deserialise a 'serialise'd 'B.Bytestring'. -deserialiseTerm :: B.ByteString -> Either WineryException (Schema, Term) -deserialiseTerm bs_ = do - (sch, bs) <- splitSchema bs_ - return (sch, decodeTerm sch `evalDecoder` bs) - --- | This may be thrown if illegal 'Term' is passed to an extractor. -data ExtractException = InvalidTerm !Term deriving Show -instance Exception ExtractException - --- | Serialisable datatype --- -class Typeable a => Serialise a where - -- | Obtain the schema of the datatype. - schemaGen :: Proxy a -> SchemaGen Schema - schemaGen = bundleSchemaGen bundleSerialise - {-# INLINE schemaGen #-} - - -- | Serialise a value. - toBuilder :: a -> BB.Builder - toBuilder = bundleToBuilder bundleSerialise - {-# INLINE toBuilder #-} - - -- | A value of 'Extractor a' interprets a schema and builds a function from - -- 'Term' to @a@. This must be equivalent to 'decodeCurrent' when the schema - -- is the current one. - -- - -- If @'extractor' s@ returns a function, the function must return a - -- non-bottom for any 'Term' @'decodeTerm' s@ returns. - -- - -- It must not return a function if an unsupported schema is supplied. - -- - -- @getDecoderBy extractor (schema (Proxy @ a))@ must be @Right d@ - -- where @d@ is equivalent to 'decodeCurrent'. - -- - extractor :: Extractor a - extractor = bundleExtractor bundleSerialise - {-# INLINE extractor #-} - - -- | Decode a value with the current schema. - -- - -- @'decodeCurrent' `evalDecoder` 'toBuilder' x@ ≡ x - decodeCurrent :: Decoder a - decodeCurrent = bundleDecodeCurrent bundleSerialise - {-# INLINE decodeCurrent #-} - - -- | Instead of the four methods above, you can supply a bundle. - bundleSerialise :: BundleSerialise a - bundleSerialise = BundleSerialise - { bundleSchemaGen = schemaGen - , bundleToBuilder = toBuilder - , bundleExtractor = extractor - , bundleDecodeCurrent = decodeCurrent - } - - {-# MINIMAL schemaGen, toBuilder, extractor, decodeCurrent | bundleSerialise #-} - --- | A bundle of 'Serialise' methods -data BundleSerialise a = BundleSerialise - { bundleSchemaGen :: Proxy a -> SchemaGen Schema - , bundleToBuilder :: a -> BB.Builder - , bundleExtractor :: Extractor a - , bundleDecodeCurrent :: Decoder a - } - -bundleRecord :: (GEncodeProduct (Rep a), GSerialiseRecord (Rep a), Generic a, Typeable a) - => (Extractor a -> Extractor a) -- extractor modifier - -> BundleSerialise a -bundleRecord f = BundleSerialise - { bundleSchemaGen = gschemaGenRecord - , bundleToBuilder = gtoBuilderRecord - , bundleExtractor = f $ gextractorRecord Nothing - , bundleDecodeCurrent = gdecodeCurrentRecord - } -{-# INLINE bundleRecord #-} - -bundleRecordDefault :: (GEncodeProduct (Rep a), GSerialiseRecord (Rep a), Generic a, Typeable a) - => a -- default value - -> (Extractor a -> Extractor a) -- extractor modifier - -> BundleSerialise a -bundleRecordDefault def f = BundleSerialise - { bundleSchemaGen = gschemaGenRecord - , bundleToBuilder = gtoBuilderRecord - , bundleExtractor = f $ gextractorRecord $ Just def - , bundleDecodeCurrent = gdecodeCurrentRecord - } -{-# INLINE bundleRecordDefault #-} - -bundleVariant :: (GSerialiseVariant (Rep a), Generic a, Typeable a) - => (Extractor a -> Extractor a) -- extractor modifier - -> BundleSerialise a -bundleVariant f = BundleSerialise - { bundleSchemaGen = gschemaGenVariant - , bundleToBuilder = gtoBuilderVariant - , bundleExtractor = f $ gextractorVariant - , bundleDecodeCurrent = gdecodeCurrentVariant - } -{-# INLINE bundleVariant #-} - --- | Check the integrity of a Serialise instance. --- --- /"No tears in the writer, no tears in the reader. No surprise in the writer, no surprise in the reader."/ -testSerialise :: forall a. (Eq a, Show a, Serialise a) => a -> QC.Property -testSerialise x = case getDecoderBy extractor (schema (Proxy @ a)) of - Left e -> QC.counterexample (show e) False - Right f -> QC.counterexample "extractor" (evalDecoder f b QC.=== x) - QC..&&. QC.counterexample "decodeCurrent" (evalDecoder decodeCurrent b QC.=== x) - where - b = serialiseOnly x - -decodeCurrentDefault :: forall a. Serialise a => Decoder a -decodeCurrentDefault = case getDecoderBy extractor (schema (Proxy @ a)) of - Left err -> error $ "decodeCurrentDefault: failed to get a decoder from the current schema" - ++ show err - Right a -> a - --- | Schema generator -newtype SchemaGen a = SchemaGen { unSchemaGen :: S.Set TypeRep -> (S.Set TypeRep, [TypeRep] -> a) } - -instance Functor SchemaGen where - fmap f m = SchemaGen $ \s -> case unSchemaGen m s of - (rep, k) -> (rep, f . k) - -instance Applicative SchemaGen where - pure a = SchemaGen $ const (S.empty, const a) - m <*> n = SchemaGen $ \s -> case unSchemaGen m s of - (rep, f) -> case unSchemaGen n s of - (rep', g) -> (mappend rep rep', f <*> g) - --- | Obtain a schema on 'SchemaGen', binding a fixpoint when necessary. --- If you are hand-rolling a definition of 'schemaGen', you should call this --- instead of 'schemaGen'. -getSchema :: forall proxy a. Serialise a => proxy a -> SchemaGen Schema -getSchema p = SchemaGen $ \seen -> if S.member rep seen - then (S.singleton rep, \xs -> case elemIndex rep xs of - Just i -> SVar i - Nothing -> error $ "getSchema: impossible " ++ show (rep, seen, xs)) - -- request a fixpoint for rep when it detects a recursion - else case unSchemaGen (schemaGen (Proxy @ a)) (S.insert rep seen) of - (reps, f) - | S.member rep reps -> (reps, \xs -> SFix $ f (rep : xs)) - | otherwise -> (reps, f) - where - rep = typeRep p - --- | Obtain the schema of the datatype. --- --- /"Tell me what you drink, and I will tell you what you are."/ -schema :: forall proxy a. Serialise a => proxy a -> Schema -schema p = case unSchemaGen (schemaGen (Proxy @ a)) (S.singleton rep) of - (reps, f) - | S.member rep reps -> SFix $ f [rep] - | otherwise -> f [] - where - rep = typeRep p - --- | Obtain a decoder from a schema. --- --- /"A reader lives a thousand lives before he dies... The man who never reads lives only one."/ -getDecoder :: forall a. Serialise a => Schema -> Either WineryException (Decoder a) -getDecoder sch - | sch == schema (Proxy @ a) = Right decodeCurrent - | otherwise = getDecoderBy extractor sch -{-# INLINE getDecoder #-} - --- | 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 [] -{-# INLINE getDecoderBy #-} - --- | Serialise a value along with its schema. --- --- /"Write the vision, and make it plain upon tables, that he may run that readeth it."/ -serialise :: Serialise a => a -> B.ByteString -serialise = BL.toStrict . BB.toLazyByteString . toBuilderWithSchema -{-# INLINE serialise #-} - --- | Serialise a value along with its schema. -writeFileSerialise :: Serialise a => FilePath -> a -> IO () -writeFileSerialise path a = withBinaryFile path WriteMode - $ \h -> BB.hPutBuilder h $ toBuilderWithSchema a -{-# INLINE writeFileSerialise #-} - -toBuilderWithSchema :: forall a. Serialise a => a -> BB.Builder -toBuilderWithSchema a = mappend (BB.word8 currentSchemaVersion) - $ toBuilder (schema (Proxy @ a), a) -{-# INLINE toBuilderWithSchema #-} - -splitSchema :: B.ByteString -> Either WineryException (Schema, B.ByteString) -splitSchema bs_ = case B.uncons bs_ of - Just (ver, bs) -> do - m <- getDecoder $ bootstrapSchema ver - return $ flip evalDecoder bs $ do - sch <- m - State $ \bs' -> ((sch, bs'), mempty) - Nothing -> Left EmptyInput - --- | Serialise a schema. -serialiseSchema :: Schema -> B.ByteString -serialiseSchema = BL.toStrict . BB.toLazyByteString - . mappend (BB.word8 currentSchemaVersion) . toBuilder - --- | Deserialise a 'serialise'd 'B.Bytestring'. --- --- /"Old wood to burn! Old wine to drink! Old friends to trust! Old authors to read!"/ -deserialise :: Serialise a => B.ByteString -> Either WineryException a -deserialise bs_ = do - (sch, bs) <- splitSchema bs_ - dec <- getDecoder sch - return $ evalDecoder dec bs -{-# INLINE deserialise #-} - --- | Deserialise a 'serialise'd 'B.Bytestring' using an 'Extractor'. -deserialiseBy :: Extractor a -> B.ByteString -> Either WineryException a -deserialiseBy e bs_ = do - (sch, bs) <- splitSchema bs_ - dec <- getDecoderBy e sch - return $ evalDecoder dec bs - --- | Serialise a schema. -deserialiseSchema :: B.ByteString -> Either WineryException Schema -deserialiseSchema bs_ = case B.uncons bs_ of - Just (ver, bs) -> do - m <- getDecoder $ bootstrapSchema ver - return $ evalDecoder m bs - Nothing -> Left EmptyInput - --- | Serialise a value without its schema. --- --- /"Any unsaved progress will be lost."/ -serialiseOnly :: Serialise a => a -> B.ByteString -serialiseOnly = BL.toStrict . BB.toLazyByteString . toBuilder -{-# INLINE serialiseOnly #-} - -unexpectedSchema :: forall f a. Serialise a => Doc AnsiStyle -> Schema -> Strategy' (f a) -unexpectedSchema subject actual = throwStrategy - $ UnexpectedSchema subject (pretty $ schema (Proxy @ a)) actual - -instance Serialise Tag where - schemaGen = gschemaGenVariant - toBuilder = gtoBuilderVariant - extractor = gextractorVariant - decodeCurrent = gdecodeCurrentVariant - -instance Serialise Schema where - schemaGen = gschemaGenVariant - toBuilder = gtoBuilderVariant - extractor = gextractorVariant - decodeCurrent = gdecodeCurrentVariant - -instance Serialise () where - schemaGen _ = pure $ SProduct [] - toBuilder = mempty - {-# INLINE toBuilder #-} - extractor = pure () - decodeCurrent = pure () - -instance Serialise Bool where - schemaGen _ = pure SBool - toBuilder False = BB.word8 0 - toBuilder True = BB.word8 1 - {-# INLINE toBuilder #-} - extractor = Extractor $ mkPlan $ \case - SBool -> pure $ \case - TBool b -> b - t -> throw $ InvalidTerm t - s -> unexpectedSchema "Serialise Bool" s - decodeCurrent = (/=0) <$> getWord8 - -instance Serialise Word8 where - schemaGen _ = pure SWord8 - toBuilder = BB.word8 - {-# INLINE toBuilder #-} - extractor = Extractor $ mkPlan $ \case - SWord8 -> pure $ \case - TWord8 i -> i - t -> throw $ InvalidTerm t - s -> unexpectedSchema "Serialise Word8" s - decodeCurrent = getWord8 - -instance Serialise Word16 where - schemaGen _ = pure SWord16 - toBuilder = BB.word16LE - {-# INLINE toBuilder #-} - extractor = Extractor $ mkPlan $ \case - SWord16 -> pure $ \case - TWord16 i -> i - t -> throw $ InvalidTerm t - s -> unexpectedSchema "Serialise Word16" s - decodeCurrent = getWord16 - -instance Serialise Word32 where - schemaGen _ = pure SWord32 - toBuilder = BB.word32LE - {-# INLINE toBuilder #-} - extractor = Extractor $ mkPlan $ \case - SWord32 -> pure $ \case - TWord32 i -> i - t -> throw $ InvalidTerm t - s -> unexpectedSchema "Serialise Word32" s - decodeCurrent = getWord32 - -instance Serialise Word64 where - schemaGen _ = pure SWord64 - toBuilder = BB.word64LE - {-# INLINE toBuilder #-} - extractor = Extractor $ mkPlan $ \case - SWord64 -> pure $ \case - TWord64 i -> i - t -> throw $ InvalidTerm t - s -> unexpectedSchema "Serialise Word64" s - decodeCurrent = getWord64 - -instance Serialise Word where - schemaGen _ = pure SWord64 - toBuilder = BB.word64LE . fromIntegral - {-# INLINE toBuilder #-} - extractor = Extractor $ mkPlan $ \case - SWord64 -> pure $ \case - TWord64 i -> fromIntegral i - t -> throw $ InvalidTerm t - s -> unexpectedSchema "Serialise Word" s - decodeCurrent = fromIntegral <$> getWord64 - -instance Serialise Int8 where - schemaGen _ = pure SInt8 - toBuilder = BB.word8 . fromIntegral - {-# INLINE toBuilder #-} - extractor = Extractor $ mkPlan $ \case - SInt8 -> pure $ \case - TInt8 i -> i - t -> throw $ InvalidTerm t - s -> unexpectedSchema "Serialise Int8" s - decodeCurrent = fromIntegral <$> getWord8 - -instance Serialise Int16 where - schemaGen _ = pure SInt16 - toBuilder = BB.word16LE . fromIntegral - {-# INLINE toBuilder #-} - extractor = Extractor $ mkPlan $ \case - SInt16 -> pure $ \case - TInt16 i -> i - t -> throw $ InvalidTerm t - s -> unexpectedSchema "Serialise Int16" s - decodeCurrent = fromIntegral <$> getWord16 - -instance Serialise Int32 where - schemaGen _ = pure SInt32 - toBuilder = BB.word32LE . fromIntegral - {-# INLINE toBuilder #-} - extractor = Extractor $ mkPlan $ \case - SInt32 -> pure $ \case - TInt32 i -> i - t -> throw $ InvalidTerm t - s -> unexpectedSchema "Serialise Int32" s - decodeCurrent = fromIntegral <$> getWord32 - -instance Serialise Int64 where - schemaGen _ = pure SInt64 - toBuilder = BB.word64LE . fromIntegral - {-# INLINE toBuilder #-} - extractor = Extractor $ mkPlan $ \case - SInt64 -> pure $ \case - TInt64 i -> i - t -> throw $ InvalidTerm t - s -> unexpectedSchema "Serialise Int64" s - decodeCurrent = fromIntegral <$> getWord64 - -instance Serialise Int where - schemaGen _ = pure SInteger - toBuilder = toBuilder . VarInt - {-# INLINE toBuilder #-} - extractor = Extractor $ mkPlan $ \case - SInteger -> pure $ \case - TInteger i -> fromIntegral i - t -> throw $ InvalidTerm t - s -> unexpectedSchema "Serialise Int" s - decodeCurrent = decodeVarIntFinite - -instance Serialise Float where - schemaGen _ = pure SFloat - toBuilder = BB.floatLE - {-# INLINE toBuilder #-} - extractor = Extractor $ mkPlan $ \case - SFloat -> pure $ \case - TFloat x -> x - t -> throw $ InvalidTerm t - s -> unexpectedSchema "Serialise Float" s - decodeCurrent = castWord32ToFloat <$> getWord32 - -instance Serialise Double where - schemaGen _ = pure SDouble - toBuilder = BB.doubleLE - {-# INLINE toBuilder #-} - extractor = Extractor $ mkPlan $ \case - SDouble -> pure $ \case - TDouble x -> x - t -> throw $ InvalidTerm t - s -> unexpectedSchema "Serialise Double" s - decodeCurrent = castWord64ToDouble <$> getWord64 - -instance Serialise T.Text where - schemaGen _ = pure SText - toBuilder = toBuilder . T.encodeUtf8 - {-# INLINE toBuilder #-} - extractor = Extractor $ mkPlan $ \case - SText -> pure $ \case - TText t -> t - t -> throw $ InvalidTerm t - s -> unexpectedSchema "Serialise Text" s - decodeCurrent = do - len <- decodeVarInt - T.decodeUtf8With T.lenientDecode <$> State (B.splitAt len) - --- | Encoded in variable-length quantity. -newtype VarInt a = VarInt { getVarInt :: a } deriving (Show, Read, Eq, Ord, Enum - , Bounded, Num, Real, Integral, Bits, Typeable) - -instance (Typeable a, Bits a, Integral a) => Serialise (VarInt a) where - schemaGen _ = pure SInteger - toBuilder = varInt . getVarInt - {-# INLINE toBuilder #-} - extractor = Extractor $ mkPlan $ \case - SInteger -> pure $ \case - TInteger i -> fromIntegral i - t -> throw $ InvalidTerm t - s -> unexpectedSchema "Serialise (VarInt a)" s - decodeCurrent = VarInt <$> decodeVarInt - -instance Serialise Integer where - schemaGen _ = pure SInteger - toBuilder = toBuilder . VarInt - {-# INLINE toBuilder #-} - extractor = getVarInt <$> extractor - decodeCurrent = getVarInt <$> decodeCurrent - -instance Serialise Natural where - schemaGen _ = pure SInteger - toBuilder = toBuilder . toInteger - extractor = naturalFromInteger <$> extractor - decodeCurrent = naturalFromInteger <$> decodeCurrent - -instance Serialise Char where - schemaGen _ = pure SChar - toBuilder = toBuilder . fromEnum - {-# INLINE toBuilder #-} - extractor = Extractor $ mkPlan $ \case - SChar -> pure $ \case - TChar c -> c - t -> throw $ InvalidTerm t - s -> unexpectedSchema "Serialise Char" s - decodeCurrent = toEnum <$> decodeVarInt - -instance Serialise a => Serialise (Maybe a) where - schemaGen = gschemaGenVariant - toBuilder = gtoBuilderVariant - extractor = gextractorVariant - decodeCurrent = gdecodeCurrentVariant - -instance Serialise B.ByteString where - schemaGen _ = pure SBytes - toBuilder bs = varInt (B.length bs) <> BB.byteString bs - {-# INLINE toBuilder #-} - extractor = Extractor $ mkPlan $ \case - SBytes -> pure $ \case - TBytes bs -> bs - t -> throw $ InvalidTerm t - s -> unexpectedSchema "Serialise ByteString" s - decodeCurrent = do - len <- decodeVarInt - State (B.splitAt len) - -instance Serialise BL.ByteString where - schemaGen _ = pure SBytes - toBuilder = toBuilder . BL.toStrict - {-# INLINE toBuilder #-} - extractor = BL.fromStrict <$> extractor - decodeCurrent = BL.fromStrict <$> decodeCurrent - --- | time-1.9.1 -nanosecondsToNominalDiffTime :: Int64 -> NominalDiffTime -nanosecondsToNominalDiffTime = unsafeCoerce . MkFixed . (*1000) . fromIntegral - -instance Serialise UTCTime where - schemaGen _ = pure SUTCTime - toBuilder = toBuilder . utcTimeToPOSIXSeconds - {-# INLINE toBuilder #-} - extractor = Extractor $ Plan $ \case - SUTCTime -> pure $ \case - TUTCTime bs -> bs - t -> throw $ InvalidTerm t - s -> unexpectedSchema "Serialise UTCTime" s - decodeCurrent = posixSecondsToUTCTime <$> decodeCurrent - -instance Serialise NominalDiffTime where - schemaGen _ = pure SInt64 - toBuilder x = case unsafeCoerce x of - MkFixed p -> toBuilder (fromIntegral (p `div` 1000) :: Int64) - {-# INLINE toBuilder #-} - extractor = nanosecondsToNominalDiffTime <$> extractor - decodeCurrent = nanosecondsToNominalDiffTime <$> decodeCurrent - -instance Serialise a => Serialise [a] where - schemaGen _ = SVector <$> getSchema (Proxy @ a) - toBuilder xs = varInt (length xs) - <> foldMap toBuilder xs - {-# INLINE toBuilder #-} - extractor = V.toList <$> extractListBy extractor - decodeCurrent = do - n <- decodeVarInt - replicateM n decodeCurrent - -instance Serialise a => Serialise (V.Vector a) where - schemaGen _ = SVector <$> getSchema (Proxy @ a) - toBuilder xs = varInt (V.length xs) - <> foldMap toBuilder xs - {-# INLINE toBuilder #-} - extractor = extractListBy extractor - decodeCurrent = do - n <- decodeVarInt - V.replicateM n decodeCurrent - -instance (SV.Storable a, Serialise a) => Serialise (SV.Vector a) where - schemaGen _ = SVector <$> getSchema (Proxy @ a) - toBuilder = toBuilder . (SV.convert :: SV.Vector a -> V.Vector a) - {-# INLINE toBuilder #-} - extractor = SV.convert <$> extractListBy extractor - decodeCurrent = do - n <- decodeVarInt - SV.replicateM n decodeCurrent - -instance (UV.Unbox a, Serialise a) => Serialise (UV.Vector a) where - schemaGen _ = SVector <$> getSchema (Proxy @ a) - toBuilder = toBuilder . (UV.convert :: UV.Vector a -> V.Vector a) - {-# INLINE toBuilder #-} - extractor = UV.convert <$> extractListBy extractor - decodeCurrent = do - n <- decodeVarInt - UV.replicateM n decodeCurrent - --- | Extract a list or an array of values. -extractListBy :: Typeable a => Extractor a -> Extractor (V.Vector a) -extractListBy (Extractor plan) = Extractor $ mkPlan $ \case - SVector s -> do - getItem <- unPlan plan s - return $ \case - TVector xs -> V.map getItem xs - t -> throw $ InvalidTerm t - s -> throwStrategy $ UnexpectedSchema "extractListBy ..." "[a]" s -{-# INLINE extractListBy #-} - -instance (Ord k, Serialise k, Serialise v) => Serialise (M.Map k v) where - schemaGen _ = schemaGen (Proxy @ [(k, v)]) - toBuilder m = toBuilder (M.size m) - <> M.foldMapWithKey (curry toBuilder) m - {-# INLINE toBuilder #-} - extractor = M.fromList <$> extractor - decodeCurrent = M.fromList <$> decodeCurrent - -instance (Eq k, Hashable k, Serialise k, Serialise v) => Serialise (HM.HashMap k v) where - schemaGen _ = schemaGen (Proxy @ [(k, v)]) - toBuilder m = toBuilder (HM.size m) - <> HM.foldrWithKey (\k v r -> toBuilder (k, v) <> r) mempty m - {-# INLINE toBuilder #-} - extractor = HM.fromList <$> extractor - decodeCurrent = HM.fromList <$> decodeCurrent - -instance (Serialise v) => Serialise (IM.IntMap v) where - schemaGen _ = schemaGen (Proxy @ [(Int, v)]) - toBuilder m = toBuilder (IM.size m) - <> IM.foldMapWithKey (curry toBuilder) m - {-# INLINE toBuilder #-} - extractor = IM.fromList <$> extractor - decodeCurrent = IM.fromList <$> decodeCurrent - -instance (Ord a, Serialise a) => Serialise (S.Set a) where - schemaGen _ = schemaGen (Proxy @ [a]) - toBuilder s = toBuilder (S.size s) <> foldMap toBuilder s - {-# INLINE toBuilder #-} - extractor = S.fromList <$> extractor - decodeCurrent = S.fromList <$> decodeCurrent - -instance Serialise IS.IntSet where - schemaGen _ = schemaGen (Proxy @ [Int]) - toBuilder s = toBuilder (IS.size s) <> IS.foldr (mappend . toBuilder) mempty s - {-# INLINE toBuilder #-} - extractor = IS.fromList <$> extractor - decodeCurrent = IS.fromList <$> decodeCurrent - -instance Serialise a => Serialise (Seq.Seq a) where - schemaGen _ = schemaGen (Proxy @ [a]) - toBuilder s = toBuilder (length s) <> foldMap toBuilder s - {-# INLINE toBuilder #-} - extractor = Seq.fromList <$> extractor - decodeCurrent = Seq.fromList <$> decodeCurrent - -instance (Integral a, Serialise a) => Serialise (Ratio a) where - schemaGen _ = schemaGen (Proxy @ (a, a)) - toBuilder x = toBuilder (numerator x, denominator x) - {-# INLINE toBuilder #-} - extractor = uncurry (%) <$> extractor - decodeCurrent = uncurry (%) <$> decodeCurrent - -instance Serialise Scientific where - schemaGen _ = schemaGen (Proxy @ (Integer, Int)) - toBuilder s = toBuilder (coefficient s, base10Exponent s) - {-# INLINE toBuilder #-} - extractor = Extractor $ Plan $ \s -> case s of - SWord8 -> f (fromIntegral :: Word8 -> Scientific) s - SWord16 -> f (fromIntegral :: Word16 -> Scientific) s - SWord32 -> f (fromIntegral :: Word32 -> Scientific) s - SWord64 -> f (fromIntegral :: Word64 -> Scientific) s - SInt8 -> f (fromIntegral :: Int8 -> Scientific) s - SInt16 -> f (fromIntegral :: Int16 -> Scientific) s - SInt32 -> f (fromIntegral :: Int32 -> Scientific) s - SInt64 -> f (fromIntegral :: Int64 -> Scientific) s - SInteger -> f fromInteger s - SFloat -> f (realToFrac :: Float -> Scientific) s - SDouble -> f (realToFrac :: Double -> Scientific) s - _ -> f (uncurry scientific) s - where - f c = unwrapExtractor (c <$> extractor) - decodeCurrent = decodeCurrentDefault - -buildExtractor :: Typeable a => Subextractor a -> Extractor a -buildExtractor (Subextractor e) = Extractor $ mkPlan $ unwrapExtractor e -{-# INLINE buildExtractor #-} - -newtype Subextractor a = Subextractor { unSubextractor :: Extractor a } - deriving (Functor, Applicative, Alternative) - --- | Extract a field of a record. -extractField :: Serialise a => T.Text -> Subextractor a -extractField = extractFieldBy extractor -{-# INLINE extractField #-} - --- | Extract a field using the supplied 'Extractor'. -extractFieldBy :: Extractor a -> T.Text -> Subextractor a -extractFieldBy (Extractor g) name = Subextractor $ Extractor $ Plan $ \case - SRecord schs -> case lookupWithIndexV name schs of - Just (i, sch) -> do - m <- unPlan g sch - return $ \case - TRecord xs -> maybe (error msg) (m . snd) $ xs V.!? i - t -> throw $ InvalidTerm t - _ -> throwStrategy $ FieldNotFound rep name (map fst $ V.toList schs) - s -> throwStrategy $ UnexpectedSchema rep "a record" s - where - rep = "extractFieldBy ... " <> dquotes (pretty name) - msg = "Data.Winery.extractFieldBy ... " <> show name <> ": impossible" - --- | 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 - SVar i - | point : _ <- drop i decs -> case point of - BoundSchema ofs' sch' -> unPlan (mkPlan 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) - s -> k s `unStrategy` StrategyEnv ofs decs - -instance (Serialise a, Serialise b) => Serialise (a, b) where - schemaGen = gschemaGenProduct - toBuilder = gtoBuilderProduct - extractor = gextractorProduct - decodeCurrent = gdecodeCurrentProduct - -instance (Serialise a, Serialise b, Serialise c) => Serialise (a, b, c) where - schemaGen = gschemaGenProduct - toBuilder = gtoBuilderProduct - extractor = gextractorProduct - decodeCurrent = gdecodeCurrentProduct - -instance (Serialise a, Serialise b, Serialise c, Serialise d) => Serialise (a, b, c, d) where - schemaGen = gschemaGenProduct - toBuilder = gtoBuilderProduct - extractor = gextractorProduct - decodeCurrent = gdecodeCurrentProduct - -instance (Serialise a, Serialise b, Serialise c, Serialise d, Serialise e) => Serialise (a, b, c, d, e) where - schemaGen = gschemaGenProduct - toBuilder = gtoBuilderProduct - extractor = gextractorProduct - decodeCurrent = gdecodeCurrentProduct - -instance (Serialise a, Serialise b, Serialise c, Serialise d, Serialise e, Serialise f) => Serialise (a, b, c, d, e, f) where - schemaGen = gschemaGenProduct - toBuilder = gtoBuilderProduct - extractor = gextractorProduct - decodeCurrent = gdecodeCurrentProduct - -instance (Serialise a, Serialise b) => Serialise (Either a b) where - schemaGen = gschemaGenVariant - toBuilder = gtoBuilderVariant - extractor = gextractorVariant - decodeCurrent = gdecodeCurrentVariant - --- | 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 - SVariant schs0 -> Strategy $ \decs -> do - let run :: Extractor x -> Schema -> Either WineryException (Term -> x) - run e s = unwrapExtractor e s `unStrategy` decs - case lookupWithIndexV name schs0 of - Just (i, s) -> do - (j, dec) <- fmap ((,) i) $ run d $ case s of - SProduct [s'] -> s' - s' -> s' - let rest = SVariant $ V.filter ((/=name) . fst) schs0 - k <- run (unSubextractor cont) rest - return $ \case - TVariant tag _ v - | tag == j -> f $ dec v - t -> k t - _ -> run (unSubextractor cont) (SVariant schs0) - s -> throwStrategy $ UnexpectedSchema rep "a variant" s - where - rep = "extractConstructorBy ... " <> dquotes (pretty name) - --- | Tries to match on a constructor. If it doesn't match (or constructor --- doesn't exist at all), leave it to the successor. --- --- @extractor = ("Just", Just) `extractConstructor` ("Nothing", \() -> Nothing) `extractConstructor` extractVoid@ -extractConstructor :: (Serialise a) => (T.Text, a -> r) -> Subextractor r -> Subextractor r -extractConstructor (name, f) = extractConstructorBy (extractor, name, f) -{-# INLINE extractConstructor #-} - -extractVoid :: Typeable r => Subextractor r -extractVoid = Subextractor $ Extractor $ mkPlan $ \case - SVariant schs0 - | V.null schs0 -> return $ throw . InvalidTerm - s -> throwStrategy $ UnexpectedSchema "extractVoid" "no constructors" s - -infixr 1 `extractConstructorBy` -infixr 1 `extractConstructor` - --- | Generic implementation of 'schemaGen' for a record. -gschemaGenRecord :: forall proxy a. (GSerialiseRecord (Rep a), Generic a, Typeable a) => proxy a -> SchemaGen Schema -gschemaGenRecord _ = SRecord . V.fromList <$> recordSchema (Proxy @ (Rep a)) - --- | Generic implementation of 'toBuilder' for a record. -gtoBuilderRecord :: (GEncodeProduct (Rep a), Generic a) => a -> BB.Builder -gtoBuilderRecord = productEncoder . from -{-# INLINE gtoBuilderRecord #-} - -data FieldDecoder i a = FieldDecoder !i !(Maybe a) !(Plan (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 - $ fmap (fmap (to .)) $ extractorRecord' - ("gextractorRecord :: Extractor " <> viaShow (typeRep (Proxy @ a))) - (from <$> def) - --- | Generic implementation of 'extractor' for a record. -extractorRecord' :: (GSerialiseRecord f) - => Doc AnsiStyle - -> Maybe (f x) -- ^ default value (optional) - -> Schema -> Strategy' (Term -> f x) -extractorRecord' rep def (SRecord schs) = Strategy $ \decs -> do - let go :: FieldDecoder T.Text x -> Either WineryException (Term -> x) - go (FieldDecoder name def' p) = case lookupWithIndexV name schs of - 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 - Right getItem -> Right $ \case - TRecord xs -> maybe (error (show rep)) (getItem . snd) $ xs V.!? i - t -> throw $ InvalidTerm t - Left e -> Left e - unTransFusion (recordExtractor def) go -extractorRecord' rep _ s = throwStrategy $ UnexpectedSchema rep "a record" s -{-# INLINE gextractorRecord #-} - -gdecodeCurrentRecord :: (GSerialiseRecord (Rep a), Generic a) => Decoder a -gdecodeCurrentRecord = to <$> recordDecoder -{-# INLINE gdecodeCurrentRecord #-} - --- | The 'Serialise' instance is generically defined for records. --- --- /"Remember thee! Yea, from the table of my memory I'll wipe away all trivial --- fond records."/ -newtype WineryRecord a = WineryRecord { unWineryRecord :: a } - -instance (GEncodeProduct (Rep a), GSerialiseRecord (Rep a), Generic a, Typeable a) => Serialise (WineryRecord a) where - schemaGen _ = gschemaGenRecord (Proxy @ a) - toBuilder = gtoBuilderRecord . unWineryRecord - extractor = WineryRecord <$> gextractorRecord Nothing - decodeCurrent = WineryRecord <$> gdecodeCurrentRecord - -class GEncodeProduct f where - productEncoder :: f x -> BB.Builder - -instance GEncodeProduct U1 where - productEncoder _ = mempty - {-# INLINE productEncoder #-} - -instance (GEncodeProduct f, GEncodeProduct g) => GEncodeProduct (f :*: g) where - productEncoder (f :*: g) = productEncoder f <> productEncoder g - {-# INLINE productEncoder #-} - -instance Serialise a => GEncodeProduct (S1 c (K1 i a)) where - productEncoder (M1 (K1 a)) = toBuilder a - {-# INLINE productEncoder #-} - -instance GEncodeProduct f => GEncodeProduct (C1 c f) where - productEncoder (M1 a) = productEncoder a - {-# INLINE productEncoder #-} - -instance GEncodeProduct f => GEncodeProduct (D1 c f) where - productEncoder (M1 a) = productEncoder a - {-# INLINE productEncoder #-} - -class GSerialiseRecord f where - recordSchema :: proxy f -> SchemaGen [(T.Text, Schema)] - recordExtractor :: Maybe (f x) -> TransFusion (FieldDecoder T.Text) ((->) Term) (Term -> f x) - recordDecoder :: Decoder (f x) - -instance (GSerialiseRecord f, GSerialiseRecord g) => GSerialiseRecord (f :*: g) where - recordSchema _ = (++) <$> recordSchema (Proxy @ f) <*> recordSchema (Proxy @ g) - recordExtractor def = (\f g -> (:*:) <$> f <*> g) - <$> recordExtractor ((\(x :*: _) -> x) <$> def) - <*> recordExtractor ((\(_ :*: x) -> x) <$> def) - {-# INLINE recordExtractor #-} - recordDecoder = (:*:) <$> recordDecoder <*> recordDecoder - {-# INLINE recordDecoder #-} - -instance (Serialise a, Selector c) => GSerialiseRecord (S1 c (K1 i a)) where - recordSchema _ = do - s <- getSchema (Proxy @ a) - pure [(T.pack $ selName (M1 undefined :: M1 i c (K1 i a) x), s)] - 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) - {-# INLINE recordExtractor #-} - recordDecoder = M1 . K1 <$> decodeCurrent - {-# INLINE recordDecoder #-} - -instance (GSerialiseRecord f) => GSerialiseRecord (C1 c f) where - recordSchema _ = recordSchema (Proxy @ f) - recordExtractor def = fmap M1 <$> recordExtractor (unM1 <$> def) - recordDecoder = M1 <$> recordDecoder - -instance (GSerialiseRecord f) => GSerialiseRecord (D1 c f) where - recordSchema _ = recordSchema (Proxy @ f) - recordExtractor def = fmap M1 <$> recordExtractor (unM1 <$> def) - recordDecoder = M1 <$> recordDecoder - -class GSerialiseProduct f where - productSchema :: proxy f -> SchemaGen [Schema] - productExtractor :: Compose (State Int) (TransFusion (FieldDecoder Int) ((->) Term)) (Term -> f x) - productDecoder :: Decoder (f x) - -instance GSerialiseProduct U1 where - productSchema _ = pure [] - productExtractor = pure (pure U1) - productDecoder = pure U1 - -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) - , i + 1) - productDecoder = K1 <$> decodeCurrent - -instance GSerialiseProduct f => GSerialiseProduct (M1 i c f) where - productSchema _ = productSchema (Proxy @ f) - productExtractor = fmap M1 <$> productExtractor - productDecoder = M1 <$> productDecoder - -instance (GSerialiseProduct f, GSerialiseProduct g) => GSerialiseProduct (f :*: g) where - productSchema _ = (++) <$> productSchema (Proxy @ f) <*> productSchema (Proxy @ g) - productExtractor = liftA2 (:*:) <$> productExtractor <*> productExtractor - productDecoder = (:*:) <$> productDecoder <*> productDecoder - --- | Serialise a value as a product (omits field names). --- --- /"I get ideas about what's essential when packing my suitcase."/ -newtype WineryProduct a = WineryProduct { unWineryProduct :: a } - -instance (GEncodeProduct (Rep a), GSerialiseProduct (Rep a), Generic a, Typeable a) => Serialise (WineryProduct a) where - schemaGen _ = gschemaGenProduct (Proxy @ a) - toBuilder = gtoBuilderProduct . unWineryProduct - extractor = WineryProduct <$> gextractorProduct - decodeCurrent = WineryProduct <$> gdecodeCurrentProduct - -gschemaGenProduct :: forall proxy a. (Generic a, GSerialiseProduct (Rep a)) => proxy a -> SchemaGen Schema -gschemaGenProduct _ = SProduct . V.fromList <$> productSchema (Proxy @ (Rep a)) -{-# INLINE gschemaGenProduct #-} - -gtoBuilderProduct :: (Generic a, GEncodeProduct (Rep a)) => a -> BB.Builder -gtoBuilderProduct = productEncoder . from -{-# INLINE gtoBuilderProduct #-} - --- | 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' -{-# INLINE gextractorProduct #-} - --- | Generic implementation of 'extractor' for a record. -gdecodeCurrentProduct :: forall a. (GSerialiseProduct (Rep a), Generic a) - => Decoder a -gdecodeCurrentProduct = to <$> productDecoder -{-# INLINE gdecodeCurrentProduct #-} - -extractorProduct' :: GSerialiseProduct f => Schema -> Strategy' (Term -> f x) -extractorProduct' sch - | Just schs <- strip sch = Strategy $ \recs -> do - 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 - else Left $ ProductTooSmall $ length schs - return $ \case - TProduct xs -> getItem $ maybe (throw $ InvalidTerm (TProduct xs)) id - $ xs V.!? i - t -> throw $ InvalidTerm t - unTransFusion (getCompose productExtractor `evalState` 0) go - where - strip (SProduct xs) = Just xs - strip (SRecord xs) = Just $ V.map snd xs - strip _ = Nothing -extractorProduct' sch = throwStrategy $ UnexpectedSchema "extractorProduct'" "a product" sch - --- | The 'Serialise' instance is generically defined for variants. --- --- /"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 - schemaGen _ = gschemaGenVariant (Proxy @ a) - toBuilder = gtoBuilderVariant . unWineryVariant - extractor = WineryVariant <$> gextractorVariant - decodeCurrent = WineryVariant <$> gdecodeCurrentVariant - --- | Generic implementation of 'schemaGen' for an ADT. -gschemaGenVariant :: forall proxy a. (GSerialiseVariant (Rep a), Typeable a, Generic a) => proxy a -> SchemaGen Schema -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 -{-# INLINE gtoBuilderVariant #-} - --- | Generic implementation of 'extractor' for an ADT. -gextractorVariant :: forall a. (GSerialiseVariant (Rep a), Generic a, Typeable a) - => Extractor a -gextractorVariant = Extractor $ mkPlan $ \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) - Just f -> f sch `unStrategy` decs) schs0 - return $ \case - TVariant i _ v -> to $ maybe (throw InvalidTag) ($ v) $ ds' V.!? i - t -> throw $ InvalidTerm t - s -> throwStrategy $ UnexpectedSchema rep "a variant" s - where - 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 - -class GSerialiseVariant f where - variantCount :: proxy f -> Int - 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, KnownSymbol name) => GSerialiseVariant (C1 ('MetaCons name fixity 'False) f) where - variantCount _ = 1 - 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, KnownSymbol name) => GSerialiseVariant (C1 ('MetaCons name fixity 'True) f) where - variantCount _ = 1 - 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 <$> recordDecoder] - -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 - toBuilder = gtoBuilderVariant - extractor = gextractorVariant - decodeCurrent = gdecodeCurrentVariant - -deriving instance Serialise a => Serialise (Identity a) -deriving instance (Serialise a, Typeable b, Typeable k) => Serialise (Const a (b :: k)) - -deriving instance Serialise Any -deriving instance Serialise All -deriving instance Serialise a => Serialise (Down a) -deriving instance Serialise a => Serialise (Product a) -deriving instance Serialise a => Serialise (Sum a) -deriving instance Serialise a => Serialise (Dual a) -deriving instance Serialise a => Serialise (M.Last a) -deriving instance Serialise a => Serialise (M.First a) -deriving instance Serialise a => Serialise (S.Last a) -deriving instance Serialise a => Serialise (S.First a) -deriving instance Serialise a => Serialise (ZipList a) -deriving instance Serialise a => Serialise (Option a) -deriving instance Serialise a => Serialise (Max a) -deriving instance Serialise a => Serialise (Min a) -deriving instance (Typeable k, Typeable f, Typeable a, Serialise (f a)) => Serialise (Alt f (a :: k)) -deriving instance (Typeable j, Typeable k, Typeable f, Typeable g, Typeable a, Serialise (f (g a))) => Serialise (Compose f (g :: j -> k) (a :: j)) -#if MIN_VERSION_base(4,12,0) -deriving instance (Typeable k, Typeable f, Typeable a, Serialise (f a)) => Serialise (Ap f (a :: k)) -#endif - -instance (Typeable k, Typeable a, Typeable b, a ~ b) => Serialise ((a :: k) :~: b) where - schemaGen _ = pure $ SProduct [] - toBuilder = mempty - extractor = pure Refl - decodeCurrent = pure Refl - -instance (Serialise a, Serialise b) => Serialise (Arg a b) where - schemaGen = gschemaGenProduct - toBuilder = gtoBuilderProduct - extractor = gextractorProduct - decodeCurrent = gdecodeCurrentProduct - -instance Serialise a => Serialise (Complex a) where - schemaGen = gschemaGenProduct - toBuilder = gtoBuilderProduct - extractor = gextractorProduct - decodeCurrent = gdecodeCurrentProduct - -instance Serialise Void where - schemaGen _ = pure $ SVariant V.empty - toBuilder = mempty - extractor = Extractor $ Plan $ const $ throwStrategy "No extractor for Void" - decodeCurrent = error "No decodeCurrent for Void" +module Data.Winery {-# DEPRECATED "Use Codec.Winery instead" #-} + ( module Codec.Winery ) + where + +import Codec.Winery diff --git a/src/Data/Winery/Base.hs b/src/Data/Winery/Base.hs deleted file mode 100644 --- a/src/Data/Winery/Base.hs +++ /dev/null @@ -1,293 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DeriveTraversable #-} ----------------------------------------------------------------------------- --- | --- Module : Data.Winery.Base --- Copyright : (c) Fumiaki Kinoshita 2019 --- License : BSD3 --- Stability : Provisional --- --- Maintainer : Fumiaki Kinoshita --- --- Basic types --- ------------------------------------------------------------------------------ -module Data.Winery.Base - ( Tag(..) - , Schema - , SchemaP(..) - , currentSchemaVersion - , bootstrapSchema - , Term(..) - , Extractor(..) - , Strategy' - , StrategyBind(..) - , StrategyEnv(..) - , Plan(..) - , unwrapExtractor - , WineryException(..) - , prettyWineryException) - where - -import Control.Applicative -import Control.Exception -import Data.Aeson as J -import qualified Data.ByteString as B -import Data.Dynamic -import qualified Data.HashMap.Strict as HM -import Data.Int -import Data.String -import qualified Data.Text as T -import Data.Text.Prettyprint.Doc hiding ((<>), SText, SChar) -import Data.Text.Prettyprint.Doc.Render.Terminal -import Data.Time -import Data.Typeable -import qualified Data.Vector as V -import Data.Winery.Internal -import Data.Word -import GHC.Generics (Generic) -import GHC.Exts (IsList(..)) - --- | Tag is an extra value that can be attached to a schema. -data Tag = TagInt !Int - | TagStr !T.Text - | TagList ![Tag] - deriving (Show, Read, Eq, Generic) - -instance IsString Tag where - fromString = TagStr . fromString - -instance IsList Tag where - type Item Tag = Tag - fromList = TagList - toList (TagList xs) = xs - toList _ = [] - -instance Pretty Tag where - pretty (TagInt i) = pretty i - pretty (TagStr s) = pretty s - pretty (TagList xs) = list (map pretty xs) - -currentSchemaVersion :: Word8 -currentSchemaVersion = 4 - --- | A schema preserves structure of a datatype, allowing users to inspect --- the data regardless of the current implementation. --- --- /"Yeah, it’s just a memento. Just, you know, from the first time we met."/ -type Schema = SchemaP Int - -data SchemaP a = SFix !(SchemaP a) -- ^ binds a fixpoint - | SVar !a -- ^ @SVar n@ refers to the n-th innermost fixpoint - | SVector !(SchemaP a) - | SProduct !(V.Vector (SchemaP a)) - | SRecord !(V.Vector (T.Text, SchemaP a)) - | SVariant !(V.Vector (T.Text, SchemaP a)) - | SBool - | SChar - | SWord8 - | SWord16 - | SWord32 - | SWord64 - | SInt8 - | SInt16 - | SInt32 - | SInt64 - | SInteger - | SFloat - | SDouble - | SBytes - | SText - | SUTCTime -- ^ nanoseconds from POSIX epoch - | STag !Tag !(SchemaP a) - | SLet !(SchemaP a) !(SchemaP a) - deriving (Show, Read, Eq, Generic, Functor, Foldable, Traversable) - -instance Pretty a => Pretty (SchemaP a) where - pretty = \case - SProduct [] -> "()" - SBool -> "Bool" - SChar -> "Char" - SWord8 -> "Word8" - SWord16 -> "Word16" - SWord32 -> "Word32" - SWord64 -> "Word64" - SInt8 -> "Int8" - SInt16 -> "Int16" - SInt32 -> "Int32" - SInt64 -> "Int64" - SInteger -> "Integer" - SFloat -> "Float" - SDouble -> "Double" - SBytes -> "ByteString" - SText -> "Text" - SUTCTime -> "UTCTime" - SVector s -> "[" <> pretty s <> "]" - SProduct ss -> tupled $ map pretty (V.toList ss) - SRecord ss -> align $ encloseSep "{ " " }" ", " [group $ nest 2 $ sep [pretty k, "::" <+> pretty v] | (k, v) <- V.toList ss] - SVariant ss -> align $ encloseSep "" "" (flatAlt "| " " | ") - [ nest 2 $ sep $ pretty k : case vs of - SProduct xs -> map pretty $ V.toList xs - SRecord xs -> [pretty (SRecord xs)] - s -> [pretty s] | (k, vs) <- V.toList ss] - SFix sch -> group $ nest 2 $ sep ["μ", enclose "{ " " }" $ pretty sch] - SVar i -> "$" <> pretty i - STag t s -> nest 2 $ sep [pretty t <> ":", pretty s] - SLet s t -> sep ["let" <+> pretty s, pretty t] - -bootstrapSchema :: Word8 -> Schema -bootstrapSchema 4 = SFix (SVariant [("SFix",SProduct [SVar 0]),("SVar",SProduct [SInteger]),("SVector",SProduct [SVar 0]),("SProduct",SProduct [SVector (SVar 0)]),("SRecord",SProduct [SVector (SProduct [SText,SVar 0])]),("SVariant",SProduct [SVector (SProduct [SText,SVar 0])]),("SBool",SProduct []),("SChar",SProduct []),("SWord8",SProduct []),("SWord16",SProduct []),("SWord32",SProduct []),("SWord64",SProduct []),("SInt8",SProduct []),("SInt16",SProduct []),("SInt32",SProduct []),("SInt64",SProduct []),("SInteger",SProduct []),("SFloat",SProduct []),("SDouble",SProduct []),("SBytes",SProduct []),("SText",SProduct []),("SUTCTime",SProduct []),("STag",SProduct [SFix (SVariant [("TagInt",SProduct [SInteger]),("TagStr",SProduct [SText]),("TagList",SProduct [SVector (SVar 0)])]),SVar 0]),("SLet",SProduct [SVar 0,SVar 0])]) -bootstrapSchema n = error $ "Unsupported version: " <> show n - --- | Common representation for any winery data. --- Handy for prettyprinting winery-serialised data. -data Term = TBool !Bool - | TChar !Char - | TWord8 !Word8 - | TWord16 !Word16 - | TWord32 !Word32 - | TWord64 !Word64 - | TInt8 !Int8 - | TInt16 !Int16 - | TInt32 !Int32 - | TInt64 !Int64 - | TInteger !Integer - | TFloat !Float - | TDouble !Double - | TBytes !B.ByteString - | TText !T.Text - | TUTCTime !UTCTime - | TVector !(V.Vector Term) - | TProduct !(V.Vector Term) - | TRecord !(V.Vector (T.Text, Term)) - | TVariant !Int !T.Text Term - deriving Show - -instance J.ToJSON Term where - toJSON (TBool b) = J.toJSON b - toJSON (TChar c) = J.toJSON c - toJSON (TWord8 w) = J.toJSON w - toJSON (TWord16 w) = J.toJSON w - toJSON (TWord32 w) = J.toJSON w - toJSON (TWord64 w) = J.toJSON w - toJSON (TInt8 w) = J.toJSON w - toJSON (TInt16 w) = J.toJSON w - toJSON (TInt32 w) = J.toJSON w - toJSON (TInt64 w) = J.toJSON w - toJSON (TInteger w) = J.toJSON w - toJSON (TFloat x) = J.toJSON x - toJSON (TDouble x) = J.toJSON x - toJSON (TBytes bs) = J.toJSON (B.unpack bs) - toJSON (TText t) = J.toJSON t - toJSON (TUTCTime t) = J.toJSON t - toJSON (TVector xs) = J.toJSON xs - toJSON (TProduct xs) = J.toJSON xs - toJSON (TRecord xs) = J.toJSON $ HM.fromList $ V.toList xs - toJSON (TVariant _ "Just" x) = J.toJSON x - toJSON (TVariant _ "Nothing" _) = J.Null - toJSON (TVariant _ t x) = J.object ["tag" J..= J.toJSON t, "contents" J..= J.toJSON x] - -instance Pretty Term where - pretty (TWord8 i) = pretty i - pretty (TWord16 i) = pretty i - pretty (TWord32 i) = pretty i - pretty (TWord64 i) = pretty i - pretty (TInt8 i) = pretty i - pretty (TInt16 i) = pretty i - pretty (TInt32 i) = pretty i - pretty (TInt64 i) = pretty i - pretty (TInteger i) = pretty i - pretty (TBytes s) = pretty $ show s - pretty (TText s) = pretty s - pretty (TVector xs) = list $ map pretty (V.toList xs) - pretty (TBool x) = pretty x - pretty (TChar x) = pretty x - pretty (TFloat x) = pretty x - pretty (TDouble x) = pretty x - pretty (TProduct xs) = tupled $ map pretty (V.toList xs) - pretty (TRecord xs) = align $ encloseSep "{ " " }" ", " [group $ nest 2 $ vsep [pretty k <+> "=", pretty v] | (k, v) <- V.toList xs] - pretty (TVariant _ tag (TProduct xs)) = group $ nest 2 $ sep $ pretty tag : map pretty (V.toList xs) - pretty (TVariant _ tag x) = group $ nest 2 $ sep [pretty tag, pretty x] - pretty (TUTCTime t) = pretty (show t) - --- | 'Extractor' is a 'Plan' that creates a function to extract a value from Term. --- --- The 'Applicative' instance can be used to build a user-defined extractor. --- 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) } - deriving Functor - -instance Applicative Extractor where - pure = Extractor . pure . pure - Extractor f <*> Extractor x = Extractor $ (<*>) <$> f <*> x - -instance Alternative Extractor where - empty = Extractor empty - Extractor f <|> Extractor g = Extractor $ f <|> g - -data StrategyBind = DynDecoder !Dynamic -- ^ A fixpoint of a decoder - | BoundSchema !Int !Schema - -- ^ schema bound by 'SLet'. 'Int' is a basis of the variables - -data StrategyEnv = StrategyEnv !Int ![StrategyBind] - -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 - -unwrapExtractor :: Extractor a -> Schema -> Strategy' (Term -> a) -unwrapExtractor (Extractor m) = unPlan m -{-# INLINE unwrapExtractor #-} - -data WineryException = UnexpectedSchema !(Doc AnsiStyle) !(Doc AnsiStyle) !Schema - | FieldNotFound !(Doc AnsiStyle) !T.Text ![T.Text] - | TypeMismatch !Int !TypeRep !TypeRep - | ProductTooSmall !Int - | UnboundVariable !Int - | EmptyInput - | WineryMessage !(Doc AnsiStyle) - deriving Show - -instance Exception WineryException - -instance IsString WineryException where - fromString = WineryMessage . fromString - -prettyWineryException :: WineryException -> Doc AnsiStyle -prettyWineryException = \case - UnexpectedSchema subject expected actual -> annotate bold subject - <+> "expects" <+> annotate (color Green <> bold) expected - <+> "but got " <+> pretty actual - FieldNotFound rep x xs -> rep <> ": field or constructor " <> pretty x <> " not found in " <> pretty xs - TypeMismatch i s t -> "A type mismatch in variable" - <+> pretty i <> ":" - <+> "expected" <> viaShow s - <+> "but got " <> viaShow t - ProductTooSmall i -> "The product is too small; expecting " <> pretty i - UnboundVariable i -> "Unbound variable: " <> pretty i - EmptyInput -> "Unexpected empty string" - WineryMessage a -> a diff --git a/src/Data/Winery/Internal.hs b/src/Data/Winery/Internal.hs deleted file mode 100644 --- a/src/Data/Winery/Internal.hs +++ /dev/null @@ -1,262 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- --- | --- Module : Data.Winery.Internal --- Copyright : (c) Fumiaki Kinoshita 2019 --- License : BSD3 --- Stability : Experimental --- --- Maintainer : Fumiaki Kinoshita --- --- Internal functions and datatypes --- ------------------------------------------------------------------------------ -module Data.Winery.Internal - ( unsignedVarInt - , varInt - , Decoder - , evalDecoder - , State(..) - , evalState - , decodeVarInt - , decodeVarIntFinite - , getWord8 - , getWord16 - , getWord32 - , getWord64 - , DecodeException(..) - , indexDefault - , unsafeIndexV - , lookupWithIndexV - , Strategy(..) - , throwStrategy - , TransFusion(..) - )where - -import Control.Applicative -import Control.Exception -import Control.Monad -import Control.Monad.Fix -import qualified Data.ByteString as B -import qualified Data.ByteString.FastBuilder as BB -import qualified Data.ByteString.Internal as B -import qualified Data.ByteString.Builder.Prim.Internal as BPI -import Data.Bits -import Data.Monoid ((<>)) -import Data.String -import qualified Data.Vector.Unboxed as U -import qualified Data.Vector as V -import Data.Word -import Foreign.ForeignPtr -import Foreign.Storable -import Foreign.Ptr -import System.Endian - -unsignedVarInt :: (Bits a, Integral a) => a -> BB.Builder -unsignedVarInt n - | n < 0x80 = BB.word8 (fromIntegral n) - | otherwise = BB.word8 (fromIntegral n `setBit` 7) <> uvarInt (unsafeShiftR n 7) -{-# INLINE unsignedVarInt #-} - -varInt :: (Bits a, Integral a) => a -> BB.Builder -varInt n - | n < 0 = case negate n of - n' - | n' < 0x40 -> BB.word8 (fromIntegral n' `setBit` 6) - | otherwise -> BB.word8 (0xc0 .|. fromIntegral n') <> uvarInt (unsafeShiftR n' 6) - | n < 0x40 = BB.word8 (fromIntegral n) - | otherwise = BB.word8 (fromIntegral n `setBit` 7 `clearBit` 6) <> uvarInt (unsafeShiftR n 6) -{-# RULES "varInt/Int" varInt = varIntFinite #-} -{-# INLINEABLE[1] varInt #-} - -varIntFinite :: Int -> BB.Builder -varIntFinite = BB.primBounded (BPI.boudedPrim 10 writeIntFinite) - -writeWord8 :: Word8 -> Ptr Word8 -> IO (Ptr Word8) -writeWord8 w p = do - poke p w - return $! plusPtr p 1 - -writeIntFinite :: Int -> Ptr Word8 -> IO (Ptr Word8) -writeIntFinite !n - | n < 0 = case negate n of - n' - | n' < 0x40 -> writeWord8 (fromIntegral n' `setBit` 6) - | otherwise -> - writeWord8 (0xc0 .|. fromIntegral n') >=> - writeUnsignedFinite pure (unsafeShiftR n' 6) - | n < 0x40 = writeWord8 (fromIntegral n) - | otherwise = writeWord8 (fromIntegral n `setBit` 7 `clearBit` 6) >=> - writeUnsignedFinite pure (unsafeShiftR n 6) -{-# INLINE writeIntFinite #-} - -writeUnsignedFinite :: (Ptr Word8 -> IO r) -> Int -> Ptr Word8 -> IO r -writeUnsignedFinite k = go - where - go m - | m < 0x80 = writeWord8 (fromIntegral m) >=> k - | otherwise = writeWord8 (setBit (fromIntegral m) 7) >=> go (unsafeShiftR m 7) -{-# INLINE writeUnsignedFinite #-} - -uvarInt :: (Bits a, Integral a) => a -> BB.Builder -uvarInt = go where - go m - | m < 0x80 = BB.word8 (fromIntegral m) - | otherwise = BB.word8 (setBit (fromIntegral m) 7) <> go (unsafeShiftR m 7) -{-# INLINE uvarInt #-} - --- | A state monad. The reason being not @State@ from transformers is to --- allow coercion for newtype deriving and DerivingVia. -newtype State s a = State { runState :: s -> (a, s) } - deriving Functor - -evalState :: State s a -> s -> a -evalState m = fst . runState m -{-# INLINE evalState #-} - -instance Applicative (State s) where - pure a = State $ \s -> (a, s) - m <*> k = State $ \s -> case runState m s of - (f, s') -> case runState k s' of - (a, s'') -> (f a, s'') - -instance Monad (State s) where - m >>= k = State $ \s -> case runState m s of - (a, s') -> runState (k a) s' - -instance MonadFix (State s) where - mfix f = State $ \s -> fix $ \ ~(a, _) -> runState (f a) s - -type Decoder = State B.ByteString - -evalDecoder :: Decoder a -> B.ByteString -> a -evalDecoder = evalState -{-# INLINE evalDecoder #-} - -getWord8 :: Decoder Word8 -getWord8 = State $ \bs -> case B.uncons bs of - Nothing -> throw InsufficientInput - Just (x, bs') -> (x, bs') -{-# INLINE getWord8 #-} - -data DecodeException = InsufficientInput - | IntegerOverflow - | InvalidTag deriving (Eq, Show, Read) -instance Exception DecodeException - -decodeVarIntBase :: (Num a, Bits a) => Decoder a -> Decoder a -decodeVarIntBase body = getWord8 >>= \case - n | testBit n 7 -> do - m <- body - if testBit n 6 - then return $! negate $ unsafeShiftL m 6 .|. fromIntegral n .&. 0x3f - else return $! unsafeShiftL m 6 .|. clearBit (fromIntegral n) 7 - | testBit n 6 -> return $ negate $ fromIntegral $ clearBit n 6 - | otherwise -> return $ fromIntegral n -{-# INLINE decodeVarIntBase #-} - -decodeVarInt :: (Num a, Bits a) => Decoder a -decodeVarInt = decodeVarIntBase $ getWord8 >>= go - where - go n - | testBit n 7 = do - m <- getWord8 >>= go - return $! unsafeShiftL m 7 .|. clearBit (fromIntegral n) 7 - | otherwise = return $ fromIntegral n -{-# INLINE decodeVarInt #-} - -decodeVarIntFinite :: forall a. (Num a, FiniteBits a) => Decoder a -decodeVarIntFinite = decodeVarIntBase $ getWord8 >>= go 7 - where - go w n - | testBit n 7 = do - m <- getWord8 >>= go (w + 7) - return $! unsafeShiftL m 7 .|. clearBit (fromIntegral n) 7 - | w + 7 - countLeadingZeros n < finiteBitSize (0 :: a) = return $ fromIntegral n - | otherwise = throw IntegerOverflow -{-# INLINABLE[1] decodeVarIntFinite #-} -{-# 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)) - else throw InsufficientInput - -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)) - else throw InsufficientInput - -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)) - else throw InsufficientInput - -unsafeIndexV :: U.Unbox a => String -> U.Vector a -> Int -> a -unsafeIndexV err xs i - | i >= U.length xs || i < 0 = error err - | otherwise = U.unsafeIndex xs i -{-# INLINE unsafeIndexV #-} - -lookupWithIndexV :: Eq k => k -> V.Vector (k, v) -> Maybe (Int, v) -lookupWithIndexV k v = (\i -> (i, snd $ V.unsafeIndex v i)) - <$> V.findIndex ((k==) . fst) v -{-# INLINE lookupWithIndexV #-} - -indexDefault :: a -> [a] -> Int -> a -indexDefault err xs i = case drop i xs of - x : _ -> x - _ -> err - --- | A monad with @Reader [r]@ and @Either WineryException@ combined, used internally --- to build an extractor. --- @r@ is used to share environment such as extractors for fixpoints. -newtype Strategy e r a = Strategy { unStrategy :: r -> Either e a } - deriving Functor - -instance Applicative (Strategy e r) where - pure = return - (<*>) = ap - -instance Monad (Strategy e r) where - return = Strategy . const . Right - m >>= k = Strategy $ \decs -> case unStrategy m decs of - Right a -> unStrategy (k a) decs - Left e -> Left e - -instance IsString e => Alternative (Strategy e r) where - empty = Strategy $ const $ Left "empty" - Strategy a <|> Strategy b = Strategy $ \decs -> case a decs of - Left _ -> b decs - Right x -> Right x - -instance MonadFix (Strategy e r) where - mfix f = Strategy $ \r -> mfix $ \a -> unStrategy (f a) r - {-# INLINE mfix #-} - -throwStrategy :: e -> Strategy e r a -throwStrategy = Strategy . const . Left - --- | A Bazaar (chain of indexed store comonad)-like structure which instead --- works for natural transformations. -newtype TransFusion f g a = TransFusion { unTransFusion :: forall h. Applicative h => (forall x. f x -> h (g x)) -> h a } - -instance Functor (TransFusion f g) where - fmap f (TransFusion m) = TransFusion $ \k -> fmap f (m k) - {-# INLINE fmap #-} - -instance Applicative (TransFusion f g) where - pure a = TransFusion $ \_ -> pure a - TransFusion a <*> TransFusion b = TransFusion $ \k -> a k <*> b k - {-# INLINE (<*>) #-} diff --git a/src/Data/Winery/Query.hs b/src/Data/Winery/Query.hs deleted file mode 100644 --- a/src/Data/Winery/Query.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} ----------------------------------------------------------------------------- --- | --- Module : Data.Winery.Query --- Copyright : (c) Fumiaki Kinoshita 2019 --- License : BSD3 --- Stability : Experimental --- --- Maintainer : Fumiaki Kinoshita --- --- Building blocks for winery queries. --- ------------------------------------------------------------------------------ -module Data.Winery.Query (Query(..) - , invalid - , list - , range - , field - , con - , select) where - -import Prelude hiding ((.), id) -import Control.Applicative -import Control.Category -import Data.Winery -import Data.Winery.Internal -import Data.Typeable -import qualified Data.Text as T -import qualified Data.Vector as V - --- | Query is a transformation between 'Extractor's. --- Like jq, this returns a list of values. -newtype Query a b = Query - { runQuery :: Extractor [a] -> Extractor [b] } - deriving Functor - -instance Category Query where - id = Query id - Query f . Query g = Query $ f . g - -instance Applicative (Query a) where - pure a = Query $ const $ pure [a] - Query f <*> Query g = Query $ \d -> (<*>) <$> f d <*> g d - -instance Alternative (Query a) where - empty = Query $ const $ pure [] - Query f <|> Query g = Query $ \d -> (++) <$> f d <*> g d - --- | Throw an error. -invalid :: WineryException -> Query a b -invalid = Query . const . Extractor . Plan . const . throwStrategy - --- | Takes a list and traverses on it. -list :: Typeable a => Query a a -list = Query $ fmap concat . extractListBy - --- | Takes a list and enumerates elements in the specified range. --- Like Python's array slicing, negative numbers counts from the last element. -range :: Typeable a => Int -> Int -> Query a a -range i j = Query $ fmap (\v -> foldMap id - $ V.backpermute v (V.enumFromTo (i `mod` V.length v) (j `mod` V.length v))) - . extractListBy - --- | Takes a record and extracts the specified field. -field :: Typeable a => T.Text -> Query a a -field name = Query $ \d -> buildExtractor $ extractFieldBy d name - --- | Takes a variant and returns a value when the constructor matches. -con :: Typeable a => T.Text -> Query a a -con name = Query $ \d -> buildExtractor $ extractConstructorBy (d, name, id) (pure []) - --- | 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 - return $ \bs -> [x | and $ p bs, x <- dec bs] diff --git a/src/Data/Winery/Query/Parser.hs b/src/Data/Winery/Query/Parser.hs deleted file mode 100644 --- a/src/Data/Winery/Query/Parser.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- --- | --- Module : Data.Winery.Query.Parser --- Copyright : (c) Fumiaki Kinoshita 2019 --- License : BSD3 --- Stability : Experimental --- --- Maintainer : Fumiaki Kinoshita --- --- The language for winery queries --- --- See the Pretty-printing section of README.md for examples. --- ------------------------------------------------------------------------------ -module Data.Winery.Query.Parser (parseQuery) where - -import Prelude hiding ((.), id) -import Control.Category -import Data.Winery.Query -import Text.Megaparsec -import Text.Megaparsec.Char -import qualified Text.Megaparsec.Char.Lexer as L -import qualified Data.Text as T -import Data.Text.Prettyprint.Doc (Doc, hsep) -import Data.Typeable -import Data.Void - -type Parser = Parsec Void T.Text - -symbol :: T.Text -> Parser T.Text -symbol = L.symbol space - -name :: Parser T.Text -name = fmap T.pack (some (alphaNumChar <|> oneOf ("_\'" :: [Char])) "field name") - -parseQuery :: Typeable a => Parser (Query (Doc a) (Doc a)) -parseQuery = foldr (.) id <$> sepBy1 parseTerms (symbol "|") - --- | Space-separated list of terms translate to a tabular output, applying the --- queries in parallel -parseTerms :: Typeable a => Parser (Query (Doc a) (Doc a)) -parseTerms = fmap hsep . sequenceA <$> sepBy1 parseTerm space - -parseTerm :: Typeable a => Parser (Query (Doc a) (Doc a)) -parseTerm = L.lexeme space $ choice - [ char '.' >> choice - [ do - _ <- char '[' - i <- optional L.decimal - j <- optional (symbol ":" >> L.decimal) - _ <- char ']' - return $ range (maybe 0 id i) (maybe (-1) id j) - , field <$> name - , return id - ] - ] diff --git a/src/Data/Winery/Test.hs b/src/Data/Winery/Test.hs --- a/src/Data/Winery/Test.hs +++ b/src/Data/Winery/Test.hs @@ -1,199 +1,5 @@ -{-# LANGUAGE Rank2Types, ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE AllowAmbiguousTypes #-} ----------------------------------------------------------------------------- --- | --- Module : Data.Winery.Test --- Copyright : (c) Fumiaki Kinoshita 2019 --- License : BSD3 --- Stability : Experimental --- --- Maintainer : Fumiaki Kinoshita --- --- A test framework that allows you to test all related Serialise instances --- with automatically-generated test cases --- ------------------------------------------------------------------------------ -module Data.Winery.Test - ( -- * Generating tests - TestGen(..) - , printTests - -- * Test cases - , Tested(..) - , testCase - -- * Running tests - , allTests - , mergeTests - ) where - -import Test.HUnit -import qualified Data.Map as M -import qualified Data.HashMap.Strict as HM -import qualified Data.ByteString as B -import Data.Functor.Identity -import Data.Hashable -import Data.Proxy -import qualified Data.Sequence as S -import Data.Typeable -import Data.Winery -import qualified Data.Vector as V -import qualified Data.Vector.Unboxed as UV -import GHC.Generics -import Text.Show - --- | Construct a test case. -testCase :: (Show a, Eq a, Serialise a) - => Schema -- ^ the schema - -> B.ByteString -- ^ serialised - -> a -- ^ expected - -> Test -testCase sch bs expected = case getDecoder sch of - Left err -> TestCase $ assertFailure (show err) - Right f -> expected ~=? evalDecoder f bs - --- | Merge multiple tests into one. -mergeTests :: M.Map TypeRep [Test] -> Test -mergeTests = TestList . concatMap (\(k, v) -> map (show k ~:) v) . M.toList - --- | Gather all test cases involved in the specified type. -allTests :: forall a. (TestGen a, Tested a) => M.Map TypeRep [Test] -allTests = M.insertWith (++) (typeRep (Proxy @ a)) (testCases @ a) (inheritedTests (Proxy @ a)) - --- | Types with concrete test cases. --- --- /"Doubt is useful, it keeps faith a living thing. After all, you cannot know --- the strength of your faith until it has been tested."/ -class TestGen a => Tested a where - -- | List of test cases for the type. - testCases :: [Test] - --- these are already covered by the QuickCheck tests from winery -instance Tested Bool where testCases = [] -instance Tested Int where testCases = [] -instance Tested Double where testCases = [] -instance Tested () where testCases = [] -instance Tested Char where testCases = [] -instance Tested a => Tested (Identity a) where - testCases = testCases @ a -instance Tested a => Tested (S.Seq a) where testCases = [] -instance Tested a => Tested [a] where testCases = [] -instance (Tested a, Tested b) => Tested (Either a b) where testCases = [] -instance (Tested a, Tested b) => Tested (a, b) where testCases = [] -instance Tested a => Tested (V.Vector a) where testCases = [] -instance (UV.Unbox a, Tested a) => Tested (UV.Vector a) where testCases = [] -instance (Hashable k, Tested k, Tested a) => Tested (HM.HashMap k a) where testCases = [] - --- | Generate test cases and print them to the standard output. -printTests :: forall a. (TestGen a, Serialise a, Show a) => IO () -printTests = putStrLn $ showTests (genTestCases :: [a]) - -showTests :: (Serialise a, Show a) => [a] -> String -showTests xs = showListWith ppTest xs "" - -ppTest :: (Serialise a, Show a) => a -> ShowS -ppTest a = showString "testCase " - . showsPrec 11 (schema [a]) - . showChar ' ' - . showsPrec 11 (serialiseOnly a) - . showChar ' ' - . showsPrec 11 a - --- | A class to provide test values and gather tests for its components. --- It is recommended to use the generic default methods. -class Typeable a => TestGen a where - -- | A list of values that can be used as test cases. - -- It should contain at least one value as long as there is a non-bottom value - -- in the type. - genTestCases :: [a] - - -- | Inherited set of test cases for each type it involves. - inheritedTests :: Proxy a -> M.Map TypeRep [Test] - - default genTestCases :: (Generic a, GTestGen (Rep a)) => [a] - genTestCases = fmap to ggenTestCases - - default inheritedTests :: (GTestGen (Rep a)) => Proxy a -> M.Map TypeRep [Test] - inheritedTests _ = ginheritedTests (Proxy @ (Rep a)) - -class GTestGen f where - ggenTestCases :: [f x] - ginheritedTests :: proxy f -> M.Map TypeRep [Test] - -instance GTestGen V1 where - ggenTestCases = mempty - ginheritedTests _ = mempty - -instance GTestGen U1 where - ggenTestCases = [U1] - ginheritedTests _ = mempty - -instance GTestGen f => GTestGen (Rec1 f) where - ggenTestCases = fmap Rec1 ggenTestCases - ginheritedTests _ = ginheritedTests (Proxy @ f) - -instance (Tested c, TestGen c) => GTestGen (K1 i c) where - ggenTestCases = fmap K1 genTestCases - ginheritedTests _ = allTests @ c - -instance GTestGen f => GTestGen (M1 i c f) where - ggenTestCases = fmap M1 ggenTestCases - ginheritedTests _ = ginheritedTests (Proxy @ f) - -instance (GTestGen f, GTestGen g) => GTestGen (f :+: g) where - ggenTestCases = fmap L1 ggenTestCases ++ fmap R1 ggenTestCases - ginheritedTests _ = ginheritedTests (Proxy @ f) - `mappend` ginheritedTests (Proxy @ g) - -instance (GTestGen f, GTestGen g) => GTestGen (f :*: g) where - ggenTestCases = ((:*:) <$> ggenTestCases <*> xs) - ++ ((:*:) <$> take 1 ggenTestCases <*> ys) - where - (xs, ys) = splitAt 1 ggenTestCases - ginheritedTests _ = ginheritedTests (Proxy @ f) - `mappend` ginheritedTests (Proxy @ g) - -deriving instance TestGen a => TestGen (Identity a) -instance TestGen () -instance TestGen Bool -instance (Tested a, Tested b) => TestGen (a, b) -instance (Tested a, Tested b, Tested c) => TestGen (a, b, c) -instance (Tested a, Tested b, Tested c, Tested d) => TestGen (a, b, c, d) -instance (Tested a, Tested b) => TestGen (Either a b) - -instance Tested a => TestGen [a] where - genTestCases = [[]] - inheritedTests _ = allTests @ a - -instance Tested a => TestGen (S.Seq a) where - genTestCases = [mempty] - inheritedTests _ = allTests @ a - -instance Tested a => TestGen (V.Vector a) where - genTestCases = [V.empty] - inheritedTests _ = allTests @ a - -instance (UV.Unbox a, Tested a) => TestGen (UV.Vector a) where - genTestCases = [UV.empty] - inheritedTests _ = allTests @ a - -instance (Hashable k, Tested k, Tested a) => TestGen (HM.HashMap k a) where - genTestCases = HM.singleton <$> genTestCases <*> genTestCases - inheritedTests _ = allTests @ k `mappend` allTests @ a - -instance TestGen Int where - genTestCases = [42] - inheritedTests = mempty - -instance TestGen Double where - genTestCases = [pi] - inheritedTests = mempty +module Data.Winery.Test {-# DEPRECATED "Use Codec.Winery instead" #-} + ( module Codec.Winery.Test ) + where -instance TestGen Char where - genTestCases = ['X'] - inheritedTests = mempty +import Codec.Winery.Test diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -14,8 +14,8 @@ import Data.Set (Set) import Data.Text (Text) import Data.Time (UTCTime, NominalDiffTime) -import Data.Winery -import Data.Winery.Internal +import Codec.Winery +import Codec.Winery.Internal import Data.Word import qualified Data.ByteString.FastBuilder as B import qualified Data.ByteString.Lazy as BL diff --git a/winery.cabal b/winery.cabal --- a/winery.cabal +++ b/winery.cabal @@ -1,9 +1,12 @@ cabal-version: 1.12 name: winery -version: 1.0.1 -synopsis: Sustainable serialisation library -description: Please see the README on GitHub at +version: 1.1 +synopsis: A compact, well-typed seralisation format for Haskell values +description: + <> + . + Please see the README on GitHub at category: Data, Codec, Parsing, Serialization homepage: https://github.com/fumieval/winery#readme bug-reports: https://github.com/fumieval/winery/issues @@ -15,8 +18,11 @@ tested-with: GHC == 8.4.4, GHC == 8.6.3 build-type: Simple extra-source-files: - README.md - ChangeLog.md + README.md + ChangeLog.md + .travis.yml + art/logo.png + art/logo.svg source-repository head type: git @@ -24,11 +30,13 @@ library exposed-modules: + Codec.Winery + Codec.Winery.Base + Codec.Winery.Internal + Codec.Winery.Query + Codec.Winery.Query.Parser + Codec.Winery.Test Data.Winery - Data.Winery.Base - Data.Winery.Internal - Data.Winery.Query - Data.Winery.Query.Parser Data.Winery.Test other-modules: Paths_winery