├── .ghci ├── .github └── workflows │ ├── haskell-ci.yml │ └── stack.yml ├── .gitignore ├── CHANGELOG.md ├── README.md ├── Setup.hs ├── cabal.haskell-ci ├── safecopy.cabal ├── src └── Data │ ├── SafeCopy.hs │ └── SafeCopy │ ├── Derive.hs │ ├── Instances.hs │ ├── Internal.hs │ └── SafeCopy.hs ├── stack-8.0.yaml ├── stack-8.10.yaml ├── stack-8.2.yaml ├── stack-8.4.yaml ├── stack-8.6.yaml ├── stack-8.8.yaml ├── stack-9.0.yaml ├── stack-9.10.yaml ├── stack-9.2.yaml ├── stack-9.4.yaml ├── stack-9.6.yaml ├── stack-9.8.yaml └── test ├── generic.hs └── instances.hs /.ghci: -------------------------------------------------------------------------------- 1 | :set -isrc 2 | :set -itest 3 | :set -DDEFAULT_SIGNATURES 4 | :set -XOverloadedStrings 5 | :set -Wall -Wredundant-constraints 6 | :set prompt "λ> " 7 | -------------------------------------------------------------------------------- /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' 'safecopy.cabal' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.19.20250216 12 | # 13 | # REGENDATA ("0.19.20250216",["github","safecopy.cabal"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | push: 18 | branches: 19 | - master 20 | pull_request: 21 | branches: 22 | - master 23 | jobs: 24 | linux: 25 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 26 | runs-on: ubuntu-24.04 27 | timeout-minutes: 28 | 60 29 | container: 30 | image: buildpack-deps:jammy 31 | continue-on-error: ${{ matrix.allow-failure }} 32 | strategy: 33 | matrix: 34 | include: 35 | - compiler: ghc-9.12.1 36 | compilerKind: ghc 37 | compilerVersion: 9.12.1 38 | setup-method: ghcup 39 | allow-failure: false 40 | - compiler: ghc-9.10.1 41 | compilerKind: ghc 42 | compilerVersion: 9.10.1 43 | setup-method: ghcup 44 | allow-failure: false 45 | - compiler: ghc-9.8.4 46 | compilerKind: ghc 47 | compilerVersion: 9.8.4 48 | setup-method: ghcup 49 | allow-failure: false 50 | - compiler: ghc-9.6.6 51 | compilerKind: ghc 52 | compilerVersion: 9.6.6 53 | setup-method: ghcup 54 | allow-failure: false 55 | - compiler: ghc-9.4.8 56 | compilerKind: ghc 57 | compilerVersion: 9.4.8 58 | setup-method: ghcup 59 | allow-failure: false 60 | - compiler: ghc-9.2.8 61 | compilerKind: ghc 62 | compilerVersion: 9.2.8 63 | setup-method: ghcup 64 | allow-failure: false 65 | - compiler: ghc-9.0.2 66 | compilerKind: ghc 67 | compilerVersion: 9.0.2 68 | setup-method: ghcup 69 | allow-failure: false 70 | - compiler: ghc-8.10.7 71 | compilerKind: ghc 72 | compilerVersion: 8.10.7 73 | setup-method: ghcup 74 | allow-failure: false 75 | - compiler: ghc-8.8.4 76 | compilerKind: ghc 77 | compilerVersion: 8.8.4 78 | setup-method: ghcup 79 | allow-failure: false 80 | - compiler: ghc-8.6.5 81 | compilerKind: ghc 82 | compilerVersion: 8.6.5 83 | setup-method: ghcup 84 | allow-failure: false 85 | - compiler: ghc-8.4.4 86 | compilerKind: ghc 87 | compilerVersion: 8.4.4 88 | setup-method: ghcup 89 | allow-failure: false 90 | - compiler: ghc-8.2.2 91 | compilerKind: ghc 92 | compilerVersion: 8.2.2 93 | setup-method: ghcup 94 | allow-failure: false 95 | - compiler: ghc-8.0.2 96 | compilerKind: ghc 97 | compilerVersion: 8.0.2 98 | setup-method: ghcup 99 | allow-failure: false 100 | fail-fast: false 101 | steps: 102 | - name: apt-get install 103 | run: | 104 | apt-get update 105 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 libnuma-dev 106 | - name: Install GHCup 107 | run: | 108 | mkdir -p "$HOME/.ghcup/bin" 109 | curl -sL https://downloads.haskell.org/ghcup/0.1.30.0/x86_64-linux-ghcup-0.1.30.0 > "$HOME/.ghcup/bin/ghcup" 110 | chmod a+x "$HOME/.ghcup/bin/ghcup" 111 | - name: Install cabal-install 112 | run: | 113 | "$HOME/.ghcup/bin/ghcup" install cabal 3.12.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 114 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.12.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" 115 | - name: Install GHC (GHCup) 116 | if: matrix.setup-method == 'ghcup' 117 | run: | 118 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 119 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 120 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 121 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 122 | echo "HC=$HC" >> "$GITHUB_ENV" 123 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 124 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 125 | env: 126 | HCKIND: ${{ matrix.compilerKind }} 127 | HCNAME: ${{ matrix.compiler }} 128 | HCVER: ${{ matrix.compilerVersion }} 129 | - name: Set PATH and environment variables 130 | run: | 131 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 132 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 133 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 134 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 135 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 136 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 137 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 138 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 139 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 140 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 141 | env: 142 | HCKIND: ${{ matrix.compilerKind }} 143 | HCNAME: ${{ matrix.compiler }} 144 | HCVER: ${{ matrix.compilerVersion }} 145 | - name: env 146 | run: | 147 | env 148 | - name: write cabal config 149 | run: | 150 | mkdir -p $CABAL_DIR 151 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 184 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 185 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 186 | rm -f cabal-plan.xz 187 | chmod a+x $HOME/.cabal/bin/cabal-plan 188 | cabal-plan --version 189 | - name: checkout 190 | uses: actions/checkout@v4 191 | with: 192 | path: source 193 | - name: initial cabal.project for sdist 194 | run: | 195 | touch cabal.project 196 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 197 | cat cabal.project 198 | - name: sdist 199 | run: | 200 | mkdir -p sdist 201 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 202 | - name: unpack 203 | run: | 204 | mkdir -p unpacked 205 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 206 | - name: generate cabal.project 207 | run: | 208 | PKGDIR_safecopy="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/safecopy-[0-9.]*')" 209 | echo "PKGDIR_safecopy=${PKGDIR_safecopy}" >> "$GITHUB_ENV" 210 | rm -f cabal.project cabal.project.local 211 | touch cabal.project 212 | touch cabal.project.local 213 | echo "packages: ${PKGDIR_safecopy}" >> cabal.project 214 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package safecopy" >> cabal.project ; fi 215 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi 216 | cat >> cabal.project <> cabal.project.local 220 | cat cabal.project 221 | cat cabal.project.local 222 | - name: dump install plan 223 | run: | 224 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 225 | cabal-plan 226 | - name: restore cache 227 | uses: actions/cache/restore@v4 228 | with: 229 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 230 | path: ~/.cabal/store 231 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 232 | - name: install dependencies 233 | run: | 234 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 235 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 236 | - name: build w/o tests 237 | run: | 238 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 239 | - name: build 240 | run: | 241 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 242 | - name: tests 243 | run: | 244 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 245 | - name: cabal check 246 | run: | 247 | cd ${PKGDIR_safecopy} || false 248 | ${CABAL} -vnormal check 249 | - name: haddock 250 | run: | 251 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 252 | - name: unconstrained build 253 | run: | 254 | rm -f cabal.project.local 255 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 256 | - name: prepare for constraint sets 257 | run: | 258 | rm -f cabal.project.local 259 | - name: constraint set containers-0.8 260 | run: | 261 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --enable-tests --disable-benchmarks --constraint='containers ^>= 0.8' all --dry-run ; fi 262 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then cabal-plan topo | sort ; fi 263 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --enable-tests --disable-benchmarks --constraint='containers ^>= 0.8' --dependencies-only -j2 all ; fi 264 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --enable-tests --disable-benchmarks --constraint='containers ^>= 0.8' all ; fi 265 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then $CABAL v2-test $ARG_COMPILER --enable-tests --disable-benchmarks --constraint='containers ^>= 0.8' all ; fi 266 | - name: save cache 267 | if: always() 268 | uses: actions/cache/save@v4 269 | with: 270 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 271 | path: ~/.cabal/store 272 | -------------------------------------------------------------------------------- /.github/workflows/stack.yml: -------------------------------------------------------------------------------- 1 | name: Stack build 2 | 3 | on: 4 | push: 5 | branches: [master] 6 | pull_request: 7 | branches: [master] 8 | 9 | jobs: 10 | build: 11 | name: Stack ${{ matrix.ghc }} ${{ matrix.os }} 12 | runs-on: ${{ matrix.os }} 13 | strategy: 14 | fail-fast: false 15 | matrix: 16 | os: [ubuntu-latest] 17 | ghc: ['9.10', '9.8', '9.6', '9.4', '9.2', '9.0', '8.10', '8.8', '8.6', '8.4'] 18 | include: 19 | - os: macos-latest 20 | ghc: '9.10' 21 | - os: windows-latest 22 | ghc: '9.10' 23 | 24 | steps: 25 | - uses: actions/checkout@v4 26 | 27 | - uses: haskell-actions/setup@v2 28 | id: setup 29 | with: 30 | ghc-version: ${{ matrix.ghc }} 31 | enable-stack: true 32 | cabal-update: false 33 | 34 | - name: Restore cache 35 | uses: actions/cache/restore@v4 36 | id: cache 37 | env: 38 | key: ${{ runner.os }}-stack-${{ steps.setup.outputs.stack-version }}-ghc-${{ steps.setup.outputs.ghc-version }} 39 | with: 40 | key: ${{ env.key }}-commit-${{ github.sha }} 41 | restore-keys: ${{ env.key }}- 42 | path: | 43 | ${{ steps.setup.outputs.stack-root }} 44 | .stack-work 45 | 46 | - name: Build dependencies 47 | run: stack build --stack-yaml=stack-${{ matrix.ghc }}.yaml --system-ghc --only-dependencies 48 | 49 | - name: Build 50 | run: stack build --stack-yaml=stack-${{ matrix.ghc }}.yaml --system-ghc 51 | 52 | - name: Build tests 53 | run: stack test --stack-yaml=stack-${{ matrix.ghc }}.yaml --system-ghc --no-run-tests 54 | 55 | - name: Run tests 56 | run: stack test --stack-yaml=stack-${{ matrix.ghc }}.yaml --system-ghc 57 | 58 | - name: Save cache 59 | uses: actions/cache/save@v4 60 | if: always() && steps.cache.outputs.cache-hit != 'true' 61 | with: 62 | key: ${{ steps.cache.outputs.cache-primary-key }} 63 | path: | 64 | ${{ steps.setup.outputs.stack-root }} 65 | .stack-work 66 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /dist-newstyle/ 2 | /.stack-work/ 3 | *.nix 4 | stack*.yaml.lock 5 | *~ -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | 0.10.4 2 | ====== 3 | 4 | Add a Typeable a superclass to SafeCopy. The previous version in effect 5 | had the Typeable constraint anyway, this means less need to specify it. 6 | The SafeCopy' type alias is now identical to SafeCopy. This should not 7 | break any code except perhaps some GADT types that use "deriving Typeable". 8 | These may need a standalone deriving instance. 9 | 10 | 0.10.0 11 | ====== 12 | 13 | This version replaces the default implementation of getCopy and putCopy 14 | with a full implementation using GHC.Generics. Before these functions 15 | simply serialized and deserialized their argument. Now they function 16 | identically to the instances generated by deriveSafeCopy. This means 17 | that embedded values with SafeCopy instances will be migrated properly, 18 | and that you can replace template haskell with standalone deriving 19 | instances such as "deriving instance SafeCopy Foo where kind = extension; 20 | version = 3". 21 | 22 | The one caveat is that the new default implementation of getCopy and 23 | putCopy adds the constraint "Typeable a", so that it can build a set of 24 | the subtypes that appear in a. This will only affect code that already 25 | used the default instance, not code that used deriveSafeCopy or custom 26 | SafeCopy instances. If you do run into this you can add a custom SafeCopy 27 | instance with the old implementations mentioned above. 28 | 29 | 0.9.4 30 | ===== 31 | - Support ghc-8.4.1 32 | - Travis config for ghc-8.2.1 33 | - SafeCopy instance for Data.List.NonEmpty.NonEmpty 34 | 35 | 0.9.1 36 | ===== 37 | 38 | - fixed tests to work with QuickCheck-2.8.2 39 | - add SafeCopy instance for Word 40 | - updates for template-haskell 2.11 41 | - export some internal TH derivation helpers 42 | 43 | 0.9.0 44 | ===== 45 | 46 | This version changes the way `Float` and `Double` are serialized to a 47 | more compact format. Old data should be migrated automatically. As a 48 | result, however, the `Float` and `Double` data serialized by this version can not be read 49 | by older versions of `safecopy`. 50 | 51 | This change originated as a modification to the way `cereal` 0.5 serializes `Float` and `Double`. 52 | 53 | [https://github.com/GaloisInc/cereal/commit/47d839609413e3e9d1147b99c34ae421ae36bced](https://github.com/GaloisInc/cereal/commit/47d839609413e3e9d1147b99c34ae421ae36bced) 54 | 55 | [https://github.com/GaloisInc/cereal/issues/35](https://github.com/GaloisInc/cereal/issues/35) 56 | 57 | 58 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | SafeCopy 2 | ======== 3 | 4 | [![Build Status](https://github.com/acid-state/safecopy/actions/workflows/haskell-ci.yml/badge.svg)](https://github.com/acid-state/safecopy/actions/workflows/haskell-ci.yml) 5 | [![Hackage Status](https://img.shields.io/hackage/v/safecopy.svg?color=informational)][hackage] 6 | [![safecopy on Stackage Nightly](https://stackage.org/package/safecopy/badge/nightly)](https://stackage.org/nightly/package/safecopy) 7 | [![Stackage LTS version](https://www.stackage.org/package/safecopy/badge/lts?label=Stackage)](https://www.stackage.org/package/safecopy) 8 | [![Public Domain](http://b.repl.ca/v1/license-public-blue.png)](https://en.wikipedia.org/wiki/Public_domain_software) 9 | [![Haskell](http://b.repl.ca/v1/language-haskell-4e6272.png)](Http://www.haskell.org) 10 | 11 | [hackage]: https://hackage.haskell.org/package/safecopy 12 | 13 | SafeCopy extends the parsing and serialization capabilities of 14 | [`Data.Serialize`](https://github.com/GaloisInc/cereal) to include nested 15 | version control. Nested version control means that you can change the 16 | definition and binary format of a type nested deep within other types without 17 | problems. 18 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /cabal.haskell-ci: -------------------------------------------------------------------------------- 1 | branches: master 2 | installed: +all 3 | 4 | constraint-set containers-0.8 5 | ghc: >= 8.2 6 | constraints: containers ^>= 0.8 7 | tests: True 8 | run-tests: True 9 | 10 | raw-project 11 | allow-newer: containers 12 | -------------------------------------------------------------------------------- /safecopy.cabal: -------------------------------------------------------------------------------- 1 | Name: safecopy 2 | Version: 0.10.4.2 3 | x-revision: 11 4 | Synopsis: Binary serialization with version control. 5 | Description: An extension to Data.Serialize with built-in version control. 6 | Homepage: https://github.com/acid-state/safecopy 7 | License: PublicDomain 8 | Author: David Himmelstrup, Felipe Lessa 9 | Maintainer: Lemmih , David Fox 10 | -- Copyright: 11 | Category: Data, Parsing 12 | Build-type: Simple 13 | Extra-source-files: CHANGELOG.md 14 | Cabal-version: >=1.10 15 | 16 | tested-with: 17 | GHC == 9.12.1 18 | GHC == 9.10.1 19 | GHC == 9.8.4 20 | GHC == 9.6.6 21 | GHC == 9.4.8 22 | GHC == 9.2.8 23 | GHC == 9.0.2 24 | GHC == 8.10.7 25 | GHC == 8.8.4 26 | GHC == 8.6.5 27 | GHC == 8.4.4 28 | GHC == 8.2.2 29 | GHC == 8.0.2 30 | 31 | Source-repository head 32 | type: git 33 | location: https://github.com/acid-state/safecopy.git 34 | 35 | 36 | Library 37 | Default-language: Haskell2010 38 | Exposed-modules: Data.SafeCopy 39 | Data.SafeCopy.Internal 40 | 41 | Hs-Source-Dirs: src/ 42 | 43 | -- Lower bounds are chosen to match LTS 7.24 (GHC 8.0) 44 | Build-depends: base >= 4.9 && < 5 45 | , array >= 0.5.1.1 && < 0.6 46 | , cereal >= 0.5.4.0 && < 0.6 47 | , bytestring >= 0.10.8.1 && < 0.13 48 | , generic-data >= 0.3.0.0 && < 2 49 | , containers >= 0.5.7.1 && < 1 50 | , old-time >= 1.1.0.3 && < 1.2 51 | , template-haskell >= 2.11.0.0 && < 2.24 52 | , text >= 1.2.2.2 && < 1.3 || >= 2.0 && < 2.2 53 | , time >= 1.6.0.1 && < 1.15 54 | , transformers >= 0.5.2.0 && < 0.7 55 | , vector >= 0.11.0.0 && < 0.14 56 | 57 | Other-modules: Data.SafeCopy.Instances 58 | Data.SafeCopy.SafeCopy 59 | Data.SafeCopy.Derive 60 | 61 | GHC-Options: -Wall 62 | 63 | cpp-options: -DDEFAULT_SIGNATURES -DSAFE_HASKELL 64 | 65 | Test-suite instances 66 | Default-language: Haskell2010 67 | Type: exitcode-stdio-1.0 68 | Main-is: instances.hs 69 | Hs-Source-Dirs: test/ 70 | GHC-Options: -Wall -threaded -rtsopts -with-rtsopts=-N 71 | Build-depends: base 72 | , array 73 | , cereal 74 | , containers 75 | , safecopy 76 | , template-haskell 77 | , time 78 | , vector 79 | -- new dependencies: 80 | , lens >= 4.7 && < 6 81 | , lens-action 82 | , tasty 83 | , tasty-quickcheck 84 | , quickcheck-instances 85 | , QuickCheck >= 2.8.2 && < 3 86 | 87 | Test-suite generic 88 | Default-language: Haskell2010 89 | Type: exitcode-stdio-1.0 90 | Main-is: generic.hs 91 | Hs-Source-Dirs: test/ 92 | GHC-Options: -Wall -threaded -rtsopts -with-rtsopts=-N 93 | Build-depends: base 94 | , bytestring 95 | , cereal 96 | , safecopy 97 | , HUnit 98 | -------------------------------------------------------------------------------- /src/Data/SafeCopy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #ifdef SAFE_HASKELL 3 | {-# LANGUAGE Trustworthy #-} 4 | #endif 5 | 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Data.SafeCopy 9 | -- Copyright : PublicDomain 10 | -- 11 | -- Maintainer : lemmih@gmail.com 12 | -- Portability : non-portable (uses GHC extensions) 13 | -- 14 | -- SafeCopy extends the parsing and serialization capabilities of Data.Serialize 15 | -- to include nested version control. Nested version control means that you 16 | -- can change the definition and binary format of a type nested deep within 17 | -- other types without problems. 18 | -- 19 | -- = Migration 20 | -- 21 | -- Consider this scenario. You want to store your contact list on disk 22 | -- and so write the following code: 23 | -- 24 | -- @ 25 | --type Name = String 26 | --type Address = String 27 | --data Contacts = Contacts [(Name, Address)] 28 | --instance SafeCopy Contacts where 29 | -- putCopy (Contacts list) = contain $ safePut list 30 | -- getCopy = contain $ Contacts \<$\> safeGet 31 | -- @ 32 | -- 33 | -- At this point, everything is fine. You get the awesome speed of Data.Serialize 34 | -- together with Haskell's ease of use. However, things quickly take a U-turn for the worse 35 | -- when you realize that you want to keep phone numbers as well as names and 36 | -- addresses. Being the experienced coder that you are, you see that using a 3-tuple 37 | -- isn't very pretty and you'd rather use a record. At first you fear that this 38 | -- change in structure will invalidate all your old data. Those fears are quickly quelled, 39 | -- though, when you remember how nifty SafeCopy is. With renewed enthusiasm, 40 | -- you set out and write the following code: 41 | -- 42 | -- @ 43 | --type Name = String 44 | --type Address = String 45 | --type Phone = String 46 | -- 47 | --{- We rename our old Contacts structure -} 48 | --data Contacts_v0 = Contacts_v0 [(Name, Address)] 49 | --instance SafeCopy Contacts_v0 where 50 | -- putCopy (Contacts_v0 list) = contain $ safePut list 51 | -- getCopy = contain $ Contacts_v0 \<$\> safeGet 52 | -- 53 | --data Contact = Contact { name :: Name 54 | -- , address :: Address 55 | -- , phone :: Phone } 56 | --instance SafeCopy Contact where 57 | -- putCopy Contact{..} = contain $ do safePut name; safePut address; safePut phone 58 | -- getCopy = contain $ Contact \<$\> safeGet \<*\> safeGet \<*\> safeGet 59 | -- 60 | --data Contacts = Contacts [Contact] 61 | --instance SafeCopy Contacts where 62 | -- version = 2 63 | -- kind = extension 64 | -- putCopy (Contacts contacts) = contain $ safePut contacts 65 | -- getCopy = contain $ Contacts \<$\> safeGet 66 | -- 67 | --{- Here the magic happens: -} 68 | --instance Migrate Contacts where 69 | -- type MigrateFrom Contacts = Contacts_v0 70 | -- migrate (Contacts_v0 contacts) = Contacts [ Contact{ name = name 71 | -- , address = address 72 | -- , phone = \"\" } 73 | -- | (name, address) <- contacts ] 74 | -- @ 75 | -- 76 | -- With this, you reflect on your code and you are happy. You feel confident in the safety of 77 | -- your data and you know you can remove @Contacts_v0@ once you no longer wish to support 78 | -- that legacy format. 79 | -- 80 | -- = Retiring Migrations 81 | -- 82 | -- There may come a time when you have to remove @Contacts_v0@. 83 | -- Perhaps it uses types you want to remove from your build to 84 | -- decrease its size. Perhaps it has constraints such as @Enum@ which 85 | -- are imposed on your new @Contacts@ type via the @SafeCopy@ 86 | -- instance. 87 | -- 88 | -- In any case, if you are using @safecopy@ incombination with 89 | -- @acid-state@, some care must be taken when removing @Contacts_v0@. 90 | -- The following steps must be taken to add a new type and remove the old: 91 | -- 92 | -- 1. Add the migration as described above. 93 | -- 2. Run the server with the new migration on /all important data/. This 94 | -- will cause the type to be modified in the running program. 95 | -- 3. /Restart/ the server with the new migration on /all important data/. This 96 | -- causes checkpoints to be written that only contain the new type. 97 | -- 4. Remove the old type from your source code, changing the @kind@ of 98 | -- the new type from @extension@ to @base@. Build and deploy. 99 | -- 100 | -- If you omit any of these steps it is a certainty that you will 101 | -- proceed happily with your development thinking all is grand, and 102 | -- then when you go to deploy your live system the migration will fail. 103 | 104 | module Data.SafeCopy 105 | ( 106 | safeGet 107 | , safePut 108 | , SafeCopy(version, kind, getCopy, putCopy, objectProfile, errorTypeName) 109 | , SafeCopy' 110 | , Profile(..) 111 | , Prim(..) 112 | , Migrate(..) 113 | , Reverse(..) 114 | , Kind 115 | , extension 116 | , extended_extension 117 | , extended_base 118 | , base 119 | , Contained 120 | , contain 121 | , Version 122 | 123 | -- * Template haskell functions 124 | , deriveSafeCopy 125 | , deriveSafeCopyIndexedType 126 | , deriveSafeCopySimple 127 | , deriveSafeCopySimpleIndexedType 128 | , deriveSafeCopyHappstackData 129 | , deriveSafeCopyHappstackDataIndexedType 130 | 131 | -- * Rarely used functions 132 | , getSafeGet 133 | , getSafePut 134 | , primitive 135 | ) where 136 | 137 | import Data.SafeCopy.Instances () 138 | import Data.SafeCopy.SafeCopy 139 | import Data.SafeCopy.Derive 140 | -------------------------------------------------------------------------------- /src/Data/SafeCopy/Derive.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, CPP #-} 2 | 3 | module Data.SafeCopy.Derive where 4 | 5 | import Data.Serialize (getWord8, putWord8, label) 6 | import Data.SafeCopy.SafeCopy 7 | 8 | import Language.Haskell.TH hiding (Kind) 9 | import Control.Monad 10 | import Data.Maybe (fromMaybe) 11 | #ifdef __HADDOCK__ 12 | import Data.Word (Word8) -- Haddock 13 | #endif 14 | 15 | -- | Derive an instance of 'SafeCopy'. 16 | -- 17 | -- When serializing, we put a 'Word8' describing the 18 | -- constructor (if the data type has more than one 19 | -- constructor). For each type used in the constructor, we 20 | -- call 'getSafePut' (which immediately serializes the version 21 | -- of the type). Then, for each field in the constructor, we 22 | -- use one of the put functions obtained in the last step. 23 | -- 24 | -- For example, given the data type and the declaration below 25 | -- 26 | -- @ 27 | --data T0 b = T0 b Int 28 | --deriveSafeCopy 1 'base ''T0 29 | -- @ 30 | -- 31 | -- we generate 32 | -- 33 | -- @ 34 | --instance (SafeCopy a, SafeCopy b) => 35 | -- SafeCopy (T0 b) where 36 | -- putCopy (T0 arg1 arg2) = contain $ do put_b <- getSafePut 37 | -- put_Int <- getSafePut 38 | -- put_b arg1 39 | -- put_Int arg2 40 | -- return () 41 | -- getCopy = contain $ do get_b <- getSafeGet 42 | -- get_Int <- getSafeGet 43 | -- return T0 \<*\> get_b \<*\> get_Int 44 | -- version = 1 45 | -- kind = base 46 | -- @ 47 | -- 48 | -- And, should we create another data type as a newer version of @T0@, such as 49 | -- 50 | -- @ 51 | --data T a b = C a a | D b Int 52 | --deriveSafeCopy 2 'extension ''T 53 | -- 54 | --instance SafeCopy b => Migrate (T a b) where 55 | -- type MigrateFrom (T a b) = T0 b 56 | -- migrate (T0 b i) = D b i 57 | -- @ 58 | -- 59 | -- we generate 60 | -- 61 | -- @ 62 | --instance (SafeCopy a, SafeCopy b) => 63 | -- SafeCopy (T a b) where 64 | -- putCopy (C arg1 arg2) = contain $ do putWord8 0 65 | -- put_a <- getSafePut 66 | -- put_a arg1 67 | -- put_a arg2 68 | -- return () 69 | -- putCopy (D arg1 arg2) = contain $ do putWord8 1 70 | -- put_b <- getSafePut 71 | -- put_Int <- getSafePut 72 | -- put_b arg1 73 | -- put_Int arg2 74 | -- return () 75 | -- getCopy = contain $ do tag <- getWord8 76 | -- case tag of 77 | -- 0 -> do get_a <- getSafeGet 78 | -- return C \<*\> get_a \<*\> get_a 79 | -- 1 -> do get_b <- getSafeGet 80 | -- get_Int <- getSafeGet 81 | -- return D \<*\> get_b \<*\> get_Int 82 | -- _ -> fail $ \"Could not identify tag \\\"\" ++ 83 | -- show tag ++ \"\\\" for type Main.T \" ++ 84 | -- \"that has only 2 constructors. \" ++ 85 | -- \"Maybe your data is corrupted?\" 86 | -- version = 2 87 | -- kind = extension 88 | -- @ 89 | -- 90 | -- Note that by using getSafePut, we saved 4 bytes in the case 91 | -- of the @C@ constructor. For @D@ and @T0@, we didn't save 92 | -- anything. The instance derived by this function always use 93 | -- at most the same space as those generated by 94 | -- 'deriveSafeCopySimple', but never more (as we don't call 95 | -- 'getSafePut'/'getSafeGet' for types that aren't needed). 96 | -- 97 | -- Note that you may use 'deriveSafeCopySimple' with one 98 | -- version of your data type and 'deriveSafeCopy' in another 99 | -- version without any problems. 100 | deriveSafeCopy :: Version a -> Name -> Name -> Q [Dec] 101 | deriveSafeCopy = internalDeriveSafeCopy Normal 102 | 103 | deriveSafeCopyIndexedType :: Version a -> Name -> Name -> [Name] -> Q [Dec] 104 | deriveSafeCopyIndexedType = internalDeriveSafeCopyIndexedType Normal 105 | 106 | -- | Derive an instance of 'SafeCopy'. The instance derived by 107 | -- this function is simpler than the one derived by 108 | -- 'deriveSafeCopy' in that we always use 'safePut' and 109 | -- 'safeGet' (instead of 'getSafePut' and 'getSafeGet'). 110 | -- 111 | -- When serializing, we put a 'Word8' describing the 112 | -- constructor (if the data type has more than one constructor) 113 | -- and, for each field of the constructor, we use 'safePut'. 114 | -- 115 | -- For example, given the data type and the declaration below 116 | -- 117 | -- @ 118 | --data T a b = C a a | D b Int 119 | --deriveSafeCopySimple 1 'base ''T 120 | -- @ 121 | -- 122 | -- we generate 123 | -- 124 | -- @ 125 | --instance (SafeCopy a, SafeCopy b) => 126 | -- SafeCopy (T a b) where 127 | -- putCopy (C arg1 arg2) = contain $ do putWord8 0 128 | -- safePut arg1 129 | -- safePut arg2 130 | -- return () 131 | -- putCopy (D arg1 arg2) = contain $ do putWord8 1 132 | -- safePut arg1 133 | -- safePut arg2 134 | -- return () 135 | -- getCopy = contain $ do tag <- getWord8 136 | -- case tag of 137 | -- 0 -> do return C \<*\> safeGet \<*\> safeGet 138 | -- 1 -> do return D \<*\> safeGet \<*\> safeGet 139 | -- _ -> fail $ \"Could not identify tag \\\"\" ++ 140 | -- show tag ++ \"\\\" for type Main.T \" ++ 141 | -- \"that has only 2 constructors. \" ++ 142 | -- \"Maybe your data is corrupted?\" 143 | -- version = 1 144 | -- kind = base 145 | -- @ 146 | -- 147 | -- Using this simpler instance means that you may spend more 148 | -- bytes when serializing data. On the other hand, it is more 149 | -- straightforward and may match any other format you used in 150 | -- the past. 151 | -- 152 | -- Note that you may use 'deriveSafeCopy' with one version of 153 | -- your data type and 'deriveSafeCopySimple' in another version 154 | -- without any problems. 155 | deriveSafeCopySimple :: Version a -> Name -> Name -> Q [Dec] 156 | deriveSafeCopySimple = internalDeriveSafeCopy Simple 157 | 158 | deriveSafeCopySimpleIndexedType :: Version a -> Name -> Name -> [Name] -> Q [Dec] 159 | deriveSafeCopySimpleIndexedType = internalDeriveSafeCopyIndexedType Simple 160 | 161 | -- | Derive an instance of 'SafeCopy'. The instance derived by 162 | -- this function should be compatible with the instance derived 163 | -- by the module @Happstack.Data.SerializeTH@ of the 164 | -- @happstack-data@ package. The instances use only 'safePut' 165 | -- and 'safeGet' (as do the instances created by 166 | -- 'deriveSafeCopySimple'), but we also always write a 'Word8' 167 | -- tag, even if the data type isn't a sum type. 168 | -- 169 | -- For example, given the data type and the declaration below 170 | -- 171 | -- @ 172 | --data T0 b = T0 b Int 173 | --deriveSafeCopy 1 'base ''T0 174 | -- @ 175 | -- 176 | -- we generate 177 | -- 178 | -- @ 179 | --instance (SafeCopy a, SafeCopy b) => 180 | -- SafeCopy (T0 b) where 181 | -- putCopy (T0 arg1 arg2) = contain $ do putWord8 0 182 | -- safePut arg1 183 | -- safePut arg2 184 | -- return () 185 | -- getCopy = contain $ do tag <- getWord8 186 | -- case tag of 187 | -- 0 -> do return T0 \<*\> safeGet \<*\> safeGet 188 | -- _ -> fail $ \"Could not identify tag \\\"\" ++ 189 | -- show tag ++ \"\\\" for type Main.T0 \" ++ 190 | -- \"that has only 1 constructors. \" ++ 191 | -- \"Maybe your data is corrupted?\" 192 | -- version = 1 193 | -- kind = base 194 | -- @ 195 | -- 196 | -- This instance always consumes at least the same space as 197 | -- 'deriveSafeCopy' or 'deriveSafeCopySimple', but may use more 198 | -- because of the useless tag. So we recomend using it only if 199 | -- you really need to read a previous version in this format, 200 | -- and not for newer versions. 201 | -- 202 | -- Note that you may use 'deriveSafeCopy' with one version of 203 | -- your data type and 'deriveSafeCopyHappstackData' in another version 204 | -- without any problems. 205 | deriveSafeCopyHappstackData :: Version a -> Name -> Name -> Q [Dec] 206 | deriveSafeCopyHappstackData = internalDeriveSafeCopy HappstackData 207 | 208 | deriveSafeCopyHappstackDataIndexedType :: Version a -> Name -> Name -> [Name] -> Q [Dec] 209 | deriveSafeCopyHappstackDataIndexedType = internalDeriveSafeCopyIndexedType HappstackData 210 | 211 | data DeriveType = Normal | Simple | HappstackData 212 | 213 | forceTag :: DeriveType -> Bool 214 | forceTag HappstackData = True 215 | forceTag _ = False 216 | 217 | #if MIN_VERSION_template_haskell(2,17,0) 218 | tyVarName :: TyVarBndr s -> Name 219 | tyVarName (PlainTV n _) = n 220 | tyVarName (KindedTV n _ _) = n 221 | #else 222 | tyVarName :: TyVarBndr -> Name 223 | tyVarName (PlainTV n) = n 224 | tyVarName (KindedTV n _) = n 225 | #endif 226 | 227 | internalDeriveSafeCopy :: DeriveType -> Version a -> Name -> Name -> Q [Dec] 228 | internalDeriveSafeCopy deriveType versionId kindName tyName = do 229 | info <- reify tyName 230 | internalDeriveSafeCopy' deriveType versionId kindName tyName info 231 | 232 | internalDeriveSafeCopy' :: DeriveType -> Version a -> Name -> Name -> Info -> Q [Dec] 233 | internalDeriveSafeCopy' deriveType versionId kindName tyName info = do 234 | case info of 235 | TyConI (DataD context _name tyvars _kind cons _derivs) 236 | | length cons > 255 -> fail $ "Can't derive SafeCopy instance for: " ++ show tyName ++ 237 | ". The datatype must have less than 256 constructors." 238 | | otherwise -> worker context tyvars (zip [0..] cons) 239 | 240 | TyConI (NewtypeD context _name tyvars _kind con _derivs) -> 241 | worker context tyvars [(0, con)] 242 | 243 | FamilyI _ insts -> do 244 | decs <- forM insts $ \inst -> 245 | case inst of 246 | #if MIN_VERSION_template_haskell(2,15,0) 247 | DataInstD context _ nty _kind cons _derivs -> 248 | worker' (return nty) context [] (zip [0..] cons) 249 | 250 | NewtypeInstD context _ nty _kind con _derivs -> 251 | worker' (return nty) context [] [(0, con)] 252 | #else 253 | DataInstD context _name ty _kind cons _derivs -> 254 | worker' (foldl appT (conT tyName) (map return ty)) context [] (zip [0..] cons) 255 | 256 | NewtypeInstD context _name ty _kind con _derivs -> 257 | worker' (foldl appT (conT tyName) (map return ty)) context [] [(0, con)] 258 | #endif 259 | _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, inst) 260 | return $ concat decs 261 | _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, info) 262 | where 263 | worker = worker' (conT tyName) 264 | worker' tyBase context tyvars cons = 265 | let ty = foldl appT tyBase [ varT $ tyVarName var | var <- tyvars ] 266 | safeCopyClass args = foldl appT (conT ''SafeCopy) args 267 | in (:[]) <$> instanceD (cxt $ [safeCopyClass [varT $ tyVarName var] | var <- tyvars] ++ map return context) 268 | (conT ''SafeCopy `appT` ty) 269 | [ mkPutCopy deriveType cons 270 | , mkGetCopy deriveType (show tyName) cons 271 | , valD (varP 'version) (normalB $ litE $ integerL $ fromIntegral $ unVersion versionId) [] 272 | , valD (varP 'kind) (normalB (varE kindName)) [] 273 | , funD 'errorTypeName [clause [wildP] (normalB $ litE $ StringL (show tyName)) []] 274 | ] 275 | 276 | internalDeriveSafeCopyIndexedType :: DeriveType -> Version a -> Name -> Name -> [Name] -> Q [Dec] 277 | internalDeriveSafeCopyIndexedType deriveType versionId kindName tyName tyIndex' = do 278 | info <- reify tyName 279 | internalDeriveSafeCopyIndexedType' deriveType versionId kindName tyName tyIndex' info 280 | 281 | internalDeriveSafeCopyIndexedType' :: DeriveType -> Version a -> Name -> Name -> [Name] -> Info -> Q [Dec] 282 | internalDeriveSafeCopyIndexedType' deriveType versionId kindName tyName tyIndex' info = do 283 | tyIndex <- mapM conT tyIndex' 284 | case info of 285 | FamilyI _ insts -> do 286 | decs <- forM insts $ \inst -> 287 | case inst of 288 | #if MIN_VERSION_template_haskell(2,15,0) 289 | DataInstD context _ nty _kind cons _derivs 290 | | nty == foldl AppT (ConT tyName) tyIndex -> 291 | worker' (return nty) context [] (zip [0..] cons) 292 | #else 293 | DataInstD context _name ty _kind cons _derivs 294 | | ty == tyIndex -> 295 | worker' (foldl appT (conT tyName) (map return ty)) context [] (zip [0..] cons) 296 | #endif 297 | | otherwise -> 298 | return [] 299 | 300 | #if MIN_VERSION_template_haskell(2,15,0) 301 | NewtypeInstD context _ nty _kind con _derivs 302 | | nty == foldl AppT (ConT tyName) tyIndex -> 303 | worker' (return nty) context [] [(0, con)] 304 | #else 305 | NewtypeInstD context _name ty _kind con _derivs 306 | | ty == tyIndex -> 307 | worker' (foldl appT (conT tyName) (map return ty)) context [] [(0, con)] 308 | #endif 309 | | otherwise -> 310 | return [] 311 | _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, inst) 312 | return $ concat decs 313 | _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, info) 314 | where 315 | typeNameStr = unwords $ map show (tyName:tyIndex') 316 | worker' tyBase context tyvars cons = 317 | let ty = foldl appT tyBase [ varT $ tyVarName var | var <- tyvars ] 318 | safeCopyClass args = foldl appT (conT ''SafeCopy) args 319 | in (:[]) <$> instanceD (cxt $ [safeCopyClass [varT $ tyVarName var] | var <- tyvars] ++ map return context) 320 | (conT ''SafeCopy `appT` ty) 321 | [ mkPutCopy deriveType cons 322 | , mkGetCopy deriveType typeNameStr cons 323 | , valD (varP 'version) (normalB $ litE $ integerL $ fromIntegral $ unVersion versionId) [] 324 | , valD (varP 'kind) (normalB (varE kindName)) [] 325 | , funD 'errorTypeName [clause [wildP] (normalB $ litE $ StringL typeNameStr) []] 326 | ] 327 | 328 | mkPutCopy :: DeriveType -> [(Integer, Con)] -> DecQ 329 | mkPutCopy deriveType cons = funD 'putCopy $ map mkPutClause cons 330 | where 331 | manyConstructors = length cons > 1 || forceTag deriveType 332 | mkPutClause (conNumber, con) 333 | = do putVars <- mapM (\n -> newName ("a" ++ show n)) [1..conSize con] 334 | (putFunsDecs, putFuns) <- case deriveType of 335 | Normal -> mkSafeFunctions "safePut_" 'getSafePut con 336 | _ -> return ([], const 'safePut) 337 | let putClause = conP (conName con) (map varP putVars) 338 | putCopyBody = varE 'contain `appE` doE ( 339 | [ noBindS $ varE 'putWord8 `appE` litE (IntegerL conNumber) | manyConstructors ] ++ 340 | putFunsDecs ++ 341 | [ noBindS $ varE (putFuns typ) `appE` varE var | (typ, var) <- zip (conTypes con) putVars ] ++ 342 | [ noBindS $ varE 'return `appE` tupE [] ]) 343 | clause [putClause] (normalB putCopyBody) [] 344 | 345 | mkGetCopy :: DeriveType -> String -> [(Integer, Con)] -> DecQ 346 | mkGetCopy deriveType tyName cons = valD (varP 'getCopy) (normalB $ varE 'contain `appE` mkLabel) [] 347 | where 348 | mkLabel = varE 'label `appE` litE (stringL labelString) `appE` getCopyBody 349 | labelString = tyName ++ ":" 350 | getCopyBody 351 | = case cons of 352 | [(_, con)] | not (forceTag deriveType) -> mkGetBody con 353 | _ -> do 354 | tagVar <- newName "tag" 355 | doE [ bindS (varP tagVar) (varE 'getWord8) 356 | , noBindS $ caseE (varE tagVar) ( 357 | [ match (litP $ IntegerL i) (normalB $ mkGetBody con) [] | (i, con) <- cons ] ++ 358 | [ match wildP (normalB $ varE 'fail `appE` errorMsg tagVar) [] ]) ] 359 | mkGetBody con 360 | = do (getFunsDecs, getFuns) <- case deriveType of 361 | Normal -> mkSafeFunctions "safeGet_" 'getSafeGet con 362 | _ -> return ([], const 'safeGet) 363 | let getBase = appE (varE 'return) (conE (conName con)) 364 | getArgs = foldl (\a t -> infixE (Just a) (varE '(<*>)) (Just (varE (getFuns t)))) getBase (conTypes con) 365 | doE (getFunsDecs ++ [noBindS getArgs]) 366 | errorMsg tagVar = infixE (Just $ strE str1) (varE '(++)) $ Just $ 367 | infixE (Just tagStr) (varE '(++)) (Just $ strE str2) 368 | where 369 | strE = litE . StringL 370 | tagStr = varE 'show `appE` varE tagVar 371 | str1 = "Could not identify tag \"" 372 | str2 = concat [ "\" for type " 373 | , show tyName 374 | , " that has only " 375 | , show (length cons) 376 | , " constructors. Maybe your data is corrupted?" ] 377 | 378 | mkSafeFunctions :: String -> Name -> Con -> Q ([StmtQ], Type -> Name) 379 | mkSafeFunctions name baseFun con = do let origTypes = conTypes con 380 | realTypes <- mapM followSynonyms origTypes 381 | finish (zip origTypes realTypes) <$> foldM go ([], []) realTypes 382 | where go (ds, fs) t 383 | | found = return (ds, fs) 384 | | otherwise = do funVar <- newName (name ++ typeName t) 385 | return ( bindS (varP funVar) (varE baseFun) : ds 386 | , (t, funVar) : fs ) 387 | where found = any ((== t) . fst) fs 388 | finish 389 | :: [(Type, Type)] -- "dictionary" from synonyms(or not) to real types 390 | -> ([StmtQ], [(Type, Name)]) -- statements 391 | -> ([StmtQ], Type -> Name) -- function body and name-generator 392 | finish typeList (ds, fs) = (reverse ds, getName) 393 | where getName typ = fromMaybe err $ lookup typ typeList >>= flip lookup fs 394 | err = error "mkSafeFunctions: never here" 395 | 396 | -- | Follow type synonyms. This allows us to see, for example, 397 | -- that @[Char]@ and @String@ are the same type and we just need 398 | -- to call 'getSafePut' or 'getSafeGet' once for both. 399 | followSynonyms :: Type -> Q Type 400 | followSynonyms t@(ConT name) 401 | = maybe (return t) followSynonyms =<< 402 | recover (return Nothing) (do info <- reify name 403 | return $ case info of 404 | TyVarI _ ty -> Just ty 405 | TyConI (TySynD _ _ ty) -> Just ty 406 | _ -> Nothing) 407 | followSynonyms (AppT ty1 ty2) = liftM2 AppT (followSynonyms ty1) (followSynonyms ty2) 408 | followSynonyms (SigT ty k) = liftM (flip SigT k) (followSynonyms ty) 409 | followSynonyms t = return t 410 | 411 | conSize :: Con -> Int 412 | conSize (NormalC _name args) = length args 413 | conSize (RecC _name recs) = length recs 414 | conSize InfixC{} = 2 415 | conSize ForallC{} = error "Found constructor with existentially quantified binder. Cannot derive SafeCopy for it." 416 | conSize GadtC{} = error "Found GADT constructor. Cannot derive SafeCopy for it." 417 | conSize RecGadtC{} = error "Found GADT constructor. Cannot derive SafeCopy for it." 418 | 419 | conName :: Con -> Name 420 | conName (NormalC name _args) = name 421 | conName (RecC name _recs) = name 422 | conName (InfixC _ name _) = name 423 | conName _ = error "conName: never here" 424 | 425 | conTypes :: Con -> [Type] 426 | conTypes (NormalC _name args) = [t | (_, t) <- args] 427 | conTypes (RecC _name args) = [t | (_, _, t) <- args] 428 | conTypes (InfixC (_, t1) _ (_, t2)) = [t1, t2] 429 | conTypes _ = error "conName: never here" 430 | 431 | typeName :: Type -> String 432 | typeName (VarT name) = nameBase name 433 | typeName (ConT name) = nameBase name 434 | typeName (TupleT n) = "Tuple" ++ show n 435 | typeName ArrowT = "Arrow" 436 | typeName ListT = "List" 437 | typeName (AppT t u) = typeName t ++ typeName u 438 | typeName (SigT t _k) = typeName t 439 | typeName _ = "_" 440 | -------------------------------------------------------------------------------- /src/Data/SafeCopy/Instances.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable, FlexibleContexts, UndecidableInstances, TypeFamilies #-} 3 | {-# OPTIONS_GHC -fno-warn-orphans #-} 4 | 5 | module Data.SafeCopy.Instances where 6 | 7 | import Data.SafeCopy.SafeCopy 8 | 9 | import Control.Monad 10 | import qualified Data.Array as Array 11 | import qualified Data.Array.Unboxed as UArray 12 | import qualified Data.Array.IArray as IArray 13 | import qualified Data.ByteString.Lazy.Char8 as L 14 | import qualified Data.ByteString.Char8 as B 15 | import qualified Data.Foldable as Foldable 16 | import Data.Fixed (HasResolution, Fixed) 17 | import Data.Int 18 | import qualified Data.IntMap as IntMap 19 | import qualified Data.IntSet as IntSet 20 | import Data.Ix 21 | import qualified Data.List.NonEmpty as NonEmpty 22 | import qualified Data.Map as Map 23 | import Data.Ratio (Ratio, (%), numerator, denominator) 24 | import qualified Data.Sequence as Sequence 25 | import Data.Serialize 26 | import qualified Data.Set as Set 27 | import qualified Data.Text as T 28 | import qualified Data.Text.Encoding as T 29 | import qualified Data.Text.Lazy as TL 30 | import qualified Data.Text.Lazy.Encoding as TL 31 | import Data.Time.Calendar (Day(..)) 32 | import Data.Time.Clock (DiffTime, NominalDiffTime, UniversalTime(..), UTCTime(..)) 33 | import Data.Time.Clock.TAI (AbsoluteTime, taiEpoch, addAbsoluteTime, diffAbsoluteTime) 34 | import Data.Time.LocalTime (LocalTime(..), TimeOfDay(..), TimeZone(..), ZonedTime(..)) 35 | import qualified Data.Tree as Tree 36 | import Data.Typeable hiding (Proxy) 37 | import Data.Word 38 | import Numeric.Natural (Natural) 39 | import System.Time (ClockTime(..), TimeDiff(..), CalendarTime(..), Month(..)) 40 | import qualified System.Time as OT 41 | import qualified Data.Vector as V 42 | import qualified Data.Vector.Generic as VG 43 | import qualified Data.Vector.Primitive as VP 44 | import qualified Data.Vector.Storable as VS 45 | import qualified Data.Vector.Unboxed as VU 46 | 47 | instance SafeCopy a => SafeCopy (Prim a) where 48 | kind = primitive 49 | getCopy = contain $ 50 | do e <- unsafeUnPack getCopy 51 | return $ Prim e 52 | putCopy (Prim e) 53 | = contain $ unsafeUnPack (putCopy e) 54 | 55 | instance SafeCopy a => SafeCopy [a] where 56 | getCopy = contain $ do 57 | n <- get 58 | g <- getSafeGet 59 | go g [] n 60 | where 61 | go :: Get a -> [a] -> Int -> Get [a] 62 | go _ as 0 = return (reverse as) 63 | go g as i = do x <- g 64 | x `seq` go g (x:as) (i - 1) 65 | putCopy lst = contain $ do put (length lst) 66 | getSafePut >>= forM_ lst 67 | errorTypeName = typeName1 68 | 69 | instance SafeCopy a => SafeCopy (NonEmpty.NonEmpty a) where 70 | getCopy = contain $ fmap NonEmpty.fromList safeGet 71 | putCopy = contain . safePut . NonEmpty.toList 72 | errorTypeName = typeName1 73 | 74 | instance SafeCopy a => SafeCopy (Maybe a) where 75 | getCopy = contain $ do n <- get 76 | if n then liftM Just safeGet 77 | else return Nothing 78 | putCopy (Just a) = contain $ put True >> safePut a 79 | putCopy Nothing = contain $ put False 80 | errorTypeName = typeName1 81 | 82 | instance (SafeCopy a, Ord a) => SafeCopy (Set.Set a) where 83 | getCopy = contain $ fmap Set.fromDistinctAscList safeGet 84 | putCopy = contain . safePut . Set.toAscList 85 | errorTypeName = typeName1 86 | 87 | instance (SafeCopy a, SafeCopy b, Ord a) => SafeCopy (Map.Map a b) where 88 | getCopy = contain $ fmap Map.fromDistinctAscList safeGet 89 | putCopy = contain . safePut . Map.toAscList 90 | errorTypeName = typeName2 91 | 92 | instance (SafeCopy a) => SafeCopy (IntMap.IntMap a) where 93 | getCopy = contain $ fmap IntMap.fromDistinctAscList safeGet 94 | putCopy = contain . safePut . IntMap.toAscList 95 | errorTypeName = typeName1 96 | 97 | instance SafeCopy IntSet.IntSet where 98 | getCopy = contain $ fmap IntSet.fromDistinctAscList safeGet 99 | putCopy = contain . safePut . IntSet.toAscList 100 | errorTypeName = typeName 101 | 102 | instance (SafeCopy a) => SafeCopy (Sequence.Seq a) where 103 | getCopy = contain $ fmap Sequence.fromList safeGet 104 | putCopy = contain . safePut . Foldable.toList 105 | errorTypeName = typeName1 106 | 107 | instance (SafeCopy a) => SafeCopy (Tree.Tree a) where 108 | getCopy = contain $ liftM2 Tree.Node safeGet safeGet 109 | putCopy (Tree.Node root sub) = contain $ safePut root >> safePut sub 110 | errorTypeName = typeName1 111 | 112 | iarray_getCopy :: (Ix i, SafeCopy e, SafeCopy i, IArray.IArray a e) => Contained (Get (a i e)) 113 | iarray_getCopy = contain $ do getIx <- getSafeGet 114 | liftM3 mkArray getIx getIx safeGet 115 | where 116 | mkArray l h xs = IArray.listArray (l, h) xs 117 | {-# INLINE iarray_getCopy #-} 118 | 119 | iarray_putCopy :: (Ix i, SafeCopy e, SafeCopy i, IArray.IArray a e) => a i e -> Contained Put 120 | iarray_putCopy arr = contain $ do putIx <- getSafePut 121 | let (l,h) = IArray.bounds arr 122 | putIx l >> putIx h 123 | safePut (IArray.elems arr) 124 | {-# INLINE iarray_putCopy #-} 125 | 126 | instance (Ix i, SafeCopy e, SafeCopy i) => SafeCopy (Array.Array i e) where 127 | getCopy = iarray_getCopy 128 | putCopy = iarray_putCopy 129 | errorTypeName = typeName2 130 | 131 | instance (IArray.IArray UArray.UArray e, Ix i, SafeCopy e, SafeCopy i) => SafeCopy (UArray.UArray i e) where 132 | getCopy = iarray_getCopy 133 | putCopy = iarray_putCopy 134 | errorTypeName = typeName2 135 | 136 | instance (SafeCopy a, SafeCopy b) => SafeCopy (a,b) where 137 | getCopy = contain $ liftM2 (,) safeGet safeGet 138 | putCopy (a,b) = contain $ safePut a >> safePut b 139 | errorTypeName = typeName2 140 | instance (SafeCopy a, SafeCopy b, SafeCopy c) => SafeCopy (a,b,c) where 141 | getCopy = contain $ liftM3 (,,) safeGet safeGet safeGet 142 | putCopy (a,b,c) = contain $ safePut a >> safePut b >> safePut c 143 | instance (SafeCopy a, SafeCopy b, SafeCopy c, SafeCopy d) => SafeCopy (a,b,c,d) where 144 | getCopy = contain $ liftM4 (,,,) safeGet safeGet safeGet safeGet 145 | putCopy (a,b,c,d) = contain $ safePut a >> safePut b >> safePut c >> safePut d 146 | instance (SafeCopy a, SafeCopy b, SafeCopy c, SafeCopy d, SafeCopy e) => 147 | SafeCopy (a,b,c,d,e) where 148 | getCopy = contain $ liftM5 (,,,,) safeGet safeGet safeGet safeGet safeGet 149 | putCopy (a,b,c,d,e) = contain $ safePut a >> safePut b >> safePut c >> safePut d >> safePut e 150 | instance (SafeCopy a, SafeCopy b, SafeCopy c, SafeCopy d, SafeCopy e, SafeCopy f) => 151 | SafeCopy (a,b,c,d,e,f) where 152 | getCopy = contain $ (,,,,,) <$> safeGet <*> safeGet <*> safeGet <*> safeGet <*> safeGet <*> safeGet 153 | putCopy (a,b,c,d,e,f) = contain $ safePut a >> safePut b >> safePut c >> safePut d >> 154 | safePut e >> safePut f 155 | instance (SafeCopy a, SafeCopy b, SafeCopy c, SafeCopy d, SafeCopy e, SafeCopy f, SafeCopy g) => 156 | SafeCopy (a,b,c,d,e,f,g) where 157 | getCopy = contain $ (,,,,,,) <$> safeGet <*> safeGet <*> safeGet <*> safeGet <*> 158 | safeGet <*> safeGet <*> safeGet 159 | putCopy (a,b,c,d,e,f,g) = contain $ safePut a >> safePut b >> safePut c >> safePut d >> 160 | safePut e >> safePut f >> safePut g 161 | 162 | 163 | instance SafeCopy Int where 164 | getCopy = contain get; putCopy = contain . put; errorTypeName = typeName 165 | instance SafeCopy Integer where 166 | getCopy = contain get; putCopy = contain . put; errorTypeName = typeName 167 | instance SafeCopy Natural where 168 | getCopy = contain get; putCopy = contain . put; errorTypeName = typeName 169 | 170 | -- | cereal changed the formats for Float/Double in 0.5.* 171 | -- 172 | -- https://github.com/GaloisInc/cereal/commit/47d839609413e3e9d1147b99c34ae421ae36bced 173 | -- https://github.com/GaloisInc/cereal/issues/35 174 | newtype CerealFloat040 = CerealFloat040 { unCerealFloat040 :: Float} deriving (Show, Typeable) 175 | instance SafeCopy CerealFloat040 where 176 | getCopy = contain (CerealFloat040 <$> liftM2 encodeFloat get get) 177 | putCopy (CerealFloat040 float) = contain (put (decodeFloat float)) 178 | errorTypeName = typeName 179 | 180 | instance Migrate Float where 181 | type MigrateFrom Float = CerealFloat040 182 | migrate (CerealFloat040 d) = d 183 | 184 | instance SafeCopy Float where 185 | version = Version 1 186 | kind = extension 187 | getCopy = contain get 188 | putCopy = contain . put 189 | errorTypeName = typeName 190 | 191 | -- | cereal changed the formats for Float/Double in 0.5.* 192 | -- 193 | -- https://github.com/GaloisInc/cereal/commit/47d839609413e3e9d1147b99c34ae421ae36bced 194 | -- https://github.com/GaloisInc/cereal/issues/35 195 | newtype CerealDouble040 = CerealDouble040 { unCerealDouble040 :: Double} deriving (Show, Typeable) 196 | instance SafeCopy CerealDouble040 where 197 | getCopy = contain (CerealDouble040 <$> liftM2 encodeFloat get get) 198 | putCopy (CerealDouble040 double) = contain (put (decodeFloat double)) 199 | errorTypeName = typeName 200 | 201 | instance Migrate Double where 202 | type MigrateFrom Double = CerealDouble040 203 | migrate (CerealDouble040 d) = d 204 | 205 | instance SafeCopy Double where 206 | version = Version 1 207 | kind = extension 208 | getCopy = contain get 209 | putCopy = contain . put 210 | errorTypeName = typeName 211 | 212 | 213 | instance SafeCopy L.ByteString where 214 | getCopy = contain get; putCopy = contain . put; errorTypeName = typeName 215 | instance SafeCopy B.ByteString where 216 | getCopy = contain get; putCopy = contain . put; errorTypeName = typeName 217 | instance SafeCopy Char where 218 | getCopy = contain get; putCopy = contain . put; errorTypeName = typeName 219 | instance SafeCopy Word where 220 | getCopy = contain get; putCopy = contain . put; errorTypeName = typeName 221 | instance SafeCopy Word8 where 222 | getCopy = contain get; putCopy = contain . put; errorTypeName = typeName 223 | instance SafeCopy Word16 where 224 | getCopy = contain get; putCopy = contain . put; errorTypeName = typeName 225 | instance SafeCopy Word32 where 226 | getCopy = contain get; putCopy = contain . put; errorTypeName = typeName 227 | instance SafeCopy Word64 where 228 | getCopy = contain get; putCopy = contain . put; errorTypeName = typeName 229 | instance SafeCopy Ordering where 230 | getCopy = contain get; putCopy = contain . put; errorTypeName = typeName 231 | instance SafeCopy Int8 where 232 | getCopy = contain get; putCopy = contain . put; errorTypeName = typeName 233 | instance SafeCopy Int16 where 234 | getCopy = contain get; putCopy = contain . put; errorTypeName = typeName 235 | instance SafeCopy Int32 where 236 | getCopy = contain get; putCopy = contain . put; errorTypeName = typeName 237 | instance SafeCopy Int64 where 238 | getCopy = contain get; putCopy = contain . put; errorTypeName = typeName 239 | instance (Integral a, SafeCopy a) => SafeCopy (Ratio a) where 240 | getCopy = contain $ do n <- safeGet 241 | d <- safeGet 242 | return (n % d) 243 | putCopy r = contain $ do safePut (numerator r) 244 | safePut (denominator r) 245 | errorTypeName = typeName1 246 | instance (HasResolution a, Fractional (Fixed a), Typeable a) => SafeCopy (Fixed a) where 247 | getCopy = contain $ fromRational <$> safeGet 248 | putCopy = contain . safePut . toRational 249 | errorTypeName = typeName1 250 | 251 | instance SafeCopy () where 252 | getCopy = contain get; putCopy = contain . put; errorTypeName = typeName 253 | instance SafeCopy Bool where 254 | getCopy = contain get; putCopy = contain . put; errorTypeName = typeName 255 | instance (SafeCopy a, SafeCopy b) => SafeCopy (Either a b) where 256 | getCopy = contain $ do n <- get 257 | if n then liftM Right safeGet 258 | else liftM Left safeGet 259 | putCopy (Right a) = contain $ put True >> safePut a 260 | putCopy (Left a) = contain $ put False >> safePut a 261 | 262 | errorTypeName = typeName2 263 | 264 | -- instances for 'text' library 265 | 266 | instance SafeCopy T.Text where 267 | kind = base 268 | getCopy = contain $ T.decodeUtf8 <$> safeGet 269 | putCopy = contain . safePut . T.encodeUtf8 270 | errorTypeName = typeName 271 | 272 | instance SafeCopy TL.Text where 273 | kind = base 274 | getCopy = contain $ TL.decodeUtf8 <$> safeGet 275 | putCopy = contain . safePut . TL.encodeUtf8 276 | errorTypeName = typeName 277 | 278 | -- instances for 'time' library 279 | 280 | instance SafeCopy Day where 281 | kind = base 282 | getCopy = contain $ ModifiedJulianDay <$> safeGet 283 | putCopy = contain . safePut . toModifiedJulianDay 284 | errorTypeName = typeName 285 | 286 | instance SafeCopy DiffTime where 287 | kind = base 288 | getCopy = contain $ fromRational <$> safeGet 289 | putCopy = contain . safePut . toRational 290 | errorTypeName = typeName 291 | 292 | instance SafeCopy UniversalTime where 293 | kind = base 294 | getCopy = contain $ ModJulianDate <$> safeGet 295 | putCopy = contain . safePut . getModJulianDate 296 | errorTypeName = typeName 297 | 298 | instance SafeCopy UTCTime where 299 | kind = base 300 | getCopy = contain $ do day <- safeGet 301 | diffTime <- safeGet 302 | return (UTCTime day diffTime) 303 | putCopy u = contain $ do safePut (utctDay u) 304 | safePut (utctDayTime u) 305 | errorTypeName = typeName 306 | 307 | instance SafeCopy NominalDiffTime where 308 | kind = base 309 | getCopy = contain $ fromRational <$> safeGet 310 | putCopy = contain . safePut . toRational 311 | errorTypeName = typeName 312 | 313 | instance SafeCopy TimeOfDay where 314 | kind = base 315 | getCopy = contain $ do hour <- safeGet 316 | mins <- safeGet 317 | sec <- safeGet 318 | return (TimeOfDay hour mins sec) 319 | putCopy t = contain $ do safePut (todHour t) 320 | safePut (todMin t) 321 | safePut (todSec t) 322 | errorTypeName = typeName 323 | 324 | instance SafeCopy TimeZone where 325 | kind = base 326 | getCopy = contain $ do mins <- safeGet 327 | summerOnly <- safeGet 328 | zoneName <- safeGet 329 | return (TimeZone mins summerOnly zoneName) 330 | putCopy t = contain $ do safePut (timeZoneMinutes t) 331 | safePut (timeZoneSummerOnly t) 332 | safePut (timeZoneName t) 333 | errorTypeName = typeName 334 | 335 | instance SafeCopy LocalTime where 336 | kind = base 337 | getCopy = contain $ do day <- safeGet 338 | tod <- safeGet 339 | return (LocalTime day tod) 340 | putCopy t = contain $ do safePut (localDay t) 341 | safePut (localTimeOfDay t) 342 | errorTypeName = typeName 343 | 344 | instance SafeCopy ZonedTime where 345 | kind = base 346 | getCopy = contain $ do localTime <- safeGet 347 | timeZone <- safeGet 348 | return (ZonedTime localTime timeZone) 349 | putCopy t = contain $ do safePut (zonedTimeToLocalTime t) 350 | safePut (zonedTimeZone t) 351 | errorTypeName = typeName 352 | 353 | instance SafeCopy AbsoluteTime where 354 | getCopy = contain $ liftM toAbsoluteTime safeGet 355 | where 356 | toAbsoluteTime :: DiffTime -> AbsoluteTime 357 | toAbsoluteTime dt = addAbsoluteTime dt taiEpoch 358 | putCopy = contain . safePut . fromAbsoluteTime 359 | where 360 | fromAbsoluteTime :: AbsoluteTime -> DiffTime 361 | fromAbsoluteTime at = diffAbsoluteTime at taiEpoch 362 | errorTypeName = typeName 363 | 364 | -- instances for old-time 365 | 366 | instance SafeCopy ClockTime where 367 | kind = base 368 | getCopy = contain $ do secs <- safeGet 369 | pico <- safeGet 370 | return (TOD secs pico) 371 | putCopy (TOD secs pico) = 372 | contain $ do safePut secs 373 | safePut pico 374 | 375 | instance SafeCopy TimeDiff where 376 | kind = base 377 | getCopy = contain $ do year <- get 378 | month <- get 379 | day <- get 380 | hour <- get 381 | mins <- get 382 | sec <- get 383 | pico <- get 384 | return (TimeDiff year month day hour mins sec pico) 385 | putCopy t = contain $ do put (tdYear t) 386 | put (tdMonth t) 387 | put (tdDay t) 388 | put (tdHour t) 389 | put (tdMin t) 390 | put (tdSec t) 391 | put (tdPicosec t) 392 | 393 | instance SafeCopy OT.Day where 394 | kind = base ; getCopy = contain $ toEnum <$> get ; putCopy = contain . put . fromEnum 395 | 396 | instance SafeCopy Month where 397 | kind = base ; getCopy = contain $ toEnum <$> get ; putCopy = contain . put . fromEnum 398 | 399 | 400 | instance SafeCopy CalendarTime where 401 | kind = base 402 | getCopy = contain $ do year <- get 403 | month <- safeGet 404 | day <- get 405 | hour <- get 406 | mins <- get 407 | sec <- get 408 | pico <- get 409 | wday <- safeGet 410 | yday <- get 411 | tzname <- safeGet 412 | tz <- get 413 | dst <- get 414 | return (CalendarTime year month day hour mins sec pico wday yday tzname tz dst) 415 | putCopy t = contain $ do put (ctYear t) 416 | safePut (ctMonth t) 417 | put (ctDay t) 418 | put (ctHour t) 419 | put (ctMin t) 420 | put (ctSec t) 421 | put (ctPicosec t) 422 | safePut (ctWDay t) 423 | put (ctYDay t) 424 | safePut (ctTZName t) 425 | put (ctTZ t) 426 | put (ctIsDST t) 427 | 428 | typeName :: Typeable a => Proxy a -> String 429 | typeName proxy = show (typeOf (undefined `asProxyType` proxy)) 430 | 431 | #if MIN_VERSION_base(4,10,0) 432 | typeName1 :: (Typeable c) => Proxy (c a) -> String 433 | typeName2 :: (Typeable c) => Proxy (c a b) -> String 434 | #else 435 | typeName1 :: (Typeable1 c) => Proxy (c a) -> String 436 | typeName2 :: (Typeable2 c) => Proxy (c a b) -> String 437 | #endif 438 | 439 | typeName1 proxy = show (typeOf1 (undefined `asProxyType` proxy)) 440 | typeName2 proxy = show (typeOf2 (undefined `asProxyType` proxy)) 441 | 442 | getGenericVector :: (SafeCopy a, VG.Vector v a) => Contained (Get (v a)) 443 | getGenericVector = contain $ do n <- get 444 | getSafeGet >>= VG.replicateM n 445 | 446 | putGenericVector :: (SafeCopy a, VG.Vector v a) => v a -> Contained Put 447 | putGenericVector v = contain $ do put (VG.length v) 448 | getSafePut >>= VG.forM_ v 449 | 450 | instance SafeCopy a => SafeCopy (V.Vector a) where 451 | getCopy = getGenericVector 452 | putCopy = putGenericVector 453 | 454 | instance (SafeCopy a, VP.Prim a) => SafeCopy (VP.Vector a) where 455 | getCopy = getGenericVector 456 | putCopy = putGenericVector 457 | 458 | instance (SafeCopy a, VS.Storable a) => SafeCopy (VS.Vector a) where 459 | getCopy = getGenericVector 460 | putCopy = putGenericVector 461 | 462 | instance (SafeCopy a, VU.Unbox a) => SafeCopy (VU.Vector a) where 463 | getCopy = getGenericVector 464 | putCopy = putGenericVector 465 | -------------------------------------------------------------------------------- /src/Data/SafeCopy/Internal.hs: -------------------------------------------------------------------------------- 1 | module Data.SafeCopy.Internal ( 2 | module Data.SafeCopy.SafeCopy 3 | , module Data.SafeCopy.Derive 4 | ) where 5 | 6 | import Data.SafeCopy.SafeCopy 7 | import Data.SafeCopy.Derive 8 | -------------------------------------------------------------------------------- /src/Data/SafeCopy/SafeCopy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE DefaultSignatures #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE TypeApplications #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | {-# LANGUAGE TypeOperators #-} 13 | 14 | ----------------------------------------------------------------------------- 15 | -- | 16 | -- Module : Data.SafeCopy.SafeCopy 17 | -- Copyright : PublicDomain 18 | -- 19 | -- Maintainer : lemmih@gmail.com 20 | -- Portability : non-portable (uses GHC extensions) 21 | -- 22 | -- SafeCopy extends the parsing and serialization capabilities of Data.Binary 23 | -- to include nested version control. Nested version control means that you 24 | -- can change the defintion and binary format of a type nested deep within 25 | -- other types without problems. 26 | -- 27 | module Data.SafeCopy.SafeCopy where 28 | 29 | import Control.Monad 30 | import Control.Monad.Trans.Class (lift) 31 | import qualified Control.Monad.Fail as Fail 32 | import Control.Monad.Trans.State as State (evalStateT, modify, StateT) 33 | import qualified Control.Monad.Trans.State as State (get) 34 | import Control.Monad.Trans.RWS as RWS (evalRWST, modify, RWST, tell) 35 | import qualified Control.Monad.Trans.RWS as RWS (get) 36 | import Data.Bits (shiftR) 37 | import Data.Int (Int32) 38 | import Data.List 39 | import Data.Map as Map (Map, lookup, insert) 40 | import Data.Serialize 41 | import Data.Set as Set (insert, member, Set) 42 | import Data.Typeable (Typeable, TypeRep, typeOf, typeRep) 43 | import Data.Word (Word8) 44 | import GHC.Generics 45 | import Generic.Data as G (Constructors, gconIndex, gconNum) 46 | import Unsafe.Coerce (unsafeCoerce) 47 | 48 | -- | The central mechanism for dealing with version control. 49 | -- 50 | -- This type class specifies what data migrations can happen 51 | -- and how they happen. 52 | class SafeCopy (MigrateFrom a) => Migrate a where 53 | -- | This is the type we're extending. Each type capable of migration can 54 | -- only extend one other type. 55 | type MigrateFrom a 56 | 57 | -- | This method specifies how to migrate from the older type to the newer 58 | -- one. It will never be necessary to use this function manually as it 59 | -- all taken care of internally in the library. 60 | migrate :: MigrateFrom a -> a 61 | 62 | -- | This is a wrapper type used migrating backwards in the chain of compatible types. 63 | newtype Reverse a = Reverse { unReverse :: a } 64 | 65 | -- | The kind of a data type determines how it is tagged (if at all). 66 | -- 67 | -- Primitives kinds (see 'primitive') are not tagged with a version 68 | -- id and hence cannot be extended later. 69 | -- 70 | -- Extensions (see 'extension') tell the system that there exists 71 | -- a previous version of the data type which should be migrated if 72 | -- needed. 73 | -- 74 | -- There is also a default kind which is neither primitive nor 75 | -- an extension of a previous type. 76 | data Kind a where 77 | Primitive :: Kind a 78 | Base :: Kind a 79 | Extends :: (Migrate a) => Proxy (MigrateFrom a) -> Kind a 80 | Extended :: (Migrate (Reverse a)) => Kind a -> Kind a 81 | 82 | isPrimitive :: Kind a -> Bool 83 | isPrimitive Primitive = True 84 | isPrimitive _ = False 85 | 86 | -- | Wrapper for data that was saved without a version tag. 87 | newtype Prim a = Prim { getPrimitive :: a } 88 | 89 | -- | The centerpiece of this library. Defines a version for a data type 90 | -- together with how it should be serialized/parsed. 91 | -- 92 | -- Users should define instances of 'SafeCopy' for their types 93 | -- even though 'getCopy' and 'putCopy' can't be used directly. 94 | -- To serialize/parse a data type using 'SafeCopy', see 'safeGet' 95 | -- and 'safePut'. 96 | class Typeable a => SafeCopy a where 97 | -- | The version of the type. 98 | -- 99 | -- Only used as a key so it must be unique (this is checked at run-time) 100 | -- but doesn't have to be sequential or continuous. 101 | -- 102 | -- The default version is '0'. 103 | version :: Version a 104 | version = Version 0 105 | 106 | -- | The kind specifies how versions are dealt with. By default, 107 | -- values are tagged with their version id and don't have any 108 | -- previous versions. See 'extension' and the much less used 109 | -- 'primitive'. 110 | kind :: Kind a 111 | kind = Base 112 | 113 | -- | This method defines how a value should be parsed without also worrying 114 | -- about writing out the version tag. This function cannot be used directly. 115 | -- One should use 'safeGet', instead. 116 | getCopy :: Contained (Get a) 117 | 118 | -- | This method defines how a value should be parsed without worrying about 119 | -- previous versions or migrations. This function cannot be used directly. 120 | -- One should use 'safePut, instead. 121 | putCopy :: a -> Contained Put 122 | 123 | -- | Internal function that should not be overrided. 124 | -- @Consistent@ iff the version history is consistent 125 | -- (i.e. there are no duplicate version numbers) and 126 | -- the chain of migrations is valid. 127 | -- 128 | -- This function is in the typeclass so that this 129 | -- information is calculated only once during the program 130 | -- lifetime, instead of everytime 'safeGet' or 'safePut' is 131 | -- used. 132 | internalConsistency :: Consistency a 133 | internalConsistency = computeConsistency Proxy 134 | 135 | -- | Version profile. 136 | objectProfile :: Profile a 137 | objectProfile = mkProfile Proxy 138 | 139 | -- | The name of the type. This is only used in error message 140 | -- strings. 141 | errorTypeName :: Proxy a -> String 142 | 143 | default errorTypeName :: Typeable a => Proxy a -> String 144 | errorTypeName _ = show (typeRep (Proxy @a)) 145 | 146 | default putCopy :: (GPutCopy (Rep a) DatatypeInfo, Constructors a) => a -> Contained Put 147 | putCopy a = (contain . gputCopy (ConstructorInfo (fromIntegral (gconNum @a)) (fromIntegral (gconIndex a))) . from) a 148 | 149 | default getCopy :: (GGetCopy (Rep a) DatatypeInfo, Constructors a) => Contained (Get a) 150 | getCopy = contain (to <$> ggetCopy (ConstructorCount (fromIntegral (gconNum @a)))) 151 | 152 | class GPutCopy f p where 153 | gputCopy :: p -> f p -> Put 154 | 155 | instance GPutCopy a p => GPutCopy (M1 D c a) p where 156 | gputCopy p (M1 a) = gputCopy p a 157 | {-# INLINE gputCopy #-} 158 | 159 | instance (GPutCopy f p, GPutCopy g p) => GPutCopy (f :+: g) p where 160 | gputCopy p (L1 x) = gputCopy @f p x 161 | gputCopy p (R1 x) = gputCopy @g p x 162 | {-# INLINE gputCopy #-} 163 | 164 | -- | A constraint that combines 'SafeCopy' and 'Typeable'. 165 | type SafeCopy' a = SafeCopy a 166 | {-# DEPRECATED SafeCopy' "SafeCopy' is now equivalent to SafeCopy " #-} 167 | 168 | -- To get the current safecopy behavior we need to emulate the 169 | -- template haskell code here - collect the (a -> Put) values for all 170 | -- the fields and then run them in order.o 171 | instance (GPutFields a p, p ~ DatatypeInfo) => GPutCopy (M1 C c a) p where 172 | gputCopy p (M1 x) = 173 | (when (_size p >= 2) (putWord8 (fromIntegral (_code p)))) *> 174 | -- This is how I tried it first, and it works well but the 175 | -- result is not the same as deriveSafeCopy. 176 | -- mconcat (fmap join (gputFields p x)) 177 | -- join (mconcat <$> sequence (fmap snd (gputFields p x))) 178 | (do putter <- (mconcat . snd) <$> (evalRWST (gputFields p x) () mempty) 179 | putter) 180 | {-# INLINE gputCopy #-} 181 | 182 | -- | gputFields traverses the fields of a constructor and returns a put 183 | -- for the safecopy versions and a put for the field values. 184 | class GPutFields f p where 185 | gputFields :: p -> f p -> RWST () [Put] (Set TypeRep) PutM () 186 | 187 | instance (GPutFields f p, GPutFields g p) => GPutFields (f :*: g) p where 188 | gputFields p (a :*: b) = gputFields p a >> gputFields p b 189 | {-# INLINE gputFields #-} 190 | 191 | instance GPutFields f p => GPutFields (M1 S c f) p where 192 | gputFields p (M1 a) = gputFields p a 193 | {-# INLINE gputFields #-} 194 | 195 | instance SafeCopy a => GPutFields (K1 R a) p where 196 | gputFields _ (K1 a) = do 197 | getSafePutGeneric putCopy a 198 | {-# INLINE gputFields #-} 199 | 200 | -- This corresponds to ggetFields, but does it match deriveSafeCopy? 201 | instance GPutFields U1 p where 202 | gputFields _ _ = 203 | return () 204 | {- 205 | -- This outputs the version tag for (), which is 1. 206 | instance (GPutFields (K1 R ()) p) => GPutFields U1 p where 207 | gputFields p _ = 208 | gputFields p (K1 () :: K1 R () p) 209 | -} 210 | {-# INLINE gputFields #-} 211 | 212 | instance GPutFields V1 p where 213 | gputFields _ _ = undefined 214 | {-# INLINE gputFields #-} 215 | 216 | ------------------------------------------------------------------------ 217 | 218 | class GGetCopy f p where 219 | ggetCopy :: p -> Get (f a) 220 | 221 | -- | The M1 type has a fourth type parameter p: 222 | -- 223 | -- newtype M1 i (c :: Meta) (f :: k -> *) (p :: k) = M1 {unM1 :: f p} 224 | -- 225 | -- Note that the type of the M1 field is @f p@, so in order to express this 226 | -- type we add a parameter of type p that we can apply to values of type f. 227 | instance (GGetCopy f p, p ~ DatatypeInfo) => GGetCopy (M1 D d f) p where 228 | ggetCopy p 229 | | _size p >= 2 = do 230 | !code <- getWord8 231 | M1 <$> ggetCopy (ConstructorInfo (_size p) code) 232 | | otherwise = M1 <$> ggetCopy (ConstructorInfo (_size p) 0) 233 | {-# INLINE ggetCopy #-} 234 | 235 | instance (GGetCopy f p, GGetCopy g p, p ~ DatatypeInfo) => GGetCopy (f :+: g) p where 236 | ggetCopy p = do 237 | -- choose the left or right branch of the constructor types 238 | -- based on whether the code is in the left or right half of the 239 | -- remaining constructor count. 240 | let sizeL = _size p `shiftR` 1 241 | sizeR = _size p - sizeL 242 | case _code p < sizeL of 243 | True -> L1 <$> ggetCopy @f (ConstructorInfo sizeL (_code p)) 244 | False -> R1 <$> ggetCopy @g (ConstructorInfo sizeR (_code p - sizeL)) 245 | {-# INLINE ggetCopy #-} 246 | 247 | instance GGetFields f p => GGetCopy (M1 C c f) p where 248 | ggetCopy p = do 249 | M1 <$> join (evalStateT (ggetFields p) mempty) 250 | {-# INLINE ggetCopy #-} 251 | 252 | -- append constructor fields 253 | class GGetFields f p where 254 | ggetFields :: p -> StateT (Map TypeRep Int32) Get (Get (f a)) 255 | 256 | instance (GGetFields f p, GGetFields g p) => GGetFields (f :*: g) p where 257 | ggetFields p = do 258 | fgetter <- ggetFields @f p 259 | ggetter <- ggetFields @g p 260 | return ((:*:) <$> fgetter <*> ggetter) 261 | {-# INLINE ggetFields #-} 262 | 263 | instance GGetFields f p => GGetFields (M1 S c f) p where 264 | ggetFields p = do 265 | getter <- ggetFields p 266 | return (M1 <$> getter) 267 | {-# INLINE ggetFields #-} 268 | 269 | instance SafeCopy a => GGetFields (K1 R a) p where 270 | ggetFields _ = do 271 | getter <- getSafeGetGeneric 272 | return (K1 <$> getter) 273 | {-# INLINE ggetFields #-} 274 | 275 | instance GGetFields U1 p where 276 | ggetFields _p = pure (pure U1) 277 | {-# INLINE ggetFields #-} 278 | 279 | instance GGetFields V1 p where 280 | ggetFields _p = undefined 281 | {-# INLINE ggetFields #-} 282 | 283 | data DatatypeInfo = 284 | ConstructorCount {_size :: Word8} 285 | | ConstructorInfo {_size :: Word8, _code :: Word8} 286 | deriving Show 287 | 288 | -- | Whereas the other 'getSafeGet' is only run when we know we need a 289 | -- version, this one is run for every field and must decide whether to 290 | -- read a version or not. It constructs a Map TypeRep Int32 and reads 291 | -- when the new TypeRep is not in the map. 292 | getSafeGetGeneric :: 293 | forall a. SafeCopy a 294 | => StateT (Map TypeRep Int32) Get (Get a) 295 | getSafeGetGeneric 296 | = checkConsistency proxy $ 297 | case kindFromProxy proxy of 298 | Primitive -> return $ unsafeUnPack getCopy 299 | a_kind -> do let rep = typeRep (Proxy :: Proxy a) 300 | reps <- State.get 301 | v <- maybe (lift get) pure (Map.lookup rep reps) 302 | case constructGetterFromVersion (unsafeCoerce v) a_kind of 303 | Right getter -> State.modify (Map.insert rep v) >> return getter 304 | Left msg -> fail msg 305 | where proxy = Proxy :: Proxy a 306 | 307 | -- | This version returns (Put, Put), the collected version tags and 308 | -- the collected serialized fields. The original 'getSafePut' result 309 | -- type prevents doing this because each fields may have a different 310 | -- type. Maybe you can show me a better way 311 | getSafePutGeneric :: 312 | forall a. SafeCopy a 313 | => (a -> Contained Put) 314 | -> a 315 | -> RWST () [Put] (Set TypeRep) PutM () 316 | getSafePutGeneric cput a 317 | = unpureCheckConsistency proxy $ 318 | case kindFromProxy proxy of 319 | Primitive -> tell [unsafeUnPack (cput $ asProxyType a proxy)] 320 | _ -> do reps <- RWS.get 321 | let typ = typeOf a 322 | when (not (member typ reps)) $ do 323 | lift (put (versionFromProxy proxy)) 324 | RWS.modify (Set.insert typ) 325 | tell [unsafeUnPack (cput $ asProxyType a proxy)] 326 | where proxy = Proxy :: Proxy a 327 | 328 | type GSafeCopy a = (SafeCopy a, Generic a, GPutCopy (Rep a) DatatypeInfo, Constructors a) 329 | 330 | -- | Generic only version of safePut. Instead of calling 'putCopy' it 331 | -- calls 'putCopyDefault', a copy of the implementation of the 332 | -- 'SafeCopy' default method for 'putCopy'. 333 | safePutGeneric :: forall a. GSafeCopy a => a -> Put 334 | safePutGeneric a = do 335 | putter <- (mconcat . snd) <$> evalRWST (getSafePutGeneric putCopyDefault a) () mempty 336 | putter 337 | 338 | -- | See 'safePutGeneric'. A copy of the code in the default 339 | -- implementation of the putCopy method. 340 | putCopyDefault :: forall a. GSafeCopy a => a -> Contained Put 341 | putCopyDefault a = (contain . gputCopy (ConstructorInfo (fromIntegral (gconNum @a)) (fromIntegral (gconIndex a))) . from) a 342 | 343 | -- constructGetterFromVersion :: SafeCopy a => Version a -> Kind (MigrateFrom (Reverse a)) -> Get (Get a) 344 | constructGetterFromVersion :: SafeCopy a => Version a -> Kind a -> Either String (Get a) 345 | constructGetterFromVersion diskVersion orig_kind = 346 | worker False diskVersion orig_kind 347 | where 348 | worker :: forall a. SafeCopy a => Bool -> Version a -> Kind a -> Either String (Get a) 349 | worker fwd thisVersion thisKind 350 | | version == thisVersion = return $ unsafeUnPack getCopy 351 | | otherwise = 352 | case thisKind of 353 | Primitive -> Left $ errorMsg thisKind "Cannot migrate from primitive types." 354 | Base -> Left $ errorMsg thisKind versionNotFound 355 | Extends b_proxy -> do 356 | previousGetter <- worker fwd (castVersion diskVersion) (kindFromProxy b_proxy) 357 | return $ fmap migrate previousGetter 358 | Extended{} | fwd -> Left $ errorMsg thisKind versionNotFound 359 | Extended a_kind -> do 360 | let rev_proxy :: Proxy (MigrateFrom (Reverse a)) 361 | rev_proxy = Proxy 362 | forwardGetter :: Either String (Get a) 363 | forwardGetter = fmap (fmap (unReverse . migrate)) $ worker True (castVersion thisVersion) (kindFromProxy rev_proxy) 364 | previousGetter :: Either String (Get a) 365 | previousGetter = worker fwd (castVersion thisVersion) a_kind 366 | case forwardGetter of 367 | Left{} -> previousGetter 368 | Right val -> Right val 369 | versionNotFound = "Cannot find getter associated with this version number: " ++ show diskVersion 370 | errorMsg fail_kind msg = 371 | concat 372 | [ "safecopy: " 373 | , errorTypeName (proxyFromKind fail_kind) 374 | , ": " 375 | , msg 376 | ] 377 | 378 | ------------------------------------------------- 379 | -- The public interface. These functions are used 380 | -- to parse/serialize and to create new parsers & 381 | -- serialisers. 382 | 383 | -- | Parse a version tagged data type and then migrate it to the desired type. 384 | -- Any serialized value has been extended by the return type can be parsed. 385 | safeGet :: SafeCopy a => Get a 386 | safeGet 387 | = join getSafeGet 388 | 389 | -- | Parse a version tag and return the corresponding migrated parser. This is 390 | -- useful when you can prove that multiple values have the same version. 391 | -- See 'getSafePut'. 392 | getSafeGet :: forall a. SafeCopy a => Get (Get a) 393 | getSafeGet 394 | = checkConsistency proxy $ 395 | case kindFromProxy proxy of 396 | Primitive -> return $ unsafeUnPack getCopy 397 | a_kind -> do v <- get 398 | case constructGetterFromVersion v a_kind of 399 | Right getter -> return getter 400 | Left msg -> fail msg 401 | where proxy = Proxy :: Proxy a 402 | 403 | -- | Serialize a data type by first writing out its version tag. This is much 404 | -- simpler than the corresponding 'safeGet' since previous versions don't 405 | -- come into play. 406 | safePut :: SafeCopy a => a -> Put 407 | safePut a 408 | = do putter <- getSafePut 409 | putter a 410 | 411 | -- | Serialize the version tag and return the associated putter. This is useful 412 | -- when serializing multiple values with the same version. See 'getSafeGet'. 413 | getSafePut :: forall a. SafeCopy a => PutM (a -> Put) 414 | getSafePut 415 | = unpureCheckConsistency proxy $ 416 | case kindFromProxy proxy of 417 | Primitive -> return $ \a -> unsafeUnPack (putCopy $ asProxyType a proxy) 418 | _ -> do put (versionFromProxy proxy) 419 | return $ \a -> unsafeUnPack (putCopy $ asProxyType a proxy) 420 | where proxy = Proxy :: Proxy a 421 | 422 | -- | The extended_extension kind lets the system know that there is 423 | -- at least one previous and one future version of this type. 424 | extended_extension :: (Migrate a, Migrate (Reverse a)) => Kind a 425 | extended_extension = Extended extension 426 | 427 | -- | The extended_base kind lets the system know that there is 428 | -- at least one future version of this type. 429 | extended_base :: (Migrate (Reverse a)) => Kind a 430 | extended_base = Extended base 431 | 432 | -- | The extension kind lets the system know that there is 433 | -- at least one previous version of this type. A given data type 434 | -- can only extend a single other data type. However, it is 435 | -- perfectly fine to build chains of extensions. The migrations 436 | -- between each step is handled automatically. 437 | extension :: Migrate a => Kind a 438 | extension = Extends Proxy 439 | 440 | -- | The default kind. Does not extend any type. 441 | base :: Kind a 442 | base = Base 443 | 444 | -- | Primitive kinds aren't version tagged. This kind is used for small or built-in 445 | -- types that won't change such as 'Int' or 'Bool'. 446 | primitive :: Kind a 447 | primitive = Primitive 448 | 449 | ------------------------------------------------- 450 | -- Data type versions. Essentially just a unique 451 | -- identifier used to lookup the corresponding 452 | -- parser function. 453 | 454 | -- | A simple numeric version id. 455 | newtype Version a = Version {unVersion :: Int32} deriving (Read,Show,Eq) 456 | 457 | castVersion :: Version a -> Version b 458 | castVersion (Version a) = Version a 459 | 460 | instance Num (Version a) where 461 | Version a + Version b = Version (a+b) 462 | Version a - Version b = Version (a-b) 463 | Version a * Version b = Version (a*b) 464 | negate (Version a) = Version (negate a) 465 | abs (Version a) = Version (abs a) 466 | signum (Version a) = Version (signum a) 467 | fromInteger i = Version (fromInteger i) 468 | 469 | instance Serialize (Version a) where 470 | get = liftM Version get 471 | put = put . unVersion 472 | 473 | ------------------------------------------------- 474 | -- Container type to control the access to the 475 | -- parsers/putters. 476 | 477 | -- | To ensure that no-one reads or writes values without handling versions 478 | -- correctly, it is necessary to restrict access to 'getCopy' and 'putCopy'. 479 | -- This is where 'Contained' enters the picture. It allows you to put 480 | -- values in to a container but not to take them out again. 481 | newtype Contained a = Contained {unsafeUnPack :: a} 482 | 483 | -- | Place a value in an unbreakable container. 484 | contain :: a -> Contained a 485 | contain = Contained 486 | 487 | ------------------------------------------------- 488 | -- Consistency checking 489 | 490 | data Profile a = 491 | PrimitiveProfile | 492 | InvalidProfile String | 493 | Profile 494 | { profileCurrentVersion :: Int32 495 | , profileSupportedVersions :: [Int32] 496 | } deriving (Show) 497 | 498 | mkProfile :: SafeCopy a => Proxy a -> Profile a 499 | mkProfile a_proxy = 500 | case computeConsistency a_proxy of 501 | NotConsistent msg -> InvalidProfile msg 502 | Consistent | isPrimitive (kindFromProxy a_proxy) -> PrimitiveProfile 503 | Consistent -> 504 | Profile{ profileCurrentVersion = unVersion (versionFromProxy a_proxy) 505 | , profileSupportedVersions = availableVersions a_proxy 506 | } 507 | 508 | data Consistency a = Consistent | NotConsistent String 509 | 510 | availableVersions :: SafeCopy a => Proxy a -> [Int32] 511 | availableVersions a_proxy = 512 | worker True (kindFromProxy a_proxy) 513 | where 514 | worker :: SafeCopy b => Bool -> Kind b -> [Int32] 515 | worker fwd b_kind = 516 | case b_kind of 517 | Primitive -> [] 518 | Base -> [unVersion (versionFromKind b_kind)] 519 | Extends b_proxy -> unVersion (versionFromKind b_kind) : worker False (kindFromProxy b_proxy) 520 | Extended sub_kind | fwd -> worker False (getForwardKind sub_kind) 521 | Extended sub_kind -> worker False sub_kind 522 | 523 | getForwardKind :: (Migrate (Reverse a)) => Kind a -> Kind (MigrateFrom (Reverse a)) 524 | getForwardKind _ = kind 525 | 526 | -- Extend chains must end in a Base kind. Ending in a Primitive is an error. 527 | validChain :: SafeCopy a => Proxy a -> Bool 528 | validChain a_proxy = 529 | worker (kindFromProxy a_proxy) 530 | where 531 | worker Primitive = True 532 | worker Base = True 533 | worker (Extends b_proxy) = check (kindFromProxy b_proxy) 534 | worker (Extended a_kind) = worker a_kind 535 | check :: SafeCopy b => Kind b -> Bool 536 | check b_kind 537 | = case b_kind of 538 | Primitive -> False 539 | Base -> True 540 | Extends c_proxy -> check (kindFromProxy c_proxy) 541 | Extended sub_kind -> check sub_kind 542 | 543 | -- Verify that the SafeCopy instance is consistent. 544 | checkConsistency :: (SafeCopy a, Fail.MonadFail m) => Proxy a -> m b -> m b 545 | checkConsistency proxy ks 546 | = case consistentFromProxy proxy of 547 | NotConsistent msg -> Fail.fail msg 548 | Consistent -> ks 549 | 550 | -- | PutM doesn't have reasonable 'fail' implementation. 551 | -- It just throws an unpure exception anyway. 552 | unpureCheckConsistency :: SafeCopy a => Proxy a -> b -> b 553 | unpureCheckConsistency proxy ks 554 | = case consistentFromProxy proxy of 555 | NotConsistent msg -> error $ "unpureCheckConsistency: " ++ msg 556 | Consistent -> ks 557 | 558 | {-# INLINE computeConsistency #-} 559 | computeConsistency :: forall a. SafeCopy a => Proxy a -> Consistency a 560 | computeConsistency proxy 561 | -- Match a few common cases before falling through to the general case. 562 | -- This allows use to generate nearly all consistencies at compile-time. 563 | | isObviouslyConsistent (kindFromProxy proxy) 564 | = Consistent 565 | | versions /= nub versions 566 | = NotConsistent $ "Duplicate version tags for " ++ show (typeRep (Proxy @a)) ++ ": " ++ show versions 567 | | not (validChain proxy) 568 | = NotConsistent "Primitive types cannot be extended as they have no version tag." 569 | | otherwise 570 | = Consistent 571 | where versions = availableVersions proxy 572 | 573 | isObviouslyConsistent :: Kind a -> Bool 574 | isObviouslyConsistent Primitive = True 575 | isObviouslyConsistent Base = True 576 | isObviouslyConsistent _ = False 577 | 578 | ------------------------------------------------- 579 | -- Small utility functions that mean we don't 580 | -- have to depend on ScopedTypeVariables. 581 | 582 | proxyFromConsistency :: Consistency a -> Proxy a 583 | proxyFromConsistency _ = Proxy 584 | 585 | proxyFromKind :: Kind a -> Proxy a 586 | proxyFromKind _ = Proxy 587 | 588 | consistentFromProxy :: SafeCopy a => Proxy a -> Consistency a 589 | consistentFromProxy _ = internalConsistency 590 | 591 | versionFromProxy :: SafeCopy a => Proxy a -> Version a 592 | versionFromProxy _ = version 593 | 594 | versionFromKind :: (SafeCopy a) => Kind a -> Version a 595 | versionFromKind _ = version 596 | 597 | versionFromReverseKind :: (SafeCopy (MigrateFrom (Reverse a))) => Kind a -> Version (MigrateFrom (Reverse a)) 598 | versionFromReverseKind _ = version 599 | 600 | kindFromProxy :: SafeCopy a => Proxy a -> Kind a 601 | kindFromProxy _ = kind 602 | 603 | ------------------------------------------------- 604 | -- Type proxies 605 | 606 | data Proxy a = Proxy 607 | 608 | mkProxy :: a -> Proxy a 609 | mkProxy _ = Proxy 610 | 611 | asProxyType :: a -> Proxy a -> a 612 | asProxyType a _ = a 613 | -------------------------------------------------------------------------------- /stack-8.0.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-9.21 2 | 3 | extra-deps: 4 | - generic-data-0.3.0.0 5 | - base-orphans-0.8 6 | - show-combinators-0.1.0.0 7 | 8 | allow-newer: true 9 | allow-newer-deps: 10 | - profunctors 11 | -------------------------------------------------------------------------------- /stack-8.10.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-18.28 2 | -------------------------------------------------------------------------------- /stack-8.2.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-11.22 2 | 3 | extra-deps: 4 | - generic-data-0.3.0.0 5 | - base-orphans-0.8 6 | -------------------------------------------------------------------------------- /stack-8.4.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-12.26 2 | 3 | extra-deps: 4 | - generic-data-0.3.0.0 5 | - base-orphans-0.8 6 | -------------------------------------------------------------------------------- /stack-8.6.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.27 2 | -------------------------------------------------------------------------------- /stack-8.8.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-16.31 2 | -------------------------------------------------------------------------------- /stack-9.0.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-19.33 2 | -------------------------------------------------------------------------------- /stack-9.10.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2025-03-11 2 | -------------------------------------------------------------------------------- /stack-9.2.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-20.26 2 | -------------------------------------------------------------------------------- /stack-9.4.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-21.25 2 | -------------------------------------------------------------------------------- /stack-9.6.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-22.43 2 | -------------------------------------------------------------------------------- /stack-9.8.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-23.14 2 | -------------------------------------------------------------------------------- /test/generic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE StandaloneDeriving #-} 9 | {-# LANGUAGE TemplateHaskell #-} 10 | {-# LANGUAGE TypeApplications #-} 11 | {-# LANGUAGE UndecidableInstances #-} 12 | {-# OPTIONS -Wno-missing-signatures #-} 13 | 14 | import GHC.Generics 15 | #if !MIN_VERSION_base(4,11,0) 16 | import Data.Monoid ((<>)) 17 | #endif 18 | import Data.SafeCopy 19 | import Data.SafeCopy.Internal 20 | import Data.Serialize (runGet, runPut, Serialize) 21 | import Text.Printf 22 | import Test.HUnit (Test(..), assertEqual, runTestTT) 23 | --import Generic.Data as G hiding (unpack) 24 | 25 | -- Debugging 26 | import Data.Typeable hiding (Proxy) 27 | --import Debug.Trace 28 | import Data.ByteString (ByteString, unpack) 29 | import Data.Char (chr) 30 | import Data.Word (Word8, Word32) 31 | 32 | -- Test types 33 | data Foo = Foo Int Char deriving (Generic, Show, Eq) 34 | data Bar = Bar Float Foo deriving (Generic, Show, Eq) 35 | data Baz = Baz1 Int | Baz2 Bool deriving (Generic, Show, Eq) 36 | 37 | #if 0 38 | safePutTest :: forall a. (SafeCopy' a, Generic a, GPutCopy (Rep a) DatatypeInfo, GConstructors (Rep a)) => a -> Put 39 | safePutTest a = 40 | case runPut p1 == runPut p2 of 41 | True -> p1 42 | False -> trace ("safePutTest failed for " ++ show (typeRep (Proxy :: Proxy a)) ++ "\n custom: " ++ showBytes (runPut p1) ++ "\n generic: " ++ showBytes (runPut p2)) p1 43 | where 44 | p1 = safePut a 45 | p2 = safePutGeneric a 46 | #endif 47 | 48 | ---------------------------------------------- 49 | 50 | -- Compare a value to the result of encoding and then decoding it. 51 | roundTrip :: forall a. (SafeCopy a, Typeable a, Eq a, Show a) => a -> Test 52 | roundTrip x = do 53 | -- putStrLn ("\n========== " ++ show x ++ " :: " ++ show (typeRep (Proxy :: Proxy a)) ++ " ==========") 54 | let d = runPut (safePut x) -- Use custom putCopy/getCopy implementation if present 55 | a :: Either String a 56 | a = runGet safeGet d 57 | TestCase (assertEqual ("roundTrip " ++ show x ++ " :: " ++ show (typeRep (Proxy :: Proxy a))) (Right x) a) 58 | 59 | -- Test whether two values of different types have the same encoded 60 | -- representation. This is used here on types of similar shape to 61 | -- test whether the generic SafeCopy instance matches the template 62 | -- haskell instance. 63 | compareBytes :: 64 | forall expected actual. (SafeCopy expected, Typeable expected, 65 | SafeCopy actual, Typeable actual) 66 | => expected -> actual -> Test 67 | compareBytes e a = 68 | TestCase (assertEqual ("compareBytes " ++ show (typeRep (Proxy :: Proxy expected)) ++ " " ++ 69 | show (typeRep (Proxy :: Proxy actual))) 70 | (showBytes (runPut $ safePut e)) 71 | (showBytes (runPut $ safePut a))) 72 | 73 | showBytes :: ByteString -> String 74 | showBytes b = mconcat (fmap f (unpack b)) 75 | where f :: Word8 -> String 76 | f 192 = "[G|" 77 | f 193 = "[C|" 78 | f 194 = "[T|" 79 | f 195 = "]_ " 80 | f 196 = " _<" 81 | f 197 = ">_ " 82 | f c | c >= 32 && c < 127 = [' ', chr (fromIntegral c), ' '] 83 | f c | c == 0 = " __" 84 | f c = printf " %02x" c 85 | 86 | ----------------------------- 87 | -- Test Types and Values 88 | ----------------------------- 89 | 90 | foo = Foo maxBound 'x' 91 | bar = Bar 1.5 foo 92 | baz1 = Baz1 3 93 | baz2 = Baz2 True 94 | 95 | -- These instances will use the generic putCopy and getCopy 96 | instance SafeCopy Foo where version = 3; kind = base 97 | instance SafeCopy Bar where version = 4; kind = base 98 | instance SafeCopy Baz where version = 5; kind = base 99 | 100 | -- Copies of the types above with generated SafeCopy instances 101 | data FooTH = FooTH Int Char deriving (Generic, Serialize, Show, Eq) 102 | data BarTH = BarTH Float FooTH deriving (Generic, Serialize, Show, Eq) 103 | data BazTH = Baz1TH Int | Baz2TH Bool deriving (Generic, Serialize, Show, Eq) 104 | 105 | fooTH = FooTH maxBound 'x' 106 | barTH = BarTH 1.5 fooTH 107 | baz1TH = Baz1TH 3 108 | baz2TH = Baz2TH True 109 | 110 | -- For comparison, these instances have the generated implementations 111 | -- of putCopy and getCopy 112 | #if 1 113 | $(deriveSafeCopy 3 'base ''FooTH) 114 | $(deriveSafeCopy 4 'base ''BarTH) 115 | $(deriveSafeCopy 5 'base ''BazTH) 116 | #else 117 | instance SafeCopy FooTH where 118 | putCopy (FooTH a1_aeVVN a2_aeVVO) 119 | = contain 120 | (do safePut_Int_aeVVP <- getSafePut 121 | safePut_Char_aeVVQ <- getSafePut 122 | safePut_Int_aeVVP a1_aeVVN 123 | safePut_Char_aeVVQ a2_aeVVO 124 | return ()) 125 | getCopy 126 | = contain 127 | ((Data.Serialize.Get.label "Main.FooTH:") 128 | (do safeGet_Int_aeVVR <- getSafeGet 129 | safeGet_Char_aeVVS <- getSafeGet 130 | ((return FooTH <*> safeGet_Int_aeVVR) <*> safeGet_Char_aeVVS))) 131 | version = 3 132 | kind = base 133 | errorTypeName _ = "Main.FooTH" 134 | 135 | instance SafeCopy BarTH where 136 | putCopy (BarTH a1_aeVXE a2_aeVXF) 137 | = contain 138 | (do safePut_Float_aeVXG <- getSafePut 139 | safePut_FooTH_aeVXH <- getSafePut 140 | safePut_Float_aeVXG a1_aeVXE 141 | safePut_FooTH_aeVXH a2_aeVXF 142 | return ()) 143 | getCopy 144 | = contain 145 | ((Data.Serialize.Get.label "Main.BarTH:") 146 | (do safeGet_Float_aeVXI <- getSafeGet 147 | safeGet_FooTH_aeVXJ <- getSafeGet 148 | ((return BarTH <*> safeGet_Float_aeVXI) <*> safeGet_FooTH_aeVXJ))) 149 | version = 4 150 | kind = base 151 | errorTypeName _ = "Main.BarTH" 152 | 153 | instance SafeCopy BazTH where 154 | putCopy (Baz1TH a1_aeVZv) 155 | = contain 156 | (do Data.Serialize.Put.putWord8 0 157 | safePut_Int_aeVZw <- getSafePut 158 | safePut_Int_aeVZw a1_aeVZv 159 | return ()) 160 | putCopy (Baz2TH a1_aeVZx) 161 | = contain 162 | (do Data.Serialize.Put.putWord8 1 163 | safePut_Bool_aeVZy <- getSafePut 164 | safePut_Bool_aeVZy a1_aeVZx 165 | return ()) 166 | getCopy 167 | = contain 168 | ((Data.Serialize.Get.label "Main.BazTH:") 169 | (do tag_aeVZz <- Data.Serialize.Get.getWord8 170 | case tag_aeVZz of 171 | 0 -> do safeGet_Int_aeVZA <- getSafeGet 172 | (return Baz1TH <*> safeGet_Int_aeVZA) 173 | 1 -> do safeGet_Bool_aeVZB <- getSafeGet 174 | (return Baz2TH <*> safeGet_Bool_aeVZB) 175 | _ -> fail 176 | ("Could not identify tag \"" 177 | ++ 178 | (show tag_aeVZz 179 | ++ 180 | "\" for type \"Main.BazTH\" that has only 2 constructors. Maybe your data is corrupted?")))) 181 | version = 5 182 | kind = base 183 | errorTypeName _ = "Main.BazTH" 184 | #endif 185 | 186 | data File 187 | = File { _fileChksum :: Checksum -- ^ The checksum of the file's contents 188 | , _fileMessages :: [String] -- ^ Messages received while manipulating the file 189 | , _fileExt :: String -- ^ Name is formed by appending this to checksum 190 | } deriving (Generic, Eq, Ord, Show) 191 | 192 | data FileSource 193 | = TheURI String 194 | | ThePath FilePath 195 | deriving (Generic, Eq, Ord, Show) 196 | 197 | type Checksum = String 198 | 199 | $(deriveSafeCopy 10 'base ''File) 200 | $(deriveSafeCopy 11 'base ''FileSource) 201 | 202 | file1 = File ("checksum") [] ".jpg" 203 | file2 = File ("checksum") [] ".jpg" 204 | file3 = File ("checksum") [] ".jpg" 205 | 206 | ---------------------------------------------- 207 | -- Demonstration of the ordering issue 208 | ---------------------------------------------- 209 | 210 | data T1 = T1 Char T2 T3 deriving (Generic, Show) 211 | data T2 = T2 Char deriving (Generic, Show) 212 | data T3 = T3 Char deriving (Generic, Show) 213 | data T4 = T4 Word32 Word32 Word32 deriving (Generic, Show) 214 | 215 | t1 = T1 'a' (T2 'b') (T3 'c') 216 | t2 = (T2 'b') 217 | t3 = (T3 'c') 218 | t4 = T4 100 200 300 219 | 220 | $(deriveSafeCopy 4 'base ''T2) 221 | $(deriveSafeCopy 5 'base ''T3) 222 | $(deriveSafeCopy 3 'base ''T1) 223 | $(deriveSafeCopy 6 'base ''T4) 224 | 225 | data T1G = T1G Char T2G T3G deriving (Generic, Show) 226 | data T2G = T2G Char deriving (Generic, Show) 227 | data T3G = T3G Char deriving (Generic, Show) 228 | data T4G = T4G Word32 Word32 Word32 deriving (Generic, Show) 229 | 230 | t1g = T1G 'a' (T2G 'b') (T3G 'c') 231 | t2g = (T2G 'b') 232 | t3g = (T3G 'c') 233 | t4g = T4G 100 200 300 234 | 235 | instance SafeCopy T1G where version = 3; kind = base 236 | instance SafeCopy T2G where version = 4; kind = base 237 | instance SafeCopy T3G where version = 5; kind = base 238 | instance SafeCopy T4G where version = 6; kind = base 239 | 240 | orderTests :: Test 241 | orderTests = 242 | let -- When I thought to myself "what should the output be type Baz" 243 | -- without reference to reality, this is what I came up with. 244 | _expected :: ByteString 245 | _expected = ("\NUL\NUL\NUL\ETX" <> "\NUL\NUL\NUL\NUL" <> "a" <> "\NUL\NUL\NUL\EOT" <> "\NUL\NUL\NUL\NUL" <> "b" <> "\NUL\NUL\NUL\ENQ" <> "\NUL\NUL\NUL\NUL" <> "c") 246 | -- T1 Char 'a' T2 Char 'b' T3 Char 'c' 247 | -- But this is reality - the type, followed by its three field 248 | -- types, followed by its three field values. 249 | actual :: ByteString 250 | actual = ("\NUL\NUL\NUL\ETX" <> "\NUL\NUL\NUL\NUL" <> "\NUL\NUL\NUL\EOT" <> "\NUL\NUL\NUL\ENQ" <> "a" <> "\NUL\NUL\NUL\NUL" <> "b" <> "\NUL\NUL\NUL\NUL" <> "c") in 251 | -- T1 Char T2 T3 'a' Char 'b' Char 'c' 252 | TestList 253 | [ TestCase (assertEqual "actual template haskell safeput output" (showBytes actual) (showBytes (runPut (safePut t1)))) 254 | , TestCase (assertEqual "what the new implementation does" (showBytes actual) (showBytes (runPut (safePut t1g)))) 255 | ] 256 | 257 | main = do 258 | runTestTT 259 | (TestList 260 | [ orderTests 261 | , roundTrip () 262 | , roundTrip ("hello" :: String) 263 | , roundTrip foo 264 | , roundTrip fooTH 265 | , roundTrip bar 266 | , roundTrip barTH 267 | , roundTrip baz1 268 | , roundTrip baz1TH 269 | , roundTrip baz2 270 | , roundTrip baz2TH 271 | , roundTrip (Just 'x') 272 | , roundTrip (Nothing :: Maybe Char) 273 | , roundTrip ('a', (123 :: Int), ("hello" :: String)) 274 | , roundTrip file1 275 | , roundTrip file2 276 | , roundTrip file3 277 | , compareBytes fooTH foo 278 | , compareBytes barTH bar 279 | , compareBytes baz1TH baz1 280 | , compareBytes baz2TH baz2 281 | ]) 282 | -------------------------------------------------------------------------------- /test/instances.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE StandaloneDeriving #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | 6 | {-# OPTIONS_GHC -fno-warn-orphans #-} 7 | 8 | import Control.Applicative 9 | import Control.Lens (transformOn, transformOnOf) 10 | import Control.Lens.Traversal (Traversal') 11 | import Control.Lens.Action ((^!!), act) 12 | import Data.Array (Array) 13 | import Data.Array.Unboxed (UArray) 14 | import Data.Data.Lens (template) 15 | import Data.Fixed (Fixed, E1) 16 | import Data.List 17 | import Data.SafeCopy 18 | import Data.Serialize (runPut, runGet) 19 | import Data.Time (UniversalTime(..), ZonedTime(..)) 20 | import Data.Tree (Tree) 21 | import Language.Haskell.TH 22 | import Language.Haskell.TH.Syntax 23 | import Test.Tasty 24 | import Test.Tasty.QuickCheck hiding (Fixed, (===)) 25 | import qualified Data.Vector as V 26 | import qualified Data.Vector.Primitive as VP 27 | import qualified Data.Vector.Storable as VS 28 | import qualified Data.Vector.Unboxed as VU 29 | 30 | deriving instance (Arbitrary a) => Arbitrary (Prim a) 31 | deriving instance (Eq a) => Eq (Prim a) 32 | deriving instance (Show a) => Show (Prim a) 33 | 34 | deriving instance Eq ZonedTime 35 | 36 | -- | Equality on the 'Right' value, showing the unequal value on failure; 37 | -- or explicit failure using the 'Left' message without equality testing. 38 | (===) :: (Eq a, Show a) => Either String a -> a -> Property 39 | Left e === _ = printTestCase e False 40 | Right a === b = printTestCase (show a) $ a == b 41 | 42 | -- | An instance for 'SafeCopy' makes a type isomorphic to a bytestring 43 | -- serialization, which is to say that @decode . encode = id@, i.e. 44 | -- @decode@ is the inverse of @encode@ if we ignore bottom. 45 | prop_inverse :: (SafeCopy a, Arbitrary a, Eq a, Show a) => a -> Property 46 | prop_inverse a = (decode . encode) a === a where 47 | encode = runPut . safePut 48 | decode = runGet safeGet 49 | 50 | -- | Test the 'prop_inverse' property against all 'SafeCopy' instances 51 | -- (that also satisfy the rest of the constraints) defaulting any type 52 | -- variables to 'Int'. 53 | do let a = conT ''Int 54 | 55 | -- types we skip because the Int defaulting doesn't type check 56 | excluded <- sequence 57 | [ [t| Fixed $a |] 58 | ] 59 | 60 | -- instead we include these hand-defaulted types 61 | included <- sequence 62 | [ [t| Fixed E1 |] 63 | ] 64 | 65 | -- types whose samples grow exponentially and need a lower maxSize 66 | downsized <- sequence 67 | [ [t| Array $a $a |] 68 | , [t| UArray $a $a |] 69 | , [t| Tree $a |] 70 | ] 71 | 72 | safecopy <- reify ''SafeCopy 73 | preds <- 'prop_inverse ^!! act reify . (template :: Traversal' Info Pred) 74 | classes <- 75 | case preds of 76 | [ForallT _ cxt' _] -> 77 | mapM reify [ name | AppT (ConT name) _ <- cxt' ] 78 | _ -> error "FIXME: fix this code to handle this case." 79 | def <- a 80 | 81 | let instances (ClassI _ decs) = [ typ | InstanceD _ _ (AppT _ typ) _ <- decs ] 82 | instances _ = [] 83 | types = map instances classes 84 | 85 | defaulting (VarT _) = def 86 | defaulting t = t 87 | defaulted = transformOn (traverse.traverse) defaulting types 88 | wanted = transformOn traverse defaulting $ instances safecopy 89 | 90 | common = foldl1 intersect defaulted 91 | untested = wanted \\ common 92 | exclusive = filter (`notElem` excluded) common 93 | 94 | downsize typ | typ `elem` downsized = [| mapSize (`div` 5) |] 95 | | otherwise = [| id |] 96 | 97 | unqualifying (Name occ _) = Name occ NameS 98 | name = pprint . transformOnOf template template unqualifying 99 | 100 | prop typ = 101 | [| testProperty $(litE . stringL $ name typ) 102 | ($(downsize typ) (prop_inverse :: $(return typ) -> Property)) |] 103 | 104 | props = listE . map prop 105 | 106 | mapM_ (\typ -> reportWarning $ "not tested: " ++ name typ) untested 107 | 108 | [d| inversions :: [TestTree] 109 | inversions = $(props included) ++ $(props exclusive) |] 110 | 111 | main :: IO () 112 | main = defaultMain $ testGroup "SafeCopy instances" 113 | [ testGroup "decode is the inverse of encode" inversions 114 | ] 115 | --------------------------------------------------------------------------------