├── .gitignore ├── .travis.yml ├── LICENSE ├── README.md ├── Setup.hs ├── persist.cabal ├── src └── Data │ ├── Persist.hs │ └── Persist │ └── Internal.hs ├── stack.yaml └── tests ├── .gitignore ├── GetTests.hs ├── Main.hs └── RoundTrip.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-newstyle 3 | .ghc.environment.* 4 | cabal-dev 5 | .cabal-sandbox 6 | .stack-work 7 | .stack-work-profile 8 | cabal.sandbox.config 9 | *.o 10 | *.hi 11 | *.swp 12 | stack.yaml.lock 13 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This Travis job script has been generated by a script via 2 | # 3 | # haskell-ci 'persist.cabal' 4 | # 5 | # For more information, see https://github.com/haskell-CI/haskell-ci 6 | # 7 | # version: 0.2.1 8 | # 9 | language: c 10 | dist: xenial 11 | 12 | git: 13 | submodules: false # whether to recursively clone submodules 14 | 15 | cache: 16 | directories: 17 | - $HOME/.cabal/packages 18 | - $HOME/.cabal/store 19 | 20 | before_cache: 21 | - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log 22 | # remove files that are regenerated by 'cabal update' 23 | - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.* 24 | - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json 25 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache 26 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar 27 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx 28 | 29 | - rm -rfv $CABALHOME/packages/head.hackage 30 | 31 | matrix: 32 | include: 33 | - compiler: "ghc-8.6.4" 34 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.6.4], sources: [hvr-ghc]}} 35 | - compiler: "ghc-8.4.4" 36 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.4.4], sources: [hvr-ghc]}} 37 | 38 | before_install: 39 | - HC=/opt/ghc/bin/${CC} 40 | - HCPKG=${HC/ghc/ghc-pkg} 41 | - unset CC 42 | - CABAL=/opt/ghc/bin/cabal 43 | - CABALHOME=$HOME/.cabal 44 | - export PATH="$CABALHOME/bin:$PATH" 45 | - ROOTDIR=$(pwd) 46 | - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') )) 47 | - echo $HCNUMVER 48 | 49 | install: 50 | - ${CABAL} --version 51 | - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" 52 | - TEST=--enable-tests 53 | - BENCH=--enable-benchmarks 54 | - GHCHEAD=${GHCHEAD-false} 55 | - travis_retry ${CABAL} update -v 56 | - sed -i.bak 's/^jobs:/-- jobs:/' $CABALHOME/config 57 | - rm -fv cabal.project cabal.project.local 58 | - grep -Ev -- '^\s*--' $CABALHOME/config | grep -Ev '^\s*$' 59 | - rm -f cabal.project 60 | - touch cabal.project 61 | - "printf 'packages: \".\"\\n' >> cabal.project" 62 | - "printf 'write-ghc-environment-files: always\\n' >> cabal.project" 63 | - touch cabal.project.local 64 | - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(persist)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" 65 | - cat cabal.project || true 66 | - cat cabal.project.local || true 67 | - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi 68 | - rm -f cabal.project.freeze 69 | - ${CABAL} new-freeze -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dry 70 | - "cat \"cabal.project.freeze\" | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" 71 | - rm "cabal.project.freeze" 72 | - ${CABAL} new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all 73 | - ${CABAL} new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all 74 | - rm -rf .ghc.environment.* "."/dist 75 | - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) 76 | 77 | # Here starts the actual work to be performed for the package under test; 78 | # any command which exits with a non-zero exit code causes the build to fail. 79 | script: 80 | # test that source-distributions can be generated 81 | - ${CABAL} new-sdist all 82 | - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ 83 | - cd ${DISTDIR} || false 84 | - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \; 85 | - rm -f cabal.project 86 | - touch cabal.project 87 | - "printf 'packages: \"persist-*/*.cabal\"\\n' >> cabal.project" 88 | - "printf 'write-ghc-environment-files: always\\n' >> cabal.project" 89 | - touch cabal.project.local 90 | - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(persist)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" 91 | - cat cabal.project || true 92 | - cat cabal.project.local || true 93 | # this builds all libraries and executables (without tests/benchmarks) 94 | - ${CABAL} new-build -w ${HC} --disable-tests --disable-benchmarks all 95 | 96 | # build & run tests, build benchmarks 97 | - ${CABAL} new-build -w ${HC} ${TEST} ${BENCH} all 98 | - if [ "x$TEST" = "x--enable-tests" ]; then ${CABAL} new-test -w ${HC} ${TEST} ${BENCH} all; fi 99 | 100 | ################################### 101 | # build & run tests, build benchmarks this time with alignment friendly access 102 | - ${CABAL} new-build -f force-aligned -w ${HC} ${TEST} ${BENCH} all 103 | - if [ "x$TEST" = "x--enable-tests" ]; then ${CABAL} new-test -f force-aligned -w ${HC} ${TEST} ${BENCH} all; fi 104 | ################################### 105 | 106 | # cabal check 107 | - (cd persist-* && ${CABAL} check) 108 | 109 | # haddock 110 | - ${CABAL} new-haddock -w ${HC} ${TEST} ${BENCH} all 111 | 112 | # Build without installed constraints for packages in global-db 113 | - rm -f cabal.project.local; ${CABAL} new-build -w ${HC} --disable-tests --disable-benchmarks all; 114 | 115 | # REGENDATA ["persist.cabal"] 116 | # EOF 117 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018 Daniel Mendler, 2 | Michael Sloan , 3 | FP Complete, 4 | Lennart Kolmodin , 5 | Galois Inc., 6 | Lemmih , 7 | Bas van Dijk 8 | 9 | All rights reserved. 10 | 11 | Redistribution and use in source and binary forms, with or without 12 | modification, are permitted provided that the following conditions 13 | are met: 14 | 15 | 1. Redistributions of source code must retain the above copyright 16 | notice, this list of conditions and the following disclaimer. 17 | 18 | 2. Redistributions in binary form must reproduce the above copyright 19 | notice, this list of conditions and the following disclaimer in the 20 | documentation and/or other materials provided with the distribution. 21 | 22 | 3. Neither the name of the author nor the names of his contributors 23 | may be used to endorse or promote products derived from this software 24 | without specific prior written permission. 25 | 26 | THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS 27 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 28 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 29 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 30 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 31 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 32 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 33 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 34 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 35 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 36 | POSSIBILITY OF SUCH DAMAGE. 37 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Minimal binary serialization library with focus on performance 2 | 3 | [![Hackage](https://img.shields.io/hackage/v/persist.svg)](https://hackage.haskell.org/package/persist) 4 | [![Build Status](https://secure.travis-ci.org/minad/persist.png?branch=master)](http://travis-ci.org/minad/persist) 5 | 6 | persist is a reasonably fast binary serialization library operating on strict ByteStrings with small dependency footprint. 7 | The binary format uses the little endian representation on both big- and little endian machines. 8 | The API design is mostly compatible with the cereal library. However the binary format 9 | is not compatible with binary and cereal. Its internal machinery for deserialization is based on the `store` library. 10 | Serialization generates ByteStrings directly instead of relying on the ByteString Builder. 11 | 12 | ## Comparison with other libraries 13 | 14 | * flat - bit packing (!), fast, longer compile times 15 | * store - faster serialization, machine dependent, larger library, many dependencies 16 | * cereal - similar to persist, slower 17 | * binary - lazy and slower than persist 18 | 19 | ## Benchmarks 20 | 21 | Benchmarks are available at https://github.com/haskell-perf/serialization. 22 | The following serialization and deserialization results were measured on GHC 8.6.2. 23 | Results that are within 30% of the best result are displayed in **bold**. 24 | 25 | #### deserialization (time)/BinTree Direction (best first) 26 | 27 | | package | performance | 28 | | ---| ---| 29 | | **persist** | **1.0** | 30 | | **store** | **1.1** | 31 | | **flat** | **1.2** | 32 | | cereal | 4.3 | 33 | | serialise | 6.1 | 34 | | binary | 7.8 | 35 | | packman | 13.5 | 36 | 37 | #### deserialization (time)/BinTree Int (best first) 38 | 39 | | package | performance | 40 | | ---| ---| 41 | | **store** | **1.0** | 42 | | **persist** | **1.1** | 43 | | **cereal** | **1.3** | 44 | | flat | 1.3 | 45 | | serialise | 4.1 | 46 | | binary | 4.8 | 47 | | packman | 15.0 | 48 | 49 | #### deserialization (time)/Cars (best first) 50 | 51 | | package | performance | 52 | | ---| ---| 53 | | **persist** | **1.0** | 54 | | **store** | **1.1** | 55 | | flat | 1.3 | 56 | | cereal | 2.9 | 57 | | packman | 3.7 | 58 | | serialise | 4.8 | 59 | | binary | 7.2 | 60 | 61 | #### deserialization (time)/Iris (best first) 62 | 63 | | package | performance | 64 | | ---| ---| 65 | | **store** | **1.0** | 66 | | **persist** | **1.1** | 67 | | **flat** | **1.2** | 68 | | serialise | 2.4 | 69 | | cereal | 3.6 | 70 | | packman | 3.6 | 71 | | binary | 8.5 | 72 | 73 | #### deserialization (time)/[Direction] (best first) 74 | 75 | | package | performance | 76 | | ---| ---| 77 | | **persist** | **1.0** | 78 | | **flat** | **1.1** | 79 | | **store** | **1.2** | 80 | | **cereal** | **1.3** | 81 | | serialise | 3.0 | 82 | | binary | 3.1 | 83 | | packman | 11.0 | 84 | 85 | #### serialization (time)/BinTree Direction (best first) 86 | 87 | | package | performance | 88 | | ---| ---| 89 | | **store** | **1.0** | 90 | | **persist** | **1.1** | 91 | | flat | 1.4 | 92 | | cereal | 8.4 | 93 | | binary | 16.0 | 94 | | serialise | 22.0 | 95 | | packman | 38.4 | 96 | 97 | #### serialization (time)/BinTree Int (best first) 98 | 99 | | package | performance | 100 | | ---| ---| 101 | | **store** | **1.0** | 102 | | **flat** | **1.0** | 103 | | persist | 1.7 | 104 | | cereal | 14.1 | 105 | | binary | 18.7 | 106 | | serialise | 20.6 | 107 | | packman | 54.4 | 108 | 109 | #### serialization (time)/Cars (best first) 110 | 111 | | package | performance | 112 | | ---| ---| 113 | | **store** | **1.0** | 114 | | flat | 2.1 | 115 | | persist | 3.6 | 116 | | cereal | 5.7 | 117 | | binary | 11.2 | 118 | | serialise | 13.7 | 119 | | packman | 15.6 | 120 | 121 | #### serialization (time)/Iris (best first) 122 | 123 | | package | performance | 124 | | ---| ---| 125 | | **store** | **1.0** | 126 | | flat | 5.0 | 127 | | persist | 6.4 | 128 | | serialise | 12.5 | 129 | | cereal | 15.0 | 130 | | packman | 36.0 | 131 | | binary | 80.0 | 132 | 133 | #### serialization (time)/[Direction] (best first) 134 | 135 | | package | performance | 136 | | ---| ---| 137 | | **store** | **1.0** | 138 | | **persist** | **1.1** | 139 | | flat | 1.4 | 140 | | cereal | 3.8 | 141 | | binary | 5.2 | 142 | | serialise | 7.8 | 143 | | packman | 45.0 | 144 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /persist.cabal: -------------------------------------------------------------------------------- 1 | name: persist 2 | version: 0.1.1.5 3 | license: BSD3 4 | license-file: LICENSE 5 | author: Daniel Mendler , 6 | Michael Sloan , 7 | FP Complete, 8 | Lennart Kolmodin , 9 | Galois Inc., 10 | Lemmih , 11 | Bas van Dijk 12 | maintainer: Daniel Mendler 13 | category: Data, Parsing 14 | stability: provisional 15 | build-type: Simple 16 | cabal-version: >= 1.10 17 | synopsis: Minimal serialization library with focus on performance 18 | homepage: https://github.com/minad/persist 19 | tested-with: GHC == 8.4.4, GHC == 8.6.4 20 | 21 | description: 22 | A binary serialization library with focus on performance similar to store and cereal 23 | 24 | source-repository head 25 | type: git 26 | location: git://github.com/minad/persist 27 | 28 | flag force-unaligned 29 | manual: True 30 | default: False 31 | flag force-aligned 32 | manual: True 33 | default: False 34 | 35 | library 36 | default-language: Haskell2010 37 | 38 | build-depends: base >= 4.7 && < 5, containers, 39 | bytestring >= 0.10.4 && < 1, 40 | text >= 1.2 && < 1.3 41 | 42 | if !flag(force-aligned) && (flag(force-unaligned) || arch(i386) || arch(x86_64)) 43 | cpp-options: -DUNALIGNED_MEMORY 44 | 45 | hs-source-dirs: src 46 | 47 | exposed-modules: Data.Persist, 48 | Data.Persist.Internal 49 | 50 | ghc-options: -Wall -O2 -funbox-strict-fields 51 | 52 | 53 | 54 | test-suite test-persist 55 | default-language: Haskell2010 56 | 57 | type: exitcode-stdio-1.0 58 | 59 | build-depends: base == 4.*, 60 | bytestring >= 0.9, 61 | QuickCheck, 62 | test-framework, 63 | test-framework-quickcheck2, 64 | persist, 65 | text >= 1.2 && < 1.3 66 | 67 | main-is: Main.hs 68 | other-modules: RoundTrip 69 | GetTests 70 | 71 | hs-source-dirs: tests 72 | -------------------------------------------------------------------------------- /src/Data/Persist.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | {-# LANGUAGE CPP #-} 4 | {-# LANGUAGE DataKinds #-} 5 | {-# LANGUAGE DefaultSignatures #-} 6 | {-# LANGUAGE DeriveFoldable #-} 7 | {-# LANGUAGE DeriveFunctor #-} 8 | {-# LANGUAGE DeriveGeneric #-} 9 | {-# LANGUAGE DeriveTraversable #-} 10 | {-# LANGUAGE EmptyCase #-} 11 | {-# LANGUAGE FlexibleContexts #-} 12 | {-# LANGUAGE FlexibleInstances #-} 13 | {-# LANGUAGE KindSignatures #-} 14 | {-# LANGUAGE LambdaCase #-} 15 | {-# LANGUAGE MultiParamTypeClasses #-} 16 | {-# LANGUAGE MultiWayIf #-} 17 | {-# LANGUAGE ScopedTypeVariables #-} 18 | {-# LANGUAGE TypeApplications #-} 19 | {-# LANGUAGE TypeFamilies #-} 20 | {-# LANGUAGE TypeOperators #-} 21 | {-# LANGUAGE UndecidableInstances #-} 22 | 23 | module Data.Persist ( 24 | 25 | -- * The Persist class 26 | Persist(..) 27 | 28 | -- * Endianness 29 | , HostEndian 30 | , BigEndian(..) 31 | , LittleEndian(..) 32 | 33 | -- * Serialization 34 | , encode 35 | , decode 36 | 37 | -- * The Get type 38 | , Get 39 | , runGet 40 | , ensure 41 | , skip 42 | , getBytes 43 | , getByteString 44 | , remaining 45 | , eof 46 | , getHE 47 | , getLE 48 | , getBE 49 | 50 | -- * The Put type 51 | , Put 52 | , runPut 53 | , evalPut 54 | , grow 55 | , putByteString 56 | , putHE 57 | , putLE 58 | , putBE 59 | ) where 60 | 61 | import Control.Monad 62 | import Data.Bits 63 | import Data.ByteString (ByteString) 64 | import Data.Int 65 | import Data.IntMap (IntMap) 66 | import Data.IntSet (IntSet) 67 | import Data.List (unfoldr) 68 | import Data.List.NonEmpty (NonEmpty(..)) 69 | import Data.Map (Map) 70 | import Data.Persist.Internal 71 | import Data.Proxy 72 | import Data.Sequence (Seq) 73 | import Data.Set (Set) 74 | import Data.Text (Text) 75 | import Data.Word 76 | import Foreign (Ptr, Storable(..), plusPtr, minusPtr, castPtr, withForeignPtr) 77 | import GHC.Base (unsafeChr, ord) 78 | import GHC.Exts (IsList(..)) 79 | import GHC.Generics 80 | import GHC.Real (Ratio(..)) 81 | import GHC.TypeLits 82 | import Numeric.Natural 83 | import qualified Data.ByteString as B 84 | import qualified Data.ByteString.Internal as B 85 | import qualified Data.ByteString.Lazy as L 86 | import qualified Data.ByteString.Short as S 87 | import qualified Data.ByteString.Short.Internal as S 88 | import qualified Data.Monoid as M 89 | import qualified Data.Text.Encoding as TE 90 | import qualified Data.Tree as T 91 | 92 | #include "MachDeps.h" 93 | 94 | putHE :: Persist (HostEndian a) => a -> Put () 95 | getHE :: Persist (HostEndian a) => Get a 96 | {-# INLINE putHE #-} 97 | {-# INLINE getHE #-} 98 | 99 | #ifdef WORDS_BIGENDIAN 100 | type HostEndian = BigEndian 101 | getHE = getBE 102 | putHE = putBE 103 | #else 104 | type HostEndian = LittleEndian 105 | getHE = getLE 106 | putHE = putLE 107 | #endif 108 | 109 | poke16LE :: Ptr Word8 -> Word16 -> IO () 110 | poke32LE :: Ptr Word8 -> Word32 -> IO () 111 | poke64LE :: Ptr Word8 -> Word64 -> IO () 112 | {-# INLINE poke16LE #-} 113 | {-# INLINE poke32LE #-} 114 | {-# INLINE poke64LE #-} 115 | 116 | poke16BE :: Ptr Word8 -> Word16 -> IO () 117 | poke32BE :: Ptr Word8 -> Word32 -> IO () 118 | poke64BE :: Ptr Word8 -> Word64 -> IO () 119 | {-# INLINE poke16BE #-} 120 | {-# INLINE poke32BE #-} 121 | {-# INLINE poke64BE #-} 122 | 123 | peek16LE :: Ptr Word8 -> IO Word16 124 | peek32LE :: Ptr Word8 -> IO Word32 125 | peek64LE :: Ptr Word8 -> IO Word64 126 | {-# INLINE peek16LE #-} 127 | {-# INLINE peek32LE #-} 128 | {-# INLINE peek64LE #-} 129 | 130 | peek16BE :: Ptr Word8 -> IO Word16 131 | peek32BE :: Ptr Word8 -> IO Word32 132 | peek64BE :: Ptr Word8 -> IO Word64 133 | {-# INLINE peek16BE #-} 134 | {-# INLINE peek32BE #-} 135 | {-# INLINE peek64BE #-} 136 | 137 | #ifndef UNALIGNED_MEMORY 138 | pokeByte :: (Integral a) => Ptr Word8 -> a -> IO () 139 | pokeByte p x = poke p (fromIntegral x) 140 | {-# INLINE pokeByte #-} 141 | 142 | peekByte :: (Integral a) => Ptr Word8 -> IO a 143 | peekByte p = do 144 | !b <- peek p 145 | return $! fromIntegral b 146 | {-# INLINE peekByte #-} 147 | 148 | poke16LE p y = do 149 | pokeByte p $ y 150 | pokeByte (p `plusPtr` 1) $ y `unsafeShiftR` 8 151 | 152 | poke16BE p y = do 153 | pokeByte p $ y `unsafeShiftR` 8 154 | pokeByte (p `plusPtr` 1) $ y 155 | 156 | poke32LE p y = do 157 | pokeByte p $ y 158 | pokeByte (p `plusPtr` 1) $ y `unsafeShiftR` 8 159 | pokeByte (p `plusPtr` 2) $ y `unsafeShiftR` 16 160 | pokeByte (p `plusPtr` 3) $ y `unsafeShiftR` 24 161 | 162 | poke32BE p y = do 163 | pokeByte p $ y `unsafeShiftR` 24 164 | pokeByte (p `plusPtr` 1) $ y `unsafeShiftR` 16 165 | pokeByte (p `plusPtr` 2) $ y `unsafeShiftR` 8 166 | pokeByte (p `plusPtr` 3) $ y 167 | 168 | poke64LE p y = do 169 | pokeByte p $ y 170 | pokeByte (p `plusPtr` 1) $ y `unsafeShiftR` 8 171 | pokeByte (p `plusPtr` 2) $ y `unsafeShiftR` 16 172 | pokeByte (p `plusPtr` 3) $ y `unsafeShiftR` 24 173 | pokeByte (p `plusPtr` 4) $ y `unsafeShiftR` 32 174 | pokeByte (p `plusPtr` 5) $ y `unsafeShiftR` 40 175 | pokeByte (p `plusPtr` 6) $ y `unsafeShiftR` 48 176 | pokeByte (p `plusPtr` 7) $ y `unsafeShiftR` 56 177 | 178 | poke64BE p y = do 179 | pokeByte p $ y `unsafeShiftR` 56 180 | pokeByte (p `plusPtr` 1) $ y `unsafeShiftR` 48 181 | pokeByte (p `plusPtr` 2) $ y `unsafeShiftR` 40 182 | pokeByte (p `plusPtr` 3) $ y `unsafeShiftR` 32 183 | pokeByte (p `plusPtr` 4) $ y `unsafeShiftR` 24 184 | pokeByte (p `plusPtr` 5) $ y `unsafeShiftR` 16 185 | pokeByte (p `plusPtr` 6) $ y `unsafeShiftR` 8 186 | pokeByte (p `plusPtr` 7) $ y 187 | 188 | peek16LE p = do 189 | !x0 <- peekByte @Word16 p 190 | !x1 <- peekByte @Word16 (p `plusPtr` 1) 191 | return $ x1 `unsafeShiftL` 8 192 | .|. x0 193 | 194 | peek16BE p = do 195 | !x0 <- peekByte @Word16 p 196 | !x1 <- peekByte @Word16 (p `plusPtr` 1) 197 | return $ x0 `unsafeShiftL` 8 198 | .|. x1 199 | 200 | peek32LE p = do 201 | !x0 <- peekByte @Word32 p 202 | !x1 <- peekByte @Word32 (p `plusPtr` 1) 203 | !x2 <- peekByte @Word32 (p `plusPtr` 2) 204 | !x3 <- peekByte @Word32 (p `plusPtr` 3) 205 | return $ x3 `unsafeShiftL` 24 206 | .|. x2 `unsafeShiftL` 16 207 | .|. x1 `unsafeShiftL` 8 208 | .|. x0 209 | 210 | peek32BE p = do 211 | !x0 <- peekByte @Word32 p 212 | !x1 <- peekByte @Word32 (p `plusPtr` 1) 213 | !x2 <- peekByte @Word32 (p `plusPtr` 2) 214 | !x3 <- peekByte @Word32 (p `plusPtr` 3) 215 | return $ x0 `unsafeShiftL` 24 216 | .|. x1 `unsafeShiftL` 16 217 | .|. x2 `unsafeShiftL` 8 218 | .|. x3 219 | 220 | peek64LE p = do 221 | !x0 <- peekByte @Word64 p 222 | !x1 <- peekByte @Word64 (p `plusPtr` 1) 223 | !x2 <- peekByte @Word64 (p `plusPtr` 2) 224 | !x3 <- peekByte @Word64 (p `plusPtr` 3) 225 | !x4 <- peekByte @Word64 (p `plusPtr` 4) 226 | !x5 <- peekByte @Word64 (p `plusPtr` 5) 227 | !x6 <- peekByte @Word64 (p `plusPtr` 6) 228 | !x7 <- peekByte @Word64 (p `plusPtr` 7) 229 | return $ x7 `unsafeShiftL` 56 230 | .|. x6 `unsafeShiftL` 48 231 | .|. x5 `unsafeShiftL` 40 232 | .|. x4 `unsafeShiftL` 32 233 | .|. x3 `unsafeShiftL` 24 234 | .|. x2 `unsafeShiftL` 16 235 | .|. x1 `unsafeShiftL` 8 236 | .|. x0 237 | 238 | peek64BE p = do 239 | !x0 <- peekByte @Word64 p 240 | !x1 <- peekByte @Word64 (p `plusPtr` 1) 241 | !x2 <- peekByte @Word64 (p `plusPtr` 2) 242 | !x3 <- peekByte @Word64 (p `plusPtr` 3) 243 | !x4 <- peekByte @Word64 (p `plusPtr` 4) 244 | !x5 <- peekByte @Word64 (p `plusPtr` 5) 245 | !x6 <- peekByte @Word64 (p `plusPtr` 6) 246 | !x7 <- peekByte @Word64 (p `plusPtr` 7) 247 | return $ x0 `unsafeShiftL` 56 248 | .|. x1 `unsafeShiftL` 48 249 | .|. x2 `unsafeShiftL` 40 250 | .|. x3 `unsafeShiftL` 32 251 | .|. x4 `unsafeShiftL` 24 252 | .|. x5 `unsafeShiftL` 16 253 | .|. x6 `unsafeShiftL` 8 254 | .|. x7 255 | 256 | #else 257 | fromLE16 :: Word16 -> Word16 258 | fromLE32 :: Word32 -> Word32 259 | fromLE64 :: Word64 -> Word64 260 | {-# INLINE fromLE16 #-} 261 | {-# INLINE fromLE32 #-} 262 | {-# INLINE fromLE64 #-} 263 | 264 | fromBE16 :: Word16 -> Word16 265 | fromBE32 :: Word32 -> Word32 266 | fromBE64 :: Word64 -> Word64 267 | {-# INLINE fromBE16 #-} 268 | {-# INLINE fromBE32 #-} 269 | {-# INLINE fromBE64 #-} 270 | 271 | toLE16 :: Word16 -> Word16 272 | toLE32 :: Word32 -> Word32 273 | toLE64 :: Word64 -> Word64 274 | {-# INLINE toLE16 #-} 275 | {-# INLINE toLE32 #-} 276 | {-# INLINE toLE64 #-} 277 | 278 | toBE16 :: Word16 -> Word16 279 | toBE32 :: Word32 -> Word32 280 | toBE64 :: Word64 -> Word64 281 | {-# INLINE toBE16 #-} 282 | {-# INLINE toBE32 #-} 283 | {-# INLINE toBE64 #-} 284 | 285 | #ifdef WORDS_BIGENDIAN 286 | fromBE16 = id 287 | fromBE32 = id 288 | fromBE64 = id 289 | toBE16 = id 290 | toBE32 = id 291 | toBE64 = id 292 | fromLE16 = byteSwap16 293 | fromLE32 = byteSwap32 294 | fromLE64 = byteSwap64 295 | toLE16 = byteSwap16 296 | toLE32 = byteSwap32 297 | toLE64 = byteSwap64 298 | #else 299 | fromLE16 = id 300 | fromLE32 = id 301 | fromLE64 = id 302 | toLE16 = id 303 | toLE32 = id 304 | toLE64 = id 305 | fromBE16 = byteSwap16 306 | fromBE32 = byteSwap32 307 | fromBE64 = byteSwap64 308 | toBE16 = byteSwap16 309 | toBE32 = byteSwap32 310 | toBE64 = byteSwap64 311 | #endif 312 | 313 | poke16LE p = poke (castPtr @_ @Word16 p) . toLE16 314 | poke32LE p = poke (castPtr @_ @Word32 p) . toLE32 315 | poke64LE p = poke (castPtr @_ @Word64 p) . toLE64 316 | 317 | poke16BE p = poke (castPtr @_ @Word16 p) . toBE16 318 | poke32BE p = poke (castPtr @_ @Word32 p) . toBE32 319 | poke64BE p = poke (castPtr @_ @Word64 p) . toBE64 320 | 321 | peek16LE p = fromLE16 <$!> peek (castPtr @_ @Word16 p) 322 | peek32LE p = fromLE32 <$!> peek (castPtr @_ @Word32 p) 323 | peek64LE p = fromLE64 <$!> peek (castPtr @_ @Word64 p) 324 | 325 | peek16BE p = fromBE16 <$!> peek (castPtr @_ @Word16 p) 326 | peek32BE p = fromBE32 <$!> peek (castPtr @_ @Word32 p) 327 | peek64BE p = fromBE64 <$!> peek (castPtr @_ @Word64 p) 328 | #endif 329 | 330 | newtype BigEndian a = BigEndian { unBE :: a } 331 | deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) 332 | 333 | newtype LittleEndian a = LittleEndian { unLE :: a } 334 | deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) 335 | 336 | class Persist t where 337 | -- | Encode a value in the Put monad. 338 | put :: t -> Put () 339 | -- | Decode a value in the Get monad 340 | get :: Get t 341 | 342 | default put :: (Generic t, GPersistPut (Rep t)) => t -> Put () 343 | put = gput . from 344 | 345 | default get :: (Generic t, GPersistGet (Rep t)) => Get t 346 | get = to <$!> gget 347 | 348 | -- | Encode a value using binary serialization to a strict ByteString. 349 | encode :: Persist a => a -> ByteString 350 | encode = runPut . put 351 | 352 | -- | Decode a value from a strict ByteString, reconstructing the original 353 | -- structure. 354 | decode :: Persist a => ByteString -> Either String a 355 | decode = runGet get 356 | 357 | putLE :: Persist (LittleEndian a) => a -> Put () 358 | putLE = put . LittleEndian 359 | {-# INLINE putLE #-} 360 | 361 | putBE :: Persist (BigEndian a) => a -> Put () 362 | putBE = put . BigEndian 363 | {-# INLINE putBE #-} 364 | 365 | getLE :: Persist (LittleEndian a) => Get a 366 | getLE = unLE <$!> get 367 | {-# INLINE getLE #-} 368 | 369 | getBE :: Persist (BigEndian a) => Get a 370 | getBE = unBE <$!> get 371 | {-# INLINE getBE #-} 372 | 373 | unsafePutByte :: Integral a => a -> Put () 374 | unsafePutByte x = Put $ \_ p -> do 375 | poke p $ fromIntegral x 376 | pure $! p `plusPtr` 1 :!: () 377 | {-# INLINE unsafePutByte #-} 378 | 379 | unsafePut16LE :: Integral a => a -> Put () 380 | unsafePut16LE x = Put $ \_ p -> do 381 | poke16LE p $ fromIntegral x 382 | pure $! p `plusPtr` 2 :!: () 383 | {-# INLINE unsafePut16LE #-} 384 | 385 | unsafePut32LE :: Integral a => a -> Put () 386 | unsafePut32LE x = Put $ \_ p -> do 387 | poke32LE p $ fromIntegral x 388 | pure $! p `plusPtr` 4 :!: () 389 | {-# INLINE unsafePut32LE #-} 390 | 391 | unsafePut64LE :: Integral a => a -> Put () 392 | unsafePut64LE x = Put $ \_ p -> do 393 | poke64LE p $ fromIntegral x 394 | pure $! p `plusPtr` 8 :!: () 395 | {-# INLINE unsafePut64LE #-} 396 | 397 | unsafePut16BE :: Integral a => a -> Put () 398 | unsafePut16BE x = Put $ \_ p -> do 399 | poke16BE p $ fromIntegral x 400 | pure $! p `plusPtr` 2 :!: () 401 | {-# INLINE unsafePut16BE #-} 402 | 403 | unsafePut32BE :: Integral a => a -> Put () 404 | unsafePut32BE x = Put $ \_ p -> do 405 | poke32BE p $ fromIntegral x 406 | pure $! p `plusPtr` 4 :!: () 407 | {-# INLINE unsafePut32BE #-} 408 | 409 | unsafePut64BE :: Integral a => a -> Put () 410 | unsafePut64BE x = Put $ \_ p -> do 411 | poke64BE p $ fromIntegral x 412 | pure $! p `plusPtr` 8 :!: () 413 | {-# INLINE unsafePut64BE #-} 414 | 415 | unsafeGetByte :: Num a => Get a 416 | unsafeGetByte = Get $ \_ p -> do 417 | x <- peek p 418 | pure $! p `plusPtr` 1 :!: fromIntegral x 419 | {-# INLINE unsafeGetByte #-} 420 | 421 | unsafeGet16LE :: Num a => Get a 422 | unsafeGet16LE = Get $ \_ p -> do 423 | x <- peek16LE p 424 | pure $! p `plusPtr` 2 :!: fromIntegral x 425 | {-# INLINE unsafeGet16LE #-} 426 | 427 | unsafeGet32LE :: Num a => Get a 428 | unsafeGet32LE = Get $ \_ p -> do 429 | x <- peek32LE p 430 | pure $! p `plusPtr` 4 :!: fromIntegral x 431 | {-# INLINE unsafeGet32LE #-} 432 | 433 | unsafeGet64LE :: Num a => Get a 434 | unsafeGet64LE = Get $ \_ p -> do 435 | x <- peek64LE p 436 | pure $! p `plusPtr` 8 :!: fromIntegral x 437 | {-# INLINE unsafeGet64LE #-} 438 | 439 | unsafeGet16BE :: Num a => Get a 440 | unsafeGet16BE = Get $ \_ p -> do 441 | x <- peek16BE p 442 | pure $! p `plusPtr` 2 :!: fromIntegral x 443 | {-# INLINE unsafeGet16BE #-} 444 | 445 | unsafeGet32BE :: Num a => Get a 446 | unsafeGet32BE = Get $ \_ p -> do 447 | x <- peek32BE p 448 | pure $! p `plusPtr` 4 :!: fromIntegral x 449 | {-# INLINE unsafeGet32BE #-} 450 | 451 | unsafeGet64BE :: Num a => Get a 452 | unsafeGet64BE = Get $ \_ p -> do 453 | x <- peek64BE p 454 | pure $! p `plusPtr` 8 :!: fromIntegral x 455 | {-# INLINE unsafeGet64BE #-} 456 | 457 | reinterpretCast :: (Storable a, Storable b) => Ptr p -> a -> IO b 458 | reinterpretCast p x = do 459 | poke (castPtr p) x 460 | peek (castPtr p) 461 | {-# INLINE reinterpretCast #-} 462 | 463 | reinterpretCastPut :: (Storable a, Storable b) => a -> Put b 464 | reinterpretCastPut x = Put $ \e p -> (p :!:) <$!> reinterpretCast (peTmp e) x 465 | {-# INLINE reinterpretCastPut #-} 466 | 467 | reinterpretCastGet :: (Storable a, Storable b) => a -> Get b 468 | reinterpretCastGet x = Get $ \e p -> (p :!:) <$!> reinterpretCast (geTmp e) x 469 | {-# INLINE reinterpretCastGet #-} 470 | 471 | -- The () type need never be written to disk: values of singleton type 472 | -- can be reconstructed from the type alone 473 | instance Persist () where 474 | put () = pure () 475 | {-# INLINE put #-} 476 | get = pure () 477 | {-# INLINE get #-} 478 | 479 | instance Persist Word8 where 480 | put x = do 481 | grow 1 482 | unsafePutByte x 483 | {-# INLINE put #-} 484 | 485 | get = do 486 | ensure 1 487 | unsafeGetByte 488 | {-# INLINE get #-} 489 | 490 | instance Persist (LittleEndian Word16) where 491 | put x = do 492 | grow 2 493 | unsafePut16LE $ unLE x 494 | {-# INLINE put #-} 495 | 496 | get = do 497 | ensure 2 498 | LittleEndian <$!> unsafeGet16LE 499 | {-# INLINE get #-} 500 | 501 | instance Persist (BigEndian Word16) where 502 | put x = do 503 | grow 2 504 | unsafePut16BE $ unBE x 505 | {-# INLINE put #-} 506 | 507 | get = do 508 | ensure 2 509 | BigEndian <$!> unsafeGet16BE 510 | {-# INLINE get #-} 511 | 512 | instance Persist Word16 where 513 | put = putLE 514 | {-# INLINE put #-} 515 | get = getLE 516 | {-# INLINE get #-} 517 | 518 | instance Persist (LittleEndian Word32) where 519 | put x = do 520 | grow 4 521 | unsafePut32LE $ unLE x 522 | {-# INLINE put #-} 523 | 524 | get = do 525 | ensure 4 526 | LittleEndian <$!> unsafeGet32LE 527 | {-# INLINE get #-} 528 | 529 | instance Persist (BigEndian Word32) where 530 | put x = do 531 | grow 4 532 | unsafePut32BE $ unBE x 533 | {-# INLINE put #-} 534 | 535 | get = do 536 | ensure 4 537 | BigEndian <$!> unsafeGet32BE 538 | {-# INLINE get #-} 539 | 540 | instance Persist Word32 where 541 | put = putLE 542 | {-# INLINE put #-} 543 | get = getLE 544 | {-# INLINE get #-} 545 | 546 | instance Persist (LittleEndian Word64) where 547 | put x = do 548 | grow 8 549 | unsafePut64LE $ unLE x 550 | {-# INLINE put #-} 551 | 552 | get = do 553 | ensure 8 554 | LittleEndian <$!> unsafeGet64LE 555 | {-# INLINE get #-} 556 | 557 | instance Persist (BigEndian Word64) where 558 | put x = do 559 | grow 8 560 | unsafePut64BE $ unBE x 561 | {-# INLINE put #-} 562 | 563 | get = do 564 | ensure 8 565 | BigEndian <$!> unsafeGet64BE 566 | {-# INLINE get #-} 567 | 568 | instance Persist Word64 where 569 | put = putLE 570 | {-# INLINE put #-} 571 | get = getLE 572 | {-# INLINE get #-} 573 | 574 | instance Persist Int8 where 575 | put = put @Word8 . fromIntegral 576 | {-# INLINE put #-} 577 | get = fromIntegral <$!> get @Word8 578 | {-# INLINE get #-} 579 | 580 | instance Persist (LittleEndian Int16) where 581 | put = put . fmap (fromIntegral @_ @Word16) 582 | {-# INLINE put #-} 583 | get = fmap (fromIntegral @Word16) <$!> get 584 | {-# INLINE get #-} 585 | 586 | instance Persist (BigEndian Int16) where 587 | put = put . fmap (fromIntegral @_ @Word16) 588 | {-# INLINE put #-} 589 | get = fmap (fromIntegral @Word16) <$!> get 590 | {-# INLINE get #-} 591 | 592 | instance Persist Int16 where 593 | put = putLE 594 | {-# INLINE put #-} 595 | get = getLE 596 | {-# INLINE get #-} 597 | 598 | instance Persist (LittleEndian Int32) where 599 | put = put . fmap (fromIntegral @_ @Word32) 600 | {-# INLINE put #-} 601 | get = fmap (fromIntegral @Word32) <$!> get 602 | {-# INLINE get #-} 603 | 604 | instance Persist (BigEndian Int32) where 605 | put = put . fmap (fromIntegral @_ @Word32) 606 | {-# INLINE put #-} 607 | get = fmap (fromIntegral @Word32) <$!> get 608 | {-# INLINE get #-} 609 | 610 | instance Persist Int32 where 611 | put = putLE 612 | {-# INLINE put #-} 613 | get = getLE 614 | {-# INLINE get #-} 615 | 616 | instance Persist (LittleEndian Int64) where 617 | put = put . fmap (fromIntegral @_ @Word64) 618 | {-# INLINE put #-} 619 | get = fmap (fromIntegral @Word64) <$!> get 620 | {-# INLINE get #-} 621 | 622 | instance Persist (BigEndian Int64) where 623 | put = put . fmap (fromIntegral @_ @Word64) 624 | {-# INLINE put #-} 625 | get = fmap (fromIntegral @Word64) <$!> get 626 | {-# INLINE get #-} 627 | 628 | instance Persist Int64 where 629 | put = putLE 630 | {-# INLINE put #-} 631 | get = getLE 632 | {-# INLINE get #-} 633 | 634 | instance Persist (LittleEndian Double) where 635 | put x = reinterpretCastPut (unLE x) >>= putLE @Word64 636 | {-# INLINE put #-} 637 | get = getLE @Word64 >>= fmap LittleEndian . reinterpretCastGet 638 | {-# INLINE get #-} 639 | 640 | instance Persist (BigEndian Double) where 641 | put x = reinterpretCastPut (unBE x) >>= putBE @Word64 642 | {-# INLINE put #-} 643 | get = getBE @Word64 >>= fmap BigEndian . reinterpretCastGet 644 | {-# INLINE get #-} 645 | 646 | instance Persist Double where 647 | put = putLE 648 | {-# INLINE put #-} 649 | get = getLE 650 | {-# INLINE get #-} 651 | 652 | instance Persist (LittleEndian Float) where 653 | put x = reinterpretCastPut (unLE x) >>= putLE @Word32 654 | {-# INLINE put #-} 655 | get = getLE @Word32 >>= fmap LittleEndian . reinterpretCastGet 656 | {-# INLINE get #-} 657 | 658 | instance Persist (BigEndian Float) where 659 | put x = reinterpretCastPut (unBE x) >>= putBE @Word32 660 | {-# INLINE put #-} 661 | get = getBE @Word32 >>= fmap BigEndian . reinterpretCastGet 662 | {-# INLINE get #-} 663 | 664 | instance Persist Float where 665 | put = putLE 666 | {-# INLINE put #-} 667 | get = getLE 668 | {-# INLINE get #-} 669 | 670 | instance Persist (LittleEndian Word) where 671 | put = put . fmap (fromIntegral @_ @Word64) 672 | {-# INLINE put #-} 673 | get = fmap (fromIntegral @Word64) <$!> get 674 | {-# INLINE get #-} 675 | 676 | instance Persist (BigEndian Word) where 677 | put = put . fmap (fromIntegral @_ @Word64) 678 | {-# INLINE put #-} 679 | get = fmap (fromIntegral @Word64) <$!> get 680 | {-# INLINE get #-} 681 | 682 | instance Persist Word where 683 | put = putLE 684 | {-# INLINE put #-} 685 | get = getLE 686 | {-# INLINE get #-} 687 | 688 | instance Persist (LittleEndian Int) where 689 | put = put . fmap (fromIntegral @_ @Int64) 690 | {-# INLINE put #-} 691 | get = fmap (fromIntegral @Int64) <$!> get 692 | {-# INLINE get #-} 693 | 694 | instance Persist (BigEndian Int) where 695 | put = put . fmap (fromIntegral @_ @Int64) 696 | {-# INLINE put #-} 697 | get = fmap (fromIntegral @Int64) <$!> get 698 | {-# INLINE get #-} 699 | 700 | instance Persist Int where 701 | put = putLE 702 | {-# INLINE put #-} 703 | get = getLE 704 | {-# INLINE get #-} 705 | 706 | instance Persist Integer where 707 | put n = do 708 | put $ n < 0 709 | put $ unroll $ abs n 710 | 711 | get = do 712 | neg <- get 713 | val <- roll <$!> get 714 | pure $! if neg then negate val else val 715 | 716 | unroll :: (Integral a, Bits a) => a -> [Word8] 717 | unroll = unfoldr step 718 | where step 0 = Nothing 719 | step i = Just (fromIntegral i, i `unsafeShiftR` 8) 720 | 721 | roll :: (Integral a, Bits a) => [Word8] -> a 722 | roll = foldr unstep 0 723 | where unstep b a = a `unsafeShiftL` 8 .|. fromIntegral b 724 | 725 | instance Persist a => Persist (Ratio a) where 726 | put (n :% d) = put n *> put d 727 | {-# INLINE put #-} 728 | 729 | get = (:%) <$!> get <*> get 730 | {-# INLINE get #-} 731 | 732 | instance Persist Natural where 733 | put = put . unroll 734 | get = roll <$!> get 735 | 736 | -- Char is serialized as UTF-8 737 | instance Persist Char where 738 | put a | c <= 0x7f = put (fromIntegral c :: Word8) 739 | | c <= 0x7ff = do put (0xc0 .|. y) 740 | put (0x80 .|. z) 741 | | c <= 0xffff = do put (0xe0 .|. x) 742 | put (0x80 .|. y) 743 | put (0x80 .|. z) 744 | | c <= 0x10ffff = do put (0xf0 .|. w) 745 | put (0x80 .|. x) 746 | put (0x80 .|. y) 747 | put (0x80 .|. z) 748 | | otherwise = error "Not a valid Unicode code point" 749 | where 750 | c = ord a 751 | z, y, x, w :: Word8 752 | z = fromIntegral (c .&. 0x3f) 753 | y = fromIntegral (unsafeShiftR c 6 .&. 0x3f) 754 | x = fromIntegral (unsafeShiftR c 12 .&. 0x3f) 755 | w = fromIntegral (unsafeShiftR c 18 .&. 0x7) 756 | {-# INLINE put #-} 757 | 758 | get = do 759 | let byte = fromIntegral <$!> get @Word8 760 | shiftL6 = flip unsafeShiftL 6 761 | w <- byte 762 | r <- if | w < 0x80 -> pure w 763 | | w < 0xe0 -> do 764 | x <- xor 0x80 <$!> byte 765 | pure $ x .|. shiftL6 (xor 0xc0 w) 766 | | w < 0xf0 -> do 767 | x <- xor 0x80 <$!> byte 768 | y <- xor 0x80 <$!> byte 769 | pure $ y .|. shiftL6 (x .|. shiftL6 770 | (xor 0xe0 w)) 771 | | otherwise -> do 772 | x <- xor 0x80 <$!> byte 773 | y <- xor 0x80 <$!> byte 774 | z <- xor 0x80 <$!> byte 775 | pure $ z .|. shiftL6 (y .|. shiftL6 776 | (x .|. shiftL6 (xor 0xf0 w))) 777 | if r <= 0x10FFFF then 778 | pure $ unsafeChr r 779 | else 780 | failGet CharException "Invalid character" 781 | {-# INLINE get #-} 782 | 783 | instance Persist Text where 784 | put = put . TE.encodeUtf8 785 | {-# INLINE put #-} 786 | get = do 787 | n <- get 788 | TE.decodeUtf8 <$!> getBytes n 789 | {-# INLINE get #-} 790 | 791 | instance Persist Bool 792 | instance Persist Ordering 793 | instance (Persist a) => Persist (Maybe a) 794 | instance Persist e => Persist (T.Tree e) 795 | instance (Persist a, Persist b) => Persist (Either a b) 796 | instance (Persist a, Persist b) => Persist (a,b) 797 | instance (Persist a, Persist b, Persist c) => Persist (a,b,c) 798 | instance (Persist a, Persist b, Persist c, Persist d) 799 | => Persist (a,b,c,d) 800 | instance (Persist a, Persist b, Persist c, Persist d, Persist e) 801 | => Persist (a,b,c,d,e) 802 | instance (Persist a, Persist b, Persist c, Persist d, Persist e 803 | , Persist f) 804 | => Persist (a,b,c,d,e,f) 805 | instance (Persist a, Persist b, Persist c, Persist d, Persist e 806 | , Persist f, Persist g) 807 | => Persist (a,b,c,d,e,f,g) 808 | instance Persist a => Persist (M.Dual a) 809 | instance Persist M.All 810 | instance Persist M.Any 811 | instance Persist a => Persist (M.Sum a) 812 | instance Persist a => Persist (M.Product a) 813 | instance Persist a => Persist (M.First a) 814 | instance Persist a => Persist (M.Last a) 815 | 816 | -- | Persist a list in the following format: 817 | -- Word64 (little endian format) 818 | -- element 1 819 | -- ... 820 | -- element n 821 | instance Persist a => Persist [a] where 822 | put l = do 823 | put $ length l 824 | mapM_ put l 825 | {-# INLINE put #-} 826 | 827 | get = go [] =<< get @Word64 828 | where go as 0 = pure $! reverse as 829 | go as i = do x <- get 830 | x `seq` go (x:as) (i - 1) 831 | {-# INLINE get #-} 832 | 833 | instance Persist ByteString where 834 | put s = do 835 | put $ B.length s 836 | putByteString s 837 | get = get >>= getByteString 838 | 839 | instance Persist L.ByteString where 840 | put = put . L.toStrict 841 | get = L.fromStrict <$!> get 842 | 843 | instance Persist S.ShortByteString where 844 | put s = do 845 | let n = S.length s 846 | put n 847 | grow n 848 | Put $ \_ p -> do 849 | S.copyToPtr s 0 p n 850 | pure $! p `plusPtr` n :!: () 851 | 852 | get = S.toShort <$!> get 853 | 854 | instance (Ord a, Persist a) => Persist (Set a) where 855 | put = put . toList 856 | {-# INLINE put #-} 857 | get = fromList <$!> get 858 | {-# INLINE get #-} 859 | 860 | instance (Ord k, Persist k, Persist e) => Persist (Map k e) where 861 | put = put . toList 862 | {-# INLINE put #-} 863 | get = fromList <$!> get 864 | {-# INLINE get #-} 865 | 866 | instance Persist IntSet where 867 | put = put . toList 868 | get = fromList <$!> get 869 | 870 | instance Persist e => Persist (NonEmpty e) where 871 | put = put . toList 872 | {-# INLINE put #-} 873 | get = fromList <$!> get 874 | {-# INLINE get #-} 875 | 876 | instance Persist e => Persist (IntMap e) where 877 | put = put . toList 878 | {-# INLINE put #-} 879 | get = fromList <$!> get 880 | {-# INLINE get #-} 881 | 882 | instance Persist e => Persist (Seq e) where 883 | put = put . toList 884 | {-# INLINE put #-} 885 | get = fromList <$!> get 886 | {-# INLINE get #-} 887 | 888 | type family SumArity (a :: * -> *) :: Nat where 889 | SumArity (C1 c a) = 1 890 | SumArity (x :+: y) = SumArity x + SumArity y 891 | 892 | class GPersistPut f where 893 | gput :: f a -> Put () 894 | 895 | class GPersistGet f where 896 | gget :: Get (f a) 897 | 898 | instance GPersistPut f => GPersistPut (M1 i c f) where 899 | gput = gput . unM1 900 | {-# INLINE gput #-} 901 | 902 | instance GPersistGet f => GPersistGet (M1 i c f) where 903 | gget = fmap M1 gget 904 | {-# INLINE gget #-} 905 | 906 | instance Persist a => GPersistPut (K1 i a) where 907 | gput = put . unK1 908 | {-# INLINE gput #-} 909 | 910 | instance Persist a => GPersistGet (K1 i a) where 911 | gget = fmap K1 get 912 | {-# INLINE gget #-} 913 | 914 | instance GPersistPut U1 where 915 | gput _ = pure () 916 | {-# INLINE gput #-} 917 | 918 | instance GPersistGet U1 where 919 | gget = pure U1 920 | {-# INLINE gget #-} 921 | 922 | instance GPersistPut V1 where 923 | gput x = case x of {} 924 | {-# INLINE gput #-} 925 | 926 | instance GPersistGet V1 where 927 | gget = undefined 928 | {-# INLINE gget #-} 929 | 930 | instance (GPersistPut a, GPersistPut b) => GPersistPut (a :*: b) where 931 | gput (a :*: b) = gput a *> gput b 932 | {-# INLINE gput #-} 933 | 934 | instance (GPersistGet a, GPersistGet b) => GPersistGet (a :*: b) where 935 | gget = (:*:) <$!> gget <*> gget 936 | {-# INLINE gget #-} 937 | 938 | instance (SumArity (a :+: b) <= 255, GPersistPutSum 0 (a :+: b)) => GPersistPut (a :+: b) where 939 | gput x = gputSum x (Proxy :: Proxy 0) 940 | {-# INLINE gput #-} 941 | 942 | instance (SumArity (a :+: b) <= 255, GPersistGetSum 0 (a :+: b)) => GPersistGet (a :+: b) where 943 | gget = do 944 | tag <- get 945 | ggetSum tag (Proxy :: Proxy 0) 946 | {-# INLINE gget #-} 947 | 948 | class KnownNat n => GPersistPutSum (n :: Nat) (f :: * -> *) where 949 | gputSum :: f p -> Proxy n -> Put () 950 | 951 | class KnownNat n => GPersistGetSum (n :: Nat) (f :: * -> *) where 952 | ggetSum :: Word8 -> Proxy n -> Get (f p) 953 | 954 | instance (GPersistPutSum n a, GPersistPutSum (n + SumArity a) b, KnownNat n) 955 | => GPersistPutSum n (a :+: b) where 956 | gputSum (L1 l) _ = gputSum l (Proxy :: Proxy n) 957 | gputSum (R1 r) _ = gputSum r (Proxy :: Proxy (n + SumArity a)) 958 | {-# INLINE gputSum #-} 959 | 960 | instance (GPersistGetSum n a, GPersistGetSum (n + SumArity a) b, KnownNat n) 961 | => GPersistGetSum n (a :+: b) where 962 | ggetSum tag proxyL 963 | | tag < sizeL = L1 <$!> ggetSum tag proxyL 964 | | otherwise = R1 <$!> ggetSum tag (Proxy :: Proxy (n + SumArity a)) 965 | where 966 | sizeL = fromInteger (natVal (Proxy :: Proxy (n + SumArity a))) 967 | {-# INLINE ggetSum #-} 968 | 969 | instance (GPersistPut a, KnownNat n) => GPersistPutSum n (C1 c a) where 970 | gputSum x _ = do 971 | put (fromInteger (natVal (Proxy :: Proxy n)) :: Word8) 972 | gput x 973 | {-# INLINE gputSum #-} 974 | 975 | instance (GPersistGet a, KnownNat n) => GPersistGetSum n (C1 c a) where 976 | ggetSum tag _ 977 | | tag == cur = gget 978 | | tag > cur = fail "Sum tag invalid" 979 | | otherwise = fail "Implementation error" 980 | where 981 | cur = fromInteger (natVal (Proxy :: Proxy n)) 982 | {-# INLINE ggetSum #-} 983 | 984 | -- | Ensure that @n@ bytes are available. Fails if fewer than @n@ bytes are available. 985 | ensure :: Int -> Get () 986 | ensure n 987 | | n < 0 = failGet LengthException "ensure: negative length" 988 | | otherwise = do 989 | m <- remaining 990 | when (m < n) $ failGet LengthException "Not enough bytes available" 991 | {-# INLINE ensure #-} 992 | 993 | -- | Skip ahead @n@ bytes. Fails if fewer than @n@ bytes are available. 994 | skip :: Int -> Get () 995 | skip n = do 996 | ensure n 997 | Get $ \_ p -> pure $! p `plusPtr` n :!: () 998 | {-# INLINE skip #-} 999 | 1000 | -- | Get the number of remaining unparsed bytes. Useful for checking whether 1001 | -- all input has been consumed. 1002 | remaining :: Get Int 1003 | remaining = Get $ \e p -> pure $! p :!: geEnd e `minusPtr` p 1004 | {-# INLINE remaining #-} 1005 | 1006 | -- -- | Succeed if end of input reached. 1007 | eof :: Get () 1008 | eof = do 1009 | n <- remaining 1010 | when (n /= 0) $ failGet EOFException "Expected end of file" 1011 | {-# INLINE eof #-} 1012 | 1013 | -- | Pull @n@ bytes from the input, as a strict ByteString. 1014 | getBytes :: Int -> Get ByteString 1015 | getBytes n = do 1016 | ensure n 1017 | Get $ \e p -> pure $! p `plusPtr` n :!: B.PS (geBuf e) (p `minusPtr` geBegin e) n 1018 | {-# INLINE getBytes #-} 1019 | 1020 | -- | An efficient 'get' method for strict ByteStrings. Fails if fewer 1021 | -- than @n@ bytes are left in the input. This function creates a fresh 1022 | -- copy of the underlying bytes. 1023 | getByteString :: Int -> Get ByteString 1024 | getByteString n = B.copy <$!> getBytes n 1025 | {-# INLINE getByteString #-} 1026 | 1027 | runPut :: Put a -> ByteString 1028 | runPut = snd . evalPut 1029 | {-# INLINE runPut #-} 1030 | 1031 | putByteString :: ByteString -> Put () 1032 | putByteString (B.PS b o n) = do 1033 | grow n 1034 | Put $ \_ p -> do 1035 | withForeignPtr b $ \q -> B.memcpy p (q `plusPtr` o) n 1036 | pure $! p `plusPtr` n :!: () 1037 | {-# INLINE putByteString #-} 1038 | -------------------------------------------------------------------------------- /src/Data/Persist/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE DefaultSignatures #-} 5 | {-# LANGUAGE DeriveFoldable #-} 6 | {-# LANGUAGE DeriveFunctor #-} 7 | {-# LANGUAGE DeriveGeneric #-} 8 | {-# LANGUAGE DeriveTraversable #-} 9 | {-# LANGUAGE EmptyCase #-} 10 | {-# LANGUAGE FlexibleContexts #-} 11 | {-# LANGUAGE FlexibleInstances #-} 12 | {-# LANGUAGE KindSignatures #-} 13 | {-# LANGUAGE LambdaCase #-} 14 | {-# LANGUAGE MultiParamTypeClasses #-} 15 | {-# LANGUAGE MultiWayIf #-} 16 | {-# LANGUAGE ScopedTypeVariables #-} 17 | {-# LANGUAGE TypeApplications #-} 18 | {-# LANGUAGE TypeFamilies #-} 19 | {-# LANGUAGE TypeOperators #-} 20 | {-# LANGUAGE UndecidableInstances #-} 21 | 22 | module Data.Persist.Internal ( 23 | (:!:)(..) 24 | -- * The Get type 25 | , Get(..) 26 | , GetEnv(..) 27 | , GetException(..) 28 | , getOffset 29 | , failGet 30 | , runGet 31 | , runGetIO 32 | 33 | -- * The Put type 34 | , Put(..) 35 | , PutEnv(..) 36 | , Chunk(..) 37 | , evalPut 38 | , evalPutIO 39 | , grow 40 | ) where 41 | 42 | import Control.Exception 43 | import Control.Monad 44 | import Data.ByteString (ByteString) 45 | import Data.Foldable (foldlM) 46 | import Data.IORef 47 | import Data.List.NonEmpty (NonEmpty(..)) 48 | import Data.Word 49 | import Foreign (ForeignPtr, Ptr, plusPtr, minusPtr, 50 | withForeignPtr, mallocBytes, free, allocaBytes) 51 | import System.IO.Unsafe 52 | import qualified Control.Monad.Fail as Fail 53 | import qualified Data.ByteString.Internal as B 54 | 55 | #include "MachDeps.h" 56 | 57 | data a :!: b = !a :!: !b 58 | infixl 2 :!: 59 | 60 | data GetEnv = GetEnv 61 | { geBuf :: !(ForeignPtr Word8) 62 | , geBegin :: {-#UNPACK#-}!(Ptr Word8) 63 | , geEnd :: {-#UNPACK#-}!(Ptr Word8) 64 | , geTmp :: {-#UNPACK#-}!(Ptr Word8) 65 | } 66 | 67 | newtype Get a = Get 68 | { unGet :: GetEnv -> Ptr Word8 -> IO ((Ptr Word8) :!: a) 69 | } 70 | 71 | instance Functor Get where 72 | fmap f m = Get $ \e p -> do 73 | p' :!: x <- unGet m e p 74 | pure $! p' :!: f x 75 | {-# INLINE fmap #-} 76 | 77 | instance Applicative Get where 78 | pure a = Get $ \_ p -> pure $! p :!: a 79 | {-# INLINE pure #-} 80 | 81 | f <*> a = Get $ \e p -> do 82 | p' :!: f' <- unGet f e p 83 | p'' :!: a' <- unGet a e p' 84 | pure $! p'' :!: f' a' 85 | {-# INLINE (<*>) #-} 86 | 87 | m1 *> m2 = do 88 | void m1 89 | m2 90 | {-# INLINE (*>) #-} 91 | 92 | instance Monad Get where 93 | m >>= f = Get $ \e p -> do 94 | p' :!: x <- unGet m e p 95 | unGet (f x) e p' 96 | {-# INLINE (>>=) #-} 97 | 98 | #if !MIN_VERSION_base(4,11,0) 99 | fail = Fail.fail 100 | {-# INLINE fail #-} 101 | #endif 102 | 103 | data GetException 104 | = LengthException Int String 105 | | CharException Int String 106 | | EOFException Int String 107 | | GenericGetException Int String 108 | deriving (Eq, Show) 109 | 110 | instance Exception GetException 111 | 112 | instance Fail.MonadFail Get where 113 | fail msg = failGet GenericGetException ("Failed reading: " <> msg) 114 | {-# INLINE fail #-} 115 | 116 | getOffset :: Get Int 117 | getOffset = Get $ \e p -> pure $! p :!: (p `minusPtr` (geBegin e)) 118 | {-# INLINE getOffset #-} 119 | 120 | failGet :: (Int -> String -> GetException) -> String -> Get a 121 | failGet ctor msg = do 122 | offset <- getOffset 123 | Get $ \_ _ -> throwIO (ctor offset msg) 124 | 125 | runGetIO :: Get a -> ByteString -> IO a 126 | runGetIO m s = run 127 | where run = withForeignPtr buf $ \p -> allocaBytes 8 $ \t -> do 128 | let env = GetEnv { geBuf = buf, geBegin = p, geEnd = p `plusPtr` (pos + len), geTmp = t } 129 | _ :!: r <- unGet m env (p `plusPtr` pos) 130 | pure r 131 | (B.PS buf pos len) = s 132 | 133 | -- | Run the Get monad applies a 'get'-based parser on the input ByteString 134 | runGet :: Get a -> ByteString -> Either String a 135 | runGet m s = unsafePerformIO $ catch (Right <$!> (runGetIO m s)) handler 136 | where handler (e :: GetException) = pure $ Left $ displayException e 137 | {-# NOINLINE runGet #-} 138 | 139 | data Chunk = Chunk 140 | { chkBegin :: {-#UNPACK#-}!(Ptr Word8) 141 | , chkEnd :: {-#UNPACK#-}!(Ptr Word8) 142 | } 143 | 144 | data PutEnv = PutEnv 145 | { peChks :: !(IORef (NonEmpty Chunk)) 146 | , peEnd :: !(IORef (Ptr Word8)) 147 | , peTmp :: {-#UNPACK#-}!(Ptr Word8) 148 | } 149 | 150 | newtype Put a = Put 151 | { unPut :: PutEnv -> Ptr Word8 -> IO ((Ptr Word8) :!: a) } 152 | 153 | instance Functor Put where 154 | fmap f m = Put $ \e p -> do 155 | p' :!: x <- unPut m e p 156 | pure $! p' :!: f x 157 | {-# INLINE fmap #-} 158 | 159 | instance Applicative Put where 160 | pure a = Put $ \_ p -> pure $! p :!: a 161 | {-# INLINE pure #-} 162 | 163 | f <*> a = Put $ \e p -> do 164 | p' :!: f' <- unPut f e p 165 | p'' :!: a' <- unPut a e p' 166 | pure $! p'' :!: f' a' 167 | {-# INLINE (<*>) #-} 168 | 169 | m1 *> m2 = do 170 | void m1 171 | m2 172 | {-# INLINE (*>) #-} 173 | 174 | instance Monad Put where 175 | m >>= f = Put $ \e p -> do 176 | p' :!: x <- unPut m e p 177 | unPut (f x) e p' 178 | {-# INLINE (>>=) #-} 179 | 180 | minChunkSize :: Int 181 | minChunkSize = 0x10000 182 | {-# INLINE minChunkSize #-} 183 | 184 | newChunk :: Int -> IO Chunk 185 | newChunk size = do 186 | let n = max size minChunkSize 187 | p <- mallocBytes n 188 | pure $! Chunk p $ p `plusPtr` n 189 | {-# INLINE newChunk #-} 190 | 191 | -- | Ensure that @n@ bytes can be written. 192 | grow :: Int -> Put () 193 | grow n 194 | | n < 0 = error "grow: negative length" 195 | | otherwise = Put $ \e p -> do 196 | end <- readIORef (peEnd e) 197 | if end `minusPtr` p >= n then 198 | pure $! p :!: () 199 | else 200 | doGrow e p n 201 | {-# INLINE grow #-} 202 | 203 | doGrow :: PutEnv -> Ptr Word8 -> Int -> IO ((Ptr Word8) :!: ()) 204 | doGrow e p n = do 205 | k <- newChunk n 206 | modifyIORef' (peChks e) $ \case 207 | (c:|cs) -> k :| c { chkEnd = p } : cs 208 | writeIORef (peEnd e) (chkEnd k) 209 | pure $! chkBegin k :!: () 210 | {-# NOINLINE doGrow #-} 211 | 212 | chunksLength :: [Chunk] -> Int 213 | chunksLength = foldr (\c s -> s + chkEnd c `minusPtr` chkBegin c) 0 214 | {-# INLINE chunksLength #-} 215 | 216 | catChunks :: [Chunk] -> IO ByteString 217 | catChunks chks = B.create (chunksLength chks) $ \p -> 218 | void $ foldlM (\q c -> do 219 | let n = chkEnd c `minusPtr` chkBegin c 220 | B.memcpy q (chkBegin c) n 221 | free $ chkBegin c 222 | pure (q `plusPtr` n)) p $ reverse chks 223 | {-# INLINE catChunks #-} 224 | 225 | evalPutIO :: Put a -> IO (a, ByteString) 226 | evalPutIO p = do 227 | k <- newChunk 0 228 | chks <- newIORef (k:|[]) 229 | end <- newIORef (chkEnd k) 230 | p' :!: r <- allocaBytes 8 $ \t -> 231 | unPut p PutEnv { peChks = chks, peEnd = end, peTmp = t } (chkBegin k) 232 | cs <- readIORef chks 233 | s <- case cs of 234 | (x:|xs) -> catChunks $ x { chkEnd = p' } : xs 235 | pure (r, s) 236 | 237 | evalPut :: Put a -> (a, ByteString) 238 | evalPut p = unsafePerformIO $ evalPutIO p 239 | {-# NOINLINE evalPut #-} 240 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | packages: 2 | - . 3 | resolver: nightly-2020-05-26 4 | -------------------------------------------------------------------------------- /tests/.gitignore: -------------------------------------------------------------------------------- 1 | bench 2 | -------------------------------------------------------------------------------- /tests/GetTests.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | 5 | module GetTests (tests) where 6 | 7 | import Control.Applicative 8 | import Control.Monad 9 | import Data.Word 10 | import Data.Function 11 | import qualified Data.ByteString as BS 12 | import qualified Data.ByteString.Lazy as LB 13 | import Data.Persist 14 | import Test.Framework (Test(),testGroup) 15 | import Test.Framework.Providers.QuickCheck2 (testProperty) 16 | import Test.QuickCheck as QC 17 | 18 | 19 | -- Data to express Get parser to generate 20 | data GetD 21 | = Get8 22 | | Eof 23 | | Get16be 24 | | Get32be 25 | | Get64be 26 | | Get16le 27 | | Get32le 28 | | Get64le 29 | | GetD :*> GetD 30 | | Skip Int 31 | deriving Show 32 | 33 | -- Get parser generator 34 | buildGet :: GetD -> Get () 35 | buildGet = d where 36 | d Get8 = get @Word8 *> pure () 37 | d Eof = eof 38 | d Get16be = getBE @Word16 *> pure () 39 | d Get32be = getBE @Word32 *> pure () 40 | d Get64be = getBE @Word64 *> pure () 41 | d Get16le = getLE @Word16 *> pure () 42 | d Get32le = getLE @Word32 *> pure () 43 | d Get64le = getLE @Word64 *> pure () 44 | d (x :*> y) = d x *> d y 45 | d (Skip i) = skip i 46 | 47 | -- Randomly generate parser 48 | genGetD :: Gen GetD 49 | genGetD = 50 | oneof $ 51 | [ pure g 52 | | g <- [ Get8, Eof 53 | , Get16be, Get32be, Get64be 54 | , Get16le, Get32le, Get64le 55 | ] 56 | ] <> 57 | [ (:*>) <$> genGetD <*> genGetD 58 | , Skip <$> choose (0, 10) 59 | ] 60 | 61 | instance Arbitrary GetD where 62 | arbitrary = genGetD 63 | 64 | instance Arbitrary (Get ()) where 65 | arbitrary = buildGet <$> genGetD 66 | 67 | newtype R a = 68 | R { unR :: Either String a } 69 | deriving Show 70 | 71 | 72 | -- Ignore equality of error message string 73 | instance Eq a => Eq (R a) where 74 | (==) = (==) `on` either (const Nothing) Just . unR 75 | 76 | data Chunks = Chunks [[Word8]] deriving (Eq, Show) 77 | 78 | mkChunks :: Word -> Chunks 79 | mkChunks n = Chunks . take (fromIntegral n) $ cycle [ [x] | x <- [0 .. 255] ] 80 | 81 | instance Arbitrary Chunks where 82 | arbitrary = mkChunks <$> choose (0, 512) 83 | 84 | 85 | testLength :: Word 86 | testLength = 255 87 | 88 | (==!) :: Eq a => Get a -> Get a -> Property 89 | p1 ==! p2 = 90 | conjoin 91 | [ counterexample (show s) $ R (runGet p1 s) == R (runGet p2 s) 92 | | n <- [0 .. testLength] 93 | , let Chunks in0 = mkChunks n 94 | s = BS.pack $ concat in0 95 | ] 96 | 97 | infix 2 ==! 98 | 99 | monadIdL' :: GetD -> Property 100 | monadIdL' getD = 101 | (return () >>= const x) ==! x 102 | where 103 | x = buildGet getD 104 | 105 | monadIdR' :: GetD -> Property 106 | monadIdR' getD = 107 | (x >>= return) ==! x 108 | where 109 | x = buildGet getD 110 | 111 | monadAssoc' :: GetD -> GetD -> GetD -> Property 112 | monadAssoc' p1 p2 p3 = 113 | (x >> (y >> z)) ==! (x >> y >> z) 114 | where 115 | x = buildGet p1 116 | y = buildGet p2 117 | z = buildGet p3 118 | 119 | tests :: Test 120 | tests = testGroup "GetTests" 121 | [ testProperty "monad left id" monadIdL' 122 | , testProperty "monad right id" monadIdR' 123 | , testProperty "monad assoc" monadAssoc' 124 | ] 125 | -------------------------------------------------------------------------------- /tests/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified GetTests 4 | import qualified RoundTrip 5 | 6 | import Test.Framework.Runners.Console 7 | 8 | 9 | main :: IO () 10 | main = defaultMain 11 | [ GetTests.tests 12 | , RoundTrip.tests 13 | ] 14 | -------------------------------------------------------------------------------- /tests/RoundTrip.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | 4 | -------------------------------------------------------------------------------- 5 | -- | 6 | -- Module : 7 | -- Copyright : (c) Galois, Inc, 2009 8 | -- License : BSD3 9 | -- 10 | -- Maintainer : Trevor Elliott 11 | -- Stability : 12 | -- Portability : 13 | -- 14 | module RoundTrip where 15 | 16 | import Numeric.Natural 17 | import Data.Persist 18 | import Data.Text (Text) 19 | import qualified Data.Text as T 20 | import Data.Word 21 | import Data.Int 22 | import System.Exit (ExitCode(..), exitSuccess, exitWith) 23 | import Test.QuickCheck as QC 24 | 25 | import Test.Framework (Test(),testGroup) 26 | import Test.Framework.Providers.QuickCheck2 (testProperty) 27 | 28 | roundTrip :: (Persist a, Eq a) => (a -> Put ()) -> Get a -> a -> Bool 29 | roundTrip p g a = res == Right a 30 | where res = runGet (g <* eof) (runPut (p a)) 31 | 32 | -- | Did a call to 'quickCheckResult' succeed? 33 | isSuccess :: QC.Result -> Bool 34 | isSuccess Success{} = True 35 | isSuccess _ = False 36 | 37 | tests :: Test 38 | tests = testGroup "Round Trip" 39 | [ testProperty "Word8 Round Trip" $ roundTrip put (get @Word8) 40 | , testProperty "Word16 Round Trip" $ roundTrip put (get @Word16) 41 | , testProperty "Word16be Round Trip" $ roundTrip putBE (getBE @Word16) 42 | , testProperty "Word16le Round Trip" $ roundTrip putLE (getLE @Word16) 43 | , testProperty "Word16host Round Trip" $ roundTrip putHE (getHE @Word16) 44 | , testProperty "Word32 Round Trip" $ roundTrip put (get @Word32) 45 | , testProperty "Word32be Round Trip" $ roundTrip putBE (getBE @Word32) 46 | , testProperty "Word32le Round Trip" $ roundTrip putLE (getLE @Word32) 47 | , testProperty "Word32host Round Trip" $ roundTrip putHE (getHE @Word32) 48 | , testProperty "Word64 Round Trip" $ roundTrip put (get @Word64) 49 | , testProperty "Word64be Round Trip" $ roundTrip putBE (getBE @Word64) 50 | , testProperty "Word64le Round Trip" $ roundTrip putLE (getLE @Word64) 51 | , testProperty "Word64host Round Trip" $ roundTrip putHE (getHE @Word64) 52 | 53 | , testProperty "Int8 Round Trip" $ roundTrip put (get @Int8) 54 | , testProperty "Int16 Round Trip" $ roundTrip put (get @Int16) 55 | , testProperty "Int16be Round Trip" $ roundTrip putBE (getBE @Int16) 56 | , testProperty "Int16le Round Trip" $ roundTrip putLE (getLE @Int16) 57 | , testProperty "Int16host Round Trip" $ roundTrip putHE (getHE @Int16) 58 | , testProperty "Int32 Round Trip" $ roundTrip put (get @Int32) 59 | , testProperty "Int32be Round Trip" $ roundTrip putBE (getBE @Int32) 60 | , testProperty "Int32le Round Trip" $ roundTrip putLE (getLE @Int32) 61 | , testProperty "Int32host Round Trip" $ roundTrip putHE (getHE @Int32) 62 | , testProperty "Int64 Round Trip" $ roundTrip put (get @Int64) 63 | , testProperty "Int64be Round Trip" $ roundTrip putBE (getBE @Int64) 64 | , testProperty "Int64le Round Trip" $ roundTrip putLE (getLE @Int64) 65 | , testProperty "Int64host Round Trip" $ roundTrip putHE (getHE @Int64) 66 | 67 | , testProperty "Float Round Trip" $ roundTrip put (get @Float) 68 | , testProperty "Floatbe Round Trip" $ roundTrip putBE (getBE @Float) 69 | , testProperty "Floatle Round Trip" $ roundTrip putLE (getLE @Float) 70 | , testProperty "Floathost Round Trip" $ roundTrip putHE (getHE @Float) 71 | , testProperty "Double Round Trip" $ roundTrip put (get @Double) 72 | , testProperty "Doublebe Round Trip" $ roundTrip putBE (getBE @Double) 73 | , testProperty "Doublele Round Trip" $ roundTrip putLE (getLE @Double) 74 | , testProperty "Doublehost Round Trip" $ roundTrip putHE (getHE @Double) 75 | 76 | , testProperty "Char Round Trip" 77 | $ roundTrip put (get :: Get Char) 78 | , testProperty "String Round Trip" 79 | $ roundTrip put (get :: Get String) 80 | , testProperty "Text Round Trip" 81 | $ roundTrip put get . T.pack 82 | , testProperty "Integer Round Trip" 83 | $ roundTrip put (get :: Get Integer) 84 | , testProperty "Natural Round Trip" 85 | $ roundTrip put get . (fromInteger :: Integer -> Natural) . abs 86 | , testProperty "(Word8,Word8) Round Trip" 87 | $ roundTrip put (get :: Get (Word8, Word8)) 88 | , testProperty "(Word8,Word16,Word32,Word64) Round Trip" 89 | $ roundTrip put (get :: Get (Word8, Word16, Word32, Word64)) 90 | , testProperty "Complex Round Trip" 91 | $ roundTrip put (get :: Get (Either (Word8, Word8) (Word16, Either Int32 [String], Word64))) 92 | , testProperty "[Word8] Round Trip" 93 | $ roundTrip put (get :: Get [Word8]) 94 | , testProperty "Bool Round Trip" 95 | $ roundTrip put (get :: Get Bool) 96 | , testProperty "Ordering Round Trip" 97 | $ roundTrip put (get :: Get Ordering) 98 | , testProperty "Maybe Word8 Round Trip" 99 | $ roundTrip put (get :: Get (Maybe Word8)) 100 | , testProperty "Either Word8 Word16 Round Trip" 101 | $ roundTrip put (get :: Get (Either Word8 Word16)) 102 | ] 103 | --------------------------------------------------------------------------------