winery 1.0.1 → 1.1
raw patch · 20 files changed
+2411/−2185 lines, 20 filesbinary-added
Files
- .travis.yml +115/−0
- ChangeLog.md +18/−6
- app/Main.hs +3/−3
- art/logo.png binary
- art/logo.svg +1/−0
- benchmarks/bench.hs +1/−1
- src/Codec/Winery.hs +1291/−0
- src/Codec/Winery/Base.hs +302/−0
- src/Codec/Winery/Internal.hs +265/−0
- src/Codec/Winery/Query.hs +77/−0
- src/Codec/Winery/Query/Parser.hs +61/−0
- src/Codec/Winery/Test.hs +249/−0
- src/Data/Winery.hs +5/−1273
- src/Data/Winery/Base.hs +0/−293
- src/Data/Winery/Internal.hs +0/−262
- src/Data/Winery/Query.hs +0/−77
- src/Data/Winery/Query/Parser.hs +0/−61
- src/Data/Winery/Test.hs +4/−198
- test/Spec.hs +2/−2
- winery.cabal +17/−9
+ .travis.yml view
@@ -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
ChangeLog.md view
@@ -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
app/Main.hs view
@@ -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
+ art/logo.png view
binary file changed (absent → 19135 bytes)
+ art/logo.svg view
@@ -0,0 +1,1 @@+<svg id="レイヤー_1" data-name="レイヤー 1" xmlns="http://www.w3.org/2000/svg" viewBox="0 0 512 512"><defs><style>.cls-1{font-size:35.43px;fill:#9a8b5c;font-family:Cardo-Bold, Cardo;font-weight:700;}.cls-2{fill:#4d4545;}.cls-3{fill:#404040;}.cls-4{fill:#643f33;}.cls-5{fill:#bc6974;}.cls-6{fill:#4d4d4d;}.cls-7{fill:#975e4d;}</style></defs><title>logo</title><text class="cls-1" transform="translate(158.38 497.91) scale(1.03 1)">SINCE 2018</text><path class="cls-2" d="M97.13,455c-.69,0-1.15-.42-1.36-1.27q-5-15.6-10-32.12-4.64,15.15-9.3,31.24a3.44,3.44,0,0,1-1,1.81A2.7,2.7,0,0,1,74,455H67.72a1,1,0,0,1-.82-.35,3,3,0,0,1-.53-1.11c-7.69-26.45-15.26-54.8-22.63-85.41a12.21,12.21,0,0,0-1.36-3.4,14.47,14.47,0,0,0-1.88-2.53,17.35,17.35,0,0,0-3.31-2.71,6.21,6.21,0,0,1-.71-.49c-.28-.21-.56-.41-.84-.59l-.74-.5a2.56,2.56,0,0,0-.4-.24c-.22-.08-.33-.3-.33-.68v-3.12c0-.37.11-.52.33-.44q13.85,4.92,27.85,9.2c.17.06.27.14.29.26a1.36,1.36,0,0,1,0,.36c0,.94,0,1.88,0,2.83a1,1,0,0,1-.06.3c0,.11-.13.15-.27.11l-.77-.22A4.52,4.52,0,0,0,59,366.1a2.62,2.62,0,0,0-1.41,1,3.71,3.71,0,0,0-.58,1.69,15.77,15.77,0,0,0-.1,1.74,13.73,13.73,0,0,0,.29,2.76c.19.88.36,1.79.51,2.74C63,396.25,68.23,415.4,73.56,433.66a.92.92,0,0,0,.83.68.43.43,0,0,0,.39-.17,2.79,2.79,0,0,0,.25-.47q3.6-12.36,7.17-24.14-4.89-16.55-9.73-34.1a14.08,14.08,0,0,0-1.74-3.88,8.11,8.11,0,0,0-2.23-2.49,12.88,12.88,0,0,0-1.36-.95,6.12,6.12,0,0,0-1-.53c-.23-.07-.34-.27-.35-.61,0-.93,0-1.86,0-2.8,0-.33.11-.47.33-.4q20.19,6,40.63,10.76a.35.35,0,0,1,.3.24,1.26,1.26,0,0,1,0,.29l0,2.46a1,1,0,0,1,0,.3c0,.09-.13.11-.3.07l-1.59-.35a5.85,5.85,0,0,0-2.72-.05,4.23,4.23,0,0,0-2.1,1.28,9.85,9.85,0,0,0-1.7,2.65,36.12,36.12,0,0,0-1.51,4q-2.52,7.69-5.05,15.63,5.36,17.67,10.76,34.27a.9.9,0,0,0,.83.62c.29,0,.5-.18.64-.59,5.48-17.29,10.94-33.72,16.41-49.44a6.94,6.94,0,0,0,.47-2.44,2.6,2.6,0,0,0-1-2.15,9.3,9.3,0,0,0-3.61-1.3l-2.68-.56c-.23,0-.34-.21-.35-.51l0-2.42a.92.92,0,0,1,0-.26c0-.1.13-.14.3-.1q10.25,2.25,20.53,4.16a.36.36,0,0,1,.31.21,1,1,0,0,1,0,.27c0,.76,0,1.52,0,2.29a.77.77,0,0,1,0,.27c0,.09-.12.11-.3.08l-2-.37a3,3,0,0,0-1.81.17,3.79,3.79,0,0,0-1.43,1.26,12.1,12.1,0,0,0-1.25,2.33c-.4,1-.82,2.07-1.26,3.37-7,19.75-13.9,40.59-20.87,62.84a3,3,0,0,1-1,1.66,2.89,2.89,0,0,1-1.5.31Zm-5.3-76.27a8,8,0,0,0,.34-1.32,6.64,6.64,0,0,0,0-1c0-1.24-1-2.1-2.94-2.59a4.23,4.23,0,0,0-2-.11,2.56,2.56,0,0,0-1.21.65,2.42,2.42,0,0,0-.6,1.13,5.56,5.56,0,0,0-.16,1.33,9,9,0,0,0,.15,1.4c.09.5.25,1.18.47,2.05s.54,2,.94,3.38.93,3.21,1.59,5.43Q90.17,383.84,91.83,378.75Z"/><path class="cls-2" d="M168.63,447.3a4.51,4.51,0,0,0,1.33,1.8,5.19,5.19,0,0,0,2.09,1,12.17,12.17,0,0,0,2.75.31c.23,0,.35.13.35.39,0,.86,0,1.71,0,2.57a.77.77,0,0,1,0,.27c0,.08-.13.11-.3.11l-25.56-.07a.27.27,0,0,1-.28-.15.56.56,0,0,1-.07-.25l-.05-2.72a.74.74,0,0,1,.06-.25.27.27,0,0,1,.28-.15A15.44,15.44,0,0,0,152,450a4.24,4.24,0,0,0,2.09-.95,4.64,4.64,0,0,0,1.3-2.11,11.87,11.87,0,0,0,.41-3.76q-.41-25-.83-49.92a8.41,8.41,0,0,0-.5-2.89,5.76,5.76,0,0,0-1.34-2A6.33,6.33,0,0,0,151,387a12.88,12.88,0,0,0-2.77-.73.41.41,0,0,1-.35-.46c0-.9,0-1.81,0-2.72,0-.26.11-.38.34-.34q12.84,2.1,25.74,3.7a.34.34,0,0,1,.29.18.8.8,0,0,1,.07.25c0,.86,0,1.72,0,2.57a.46.46,0,0,1-.07.23c0,.1-.13.13-.28.11a16.72,16.72,0,0,0-2.76-.11,3.83,3.83,0,0,0-2.1.68,3.73,3.73,0,0,0-1.32,1.91,10.44,10.44,0,0,0-.42,3.61q.39,24.33.77,48.67A7.4,7.4,0,0,0,168.63,447.3Z"/><path class="cls-2" d="M190.76,453.65a.38.38,0,0,1-.14-.25c0-.69,0-1.37,0-2,0-.25.11-.37.34-.37H192c.4,0,.8,0,1.19,0l1.06-.09a2,2,0,0,0,.73-.18,4.93,4.93,0,0,0,1.76-1.46,6.69,6.69,0,0,0,1-2.11,12.86,12.86,0,0,0,.47-2.62c.07-.95.11-2,.09-3q-.27-23-.55-45.93a2.71,2.71,0,0,0-1-2.08,7.77,7.77,0,0,0-2.2-1.34,15.52,15.52,0,0,0-2.55-.76c-.86-.17-1.51-.27-1.94-.32a.31.31,0,0,1-.29-.16.75.75,0,0,1-.07-.24c0-.68,0-1.36,0-2.05a.56.56,0,0,1,.06-.22c0-.09.13-.13.28-.11q9.9,1,19.83,1.65c12.73,15.27,25.37,29.61,37.88,43.74a3.74,3.74,0,0,1,.31.33.26.26,0,0,0,.21.11c.12,0,.19,0,.22-.13a.84.84,0,0,0,0-.27l0-26.3a66.87,66.87,0,0,0-.32-7,10.48,10.48,0,0,0-1.15-4,4,4,0,0,0-2.24-1.86,12.42,12.42,0,0,0-3.6-.51l-2.23,0a.32.32,0,0,1-.29-.14.6.6,0,0,1-.06-.23c0-.65,0-1.3,0-2a.56.56,0,0,1,.06-.22.29.29,0,0,1,.29-.13q12.06.28,24.14.14c.17,0,.28,0,.3.13a.68.68,0,0,1,.05.22v1.95a.67.67,0,0,1-.07.22.29.29,0,0,1-.29.13,10.15,10.15,0,0,0-2.26.38,13.59,13.59,0,0,0-2.69,1,8.32,8.32,0,0,0-2.26,1.64,3.11,3.11,0,0,0-.95,2.22v52.35a2.13,2.13,0,0,1-.35,1.26,2.66,2.66,0,0,1-.88.82,4.26,4.26,0,0,1-1.17.46,4.53,4.53,0,0,1-1.15.16,6.68,6.68,0,0,1-2-.38,5.34,5.34,0,0,1-2.27-1.66c-13.64-15.46-27.44-31.06-41.35-47.75a3.15,3.15,0,0,0-.44-.41.85.85,0,0,0-.35-.09c-.15,0-.22.14-.22.45q.22,20.34.44,40.7a4.14,4.14,0,0,0,.61,2.22,5.75,5.75,0,0,0,1.51,1.6,7.69,7.69,0,0,0,2,1.06,17,17,0,0,0,2.17.62,12.73,12.73,0,0,0,1.9.3c.57.05,1,.08,1.28.08a.3.3,0,0,1,.3.18.41.41,0,0,1,.05.18c0,.66,0,1.32,0,2a.46.46,0,0,1-.07.23c0,.09-.13.13-.28.13q-11.89,0-23.78,0A.35.35,0,0,1,190.76,453.65Z"/><path class="cls-2" d="M274.07,451.56a.82.82,0,0,1,0-.2c0-.11.13-.16.31-.16h.95c1.21-.09,2.45-.15,3.72-.17a12.11,12.11,0,0,0,3.47-.5,5.25,5.25,0,0,0,2.56-1.66,5.71,5.71,0,0,0,1-3.7l.33-45.86a5,5,0,0,0-.68-2.82A5.09,5.09,0,0,0,284,394.8a9.14,9.14,0,0,0-2.58-.9q-1.45-.27-2.94-.45l-.92,0c-.15,0-.24,0-.28-.12a.46.46,0,0,1-.07-.22c0-.58,0-1.16,0-1.74a.46.46,0,0,1,.07-.22.28.28,0,0,1,.28-.14q21.85-.77,43.64-3a1.6,1.6,0,0,1,1.13.19,1.82,1.82,0,0,1,.42,1.28q.28,7.44.58,14.89c0,.15-.13.28-.37.38a2.93,2.93,0,0,1-.68.17,3.29,3.29,0,0,1-.7,0,.73.73,0,0,1-.47-.25,3.15,3.15,0,0,1-.42-1.34c-.08-.6-.17-1.26-.26-2s-.23-1.5-.4-2.29a7.88,7.88,0,0,0-.83-2.16,4.87,4.87,0,0,0-1.52-1.65,5.11,5.11,0,0,0-2.5-.83q-7.8.66-15.62,1.15a.55.55,0,0,0-.57.62l-.21,21.6c0,.31.14.45.43.44q6.22-.24,12.46-.55a8.24,8.24,0,0,0,2.16-.41,4.72,4.72,0,0,0,1.88-1.18,6.4,6.4,0,0,0,1.34-2.28,11.62,11.62,0,0,0,.54-3.67c0-.24.12-.38.36-.39l1.7-.12c.23,0,.34.11.34.35q-.14,10.66-.28,21.31c0,.16-.05.26-.14.31a.49.49,0,0,1-.22.08l-1.69.06c-.14,0-.24,0-.28-.13a.6.6,0,0,1-.06-.23,14.23,14.23,0,0,0-.45-4.18,6.1,6.1,0,0,0-1.29-2.44,3.71,3.71,0,0,0-1.88-1.12,8.17,8.17,0,0,0-2.23-.21q-6.17.27-12.32.46c-.29,0-.43.17-.43.47q-.1,9.9-.2,19.79a4.84,4.84,0,0,0,.37,2.11,2.85,2.85,0,0,0,1.05,1.19,4.21,4.21,0,0,0,1.53.53,10.77,10.77,0,0,0,1.82.12l11.82-.1a7.07,7.07,0,0,0,4.22-1.28,10.34,10.34,0,0,0,2.77-3.05,15,15,0,0,0,1.59-3.72,22.15,22.15,0,0,0,.67-3.3,1.45,1.45,0,0,1,.58-1,1.93,1.93,0,0,1,1.09-.39,1.2,1.2,0,0,1,.52.17.49.49,0,0,1,.29.42q-.84,8.64-1.67,17.23a1.61,1.61,0,0,1-.25.44.43.43,0,0,1-.37.22q-25.06,0-50.13.06-.25,0-.3-.15a.92.92,0,0,1,0-.2v-.63C274.06,452.42,274.07,452,274.07,451.56Z"/><path class="cls-2" d="M341.17,451.21a1.16,1.16,0,0,1,.05-.22c0-.11.13-.17.31-.17a5.3,5.3,0,0,0,.82-.11l1.17-.2c.41-.07.78-.15,1.13-.23l.74-.18a5.77,5.77,0,0,0,3.47-2.12,6.4,6.4,0,0,0,1-3.63q.42-25,.83-50a6.45,6.45,0,0,0-.85-3.76,5.18,5.18,0,0,0-2.08-1.85,5.89,5.89,0,0,0-2.29-.57,14.27,14.27,0,0,0-1.5,0l-1.66.22a.25.25,0,0,1-.28-.11.6.6,0,0,1-.06-.23c0-.71,0-1.42,0-2.13a.64.64,0,0,1,0-.22c0-.09.13-.16.31-.21l.2,0,.63-.11,1.39-.24,2.58-.43c1.59-.26,3.3-.56,5.11-.9l5.51-1.05,5.5-1.08,5.1-1,4.38-.79a17.69,17.69,0,0,1,6.95.1,14.93,14.93,0,0,1,6.35,3,16.33,16.33,0,0,1,4.6,6.16,22.07,22.07,0,0,1,1.67,9.46,25.43,25.43,0,0,1-.88,6.51,21.11,21.11,0,0,1-2.22,5.2,20,20,0,0,1-3.3,4.11,28.9,28.9,0,0,1-4.13,3.24q6.33,12.08,12.67,25a32.85,32.85,0,0,0,3.83,6.11,11.91,11.91,0,0,0,5.17,3.87c.23.08.37.18.41.31a1.65,1.65,0,0,1,.06.48,1.46,1.46,0,0,1-.36,1.13,1.73,1.73,0,0,1-1.09.28,32.19,32.19,0,0,1-4.12-.3,31,31,0,0,1-4.64-1,24.61,24.61,0,0,1-4.4-1.75,11.54,11.54,0,0,1-3.48-2.65,24.41,24.41,0,0,1-2.75-3.73q-1.38-2.25-2.79-4.82c-.94-1.7-1.86-3.47-2.76-5.29s-1.79-3.59-2.64-5.31-1.66-3.3-2.44-4.76-1.5-2.69-2.15-3.7l-6.74,0-.35,0a.73.73,0,0,0-.43.13.67.67,0,0,0-.18.22,1.13,1.13,0,0,0,0,.4q-.18,10.77-.37,21.53a8.43,8.43,0,0,0,.26,2.37,4,4,0,0,0,1,1.72,5.06,5.06,0,0,0,1.84,1.17,13.3,13.3,0,0,0,2.78.68l.75.14,1.08.22c.39.08.77.16,1.14.22a6.22,6.22,0,0,0,.95.09q.27,0,.3.15a1,1,0,0,1,0,.26l0,2.28a.6.6,0,0,1-.07.26.28.28,0,0,1-.28.16l-30.49.09c-.14,0-.23-.23-.27-.68s0-.87,0-1.25Zm21.61-34.59a2.25,2.25,0,0,0,.19.71.62.62,0,0,0,.62.33l1.16.07a14.19,14.19,0,0,0,2.17-.06,13.55,13.55,0,0,0,6.3-2,12.46,12.46,0,0,0,4-4.18,17.7,17.7,0,0,0,2.06-5.72,37.85,37.85,0,0,0,.65-6.54,22.44,22.44,0,0,0-.79-6.54,14.48,14.48,0,0,0-2.44-5,9.52,9.52,0,0,0-3.84-3,8.72,8.72,0,0,0-5-.48c-.41.06-.73.13-1,.18l-.67.16-.74.18-1.15.26a2.8,2.8,0,0,0-.68.24.75.75,0,0,0-.42.75q-.25,14.55-.5,29.1Z"/><path class="cls-2" d="M436,422.67a1.28,1.28,0,0,0-.12-.6c-5.73-12.92-11.42-25.1-17.1-36.67q-.71-1.42-1.53-2.85a17.8,17.8,0,0,0-1.8-2.62,10.59,10.59,0,0,0-2.15-2,5.37,5.37,0,0,0-2.54-.93l-.68,0c-.31,0-.64,0-1,0h-1l-.68,0c-.29,0-.56-.14-.81-.52a1.85,1.85,0,0,1-.37-1.07c0-.07,0-.21,0-.4a3.44,3.44,0,0,1,.09-.56,2.18,2.18,0,0,1,.2-.5.57.57,0,0,1,.35-.28Q421.52,370.12,436,366c.31-.09.51.06.59.45a5.4,5.4,0,0,1,.12,1.08c0,.41,0,.85-.08,1.32s-.21.74-.5.82l-2.17.84a5.88,5.88,0,0,0-1.76,1,4.67,4.67,0,0,0-1.16,1.68,6.85,6.85,0,0,0-.46,2.67,5.59,5.59,0,0,0,.48,2.49q6.36,13.38,12.75,27.9c.31.67.51,1.09.61,1.24a.43.43,0,0,0,.49.18c.2,0,.38-.23.54-.59s.36-.85.59-1.44q5.27-13.95,10.45-28.85c.4-1.12.81-2.36,1.23-3.71a14.15,14.15,0,0,0,.63-4,10.58,10.58,0,0,0-.3-2.87,2.48,2.48,0,0,0-1-1.41,2.7,2.7,0,0,0-1.54-.39,17.53,17.53,0,0,0-2.09.18c-.31.05-.49-.16-.55-.62a9.91,9.91,0,0,1-.07-1.29,8.72,8.72,0,0,1,.11-1.18,1,1,0,0,1,.62-.88q10.64-3.37,21.19-7.12c.22-.08.38.13.46.65a7.16,7.16,0,0,1,.13,1.12,3.09,3.09,0,0,1-.27,1.3,4.45,4.45,0,0,1-.68,1,5.12,5.12,0,0,1-.84.78l-.82.59a14.53,14.53,0,0,0-3.64,3.73,42.54,42.54,0,0,0-3,5.31c-.14.27-.34.7-.61,1.27s-.42.92-.45,1q-8.25,25.08-16.72,47.52-.07,11.42-.17,22.81a11.16,11.16,0,0,0,1.3,6q1.32,2.1,4.73,2.57a8.5,8.5,0,0,0,1.21,0l1.25,0a.26.26,0,0,1,.28.2,1.16,1.16,0,0,1,.06.33c0,1,0,2,0,2.92a1,1,0,0,1-.07.34.27.27,0,0,1-.28.2l-29.44.16a.27.27,0,0,1-.28-.18,1,1,0,0,1-.06-.3l0-2.66a1.05,1.05,0,0,1,.07-.3.3.3,0,0,1,.28-.19l1.24,0a8.14,8.14,0,0,0,1.23-.08,6.61,6.61,0,0,0,4.78-2.61,10.79,10.79,0,0,0,1.39-5.81Q435.93,432,436,422.67Z"/><path class="cls-3" d="M51.11,81.26a6.26,6.26,0,0,1-1,2.52,7.52,7.52,0,0,1-2.07,2.11,14,14,0,0,1-3,1.58,16.53,16.53,0,0,1-2.61.8,11.41,11.41,0,0,1-1.91.26,7.31,7.31,0,0,1-1.23,0,1.49,1.49,0,0,0-.51,0c-.06,0-.15.2-.26.51s-.2.61-.28.88L38,90q-1.2-2.88-2.38-5.76l.3-.12a11.08,11.08,0,0,0,1.3,1.26,15.75,15.75,0,0,0,1.48,1,9.13,9.13,0,0,0,1.51.74,5.93,5.93,0,0,0,1.37.34,10.18,10.18,0,0,0,1.57,0,6.32,6.32,0,0,0,1.74-.37,5.88,5.88,0,0,0,3.19-2.56,4.26,4.26,0,0,0,.21-3.73,3.51,3.51,0,0,0-2-2.13,5.19,5.19,0,0,0-1.42-.36,13.83,13.83,0,0,0-1.6-.06l-1.46,0-1.16.06-1.11,0c-.38,0-.84,0-1.38,0a7.88,7.88,0,0,1-1.85-.2,6.86,6.86,0,0,1-1.76-.69,6.43,6.43,0,0,1-1.49-1.16,5,5,0,0,1-1-1.63,6.09,6.09,0,0,1-.46-3,6,6,0,0,1,.91-2.54,7.68,7.68,0,0,1,2-2.06,11.41,11.41,0,0,1,2.74-1.47,12.34,12.34,0,0,1,2.5-.7,10.88,10.88,0,0,1,1.84-.13,5.31,5.31,0,0,1,1.15.12,3.22,3.22,0,0,0,.45.09c.06,0,.15-.19.26-.5s.21-.61.29-.91l.35-.13L46,69l-.35.13A11.5,11.5,0,0,0,44,67.58a8.94,8.94,0,0,0-2-1.19,7.14,7.14,0,0,0-2.25-.55,5.52,5.52,0,0,0-2.4.38,6.68,6.68,0,0,0-1.74,1,4.53,4.53,0,0,0-1.2,1.36,4,4,0,0,0-.5,1.69,4.41,4.41,0,0,0,.33,1.91,3.5,3.5,0,0,0,2,2.09,7.71,7.71,0,0,0,3.14.5c.47,0,.91,0,1.31,0l1.2-.07c.39,0,.78,0,1.19-.06l1.27,0a7.58,7.58,0,0,1,4,.93,5.57,5.57,0,0,1,2.43,3.06A5.71,5.71,0,0,1,51.11,81.26Z"/><path class="cls-3" d="M75.06,76.7q-9.41,3-18.72,6.37l-.11-.3a6.75,6.75,0,0,0,1.28-.89,2.92,2.92,0,0,0,.82-1.12,1.52,1.52,0,0,0,.07-.6c0-.25-.06-.53-.11-.85a9.37,9.37,0,0,0-.22-1c-.1-.34-.2-.66-.31-1s-.22-.66-.38-1.13l-.51-1.56c-.19-.57-.39-1.14-.6-1.74s-.41-1.18-.6-1.71l-2-5.76c-.12-.35-.26-.71-.4-1.08s-.29-.72-.43-1a5.15,5.15,0,0,0-.48-.85,1.27,1.27,0,0,0-.5-.47,2.45,2.45,0,0,0-1.23-.25,13.81,13.81,0,0,0-1.48.25l-.1-.3q8.71-3.12,17.51-6,1.89,2.1,3.75,4.22l-.27.25a15.54,15.54,0,0,0-6.13-2.48,8.25,8.25,0,0,0-2.14.25,28.14,28.14,0,0,0-3.62,1c-.44.15-.9.32-1.36.51s-.8.35-1,.46c.07.33.26,1,.57,2s.69,2.15,1.14,3.45l.65,1.9c.18.51.33.93.45,1.25s.22.57.28.75l.11.32.62-.21c.31-.11.67-.24,1.07-.4l1.19-.49a8.77,8.77,0,0,0,1-.48A5.66,5.66,0,0,0,64.18,67a3.43,3.43,0,0,0,.73-1.2,4.34,4.34,0,0,0,.24-1.38,16.11,16.11,0,0,0-.07-1.64l.37-.12Q67,67.33,68.55,72l-.38.12a9.82,9.82,0,0,0-1.41-1.71,5.26,5.26,0,0,0-1.58-1.15A4.22,4.22,0,0,0,63.76,69a6,6,0,0,0-1.75.22l-.8.23-.62.19-.63.22-.81.28a11.2,11.2,0,0,0,.36,1.23c.19.53.38,1.09.57,1.66l.31.89.35,1q.16.48.33.9l.26.72c.24.62.48,1.21.73,1.75a2.89,2.89,0,0,0,.78,1.14,2.09,2.09,0,0,0,1.52.14A15.31,15.31,0,0,0,66.69,79L68,78.49a16.54,16.54,0,0,0,1.65-.72,6.94,6.94,0,0,0,1.66-1.06,6.51,6.51,0,0,0,1.29-1.49,10.46,10.46,0,0,0,1-2,23.06,23.06,0,0,0,.8-2.68l.37,0Q74.92,73.61,75.06,76.7Z"/><path class="cls-3" d="M95.88,70.43l-.52-.3a3.74,3.74,0,0,1-.37-.24c-.13-.09-.31-.23-.53-.41s-.56-.47-1-.83L92,67.43c-.44-.37-.87-.73-1.31-1.08s-.91-.7-1.4-1-1.08-.73-1.74-1.14a12.51,12.51,0,0,0-1.75-.89A3.54,3.54,0,0,0,84,63a5.58,5.58,0,0,0-.94.15c-.19.06-.44.12-.73.19l1,3.39c.29,1,.54,1.76.76,2.42s.4,1.17.56,1.63a2.3,2.3,0,0,0,.68,1,3,3,0,0,0,1.2.51,4.67,4.67,0,0,0,2.12-.12l.09.3q-5,1.45-9.87,3l-.09-.3a9.26,9.26,0,0,0,1.36-.82A2.54,2.54,0,0,0,81,73.31a1.37,1.37,0,0,0,.08-.61,5.51,5.51,0,0,0-.11-.85c-.06-.31-.13-.64-.22-1s-.17-.67-.27-1-.2-.66-.33-1.14-.29-1-.46-1.58-.34-1.16-.52-1.76-.37-1.2-.54-1.73c-.59-1.95-1.19-3.89-1.79-5.84-.11-.36-.23-.72-.35-1.09s-.26-.7-.39-1a4.82,4.82,0,0,0-.44-.85,1.19,1.19,0,0,0-.48-.49,2.46,2.46,0,0,0-1.27-.31,11.23,11.23,0,0,0-1.54.17l-.09-.3,1.31-.41,2.45-.78,2.75-.85,2.24-.67c1.43-.43,2.72-.76,3.85-1a8.09,8.09,0,0,1,3.28-.07A6.3,6.3,0,0,1,91,51.39a5.09,5.09,0,0,1,1.7,2.76,4.84,4.84,0,0,1,.14,2.12,5.66,5.66,0,0,1-.7,1.89,7.55,7.55,0,0,1-1.33,1.63,15.16,15.16,0,0,1-1.76,1.39l0,.09a3.78,3.78,0,0,1,1.26.48,10.06,10.06,0,0,1,1.3.86l2.48,2c.88.71,1.67,1.33,2.36,1.87a9.84,9.84,0,0,0,2.87,1.68,6.5,6.5,0,0,0,2.81.24l.08.3Q99.06,69.52,95.88,70.43ZM87.43,52.55a5.6,5.6,0,0,0-2.88-1.18,7.39,7.39,0,0,0-1.76,0,10.37,10.37,0,0,0-1.82.38c-.45.13-.81.25-1.08.35l-.62.25a2.24,2.24,0,0,1,0,.34q0,.14.06.36c0,.14.08.34.14.59s.16.61.28,1.08c.18.71.41,1.5.66,2.38l.75,2.55c.25.82.47,1.54.65,2.16s.3,1,.35,1.14c.86-.26,1.65-.53,2.37-.82a11.25,11.25,0,0,0,2-1.08,6.25,6.25,0,0,0,1.5-1.31,4.92,4.92,0,0,0,1.13-3.1A5.78,5.78,0,0,0,89,55,4.84,4.84,0,0,0,87.43,52.55Z"/><path class="cls-3" d="M103.35,68.37l-.08-.3a6.46,6.46,0,0,0,1.34-.78,3.13,3.13,0,0,0,.93-1.09,1.08,1.08,0,0,0,.1-.57,5.25,5.25,0,0,0-.08-.82c0-.31-.11-.64-.19-1s-.15-.67-.24-1-.17-.67-.29-1.16-.24-1-.38-1.59-.29-1.17-.45-1.78-.32-1.21-.46-1.76c-.52-2-1-3.93-1.55-5.9l-.28-1.09a9.84,9.84,0,0,0-.32-1,5.15,5.15,0,0,0-.36-.81,1.38,1.38,0,0,0-.45-.52,2.74,2.74,0,0,0-1.31-.45,7.32,7.32,0,0,0-1.58.09l-.08-.31q4.81-1.29,9.65-2.5l.08.31a8.09,8.09,0,0,0-1.37.7,2.08,2.08,0,0,0-1,1.27,3,3,0,0,0,0,1.38q.18.8.33,1.5c.13.51.25,1,.37,1.51s.24,1,.37,1.5l.4,1.58c.14.53.28,1.1.44,1.73.59,2.28,1.17,4.57,1.76,6.85.15.59.3,1.15.46,1.69a2.22,2.22,0,0,0,.58,1.08,2.38,2.38,0,0,0,1.39.49,6.44,6.44,0,0,0,1.54,0l.08.3Q108.06,67.11,103.35,68.37Z"/><path class="cls-3" d="M129,62.11l-.07-.31a2.49,2.49,0,0,0,.45-.16,3.73,3.73,0,0,0,.7-.38,2.21,2.21,0,0,0,.6-.58.92.92,0,0,0,.14-.76,3.68,3.68,0,0,0-.37-.87c-.2-.39-.48-.87-.82-1.42s-.73-1.17-1.16-1.85-.9-1.37-1.4-2.09c-2.81.62-5.63,1.26-8.44,1.93-.13.84-.26,1.65-.39,2.42s-.25,1.55-.38,2.33a7.78,7.78,0,0,0-.1,2.47.91.91,0,0,0,.41.59,1.87,1.87,0,0,0,.74.28,3.83,3.83,0,0,0,.9,0l.9-.07.07.31q-3.33.78-6.65,1.61l-.08-.34a3.58,3.58,0,0,0,1.28-.77,2.83,2.83,0,0,0,.56-.62,6.9,6.9,0,0,0,.48-1.18,23,23,0,0,0,.65-2.64c.21-1,.45-2.26.71-3.61s.52-2.73.81-4.16.55-2.87.83-4.31.54-2.8.79-4.06c-.16-.19-.32-.39-.47-.59a5.57,5.57,0,0,0,.91-.82,5.76,5.76,0,0,0,.67-.89,6.89,6.89,0,0,0,.44-.84c.11-.26.2-.47.25-.63l.26-.06c1.05,1.54,2.05,3,3,4.39s1.84,2.72,2.69,4,1.67,2.53,2.46,3.74,1.58,2.4,2.36,3.58c.37.58.69,1.06,1,1.44l1,1.28.37.37a3.92,3.92,0,0,0,.72.5,3.43,3.43,0,0,0,1,.39,3.38,3.38,0,0,0,1.31,0l.08.37Q133.56,61.11,129,62.11Zm-8.32-17.57c-.07.29-.16.75-.28,1.38s-.26,1.38-.44,2.28-.36,1.91-.56,3-.41,2.35-.63,3.67q3.94-.93,7.91-1.81L125,50.6c-.58-.84-1.14-1.64-1.69-2.4l-1.48-2.11Z"/><path class="cls-3" d="M159.2,56.24Q149.07,57.93,139,60l-.06-.31a8.73,8.73,0,0,0,1.48-.71,3,3,0,0,0,1.06-1,1.61,1.61,0,0,0,.16-.59,4.73,4.73,0,0,0,0-.85c0-.32,0-.64-.08-1a8.48,8.48,0,0,0-.15-1q-.09-.42-.21-1.17c-.09-.49-.19-1-.29-1.62s-.22-1.18-.34-1.8-.24-1.22-.35-1.78l-1.17-6-.21-1.07c-.08-.37-.16-.71-.26-1a5.89,5.89,0,0,0-.31-.82,1.38,1.38,0,0,0-.41-.52,3,3,0,0,0-1.38-.56,7.23,7.23,0,0,0-1.68,0l-.06-.31q5.19-1.05,10.4-2l.06.31c-.28.1-.6.22-1,.38a4.08,4.08,0,0,0-1,.6,2.77,2.77,0,0,0-.75,1,2.46,2.46,0,0,0-.15,1.41c.12.72.22,1.38.33,2s.2,1.18.3,1.76.21,1.17.32,1.79.25,1.3.4,2.06.25,1.33.36,1.9.21,1.1.31,1.63.21,1.08.33,1.64.25,1.2.38,1.89.29,1.27.44,1.86a2.74,2.74,0,0,0,.58,1.26,1.21,1.21,0,0,0,.56.21,4.64,4.64,0,0,0,1,.09q.56,0,1.2,0a10.75,10.75,0,0,0,1.27-.16l.8-.16c.37-.07.77-.17,1.2-.28s.88-.24,1.34-.38a9.11,9.11,0,0,0,1.18-.46,7.64,7.64,0,0,0,1.95-1.26,7,7,0,0,0,1.22-1.53,7.76,7.76,0,0,0,.75-1.75c.18-.61.35-1.24.5-1.9l.34,0Z"/><path class="cls-3" d="M162.45,55.71l0-.31a6.5,6.5,0,0,0,1.41-.64,3.25,3.25,0,0,0,1-1,1.34,1.34,0,0,0,.15-.56,5.58,5.58,0,0,0,0-.82,8.67,8.67,0,0,0-.09-1c0-.34-.09-.67-.14-1l-.17-1.17c-.06-.5-.14-1-.22-1.63s-.17-1.19-.27-1.81-.19-1.24-.28-1.8c-.31-2-.63-4-.94-6-.06-.37-.12-.74-.17-1.11a8.83,8.83,0,0,0-.22-1,5.16,5.16,0,0,0-.28-.84,1.27,1.27,0,0,0-.39-.56,2.58,2.58,0,0,0-1.25-.58,7.14,7.14,0,0,0-1.57-.08l-.05-.31c3.27-.53,6.53-1,9.81-1.5l0,.31a8.32,8.32,0,0,0-1.43.55A2.14,2.14,0,0,0,166.31,34a2.9,2.9,0,0,0-.11,1.38q.11.81.18,1.53t.21,1.53c.07.51.14,1,.22,1.54s.16,1,.24,1.61.17,1.12.27,1.76l1.05,7c.09.59.19,1.17.29,1.72a2.28,2.28,0,0,0,.46,1.14,2.4,2.4,0,0,0,1.33.62,6.66,6.66,0,0,0,1.54.13l0,.31C168.84,54.7,165.64,55.19,162.45,55.71Z"/><path class="cls-3" d="M191.08,48.28a6,6,0,0,1-1.49,2.22,7.59,7.59,0,0,1-2.47,1.55,13.47,13.47,0,0,1-3.28.81,16.7,16.7,0,0,1-2.69.15,9.43,9.43,0,0,1-1.89-.21,6.94,6.94,0,0,1-1.16-.33,1.46,1.46,0,0,0-.49-.15c-.07,0-.19.15-.36.42s-.34.54-.48.8l-.28,0c-.32-2-.63-4.1-1-6.15l.32-.05a10.28,10.28,0,0,0,1,1.53A14.13,14.13,0,0,0,178,50.26a8.26,8.26,0,0,0,1.28,1.07,5.76,5.76,0,0,0,1.23.66,9.52,9.52,0,0,0,1.5.38,6.2,6.2,0,0,0,5.41-1.66,4.36,4.36,0,0,0,1.07-3.58,3.84,3.84,0,0,0-.47-1.49,3.54,3.54,0,0,0-.92-1,5,5,0,0,0-1.27-.69,13.49,13.49,0,0,0-1.52-.44q-.81-.19-1.41-.3L181.76,43c-.35-.07-.7-.15-1.07-.21s-.82-.17-1.33-.29a7.25,7.25,0,0,1-1.73-.64,6.87,6.87,0,0,1-1.53-1.09,6.72,6.72,0,0,1-1.16-1.48,5,5,0,0,1-.61-1.83,6.17,6.17,0,0,1,.25-3A6,6,0,0,1,176,32.18a7.43,7.43,0,0,1,2.36-1.52,12.63,12.63,0,0,1,5.53-.85,9.94,9.94,0,0,1,1.79.31,5.39,5.39,0,0,1,1.07.39,2.6,2.6,0,0,0,.41.19c.07,0,.19-.15.37-.42s.34-.54.49-.81l.36,0c.22,1.92.43,3.84.65,5.75l-.36,0a12.74,12.74,0,0,0-1.24-1.92,9.47,9.47,0,0,0-1.66-1.63,6.87,6.87,0,0,0-2-1.07,5.31,5.31,0,0,0-2.4-.21,6.29,6.29,0,0,0-1.88.52A4.5,4.5,0,0,0,178,32a3.9,3.9,0,0,0-.87,1.52A4.53,4.53,0,0,0,177,35.4a3.52,3.52,0,0,0,1.39,2.5,7.71,7.71,0,0,0,2.89,1.24c.45.11.87.2,1.27.28l1.16.22,1.15.22,1.23.26A7.42,7.42,0,0,1,189.79,42a5.59,5.59,0,0,1,1.62,3.55A5.65,5.65,0,0,1,191.08,48.28Z"/><path class="cls-3" d="M208.48,50.08l0-.32a2.19,2.19,0,0,0,.45-.1,3.65,3.65,0,0,0,.75-.28,2,2,0,0,0,.66-.49.94.94,0,0,0,.25-.74,3.85,3.85,0,0,0-.25-.91c-.15-.42-.36-.92-.62-1.52s-.56-1.26-.9-2-.71-1.48-1.1-2.27q-4.29.36-8.58.78c-.24.82-.48,1.6-.71,2.35s-.45,1.49-.68,2.25a8.08,8.08,0,0,0-.43,2.44,1,1,0,0,0,.32.64,2,2,0,0,0,.7.37,3.61,3.61,0,0,0,.88.16l.89.06,0,.31c-2.25.22-4.51.45-6.76.7l0-.34a3.81,3.81,0,0,0,1.37-.59,2.88,2.88,0,0,0,.63-.54A6.61,6.61,0,0,0,196,49a24.73,24.73,0,0,0,1-2.52c.34-1,.74-2.19,1.17-3.49s.88-2.64,1.35-4,.93-2.77,1.39-4.16.91-2.7,1.33-3.91l-.39-.66a5.28,5.28,0,0,0,1-.69,5.8,5.8,0,0,0,.78-.79,6.1,6.1,0,0,0,.54-.77,5.79,5.79,0,0,0,.33-.59l.27,0,2.36,4.75q1.11,2.25,2.11,4.34c.67,1.39,1.31,2.74,1.93,4L213,44.32a16.07,16.07,0,0,0,.78,1.56l.79,1.4c0,.08.16.22.32.42a4.17,4.17,0,0,0,.64.59,3.37,3.37,0,0,0,.94.52,3.52,3.52,0,0,0,1.3.19l0,.38Q213.14,49.7,208.48,50.08Zm-5.87-18.54c-.1.28-.26.73-.45,1.33s-.45,1.34-.74,2.21-.61,1.84-1,2.93-.71,2.28-1.11,3.55q4-.39,8-.72c-.45-.91-.9-1.81-1.36-2.72s-.9-1.77-1.33-2.6-.83-1.59-1.19-2.28S202.85,32,202.61,31.54Z"/><path class="cls-3" d="M240.69,31.61c-.19-.37-.41-.76-.66-1.16s-.51-.77-.78-1.12-.51-.66-.77-1a4.94,4.94,0,0,0-.64-.65,3.6,3.6,0,0,0-1.53-.78,9.49,9.49,0,0,0-2.08-.16l-1.09,0-.92,0-1,0-1.22.06c0,.52.05,1.23.08,2.12s.07,1.84.11,2.82.09,1.95.13,2.91.08,1.73.11,2.37c.1,2.32.21,4.63.31,7,0,.6.07,1.18.13,1.73a2.29,2.29,0,0,0,.36,1.16,2.39,2.39,0,0,0,1.4.88c.59.14,1.12.24,1.59.31v.31q-5.18.21-10.35.5l0-.31a10.15,10.15,0,0,0,1.58-.4,3.27,3.27,0,0,0,1.44-1.11,1,1,0,0,0,.21-.53c0-.24.07-.52.09-.82s0-.63,0-1,0-.7,0-1,0-.68,0-1.16,0-1-.05-1.59,0-1.19-.07-1.82-.06-1.22-.09-1.78q-.27-5.18-.53-10.35l-1.22.06-1,.06-.91.06c-.32,0-.68.06-1.1.08a7.7,7.7,0,0,0-2.05.41,3.84,3.84,0,0,0-1.44,1,4.22,4.22,0,0,0-.57.7c-.21.31-.43.64-.66,1a10.62,10.62,0,0,0-.65,1.16,6.31,6.31,0,0,0-.46,1.19l-.3-.08c.19-2,.39-4,.58-6,.52.07,1,.13,1.42.16a16,16,0,0,0,1.88,0l2.25-.09,1.91-.09,1.89-.1,2.21-.11,2.18-.1,1.92-.1,1.91-.11c.66,0,1.41-.07,2.25-.1a10.63,10.63,0,0,0,1.8-.23c.47-.11,1-.24,1.46-.4L241,31.51Z"/><path class="cls-3" d="M243.29,48.2v-.31a7.5,7.5,0,0,0,1.48-.44,3.32,3.32,0,0,0,1.15-.84,1.35,1.35,0,0,0,.23-.54c0-.23.08-.5.11-.82s0-.64,0-1,0-.69,0-1,0-.69,0-1.19V40.42c0-.6,0-1.21,0-1.84s0-1.25,0-1.81l-.12-6.1c0-.38,0-.76,0-1.13s0-.73-.07-1.05a6.39,6.39,0,0,0-.17-.87,1.4,1.4,0,0,0-.31-.61,2.69,2.69,0,0,0-1.15-.74,6.89,6.89,0,0,0-1.55-.29v-.31c3.3-.09,6.6-.14,9.9-.17v.31a9.69,9.69,0,0,0-1.49.36,2.11,2.11,0,0,0-1.2,1,2.75,2.75,0,0,0-.3,1.35q0,.81,0,1.53c0,.53,0,1,0,1.55s0,1,0,1.55,0,1.07,0,1.63,0,1.14,0,1.79l.09,7.07c0,.61,0,1.19.06,1.75a2.26,2.26,0,0,0,.3,1.19,2.39,2.39,0,0,0,1.23.8,6.82,6.82,0,0,0,1.5.33V48Q248.12,48.09,243.29,48.2Z"/><path class="cls-3" d="M279.46,41.6a11.73,11.73,0,0,1-6.64,5.91,13.42,13.42,0,0,1-9.24-.14,11.62,11.62,0,0,1-3.8-2.37,11.69,11.69,0,0,1-2.55-13.12A10.78,10.78,0,0,1,260,28.25,12,12,0,0,1,264.05,26a15,15,0,0,1,4.93-.73,12.66,12.66,0,0,1,5,1,11,11,0,0,1,3.7,2.63,10.64,10.64,0,0,1,2.24,3.72A11.45,11.45,0,0,1,280.6,37,11,11,0,0,1,279.46,41.6ZM276.18,33a11.78,11.78,0,0,0-1.44-3.56,8.34,8.34,0,0,0-2.52-2.63,6.53,6.53,0,0,0-3.65-1.06,6.77,6.77,0,0,0-3.73.93,8.13,8.13,0,0,0-2.59,2.53,11.26,11.26,0,0,0-1.5,3.54,17.7,17.7,0,0,0-.49,4,16.39,16.39,0,0,0,.5,4.1,11.57,11.57,0,0,0,1.51,3.48,8,8,0,0,0,2.51,2.44,6.81,6.81,0,0,0,3.51.95,6.09,6.09,0,0,0,3.52-.93,8.62,8.62,0,0,0,2.55-2.52A12.23,12.23,0,0,0,276,40.83a16.09,16.09,0,0,0,.62-3.93A15,15,0,0,0,276.18,33Z"/><path class="cls-3" d="M308.71,28.46a2.78,2.78,0,0,0-1.24,1.25,4.94,4.94,0,0,0-.44,1.71c-.11.84-.23,1.73-.34,2.69s-.24,1.94-.37,3.16-.25,2.51-.36,3.91c0,.58-.1,1.25-.16,2s-.11,1.47-.16,2.23-.1,1.51-.16,2.26-.11,1.43-.16,2a.3.3,0,0,1-.1.2A.4.4,0,0,1,305,50a.93.93,0,0,1-.55-.36l-4.54-6-4-5.17Q294,36,292.12,33.66c-1.25-1.56-2.58-3.16-4-4.82q-.33,6.6-.65,13.2-.08,1.59-.06,2.88a5,5,0,0,0,.31,1.92,2.32,2.32,0,0,0,1,1.14,6.8,6.8,0,0,0,2,.62l0,.31c-2.61-.14-5.23-.26-7.84-.37v-.32a6.58,6.58,0,0,0,1.55-.32,2.55,2.55,0,0,0,1.26-.93,4.29,4.29,0,0,0,.67-1.91q.18-1.28.33-3.06c.09-.89.17-2,.25-3.17s.16-2.52.22-3.92c0-.61.05-1.11.07-1.5s0-.78.06-1.16,0-.76.05-1.16,0-.92,0-1.53a3.32,3.32,0,0,0-.39-1.51,2.88,2.88,0,0,0-.81-.94,3.22,3.22,0,0,0-1.05-.52,10.63,10.63,0,0,0-1.1-.25V26c2.24.09,4.48.2,6.71.31q7.38,9.07,14.31,18.32c.27-3.54.55-7.07.83-10.61.06-.83.11-1.63.15-2.39a5.39,5.39,0,0,0-.15-1.82,2.94,2.94,0,0,0-1.06-1.51,6.14,6.14,0,0,0-2.37-.94l0-.31c2.73.19,5.46.41,8.19.64l0,.31A5.26,5.26,0,0,0,308.71,28.46Z"/><path class="cls-3" d="M346.89,54.65q-10.14-1.51-20.33-2.7l0-.31a8.19,8.19,0,0,0,1.62-.22,2.91,2.91,0,0,0,1.32-.63,1.5,1.5,0,0,0,.33-.51,4.65,4.65,0,0,0,.28-.8c.08-.31.16-.63.23-1s.13-.67.17-1,.09-.69.16-1.18.15-1,.23-1.63.16-1.19.23-1.82.16-1.24.22-1.8q.38-3,.73-6l.14-1.09a9.9,9.9,0,0,0,.07-1,6,6,0,0,0,0-.88,1.39,1.39,0,0,0-.23-.62,2.91,2.91,0,0,0-1.13-1,7.29,7.29,0,0,0-1.59-.56l0-.31c3.5.4,7,.84,10.49,1.3l0,.31c-.29,0-.63,0-1,.06a4.29,4.29,0,0,0-1.17.25,2.66,2.66,0,0,0-1,.68,2.42,2.42,0,0,0-.59,1.3l-.3,2c-.08.6-.17,1.19-.25,1.76s-.17,1.18-.25,1.8-.17,1.32-.26,2.08-.18,1.35-.25,1.93-.14,1.11-.21,1.65-.13,1.09-.19,1.66-.14,1.21-.23,1.91-.12,1.3-.16,1.91a2.72,2.72,0,0,0,.16,1.37,1.31,1.31,0,0,0,.47.38,5.05,5.05,0,0,0,.89.38c.35.12.73.24,1.15.34a10.63,10.63,0,0,0,1.25.25l.81.09c.37,0,.78.08,1.23.11s.91,0,1.38,0a9.61,9.61,0,0,0,1.27-.07,7.37,7.37,0,0,0,2.24-.6,6.93,6.93,0,0,0,1.64-1.07A8.12,8.12,0,0,0,347.66,50c.36-.52.72-1.08,1.07-1.66l.3.14C348.32,50.52,347.6,52.58,346.89,54.65Z"/><path class="cls-3" d="M350.15,55.15l.05-.31a6.83,6.83,0,0,0,1.53-.17,3.12,3.12,0,0,0,1.28-.62,1.24,1.24,0,0,0,.33-.49,6,6,0,0,0,.25-.78c.08-.3.16-.63.22-1s.13-.68.18-1,.11-.67.21-1.17.18-1,.29-1.61.21-1.19.31-1.81.2-1.24.29-1.79q.48-3,1-6l.18-1.11q.09-.55.12-1a8.4,8.4,0,0,0,0-.88,1.43,1.43,0,0,0-.2-.65,2.61,2.61,0,0,0-1-.94,6.63,6.63,0,0,0-1.47-.57l.05-.31q4.9.77,9.79,1.61l-.05.31a8.23,8.23,0,0,0-1.53.09,2.12,2.12,0,0,0-1.38.78A2.9,2.9,0,0,0,360,37q-.15.8-.3,1.5T359.45,40c-.1.5-.19,1-.28,1.52s-.17,1.05-.26,1.61-.19,1.12-.3,1.76l-1.17,7c-.1.59-.18,1.17-.25,1.73a2.22,2.22,0,0,0,.09,1.22,2.32,2.32,0,0,0,1.06,1,6.79,6.79,0,0,0,1.43.59l-.06.31Q354.94,55.9,350.15,55.15Z"/><path class="cls-3" d="M384.1,57.22a5.69,5.69,0,0,1-1.25,1.37,6.34,6.34,0,0,1-1.5.88,5.9,5.9,0,0,1-1.53.43,10.38,10.38,0,0,1-2.78,0q-1.5-.21-2.88-.48-5.42-1.08-10.85-2l.05-.31a6.8,6.8,0,0,0,1.57-.13,2.92,2.92,0,0,0,1.29-.56,1.29,1.29,0,0,0,.35-.49c.11-.22.22-.49.33-.78s.2-.62.29-.95.15-.67.21-1,.13-.67.24-1.17l.33-1.61c.11-.58.23-1.18.34-1.79s.23-1.23.33-1.79.22-1.16.3-1.63.17-.92.25-1.36.17-.91.24-1.38.17-1,.29-1.64c.07-.37.12-.74.17-1.13a10.81,10.81,0,0,0,.09-1.11c0-.36,0-.69,0-1a1.28,1.28,0,0,0-.2-.65,2.62,2.62,0,0,0-.86-.84,5.68,5.68,0,0,0-1.32-.51l.05-.31q5.5,1,11,2.07a21.37,21.37,0,0,1,2.33.61,10.44,10.44,0,0,1,2.06,1,6.56,6.56,0,0,1,2.36,2.35,4.44,4.44,0,0,1,.43,3.26,4.35,4.35,0,0,1-2.06,3,7.41,7.41,0,0,1-3.89.94l0,.12a9.59,9.59,0,0,1,2.16,1A7.28,7.28,0,0,1,383.77,51a5.6,5.6,0,0,1,1.05,2,4.57,4.57,0,0,1,.05,2.3A5.76,5.76,0,0,1,384.1,57.22Zm-2.26-16.43a4.86,4.86,0,0,0-1.71-2.14,10.06,10.06,0,0,0-3.63-1.35,10.75,10.75,0,0,0-1.25-.18,5.27,5.27,0,0,0-.88,0q-.06.18-.12.33a2,2,0,0,0-.13.37c0,.16-.08.34-.14.57s-.13.51-.22.88c-.16.71-.32,1.5-.5,2.36l-.48,2.45c-.15.76-.27,1.42-.38,2s-.17.88-.19,1l1.8.34c.49.1.89.16,1.19.2a6.83,6.83,0,0,0,4.69-.69,5,5,0,0,0,1.95-6.09Zm-.7,12.34a5.44,5.44,0,0,0-.53-1.61,5.33,5.33,0,0,0-1-1.39,6.18,6.18,0,0,0-1.43-1.08,9,9,0,0,0-1.33-.57,15.31,15.31,0,0,0-1.61-.39l-3.1-.6c-.13.65-.25,1.31-.38,2s-.24,1.28-.36,1.87-.2,1.1-.28,1.59-.16.9-.22,1.25c-.13.78-.22,1.43-.26,1.94a2.46,2.46,0,0,0,.22,1.33,2.26,2.26,0,0,0,.74.74,4.85,4.85,0,0,0,1.59.54,18.16,18.16,0,0,0,2,.27,6.14,6.14,0,0,0,2.2-.22,5.28,5.28,0,0,0,2.42-1.38,4.85,4.85,0,0,0,1.28-2.53A4.6,4.6,0,0,0,381.14,53.13Z"/><path class="cls-3" d="M404.76,66.29l-.3-.51c-.06-.11-.13-.24-.2-.39s-.16-.36-.26-.63-.25-.68-.47-1.23-.48-1.27-.67-1.8-.39-1.06-.59-1.58-.44-1.06-.69-1.6-.57-1.17-.94-1.86a13.08,13.08,0,0,0-1.06-1.64,3.61,3.61,0,0,0-1.39-1.13,4.9,4.9,0,0,0-.9-.34l-.72-.21-.81,3.45c-.22,1-.41,1.8-.54,2.48s-.24,1.21-.33,1.69a2.31,2.31,0,0,0,.07,1.24,3,3,0,0,0,.78,1,4.63,4.63,0,0,0,1.89.95l-.07.3q-5-1.19-10-2.3l.07-.31a10.5,10.5,0,0,0,1.59,0,2.6,2.6,0,0,0,1.29-.48,1.46,1.46,0,0,0,.38-.49,5.87,5.87,0,0,0,.33-.79q.15-.45.3-1c.1-.34.18-.68.26-1s.16-.67.28-1.16l.39-1.6c.15-.57.29-1.17.43-1.78s.27-1.22.4-1.77l1.35-6c.09-.37.17-.74.24-1.12s.13-.74.18-1.08a6.38,6.38,0,0,0,0-.95,1.38,1.38,0,0,0-.18-.67,2.45,2.45,0,0,0-.94-.9,11,11,0,0,0-1.41-.62l.07-.31,1.33.3,2.5.55c.94.2,1.87.41,2.8.63l2.27.54c1.45.34,2.72.69,3.82,1.05a8.09,8.09,0,0,1,2.87,1.58A6.21,6.21,0,0,1,410,47.36a5.14,5.14,0,0,1,.1,3.24,4.77,4.77,0,0,1-.95,1.91,5.57,5.57,0,0,1-1.54,1.28,7.06,7.06,0,0,1-2,.75,13.26,13.26,0,0,1-2.2.33l0,.09a4.15,4.15,0,0,1,.85,1,11.4,11.4,0,0,1,.69,1.4c.36.9.74,1.88,1.16,2.93s.78,2,1.11,2.81A9.76,9.76,0,0,0,408.91,66a6.43,6.43,0,0,0,2.31,1.61l-.08.3Q408,67.1,404.76,66.29Zm1.6-19.7a5.58,5.58,0,0,0-1.89-2.47,7.36,7.36,0,0,0-1.52-.88,10.37,10.37,0,0,0-1.76-.58c-.45-.11-.82-.18-1.11-.23a6.2,6.2,0,0,0-.66-.09,2.15,2.15,0,0,1-.14.3c0,.09-.08.2-.13.34l-.17.59-.3,1.07c-.19.71-.39,1.51-.61,2.4s-.43,1.75-.62,2.59-.37,1.56-.52,2.19-.23,1-.27,1.16c.87.2,1.69.36,2.46.47a11.73,11.73,0,0,0,2.29.08,6.2,6.2,0,0,0,1.95-.4,5,5,0,0,0,1.48-.87,5.21,5.21,0,0,0,1-1.25,5.63,5.63,0,0,0,.61-1.52A4.84,4.84,0,0,0,406.36,46.59Z"/><path class="cls-3" d="M424.59,71.67l.09-.3a3.79,3.79,0,0,0,.47.07,4.22,4.22,0,0,0,.8,0,2.43,2.43,0,0,0,.81-.22,1,1,0,0,0,.49-.61,4.31,4.31,0,0,0,.09-.93c0-.45,0-1,0-1.65s-.08-1.37-.14-2.17-.14-1.64-.22-2.51q-4.17-1.22-8.36-2.36l-1.51,1.94c-.48.61-1,1.23-1.45,1.86a7.72,7.72,0,0,0-1.27,2.12.94.94,0,0,0,.07.72,2,2,0,0,0,.52.59,4,4,0,0,0,.77.47l.82.37-.08.3q-3.3-.9-6.62-1.77l.09-.34a3.82,3.82,0,0,0,2.29-.33,6.52,6.52,0,0,0,1-.81,21.49,21.49,0,0,0,1.84-2c.7-.83,1.48-1.77,2.35-2.83L420.09,58c.94-1.12,1.87-2.24,2.8-3.38s1.82-2.2,2.65-3.18c-.05-.25-.09-.5-.14-.75a5.78,5.78,0,0,0,1.21-.28,6.28,6.28,0,0,0,1-.46,6.77,6.77,0,0,0,.79-.52c.23-.18.4-.32.53-.44l.25.08c.19,1.85.36,3.61.52,5.28s.31,3.27.44,4.8.26,3,.38,4.47.24,2.87.36,4.28c.05.68.1,1.26.18,1.73s.15,1,.25,1.6a2.56,2.56,0,0,0,.15.5,4.3,4.3,0,0,0,.38.79,3.81,3.81,0,0,0,.72.82,3.42,3.42,0,0,0,1.15.64l-.11.36C430.61,73.44,427.6,72.55,424.59,71.67Zm1.1-19.41c-.2.22-.5.58-.9,1.07s-.9,1.1-1.49,1.8-1.23,1.5-1.95,2.4L419,60.44q3.91,1.08,7.83,2.21c-.1-1-.2-2-.31-3s-.22-2-.33-2.91l-.3-2.56C425.84,53.39,425.76,52.75,425.69,52.26Z"/><path class="cls-3" d="M451.57,80.19c-.13-.24-.21-.42-.27-.54s-.1-.25-.17-.4a5.28,5.28,0,0,1-.2-.65c-.08-.28-.2-.7-.38-1.27s-.37-1.3-.52-1.84-.31-1.09-.47-1.63-.35-1.09-.56-1.66-.48-1.2-.79-1.92a13.18,13.18,0,0,0-.94-1.73A3.68,3.68,0,0,0,446,67.3a6.1,6.1,0,0,0-.87-.41l-.71-.26c-.41,1.29-.77,2.41-1.08,3.37s-.55,1.76-.74,2.42-.34,1.2-.47,1.66a2.29,2.29,0,0,0,0,1.24,3,3,0,0,0,.7,1.1,4.69,4.69,0,0,0,1.82,1.1l-.1.3q-4.9-1.6-9.84-3.13l.1-.3a9.44,9.44,0,0,0,1.59.1,2.56,2.56,0,0,0,1.33-.37,1.47,1.47,0,0,0,.42-.46,6.7,6.7,0,0,0,.39-.76c.13-.29.25-.6.38-.94s.24-.65.34-1,.21-.66.37-1.13.34-1,.53-1.56.38-1.14.56-1.74l.55-1.73L443,59c.12-.36.23-.73.33-1.1s.2-.73.27-1.06a5.74,5.74,0,0,0,.12-1,1.32,1.32,0,0,0-.12-.68,2.49,2.49,0,0,0-.87-1,10.84,10.84,0,0,0-1.36-.74l.09-.3,1.31.41,2.47.75c.91.28,1.83.57,2.74.87l2.23.72c1.43.46,2.67.92,3.75,1.36a8.25,8.25,0,0,1,2.75,1.82,6.3,6.3,0,0,1,1.61,2.61A5.13,5.13,0,0,1,458.2,65a4.79,4.79,0,0,1-1.1,1.83A5.57,5.57,0,0,1,455.45,68a7.34,7.34,0,0,1-2,.58,12.67,12.67,0,0,1-2.23.14l0,.09a4.33,4.33,0,0,1,.77,1.12,12.88,12.88,0,0,1,.58,1.45c.28.94.59,1.94.92,3s.63,2,.89,2.88a9.78,9.78,0,0,0,1.43,3,6.27,6.27,0,0,0,2.18,1.79l-.11.3C455.74,81.63,453.65,80.91,451.57,80.19Zm3.18-19.51a5.74,5.74,0,0,0-1.7-2.62,7.78,7.78,0,0,0-1.45-1,10.11,10.11,0,0,0-1.71-.73c-.45-.14-.82-.25-1.1-.32l-.65-.15c-.06.12-.12.21-.17.3a2,2,0,0,0-.15.32c-.06.14-.13.33-.22.57s-.22.6-.39,1.05q-.37,1-.81,2.34c-.29.87-.57,1.71-.83,2.52l-.69,2.15-.36,1.13c.85.28,1.66.5,2.42.67a10.6,10.6,0,0,0,2.29.27,5.92,5.92,0,0,0,2-.23,4.91,4.91,0,0,0,1.56-.75,5,5,0,0,0,1.14-1.15,5.63,5.63,0,0,0,.74-1.47A4.8,4.8,0,0,0,454.75,60.68Z"/><path class="cls-3" d="M484.73,69.16a5.37,5.37,0,0,0-1.46.31,8,8,0,0,0-1.44.71c-.49.3-1,.66-1.61,1.06l-1.63,1.1c-.69.46-1.39.94-2.12,1.45l-2.09,1.45-1.58,1.07-2.22,5.89c-.21.57-.4,1.13-.57,1.67a2.06,2.06,0,0,0,.72,2.54c.44.32.86.61,1.27.85l-.11.3q-4.67-1.78-9.35-3.49l.11-.3a8.23,8.23,0,0,0,1.49.23,3.34,3.34,0,0,0,1.6-.46,1,1,0,0,0,.42-.42,8.2,8.2,0,0,0,.41-.75c.14-.28.28-.58.41-.91s.26-.65.37-1c.23-.54.48-1.18.77-1.93s.64-1.66,1-2.74c0-.07-.07-.31-.16-.7s-.2-.86-.33-1.44l-.43-1.9c-.15-.7-.31-1.39-.47-2.06s-.3-1.29-.45-1.87-.26-1.07-.37-1.44l-.52-2a8.34,8.34,0,0,0-.56-1.56,5.66,5.66,0,0,0-.71-1.15,2.52,2.52,0,0,0-1-.72l.11-.3q4.78,1.7,9.57,3.46l-.11.3c-.33-.1-.65-.19-1-.26a4.75,4.75,0,0,0-1-.14,2.1,2.1,0,0,0-.79.11.84.84,0,0,0-.48.51,2.88,2.88,0,0,0,0,1.33c.11.63.23,1.27.37,1.92.1.44.22,1,.35,1.58s.27,1.27.44,2,.33,1.41.49,2.14.31,1.42.44,2.07q.62-.41,1.53-1l1.86-1.3,1.8-1.27c.57-.41,1-.73,1.32-1l.55-.41c.2-.16.41-.33.61-.51a7.53,7.53,0,0,0,.56-.57,2,2,0,0,0,.37-.59,1.09,1.09,0,0,0,0-.83,1.86,1.86,0,0,0-.48-.66A6,6,0,0,0,480,67l-.86-.48.11-.29q3.63,1.38,7.25,2.82l-.12.29A5.64,5.64,0,0,0,484.73,69.16Z"/><path class="cls-4" d="M80,344.89a537.5,537.5,0,0,0,80,17.59v-293A537.5,537.5,0,0,0,80,87.11Z"/><path class="cls-5" d="M361,360.11a514.16,514.16,0,0,0,73-17.75V89.64a514.16,514.16,0,0,0-73-17.75Z"/><path class="cls-6" d="M448,94.48v243c10.9-4,21.26-8.28,31-12.88V107.36C469.26,102.76,458.9,98.46,448,94.48Z"/><path class="cls-6" d="M66,91.64c-12,4.09-23.34,8.57-34,13.4V327c10.66,4.83,22,9.31,34,13.4Z"/><path class="cls-7" d="M347,69.67A667.24,667.24,0,0,0,173,67.8V364.2a659.88,659.88,0,0,0,80,4.8,654,654,0,0,0,94-6.67Z"/></svg>
benchmarks/bench.hs view
@@ -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
+ src/Codec/Winery.hs view
@@ -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 <fumiexcel@gmail.com>+--+-----------------------------------------------------------------------------+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"
+ src/Codec/Winery/Base.hs view
@@ -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 <fumiexcel@gmail.com>+--+-- 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
+ src/Codec/Winery/Internal.hs view
@@ -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 <fumiexcel@gmail.com>+--+-- 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 (<*>) #-}
+ src/Codec/Winery/Query.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE DeriveFunctor #-}+----------------------------------------------------------------------------+-- |+-- Module : Codec.Winery.Query+-- Copyright : (c) Fumiaki Kinoshita 2019+-- License : BSD3+-- Stability : Experimental+--+-- Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com>+--+-- 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]
+ src/Codec/Winery/Query/Parser.hs view
@@ -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 <fumiexcel@gmail.com>+--+-- 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+ ]+ ]
+ src/Codec/Winery/Test.hs view
@@ -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 <fumiexcel@gmail.com>+--+-- 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
src/Data/Winery.hs view
@@ -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 <fumiexcel@gmail.com>------ 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
− src/Data/Winery/Base.hs
@@ -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 <fumiexcel@gmail.com>------ 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
− src/Data/Winery/Internal.hs
@@ -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 <fumiexcel@gmail.com>------ 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 (<*>) #-}
− src/Data/Winery/Query.hs
@@ -1,77 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-------------------------------------------------------------------------------- |--- Module : Data.Winery.Query--- Copyright : (c) Fumiaki Kinoshita 2019--- License : BSD3--- Stability : Experimental------ Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com>------ 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]
− src/Data/Winery/Query/Parser.hs
@@ -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 <fumiexcel@gmail.com>------ 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- ]- ]
src/Data/Winery/Test.hs view
@@ -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 <fumiexcel@gmail.com>------ 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
test/Spec.hs view
@@ -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
winery.cabal view
@@ -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 <https://github.com/fumieval/winery#readme>+version: 1.1+synopsis: A compact, well-typed seralisation format for Haskell values+description:+ <<https://i.imgur.com/lTosHnE.png>>+ .+ Please see the README on GitHub at <https://github.com/fumieval/winery#readme> 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