From 9f286ce76ee7e74f0f70dc936a319893f715cd7b Mon Sep 17 00:00:00 2001 From: Andreas Abel Date: Mon, 18 Mar 2024 08:30:20 +0100 Subject: [PATCH 01/17] Allow latest template-haskell and time, bump CI to GHC 9.10 --- .github/workflows/haskell-ci.yml | 100 +++++++++++++++---------------- safecopy.cabal | 11 ++-- 2 files changed, 56 insertions(+), 55 deletions(-) diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 7dc178e..57f210e 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -8,9 +8,9 @@ # # For more information, see https://github.com/andreasabel/haskell-ci # -# version: 0.17.20231010 +# version: 0.19.20240416 # -# REGENDATA ("0.17.20231010",["github","safecopy.cabal"]) +# REGENDATA ("0.19.20240416",["github","safecopy.cabal"]) # name: Haskell-CI on: @@ -32,19 +32,24 @@ jobs: strategy: matrix: include: - - compiler: ghc-9.8.1 + - compiler: ghc-9.10.0.20240413 compilerKind: ghc - compilerVersion: 9.8.1 + compilerVersion: 9.10.0.20240413 setup-method: ghcup allow-failure: false - - compiler: ghc-9.6.3 + - compiler: ghc-9.8.2 compilerKind: ghc - compilerVersion: 9.6.3 + compilerVersion: 9.8.2 setup-method: ghcup allow-failure: false - - compiler: ghc-9.4.7 + - compiler: ghc-9.6.4 compilerKind: ghc - compilerVersion: 9.4.7 + compilerVersion: 9.6.4 + setup-method: ghcup + allow-failure: false + - compiler: ghc-9.4.8 + compilerKind: ghc + compilerVersion: 9.4.8 setup-method: ghcup allow-failure: false - compiler: ghc-9.2.8 @@ -65,51 +70,40 @@ jobs: - compiler: ghc-8.8.4 compilerKind: ghc compilerVersion: 8.8.4 - setup-method: hvr-ppa + setup-method: ghcup allow-failure: false - compiler: ghc-8.6.5 compilerKind: ghc compilerVersion: 8.6.5 - setup-method: hvr-ppa + setup-method: ghcup allow-failure: false - compiler: ghc-8.4.4 compilerKind: ghc compilerVersion: 8.4.4 - setup-method: hvr-ppa + setup-method: ghcup allow-failure: false - compiler: ghc-8.2.2 compilerKind: ghc compilerVersion: 8.2.2 - setup-method: hvr-ppa + setup-method: ghcup allow-failure: false - compiler: ghc-8.0.2 compilerKind: ghc compilerVersion: 8.0.2 - setup-method: hvr-ppa + setup-method: ghcup allow-failure: false fail-fast: false steps: - name: apt run: | apt-get update - apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 - if [ "${{ matrix.setup-method }}" = ghcup ]; then - mkdir -p "$HOME/.ghcup/bin" - curl -sL https://downloads.haskell.org/ghcup/0.1.19.5/x86_64-linux-ghcup-0.1.19.5 > "$HOME/.ghcup/bin/ghcup" - chmod a+x "$HOME/.ghcup/bin/ghcup" - "$HOME/.ghcup/bin/ghcup" config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml; - "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) - "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) - else - apt-add-repository -y 'ppa:hvr/ghc' - apt-get update - apt-get install -y "$HCNAME" - mkdir -p "$HOME/.ghcup/bin" - curl -sL https://downloads.haskell.org/ghcup/0.1.19.5/x86_64-linux-ghcup-0.1.19.5 > "$HOME/.ghcup/bin/ghcup" - chmod a+x "$HOME/.ghcup/bin/ghcup" - "$HOME/.ghcup/bin/ghcup" config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml; - "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) - fi + apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 libnuma-dev + mkdir -p "$HOME/.ghcup/bin" + curl -sL https://downloads.haskell.org/ghcup/0.1.20.0/x86_64-linux-ghcup-0.1.20.0 > "$HOME/.ghcup/bin/ghcup" + chmod a+x "$HOME/.ghcup/bin/ghcup" + "$HOME/.ghcup/bin/ghcup" config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.8.yaml; + "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) + "$HOME/.ghcup/bin/ghcup" install cabal 3.10.3.0 || (cat "$HOME"/.ghcup/logs/*.* && false) env: HCKIND: ${{ matrix.compilerKind }} HCNAME: ${{ matrix.compiler }} @@ -121,27 +115,18 @@ jobs: echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" HCDIR=/opt/$HCKIND/$HCVER - if [ "${{ matrix.setup-method }}" = ghcup ]; then - HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") - HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') - HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') - echo "HC=$HC" >> "$GITHUB_ENV" - echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" - echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" - echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" - else - HC=$HCDIR/bin/$HCKIND - echo "HC=$HC" >> "$GITHUB_ENV" - echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV" - echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV" - echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" - fi - + HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") + HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') + HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') + echo "HC=$HC" >> "$GITHUB_ENV" + echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" + echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" + echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.3.0 -vnormal+nowrap" >> "$GITHUB_ENV" HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" - echo "HEADHACKAGE=false" >> "$GITHUB_ENV" + if [ $((HCNUMVER >= 91000)) -ne 0 ] ; then echo "HEADHACKAGE=true" >> "$GITHUB_ENV" ; else echo "HEADHACKAGE=false" >> "$GITHUB_ENV" ; fi echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" echo "GHCJSARITH=0" >> "$GITHUB_ENV" env: @@ -170,6 +155,18 @@ jobs: repository hackage.haskell.org url: http://hackage.haskell.org/ EOF + if $HEADHACKAGE; then + cat >> $CABAL_CONFIG <> $CABAL_CONFIG <> cabal.project + fi $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: $_ installed\n" unless /^(safecopy)$/; }' >> cabal.project.local cat cabal.project cat cabal.project.local @@ -231,7 +231,7 @@ jobs: $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all cabal-plan - name: restore cache - uses: actions/cache/restore@v3 + uses: actions/cache/restore@v4 with: key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} path: ~/.cabal/store @@ -278,7 +278,7 @@ jobs: if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --enable-tests --disable-benchmarks --constraint='bytestring ^>= 0.12' all ; fi if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then $CABAL v2-test $ARG_COMPILER --enable-tests --disable-benchmarks --constraint='bytestring ^>= 0.12' all ; fi - name: save cache - uses: actions/cache/save@v3 + uses: actions/cache/save@v4 if: always() with: key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} diff --git a/safecopy.cabal b/safecopy.cabal index 64d907b..be1f3b0 100644 --- a/safecopy.cabal +++ b/safecopy.cabal @@ -14,9 +14,10 @@ Extra-source-files: CHANGELOG.md Cabal-version: >=1.10 tested-with: - GHC == 9.8.1 - GHC == 9.6.3 - GHC == 9.4.7 + GHC == 9.10.0 + GHC == 9.8.2 + GHC == 9.6.4 + GHC == 9.4.8 GHC == 9.2.8 GHC == 9.0.2 GHC == 8.10.7 @@ -47,9 +48,9 @@ Library generic-data >= 0.3, containers >= 0.3 && < 0.8, old-time < 1.2, - template-haskell < 2.22, + template-haskell < 2.23, text < 1.3 || >= 2.0 && < 2.2, - time < 1.13, + time < 1.15, transformers < 0.7, vector >= 0.10 && < 0.14 From 0dec0e705da5c9956724247c6b4b19cc5e195d81 Mon Sep 17 00:00:00 2001 From: Andreas Abel Date: Sun, 5 May 2024 15:34:03 +0200 Subject: [PATCH 02/17] Explicit imports from lens package --- test/instances.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/test/instances.hs b/test/instances.hs index 300ce27..ec10add 100644 --- a/test/instances.hs +++ b/test/instances.hs @@ -11,11 +11,12 @@ #endif import Control.Applicative -import Control.Lens -import Control.Lens.Action +import Control.Lens (transformOn, transformOnOf) +import Control.Lens.Traversal (Traversal') +import Control.Lens.Action ((^!!), act) import Data.Array (Array) import Data.Array.Unboxed (UArray) -import Data.Data.Lens +import Data.Data.Lens (template) import Data.Fixed (Fixed, E1) import Data.List import Data.SafeCopy From 40e5fb00865904de5ea478fc9b58450980177b07 Mon Sep 17 00:00:00 2001 From: Andreas Abel Date: Sun, 5 May 2024 15:35:17 +0200 Subject: [PATCH 03/17] Remove #ifs for pre GHC-8 dependency versions; relax lens upper bound --- safecopy.cabal | 9 +++--- src/Data/SafeCopy/Derive.hs | 5 ---- src/Data/SafeCopy/Instances.hs | 4 +-- test/instances.hs | 50 ---------------------------------- 4 files changed, 6 insertions(+), 62 deletions(-) diff --git a/safecopy.cabal b/safecopy.cabal index be1f3b0..c3e26ee 100644 --- a/safecopy.cabal +++ b/safecopy.cabal @@ -48,9 +48,9 @@ Library generic-data >= 0.3, containers >= 0.3 && < 0.8, old-time < 1.2, - template-haskell < 2.23, + template-haskell >= 2.11.0.0 && < 2.23, text < 1.3 || >= 2.0 && < 2.2, - time < 1.15, + time >= 1.6.0.1 && < 1.15, transformers < 0.7, vector >= 0.10 && < 0.14 @@ -69,8 +69,9 @@ Test-suite instances Hs-Source-Dirs: test/ GHC-Options: -Wall -threaded -rtsopts -with-rtsopts=-N Build-depends: base, cereal, template-haskell, safecopy, - containers, time, array, vector, lens >= 4.7 && < 5.3, - lens-action, tasty, tasty-quickcheck, quickcheck-instances, QuickCheck + containers, time, array, vector, lens >= 4.7 && < 6, + lens-action, tasty, tasty-quickcheck, quickcheck-instances + , QuickCheck >= 2.8.2 && < 3 Test-suite generic Default-language: Haskell2010 diff --git a/src/Data/SafeCopy/Derive.hs b/src/Data/SafeCopy/Derive.hs index 30494c3..e3f262c 100644 --- a/src/Data/SafeCopy/Derive.hs +++ b/src/Data/SafeCopy/Derive.hs @@ -1,10 +1,5 @@ {-# LANGUAGE TemplateHaskell, CPP #-} --- Hack for bug in older Cabal versions -#ifndef MIN_VERSION_template_haskell -#define MIN_VERSION_template_haskell(x,y,z) 1 -#endif - module Data.SafeCopy.Derive where import Data.Serialize (getWord8, putWord8, label) diff --git a/src/Data/SafeCopy/Instances.hs b/src/Data/SafeCopy/Instances.hs index 24bc274..c915f01 100644 --- a/src/Data/SafeCopy/Instances.hs +++ b/src/Data/SafeCopy/Instances.hs @@ -1,13 +1,11 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable, FlexibleContexts, UndecidableInstances, TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + module Data.SafeCopy.Instances where import Data.SafeCopy.SafeCopy -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif import Control.Monad import qualified Data.Array as Array import qualified Data.Array.Unboxed as UArray diff --git a/test/instances.hs b/test/instances.hs index ec10add..c5ff67a 100644 --- a/test/instances.hs +++ b/test/instances.hs @@ -5,11 +5,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} --- Hack for bug in older Cabal versions -#ifndef MIN_VERSION_template_haskell -#define MIN_VERSION_template_haskell(x,y,z) 1 -#endif - import Control.Applicative import Control.Lens (transformOn, transformOnOf) import Control.Lens.Traversal (Traversal') @@ -33,40 +28,11 @@ import qualified Data.Vector.Primitive as VP import qualified Data.Vector.Storable as VS import qualified Data.Vector.Unboxed as VU -#if ! MIN_VERSION_QuickCheck(2,9,0) -instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e, Arbitrary f) => - Arbitrary (a,b,c,d,e,f) where - arbitrary = (,,,,,) <$> arbitrary <*> arbitrary <*> arbitrary <*> - arbitrary <*> arbitrary <*> arbitrary - -instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e, Arbitrary f, Arbitrary g) => - Arbitrary (a,b,c,d,e,f,g) where - arbitrary = (,,,,,,) <$> arbitrary <*> arbitrary <*> arbitrary <*> - arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -#endif - -#if ! MIN_VERSION_QuickCheck(2,8,2) -instance (Arbitrary a) => Arbitrary (V.Vector a) where - arbitrary = V.fromList <$> arbitrary - -instance (Arbitrary a, VP.Prim a) => Arbitrary (VP.Vector a) where - arbitrary = VP.fromList <$> arbitrary - -instance (Arbitrary a, VS.Storable a) => Arbitrary (VS.Vector a) where - arbitrary = VS.fromList <$> arbitrary - -instance (Arbitrary a, VU.Unbox a) => Arbitrary (VU.Vector a) where - arbitrary = VU.fromList <$> arbitrary -#endif - deriving instance (Arbitrary a) => Arbitrary (Prim a) deriving instance (Eq a) => Eq (Prim a) deriving instance (Show a) => Show (Prim a) deriving instance Eq ZonedTime -#if ! MIN_VERSION_time(1,6,0) -deriving instance Show UniversalTime -#endif -- | Equality on the 'Right' value, showing the unequal value on failure; -- or explicit failure using the 'Left' message without equality testing. @@ -106,25 +72,14 @@ do let a = conT ''Int safecopy <- reify ''SafeCopy preds <- 'prop_inverse ^!! act reify . (template :: Traversal' Info Pred) -#if !MIN_VERSION_template_haskell(2,10,0) - classes <- mapM reify [ name | ClassP name _ <- preds ] -#else --- print preds - classes <- case preds of [ForallT _ cxt' _] -> mapM reify [ name | AppT (ConT name) _ <- cxt' ] _ -> error "FIXME: fix this code to handle this case." --- classes <- mapM reify [ ] -#endif def <- a -#if MIN_VERSION_template_haskell(2,11,0) let instances (ClassI _ decs) = [ typ | InstanceD _ _ (AppT _ typ) _ <- decs ] -#else - let instances (ClassI _ decs) = [ typ | InstanceD _ (AppT _ typ) _ <- decs ] -#endif instances _ = [] types = map instances classes @@ -149,11 +104,6 @@ do let a = conT ''Int props = listE . map prop -#if !MIN_VERSION_template_haskell(2,8,0) - -- 'report' throws warnings in template-haskell-2.8.0.0 - reportWarning = report False -#endif - mapM_ (\typ -> reportWarning $ "not tested: " ++ name typ) untested [d| inversions :: [TestTree] From 735e56b958ca03326bdc9fb6d63d88e65389750c Mon Sep 17 00:00:00 2001 From: Andreas Abel Date: Sun, 5 May 2024 18:39:36 +0200 Subject: [PATCH 04/17] Drop dependency quickcheck-instances --- safecopy.cabal | 4 +++- test/instances.hs | 1 - 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/safecopy.cabal b/safecopy.cabal index c3e26ee..772b9ba 100644 --- a/safecopy.cabal +++ b/safecopy.cabal @@ -70,7 +70,9 @@ Test-suite instances GHC-Options: -Wall -threaded -rtsopts -with-rtsopts=-N Build-depends: base, cereal, template-haskell, safecopy, containers, time, array, vector, lens >= 4.7 && < 6, - lens-action, tasty, tasty-quickcheck, quickcheck-instances + lens-action + , tasty + , tasty-quickcheck , QuickCheck >= 2.8.2 && < 3 Test-suite generic diff --git a/test/instances.hs b/test/instances.hs index c5ff67a..b1af845 100644 --- a/test/instances.hs +++ b/test/instances.hs @@ -20,7 +20,6 @@ import Data.Time (UniversalTime(..), ZonedTime(..)) import Data.Tree (Tree) import Language.Haskell.TH import Language.Haskell.TH.Syntax -import Test.QuickCheck.Instances () import Test.Tasty import Test.Tasty.QuickCheck hiding (Fixed, (===)) import qualified Data.Vector as V From 32b4be8e5e958ad8989726291b8994b6b660b938 Mon Sep 17 00:00:00 2001 From: Andreas Abel Date: Sun, 5 May 2024 18:40:18 +0200 Subject: [PATCH 05/17] Fix lower bound of cereal (0.5.3 needed) --- safecopy.cabal | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/safecopy.cabal b/safecopy.cabal index 772b9ba..5a4732b 100644 --- a/safecopy.cabal +++ b/safecopy.cabal @@ -43,9 +43,10 @@ Library -- Packages needed in order to build this package. Build-depends: base >= 4.9 && < 5, array < 0.6, - cereal >= 0.5 && < 0.6, + cereal >= 0.5.3 && < 0.6, + -- cereal 0.5.3 introduced instance Monoid Put bytestring < 0.13, - generic-data >= 0.3, + generic-data >= 0.3.0.0, containers >= 0.3 && < 0.8, old-time < 1.2, template-haskell >= 2.11.0.0 && < 2.23, From 153216363d81ee366c4a7d90a1724bacb6b35832 Mon Sep 17 00:00:00 2001 From: Andreas Abel Date: Sun, 5 May 2024 18:42:06 +0200 Subject: [PATCH 06/17] Include lens-5.3.1 in Haskell CI --- .github/workflows/haskell-ci.yml | 36 +++++++++++++------------------- cabal.haskell-ci | 15 ++++--------- safecopy.cabal | 2 +- 3 files changed, 19 insertions(+), 34 deletions(-) diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 57f210e..0315094 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -8,9 +8,9 @@ # # For more information, see https://github.com/andreasabel/haskell-ci # -# version: 0.19.20240416 +# version: 0.19.20240429 # -# REGENDATA ("0.19.20240416",["github","safecopy.cabal"]) +# REGENDATA ("0.19.20240429",["github","safecopy.cabal"]) # name: Haskell-CI on: @@ -27,14 +27,14 @@ jobs: timeout-minutes: 60 container: - image: buildpack-deps:focal + image: buildpack-deps:jammy continue-on-error: ${{ matrix.allow-failure }} strategy: matrix: include: - - compiler: ghc-9.10.0.20240413 + - compiler: ghc-9.10.0.20240426 compilerKind: ghc - compilerVersion: 9.10.0.20240413 + compilerVersion: 9.10.0.20240426 setup-method: ghcup allow-failure: false - compiler: ghc-9.8.2 @@ -42,9 +42,9 @@ jobs: compilerVersion: 9.8.2 setup-method: ghcup allow-failure: false - - compiler: ghc-9.6.4 + - compiler: ghc-9.6.5 compilerKind: ghc - compilerVersion: 9.6.4 + compilerVersion: 9.6.5 setup-method: ghcup allow-failure: false - compiler: ghc-9.4.8 @@ -217,8 +217,7 @@ jobs: if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package safecopy" >> cabal.project ; fi if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi cat >> cabal.project <> cabal.project @@ -263,20 +262,13 @@ jobs: - name: prepare for constraint sets run: | rm -f cabal.project.local - - name: constraint set text-2.1 + - name: constraint set lens-5.3.1 run: | - if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --enable-tests --disable-benchmarks --constraint='text ^>= 2.1' all --dry-run ; fi - if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then cabal-plan topo | sort ; fi - if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --enable-tests --disable-benchmarks --constraint='text ^>= 2.1' --dependencies-only -j2 all ; fi - if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --enable-tests --disable-benchmarks --constraint='text ^>= 2.1' all ; fi - if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then $CABAL v2-test $ARG_COMPILER --enable-tests --disable-benchmarks --constraint='text ^>= 2.1' all ; fi - - name: constraint set bytestring-0.12 - run: | - if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --enable-tests --disable-benchmarks --constraint='bytestring ^>= 0.12' all --dry-run ; fi - if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then cabal-plan topo | sort ; fi - if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --enable-tests --disable-benchmarks --constraint='bytestring ^>= 0.12' --dependencies-only -j2 all ; fi - if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --enable-tests --disable-benchmarks --constraint='bytestring ^>= 0.12' all ; fi - if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then $CABAL v2-test $ARG_COMPILER --enable-tests --disable-benchmarks --constraint='bytestring ^>= 0.12' all ; fi + if [ $((HCNUMVER < 91000)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --enable-tests --disable-benchmarks --constraint='lens ^>= 5.3.1' all --dry-run ; fi + if [ $((HCNUMVER < 91000)) -ne 0 ] ; then cabal-plan topo | sort ; fi + if [ $((HCNUMVER < 91000)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --enable-tests --disable-benchmarks --constraint='lens ^>= 5.3.1' --dependencies-only -j2 all ; fi + if [ $((HCNUMVER < 91000)) -ne 0 ] ; then $CABAL v2-build $ARG_COMPILER --enable-tests --disable-benchmarks --constraint='lens ^>= 5.3.1' all ; fi + if [ $((HCNUMVER < 91000)) -ne 0 ] ; then $CABAL v2-test $ARG_COMPILER --enable-tests --disable-benchmarks --constraint='lens ^>= 5.3.1' all ; fi - name: save cache uses: actions/cache/save@v4 if: always() diff --git a/cabal.haskell-ci b/cabal.haskell-ci index 2a89036..99b3096 100644 --- a/cabal.haskell-ci +++ b/cabal.haskell-ci @@ -1,18 +1,11 @@ branches: master installed: +all -constraint-set bytestring-0.12 - ghc: >= 8.2 - constraints: bytestring ^>= 0.12 - tests: True - run-tests: True - -constraint-set text-2.1 - ghc: >= 8.2 - constraints: text ^>= 2.1 +constraint-set lens-5.3.1 + ghc: >= 8.0 && < 9.10 + constraints: lens ^>= 5.3.1 tests: True run-tests: True raw-project - allow-newer: bytestring - allow-newer: text \ No newline at end of file + allow-newer: lens diff --git a/safecopy.cabal b/safecopy.cabal index 5a4732b..6147bf6 100644 --- a/safecopy.cabal +++ b/safecopy.cabal @@ -16,7 +16,7 @@ Cabal-version: >=1.10 tested-with: GHC == 9.10.0 GHC == 9.8.2 - GHC == 9.6.4 + GHC == 9.6.5 GHC == 9.4.8 GHC == 9.2.8 GHC == 9.0.2 From 7af5dbe3ca7825b3c5f0ffda6bb660f491cc794c Mon Sep 17 00:00:00 2001 From: Andreas Abel Date: Sun, 5 May 2024 18:43:54 +0200 Subject: [PATCH 07/17] Add Stack CI for GHC 8.0 - 9.8 --- .github/workflows/stack.yml | 65 +++++++++++++++++++++++++++++++++++++ .gitignore | 4 ++- stack-8.0.yaml | 10 ++++++ stack-8.10.yaml | 1 + stack-8.2.yaml | 5 +++ stack-8.4.yaml | 5 +++ stack-8.6.yaml | 1 + stack-8.8.yaml | 1 + stack-9.0.yaml | 1 + stack-9.2.yaml | 1 + stack-9.4.yaml | 1 + stack-9.6.yaml | 1 + stack-9.8.yaml | 1 + 13 files changed, 96 insertions(+), 1 deletion(-) create mode 100644 .github/workflows/stack.yml create mode 100644 stack-8.0.yaml create mode 100644 stack-8.10.yaml create mode 100644 stack-8.2.yaml create mode 100644 stack-8.4.yaml create mode 100644 stack-8.6.yaml create mode 100644 stack-8.8.yaml create mode 100644 stack-9.0.yaml create mode 100644 stack-9.2.yaml create mode 100644 stack-9.4.yaml create mode 100644 stack-9.6.yaml create mode 100644 stack-9.8.yaml diff --git a/.github/workflows/stack.yml b/.github/workflows/stack.yml new file mode 100644 index 0000000..d9e0d7e --- /dev/null +++ b/.github/workflows/stack.yml @@ -0,0 +1,65 @@ +name: Stack build + +on: + push: + branches: [master] + pull_request: + branches: [master] + +jobs: + build: + name: Stack ${{ matrix.ghc }} ${{ matrix.os }} + runs-on: ${{ matrix.os }} + strategy: + fail-fast: false + matrix: + os: [ubuntu-latest] + ghc: ['9.8', '9.6', '9.4', '9.2', '9.0', '8.10', '8.8', '8.6', '8.4', '8.2', '8.0'] + include: + - os: macos-latest + ghc: '9.8' + - os: windows-latest + ghc: '9.8' + + steps: + - uses: actions/checkout@v4 + + - uses: haskell-actions/setup@v2 + id: setup + with: + ghc-version: ${{ matrix.ghc }} + enable-stack: true + cabal-update: false + + - name: Restore cache + uses: actions/cache/restore@v4 + id: cache + env: + key: ${{ runner.os }}-stack-${{ steps.setup.outputs.stack-version }}-ghc-${{ steps.setup.outputs.ghc-version }} + with: + key: ${{ env.key }}-commit-${{ github.sha }} + restore-keys: ${{ env.key }}- + path: | + ${{ steps.setup.outputs.stack-root }} + .stack-work + + - name: Build dependencies + run: stack build --stack-yaml=stack-${{ matrix.ghc }}.yaml --system-ghc --only-dependencies + + - name: Build + run: stack build --stack-yaml=stack-${{ matrix.ghc }}.yaml --system-ghc + + - name: Build tests + run: stack test --stack-yaml=stack-${{ matrix.ghc }}.yaml --system-ghc --no-run-tests + + - name: Run tests + run: stack test --stack-yaml=stack-${{ matrix.ghc }}.yaml --system-ghc + + - name: Save cache + uses: actions/cache/save@v4 + if: always() && steps.cache.outputs.cache-hit != 'true' + with: + key: ${{ steps.cache.outputs.cache-primary-key }} + path: | + ${{ steps.setup.outputs.stack-root }} + .stack-work diff --git a/.gitignore b/.gitignore index 5ec7c3a..a0bc96a 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,4 @@ /dist-newstyle/ -*.nix \ No newline at end of file +/.stack-work/ +*.nix +stack*.yaml.lock diff --git a/stack-8.0.yaml b/stack-8.0.yaml new file mode 100644 index 0000000..19d62b9 --- /dev/null +++ b/stack-8.0.yaml @@ -0,0 +1,10 @@ +resolver: lts-9.21 + +extra-deps: +- generic-data-0.3.0.0 +- base-orphans-0.8 +- show-combinators-0.1.0.0 + +allow-newer: true +allow-newer-deps: +- profunctors diff --git a/stack-8.10.yaml b/stack-8.10.yaml new file mode 100644 index 0000000..773d5c9 --- /dev/null +++ b/stack-8.10.yaml @@ -0,0 +1 @@ +resolver: lts-18.28 diff --git a/stack-8.2.yaml b/stack-8.2.yaml new file mode 100644 index 0000000..ec64270 --- /dev/null +++ b/stack-8.2.yaml @@ -0,0 +1,5 @@ +resolver: lts-11.22 + +extra-deps: +- generic-data-0.3.0.0 +- base-orphans-0.8 diff --git a/stack-8.4.yaml b/stack-8.4.yaml new file mode 100644 index 0000000..4ee5f2b --- /dev/null +++ b/stack-8.4.yaml @@ -0,0 +1,5 @@ +resolver: lts-12.26 + +extra-deps: +- generic-data-0.3.0.0 +- base-orphans-0.8 diff --git a/stack-8.6.yaml b/stack-8.6.yaml new file mode 100644 index 0000000..785b146 --- /dev/null +++ b/stack-8.6.yaml @@ -0,0 +1 @@ +resolver: lts-14.27 diff --git a/stack-8.8.yaml b/stack-8.8.yaml new file mode 100644 index 0000000..53095f7 --- /dev/null +++ b/stack-8.8.yaml @@ -0,0 +1 @@ +resolver: lts-16.31 diff --git a/stack-9.0.yaml b/stack-9.0.yaml new file mode 100644 index 0000000..f9994e6 --- /dev/null +++ b/stack-9.0.yaml @@ -0,0 +1 @@ +resolver: lts-19.33 diff --git a/stack-9.2.yaml b/stack-9.2.yaml new file mode 100644 index 0000000..fc9172f --- /dev/null +++ b/stack-9.2.yaml @@ -0,0 +1 @@ +resolver: lts-20.26 diff --git a/stack-9.4.yaml b/stack-9.4.yaml new file mode 100644 index 0000000..377040a --- /dev/null +++ b/stack-9.4.yaml @@ -0,0 +1 @@ +resolver: lts-21.25 diff --git a/stack-9.6.yaml b/stack-9.6.yaml new file mode 100644 index 0000000..1ffa6e2 --- /dev/null +++ b/stack-9.6.yaml @@ -0,0 +1 @@ +resolver: lts-22.20 diff --git a/stack-9.8.yaml b/stack-9.8.yaml new file mode 100644 index 0000000..07c4198 --- /dev/null +++ b/stack-9.8.yaml @@ -0,0 +1 @@ +resolver: nightly-2024-05-05 From 5ec6800a4ae96479bf5e9c4db60bc01bcb14fa5a Mon Sep 17 00:00:00 2001 From: Andreas Abel Date: Fri, 17 May 2024 11:26:26 +0100 Subject: [PATCH 08/17] Bump Haskell CI to GHC 9.10.1 --- .github/workflows/haskell-ci.yml | 28 ++++++---------------------- safecopy.cabal | 5 +++-- 2 files changed, 9 insertions(+), 24 deletions(-) diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 0315094..01b866a 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -8,9 +8,9 @@ # # For more information, see https://github.com/andreasabel/haskell-ci # -# version: 0.19.20240429 +# version: 0.19.20240517 # -# REGENDATA ("0.19.20240429",["github","safecopy.cabal"]) +# REGENDATA ("0.19.20240517",["github","safecopy.cabal"]) # name: Haskell-CI on: @@ -32,9 +32,9 @@ jobs: strategy: matrix: include: - - compiler: ghc-9.10.0.20240426 + - compiler: ghc-9.10.1 compilerKind: ghc - compilerVersion: 9.10.0.20240426 + compilerVersion: 9.10.1 setup-method: ghcup allow-failure: false - compiler: ghc-9.8.2 @@ -101,7 +101,6 @@ jobs: mkdir -p "$HOME/.ghcup/bin" curl -sL https://downloads.haskell.org/ghcup/0.1.20.0/x86_64-linux-ghcup-0.1.20.0 > "$HOME/.ghcup/bin/ghcup" chmod a+x "$HOME/.ghcup/bin/ghcup" - "$HOME/.ghcup/bin/ghcup" config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.8.yaml; "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) "$HOME/.ghcup/bin/ghcup" install cabal 3.10.3.0 || (cat "$HOME"/.ghcup/logs/*.* && false) env: @@ -126,7 +125,7 @@ jobs: echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" - if [ $((HCNUMVER >= 91000)) -ne 0 ] ; then echo "HEADHACKAGE=true" >> "$GITHUB_ENV" ; else echo "HEADHACKAGE=false" >> "$GITHUB_ENV" ; fi + echo "HEADHACKAGE=false" >> "$GITHUB_ENV" echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" echo "GHCJSARITH=0" >> "$GITHUB_ENV" env: @@ -155,18 +154,6 @@ jobs: repository hackage.haskell.org url: http://hackage.haskell.org/ EOF - if $HEADHACKAGE; then - cat >> $CABAL_CONFIG <> $CABAL_CONFIG <> cabal.project <> cabal.project - fi - $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: $_ installed\n" unless /^(safecopy)$/; }' >> cabal.project.local + $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(safecopy)$/; }' >> cabal.project.local cat cabal.project cat cabal.project.local - name: dump install plan diff --git a/safecopy.cabal b/safecopy.cabal index 6147bf6..7c0e38d 100644 --- a/safecopy.cabal +++ b/safecopy.cabal @@ -1,6 +1,6 @@ Name: safecopy Version: 0.10.4.2 -x-revision: 8 +x-revision: 10 Synopsis: Binary serialization with version control. Description: An extension to Data.Serialize with built-in version control. Homepage: https://github.com/acid-state/safecopy @@ -14,7 +14,7 @@ Extra-source-files: CHANGELOG.md Cabal-version: >=1.10 tested-with: - GHC == 9.10.0 + GHC == 9.10.1 GHC == 9.8.2 GHC == 9.6.5 GHC == 9.4.8 @@ -74,6 +74,7 @@ Test-suite instances lens-action , tasty , tasty-quickcheck + , quickcheck-instances , QuickCheck >= 2.8.2 && < 3 Test-suite generic From eeb41eb2904a152dc8895816fd941f019ef2f7d4 Mon Sep 17 00:00:00 2001 From: David Fox Date: Sun, 1 Dec 2024 07:12:18 -0800 Subject: [PATCH 09/17] Add one unit test of deriveSafeCopy output --- safecopy.cabal | 5 ++ src/Data/SafeCopy/Derive.hs | 99 ++++++++++++++++++++++++++++++++++--- test/instances.hs | 15 ++++++ 3 files changed, 112 insertions(+), 7 deletions(-) diff --git a/safecopy.cabal b/safecopy.cabal index 7c0e38d..87ee844 100644 --- a/safecopy.cabal +++ b/safecopy.cabal @@ -49,6 +49,9 @@ Library generic-data >= 0.3.0.0, containers >= 0.3 && < 0.8, old-time < 1.2, + pretty, + regex-tdfa, + syb, template-haskell >= 2.11.0.0 && < 2.23, text < 1.3 || >= 2.0 && < 2.2, time >= 1.6.0.1 && < 1.15, @@ -73,9 +76,11 @@ Test-suite instances containers, time, array, vector, lens >= 4.7 && < 6, lens-action , tasty + , tasty-hunit , tasty-quickcheck , quickcheck-instances , QuickCheck >= 2.8.2 && < 3 + , th-orphans Test-suite generic Default-language: Haskell2010 diff --git a/src/Data/SafeCopy/Derive.hs b/src/Data/SafeCopy/Derive.hs index e3f262c..d286313 100644 --- a/src/Data/SafeCopy/Derive.hs +++ b/src/Data/SafeCopy/Derive.hs @@ -7,10 +7,17 @@ import Data.SafeCopy.SafeCopy import Language.Haskell.TH hiding (Kind) import Control.Monad +import Data.Data (Data) +import Data.Generics (everywhere, mkT) import Data.Maybe (fromMaybe) #ifdef __HADDOCK__ import Data.Word (Word8) -- Haddock #endif +import Debug.Trace (traceShowId) +import Language.Haskell.TH.PprLib (Doc, to_HPJ_Doc) +import Language.Haskell.TH.Syntax +import qualified Text.PrettyPrint as HPJ +import Text.Regex.TDFA ((=~), MatchResult(MR)) -- | Derive an instance of 'SafeCopy'. -- @@ -251,26 +258,27 @@ internalDeriveSafeCopy' deriveType versionId kindName tyName info = do worker' (return nty) context [] [(0, con)] #else DataInstD context _name ty _kind cons _derivs -> - worker' (foldl appT (conT tyName) (map return ty)) context [] (zip [0..] cons) + worker' (foldl AppT (ConT tyName) ty) context [] (zip [0..] cons) NewtypeInstD context _name ty _kind con _derivs -> - worker' (foldl appT (conT tyName) (map return ty)) context [] [(0, con)] + worker' (foldl AppT (ConT tyName) ty) context [] [(0, con)] #endif _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, inst) return $ concat decs _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, info) where - worker = worker' (conT tyName) + worker = worker' (ConT tyName) worker' tyBase context tyvars cons = - let ty = foldl appT tyBase [ varT $ tyVarName var | var <- tyvars ] + let ty = foldl AppT tyBase [ VarT $ tyVarName var | var <- tyvars ] + typeNameStr = pprWithoutSuffixes ppr (ConT tyName) safeCopyClass args = foldl appT (conT ''SafeCopy) args in (:[]) <$> instanceD (cxt $ [safeCopyClass [varT $ tyVarName var] | var <- tyvars] ++ map return context) - (conT ''SafeCopy `appT` ty) + (pure (ConT ''SafeCopy `AppT` ty)) [ mkPutCopy deriveType cons - , mkGetCopy deriveType (show tyName) cons + , mkGetCopy deriveType typeNameStr cons , valD (varP 'version) (normalB $ litE $ integerL $ fromIntegral $ unVersion versionId) [] , valD (varP 'kind) (normalB (varE kindName)) [] - , funD 'errorTypeName [clause [wildP] (normalB $ litE $ StringL (show tyName)) []] + , funD 'errorTypeName [clause [wildP] (normalB $ litE $ StringL typeNameStr) []] ] internalDeriveSafeCopyIndexedType :: DeriveType -> Version a -> Name -> Name -> [Name] -> Q [Dec] @@ -437,3 +445,80 @@ typeName ListT = "List" typeName (AppT t u) = typeName t ++ typeName u typeName (SigT t _k) = typeName t typeName _ = "_" + +-- | Apply the TH pretty printer to a value after stripping any added +-- suffixes from its names. This may make it uncompilable, but it +-- eliminates a source of randomness in the expected and actual test +-- case results. +pprWithoutSuffixes :: Data a => (a -> Doc) -> a -> String +pprWithoutSuffixes pretty decs = + fixNames $ + HPJ.renderStyle (HPJ.style {HPJ.lineLength = 1000000 {-HPJ.mode = HPJ.OneLineMode-}}) $ + to_HPJ_Doc $ + pretty $ + everywhere (mkT unsafeName) $ + {-fixText-} decs + +-- | Turn this: +-- @@ +-- (Name (mkOccName "AppraisalValue") +-- (NameG TcClsName (mkPkgName "appra_B8Hqp4MOZTzG2RIYHT6sPz") +-- (mkModName "Appraisal.ReportTH"))) +-- @@ +-- into this: +-- @@ +-- $(lift 'Appraisal.ReportTH.AppraisalValue). +-- @@ +-- This is applied to all declarations in the generated splice file. +fixNames :: String -> String +fixNames s = + let s' = fixStrings s in + case (s' =~ "\\(Name \\(mkOccName \\\"([^\"]*)\"\\) \\((NameG ([^ ]*) \\(mkPkgName \\\"([^\"]*)\\\"\\) \\(mkModName \\\"([^\"]*)\\\"\\)|NameU [0-9]*)\\)\\)" :: MatchResult String) of + MR before _ after [name, _, "", "", ""] _ -> before <> "(mkName " <> show name <> ") " <> fixNames after + MR before _ after [name, _, "VarName", _, _modpath] _ -> before <> "'" <> name <> fixNames after + MR before _ after [name, _, "DataName", _, _modpath] _ -> before <> "''" <> name <> fixNames after + MR before _ after [name, _, "TcClsName", _, _modpath] _ -> before <> "''" <> name <> fixNames after -- I think this is right + MR before _ _ _ _ -> before + +fixStrings :: String -> String +fixStrings s = + let MR before _ after xs _ = s =~ ("\\[((" <> ws <> ch <> ")*" <> ws <> ")\\]") :: MatchResult String in + case xs of + [] -> s -- eof + ["", _, _, _, _] -> before <> "[]" <> fixStrings after -- empty list + [cs, _, _, _, _] -> before <> "\"" <> fixChars cs <> "\"" <> fixStrings after + _ -> error "Regular expression failure" + +fixChars :: String -> String +fixChars "" = "" +fixChars s = + let MR before _ after [_, c, _] _ = s =~ (ws <> ch <> ws) :: MatchResult String in before <> fixChar c <> fixChars after + where + fixChar "\\'" = "'" + fixChar s' = s' + +-- | Names with the best chance of compiling when prettyprinted: +-- * Remove all package and module names +-- * Remove suffixes on all constructor names +-- * Remove suffixes on the four ids we export +-- * Leave suffixes on all variables and type variables +safeName :: Name -> Name +safeName (Name oc (NameG _ns _pn _mn)) = traceShowId $ Name oc NameS +safeName (Name oc (NameQ _mn)) = traceShowId $ Name oc NameS +safeName (Name oc@(OccName _) (NameU _)) = traceShowId $ Name oc NameS +safeName name@(Name _ (NameL _)) = traceShowId $ name -- Not seeing any of these +safeName name@(Name _ NameS) = traceShowId $ name + +-- This will probably make the expression invalid, but it +-- removes random elements that will make tests fail. +unsafeName :: Name -> Name +unsafeName (Name oc (NameG _ns _pn _mn)) = Name oc NameS +unsafeName (Name oc (NameQ _mn)) = Name oc NameS +unsafeName (Name oc@(OccName _) (NameU _)) = Name oc NameS +unsafeName name@(Name _ (NameL _)) = name -- Not seeing any of these +unsafeName name@(Name _ NameS) = name + +ws :: String +ws = "(\t|\r|\n| |,)*" +ch :: String +ch = "'([^'\\\\]|\\\\')'" diff --git a/test/instances.hs b/test/instances.hs index b1af845..c51ea90 100644 --- a/test/instances.hs +++ b/test/instances.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} @@ -15,12 +16,15 @@ import Data.Data.Lens (template) import Data.Fixed (Fixed, E1) import Data.List import Data.SafeCopy +import Data.SafeCopy.Internal (pprWithoutSuffixes) import Data.Serialize (runPut, runGet) import Data.Time (UniversalTime(..), ZonedTime(..)) import Data.Tree (Tree) import Language.Haskell.TH +import Language.Haskell.TH.Instances () import Language.Haskell.TH.Syntax import Test.Tasty +import Test.Tasty.HUnit import Test.Tasty.QuickCheck hiding (Fixed, (===)) import qualified Data.Vector as V import qualified Data.Vector.Primitive as VP @@ -111,4 +115,15 @@ do let a = conT ''Int main :: IO () main = defaultMain $ testGroup "SafeCopy instances" [ testGroup "decode is the inverse of encode" inversions + , testGroup "deriveSafeCopy'" + [ testCase "deriveSafeCopy 0 'base ''(,,,,,,,)" $ do + let decs = $(lift =<< deriveSafeCopy 0 'base ''(,,,,,,,)) + pprWithoutSuffixes ppr decs @?= intercalate "\n" + ["instance (SafeCopy a, SafeCopy b, SafeCopy c, SafeCopy d, SafeCopy e, SafeCopy f, SafeCopy g, SafeCopy h) => SafeCopy ((,,,,,,,) a b c d e f g h)", + " where putCopy ((,,,,,,,) a1 a2 a3 a4 a5 a6 a7 a8) = contain (do {safePut_a <- getSafePut; safePut_b <- getSafePut; safePut_c <- getSafePut; safePut_d <- getSafePut; safePut_e <- getSafePut; safePut_f <- getSafePut; safePut_g <- getSafePut; safePut_h <- getSafePut; safePut_a a1; safePut_b a2; safePut_c a3; safePut_d a4; safePut_e a5; safePut_f a6; safePut_g a7; safePut_h a8; return ()})", + " getCopy = contain (label \"(,,,,,,,):\" (do {safeGet_a <- getSafeGet; safeGet_b <- getSafeGet; safeGet_c <- getSafeGet; safeGet_d <- getSafeGet; safeGet_e <- getSafeGet; safeGet_f <- getSafeGet; safeGet_g <- getSafeGet; safeGet_h <- getSafeGet; (((((((return (,,,,,,,) <*> safeGet_a) <*> safeGet_b) <*> safeGet_c) <*> safeGet_d) <*> safeGet_e) <*> safeGet_f) <*> safeGet_g) <*> safeGet_h}))", + " version = 0", + " kind = base", + " errorTypeName _ = \"(,,,,,,,)\""] + ] ] From 6a5dd7a8e096df53ede49c14330329caa5fe1663 Mon Sep 17 00:00:00 2001 From: David Fox Date: Sun, 1 Dec 2024 07:24:39 -0800 Subject: [PATCH 10/17] Add alternate versions of each of the deriveSafeCopy that take a TypeQ rather than the type's Name. These cases don't yet work. --- src/Data/SafeCopy.hs | 6 ++ src/Data/SafeCopy/Derive.hs | 170 ++++++++++++++++++++---------------- 2 files changed, 103 insertions(+), 73 deletions(-) diff --git a/src/Data/SafeCopy.hs b/src/Data/SafeCopy.hs index 3ccd84a..228633e 100644 --- a/src/Data/SafeCopy.hs +++ b/src/Data/SafeCopy.hs @@ -122,11 +122,17 @@ module Data.SafeCopy -- * Template haskell functions , deriveSafeCopy + , deriveSafeCopy' , deriveSafeCopyIndexedType + , deriveSafeCopyIndexedType' , deriveSafeCopySimple + , deriveSafeCopySimple' , deriveSafeCopySimpleIndexedType + , deriveSafeCopySimpleIndexedType' , deriveSafeCopyHappstackData + , deriveSafeCopyHappstackData' , deriveSafeCopyHappstackDataIndexedType + , deriveSafeCopyHappstackDataIndexedType' -- * Rarely used functions , getSafeGet diff --git a/src/Data/SafeCopy/Derive.hs b/src/Data/SafeCopy/Derive.hs index d286313..ea7a115 100644 --- a/src/Data/SafeCopy/Derive.hs +++ b/src/Data/SafeCopy/Derive.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell, CPP #-} +{-# LANGUAGE TemplateHaskell, LambdaCase, CPP #-} module Data.SafeCopy.Derive where @@ -105,10 +105,19 @@ import Text.Regex.TDFA ((=~), MatchResult(MR)) -- version of your data type and 'deriveSafeCopy' in another -- version without any problems. deriveSafeCopy :: Version a -> Name -> Name -> Q [Dec] -deriveSafeCopy = internalDeriveSafeCopy Normal +deriveSafeCopy versionId kindName tyName = + internalDeriveSafeCopy Normal versionId kindName (conT tyName) + +deriveSafeCopy' :: Version a -> Name -> TypeQ -> Q [Dec] +deriveSafeCopy' versionId kindName typ = internalDeriveSafeCopy Normal versionId kindName typ deriveSafeCopyIndexedType :: Version a -> Name -> Name -> [Name] -> Q [Dec] -deriveSafeCopyIndexedType = internalDeriveSafeCopyIndexedType Normal +deriveSafeCopyIndexedType versionId kindName tyName = + internalDeriveSafeCopyIndexedType Normal versionId kindName (conT tyName) + +deriveSafeCopyIndexedType' :: Version a -> Name -> TypeQ -> [Name] -> Q [Dec] +deriveSafeCopyIndexedType' versionId kindName typ = + internalDeriveSafeCopyIndexedType Normal versionId kindName typ -- | Derive an instance of 'SafeCopy'. The instance derived by -- this function is simpler than the one derived by @@ -160,10 +169,20 @@ deriveSafeCopyIndexedType = internalDeriveSafeCopyIndexedType Normal -- your data type and 'deriveSafeCopySimple' in another version -- without any problems. deriveSafeCopySimple :: Version a -> Name -> Name -> Q [Dec] -deriveSafeCopySimple = internalDeriveSafeCopy Simple +deriveSafeCopySimple versionId kindName tyName = + deriveSafeCopySimple' versionId kindName (conT tyName) + +deriveSafeCopySimple' :: Version a -> Name -> TypeQ -> Q [Dec] +deriveSafeCopySimple' versionId kindName typ = + internalDeriveSafeCopy Simple versionId kindName typ deriveSafeCopySimpleIndexedType :: Version a -> Name -> Name -> [Name] -> Q [Dec] -deriveSafeCopySimpleIndexedType = internalDeriveSafeCopyIndexedType Simple +deriveSafeCopySimpleIndexedType versionId kindName tyName = + deriveSafeCopySimpleIndexedType' versionId kindName (conT tyName) + +deriveSafeCopySimpleIndexedType' :: Version a -> Name -> TypeQ -> [Name] -> Q [Dec] +deriveSafeCopySimpleIndexedType' versionId kindName typ = + internalDeriveSafeCopyIndexedType Simple versionId kindName typ -- | Derive an instance of 'SafeCopy'. The instance derived by -- this function should be compatible with the instance derived @@ -210,10 +229,19 @@ deriveSafeCopySimpleIndexedType = internalDeriveSafeCopyIndexedType Simple -- your data type and 'deriveSafeCopyHappstackData' in another version -- without any problems. deriveSafeCopyHappstackData :: Version a -> Name -> Name -> Q [Dec] -deriveSafeCopyHappstackData = internalDeriveSafeCopy HappstackData +deriveSafeCopyHappstackData versionId kindName tyName = + deriveSafeCopyHappstackData' versionId kindName (conT tyName) + +deriveSafeCopyHappstackData' :: Version a -> Name -> TypeQ -> Q [Dec] +deriveSafeCopyHappstackData' = internalDeriveSafeCopy HappstackData deriveSafeCopyHappstackDataIndexedType :: Version a -> Name -> Name -> [Name] -> Q [Dec] -deriveSafeCopyHappstackDataIndexedType = internalDeriveSafeCopyIndexedType HappstackData +deriveSafeCopyHappstackDataIndexedType versionId kindName tyName = + deriveSafeCopyHappstackDataIndexedType' versionId kindName (conT tyName) + +deriveSafeCopyHappstackDataIndexedType' :: Version a -> Name -> TypeQ -> [Name] -> Q [Dec] +deriveSafeCopyHappstackDataIndexedType' versionId kindName typ = + internalDeriveSafeCopyIndexedType HappstackData versionId kindName typ data DeriveType = Normal | Simple | HappstackData @@ -231,44 +259,42 @@ tyVarName (PlainTV n) = n tyVarName (KindedTV n _) = n #endif -internalDeriveSafeCopy :: DeriveType -> Version a -> Name -> Name -> Q [Dec] -internalDeriveSafeCopy deriveType versionId kindName tyName = do - info <- reify tyName - internalDeriveSafeCopy' deriveType versionId kindName tyName info - -internalDeriveSafeCopy' :: DeriveType -> Version a -> Name -> Name -> Info -> Q [Dec] -internalDeriveSafeCopy' deriveType versionId kindName tyName info = do - case info of - TyConI (DataD context _name tyvars _kind cons _derivs) - | length cons > 255 -> fail $ "Can't derive SafeCopy instance for: " ++ show tyName ++ - ". The datatype must have less than 256 constructors." - | otherwise -> worker context tyvars (zip [0..] cons) - - TyConI (NewtypeD context _name tyvars _kind con _derivs) -> - worker context tyvars [(0, con)] - - FamilyI _ insts -> do - decs <- forM insts $ \inst -> - case inst of +internalDeriveSafeCopy :: DeriveType -> Version a -> Name -> TypeQ -> Q [Dec] +internalDeriveSafeCopy deriveType versionId kindName typq = do + typq >>= \case + ConT tyName -> do + reify tyName >>= \case + TyConI (DataD context _name tyvars _kind cons _derivs) + | length cons > 255 -> fail $ "Can't derive SafeCopy instance for: " ++ show tyName ++ + ". The datatype must have less than 256 constructors." + | otherwise -> worker tyName context tyvars (zip [0..] cons) + + TyConI (NewtypeD context _name tyvars _kind con _derivs) -> + worker tyName context tyvars [(0, con)] + + FamilyI _ insts -> do + decs <- forM insts $ \inst -> + case inst of #if MIN_VERSION_template_haskell(2,15,0) - DataInstD context _ nty _kind cons _derivs -> - worker' (return nty) context [] (zip [0..] cons) + DataInstD context _ nty _kind cons _derivs -> + worker' tyName (return nty) context [] (zip [0..] cons) - NewtypeInstD context _ nty _kind con _derivs -> - worker' (return nty) context [] [(0, con)] + NewtypeInstD context _ nty _kind con _derivs -> + worker' tyName (return nty) context [] [(0, con)] #else - DataInstD context _name ty _kind cons _derivs -> - worker' (foldl AppT (ConT tyName) ty) context [] (zip [0..] cons) + DataInstD context _name ty _kind cons _derivs -> + worker' tyName (foldl AppT (ConT tyName) ty) context [] (zip [0..] cons) - NewtypeInstD context _name ty _kind con _derivs -> - worker' (foldl AppT (ConT tyName) ty) context [] [(0, con)] + NewtypeInstD context _name ty _kind con _derivs -> + worker' tyName (foldl AppT (ConT tyName) ty) context [] [(0, con)] #endif - _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, inst) - return $ concat decs - _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, info) + _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, inst) + return $ concat decs + info -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, info) + typ -> fail $ "Can't derive SafeCopy instance for: " ++ show typ where - worker = worker' (ConT tyName) - worker' tyBase context tyvars cons = + worker tyName = worker' tyName (ConT tyName) + worker' tyName tyBase context tyvars cons = let ty = foldl AppT tyBase [ VarT $ tyVarName var | var <- tyvars ] typeNameStr = pprWithoutSuffixes ppr (ConT tyName) safeCopyClass args = foldl appT (conT ''SafeCopy) args @@ -281,56 +307,54 @@ internalDeriveSafeCopy' deriveType versionId kindName tyName info = do , funD 'errorTypeName [clause [wildP] (normalB $ litE $ StringL typeNameStr) []] ] -internalDeriveSafeCopyIndexedType :: DeriveType -> Version a -> Name -> Name -> [Name] -> Q [Dec] -internalDeriveSafeCopyIndexedType deriveType versionId kindName tyName tyIndex' = do - info <- reify tyName - internalDeriveSafeCopyIndexedType' deriveType versionId kindName tyName tyIndex' info - -internalDeriveSafeCopyIndexedType' :: DeriveType -> Version a -> Name -> Name -> [Name] -> Info -> Q [Dec] -internalDeriveSafeCopyIndexedType' deriveType versionId kindName tyName tyIndex' info = do +internalDeriveSafeCopyIndexedType :: DeriveType -> Version a -> Name -> TypeQ -> [Name] -> Q [Dec] +internalDeriveSafeCopyIndexedType deriveType versionId kindName typq tyIndex' = do tyIndex <- mapM conT tyIndex' - case info of - FamilyI _ insts -> do - decs <- forM insts $ \inst -> - case inst of + typq >>= \case + ConT tyName -> do + reify tyName >>= \case + FamilyI _ insts -> do + decs <- forM insts $ \inst -> + case inst of #if MIN_VERSION_template_haskell(2,15,0) - DataInstD context _ nty _kind cons _derivs - | nty == foldl AppT (ConT tyName) tyIndex -> - worker' (return nty) context [] (zip [0..] cons) + DataInstD context _ nty _kind cons _derivs + | nty == foldl AppT (ConT tyName) tyIndex -> + worker' tyName (return nty) context [] (zip [0..] cons) #else - DataInstD context _name ty _kind cons _derivs - | ty == tyIndex -> - worker' (foldl appT (conT tyName) (map return ty)) context [] (zip [0..] cons) + DataInstD context _name ty _kind cons _derivs + | ty == tyIndex -> + worker' tyName (foldl appT (conT tyName) (map return ty)) context [] (zip [0..] cons) #endif - | otherwise -> - return [] + | otherwise -> + return [] #if MIN_VERSION_template_haskell(2,15,0) - NewtypeInstD context _ nty _kind con _derivs - | nty == foldl AppT (ConT tyName) tyIndex -> - worker' (return nty) context [] [(0, con)] + NewtypeInstD context _ nty _kind con _derivs + | nty == foldl AppT (ConT tyName) tyIndex -> + worker' tyName (return nty) context [] [(0, con)] #else - NewtypeInstD context _name ty _kind con _derivs - | ty == tyIndex -> - worker' (foldl appT (conT tyName) (map return ty)) context [] [(0, con)] + NewtypeInstD context _name ty _kind con _derivs + | ty == tyIndex -> + worker' tyName (foldl appT (conT tyName) (map return ty)) context [] [(0, con)] #endif - | otherwise -> - return [] - _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, inst) - return $ concat decs - _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, info) + | otherwise -> + return [] + _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, inst) + return $ concat decs + info -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, info) + typ -> fail $ "Can't derive SafeCopy instance for: " ++ show typ where - typeNameStr = unwords $ map show (tyName:tyIndex') - worker' tyBase context tyvars cons = + typeNameStr tyName = unwords $ map show (tyName:tyIndex') + worker' tyName tyBase context tyvars cons = let ty = foldl appT tyBase [ varT $ tyVarName var | var <- tyvars ] safeCopyClass args = foldl appT (conT ''SafeCopy) args in (:[]) <$> instanceD (cxt $ [safeCopyClass [varT $ tyVarName var] | var <- tyvars] ++ map return context) (conT ''SafeCopy `appT` ty) [ mkPutCopy deriveType cons - , mkGetCopy deriveType typeNameStr cons + , mkGetCopy deriveType (typeNameStr tyName) cons , valD (varP 'version) (normalB $ litE $ integerL $ fromIntegral $ unVersion versionId) [] , valD (varP 'kind) (normalB (varE kindName)) [] - , funD 'errorTypeName [clause [wildP] (normalB $ litE $ StringL typeNameStr) []] + , funD 'errorTypeName [clause [wildP] (normalB $ litE $ StringL (typeNameStr tyName)) []] ] mkPutCopy :: DeriveType -> [(Integer, Con)] -> DecQ From ceaa632f8eb7daedfb8f32deb13ff8c141dba626 Mon Sep 17 00:00:00 2001 From: David Fox Date: Sun, 1 Dec 2024 07:29:52 -0800 Subject: [PATCH 11/17] Remove unnecessary variant of the worker function --- src/Data/SafeCopy/Derive.hs | 27 +++++++++++++-------------- 1 file changed, 13 insertions(+), 14 deletions(-) diff --git a/src/Data/SafeCopy/Derive.hs b/src/Data/SafeCopy/Derive.hs index ea7a115..5a3c687 100644 --- a/src/Data/SafeCopy/Derive.hs +++ b/src/Data/SafeCopy/Derive.hs @@ -262,39 +262,38 @@ tyVarName (KindedTV n _) = n internalDeriveSafeCopy :: DeriveType -> Version a -> Name -> TypeQ -> Q [Dec] internalDeriveSafeCopy deriveType versionId kindName typq = do typq >>= \case - ConT tyName -> do + typ@(ConT tyName) -> do reify tyName >>= \case TyConI (DataD context _name tyvars _kind cons _derivs) | length cons > 255 -> fail $ "Can't derive SafeCopy instance for: " ++ show tyName ++ ". The datatype must have less than 256 constructors." - | otherwise -> worker tyName context tyvars (zip [0..] cons) + | otherwise -> worker tyName typ context tyvars (zip [0..] cons) TyConI (NewtypeD context _name tyvars _kind con _derivs) -> - worker tyName context tyvars [(0, con)] + worker tyName typ context tyvars [(0, con)] FamilyI _ insts -> do decs <- forM insts $ \inst -> case inst of #if MIN_VERSION_template_haskell(2,15,0) DataInstD context _ nty _kind cons _derivs -> - worker' tyName (return nty) context [] (zip [0..] cons) + worker tyName (return nty) context [] (zip [0..] cons) NewtypeInstD context _ nty _kind con _derivs -> - worker' tyName (return nty) context [] [(0, con)] + worker tyName (return nty) context [] [(0, con)] #else DataInstD context _name ty _kind cons _derivs -> - worker' tyName (foldl AppT (ConT tyName) ty) context [] (zip [0..] cons) + worker tyName (foldl AppT (ConT tyName) ty) context [] (zip [0..] cons) NewtypeInstD context _name ty _kind con _derivs -> - worker' tyName (foldl AppT (ConT tyName) ty) context [] [(0, con)] + worker tyName (foldl AppT (ConT tyName) ty) context [] [(0, con)] #endif _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, inst) return $ concat decs info -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, info) typ -> fail $ "Can't derive SafeCopy instance for: " ++ show typ where - worker tyName = worker' tyName (ConT tyName) - worker' tyName tyBase context tyvars cons = + worker tyName tyBase context tyvars cons = let ty = foldl AppT tyBase [ VarT $ tyVarName var | var <- tyvars ] typeNameStr = pprWithoutSuffixes ppr (ConT tyName) safeCopyClass args = foldl appT (conT ''SafeCopy) args @@ -319,11 +318,11 @@ internalDeriveSafeCopyIndexedType deriveType versionId kindName typq tyIndex' = #if MIN_VERSION_template_haskell(2,15,0) DataInstD context _ nty _kind cons _derivs | nty == foldl AppT (ConT tyName) tyIndex -> - worker' tyName (return nty) context [] (zip [0..] cons) + worker tyName (return nty) context [] (zip [0..] cons) #else DataInstD context _name ty _kind cons _derivs | ty == tyIndex -> - worker' tyName (foldl appT (conT tyName) (map return ty)) context [] (zip [0..] cons) + worker tyName (foldl appT (conT tyName) (map return ty)) context [] (zip [0..] cons) #endif | otherwise -> return [] @@ -331,11 +330,11 @@ internalDeriveSafeCopyIndexedType deriveType versionId kindName typq tyIndex' = #if MIN_VERSION_template_haskell(2,15,0) NewtypeInstD context _ nty _kind con _derivs | nty == foldl AppT (ConT tyName) tyIndex -> - worker' tyName (return nty) context [] [(0, con)] + worker tyName (return nty) context [] [(0, con)] #else NewtypeInstD context _name ty _kind con _derivs | ty == tyIndex -> - worker' tyName (foldl appT (conT tyName) (map return ty)) context [] [(0, con)] + worker tyName (foldl appT (conT tyName) (map return ty)) context [] [(0, con)] #endif | otherwise -> return [] @@ -345,7 +344,7 @@ internalDeriveSafeCopyIndexedType deriveType versionId kindName typq tyIndex' = typ -> fail $ "Can't derive SafeCopy instance for: " ++ show typ where typeNameStr tyName = unwords $ map show (tyName:tyIndex') - worker' tyName tyBase context tyvars cons = + worker tyName tyBase context tyvars cons = let ty = foldl appT tyBase [ varT $ tyVarName var | var <- tyvars ] safeCopyClass args = foldl appT (conT ''SafeCopy) args in (:[]) <$> instanceD (cxt $ [safeCopyClass [varT $ tyVarName var] | var <- tyvars] ++ map return context) From 73d8103053a04c4d594d3b565262bfab0fe06771 Mon Sep 17 00:00:00 2001 From: David Fox Date: Sun, 1 Dec 2024 07:39:57 -0800 Subject: [PATCH 12/17] * Add signatures to worker functions and rename worker1, worker2 * Change TypeQ argument type to Type --- src/Data/SafeCopy/Derive.hs | 30 ++++++++++++++++-------------- 1 file changed, 16 insertions(+), 14 deletions(-) diff --git a/src/Data/SafeCopy/Derive.hs b/src/Data/SafeCopy/Derive.hs index 5a3c687..8ce3e75 100644 --- a/src/Data/SafeCopy/Derive.hs +++ b/src/Data/SafeCopy/Derive.hs @@ -267,33 +267,34 @@ internalDeriveSafeCopy deriveType versionId kindName typq = do TyConI (DataD context _name tyvars _kind cons _derivs) | length cons > 255 -> fail $ "Can't derive SafeCopy instance for: " ++ show tyName ++ ". The datatype must have less than 256 constructors." - | otherwise -> worker tyName typ context tyvars (zip [0..] cons) + | otherwise -> worker1 tyName typ context tyvars (zip [0..] cons) TyConI (NewtypeD context _name tyvars _kind con _derivs) -> - worker tyName typ context tyvars [(0, con)] + worker1 tyName typ context tyvars [(0, con)] FamilyI _ insts -> do decs <- forM insts $ \inst -> case inst of #if MIN_VERSION_template_haskell(2,15,0) DataInstD context _ nty _kind cons _derivs -> - worker tyName (return nty) context [] (zip [0..] cons) + worker1 tyName (return nty) context [] (zip [0..] cons) NewtypeInstD context _ nty _kind con _derivs -> - worker tyName (return nty) context [] [(0, con)] + worker1 tyName (return nty) context [] [(0, con)] #else DataInstD context _name ty _kind cons _derivs -> - worker tyName (foldl AppT (ConT tyName) ty) context [] (zip [0..] cons) + worker1 tyName (foldl AppT (ConT tyName) ty) context [] (zip [0..] cons) NewtypeInstD context _name ty _kind con _derivs -> - worker tyName (foldl AppT (ConT tyName) ty) context [] [(0, con)] + worker1 tyName (foldl AppT (ConT tyName) ty) context [] [(0, con)] #endif _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, inst) return $ concat decs info -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, info) typ -> fail $ "Can't derive SafeCopy instance for: " ++ show typ where - worker tyName tyBase context tyvars cons = + worker1 :: Name -> Type -> Cxt -> [TyVarBndr] -> [(Integer, Con)] -> Q [Dec] + worker1 tyName tyBase context tyvars cons = let ty = foldl AppT tyBase [ VarT $ tyVarName var | var <- tyvars ] typeNameStr = pprWithoutSuffixes ppr (ConT tyName) safeCopyClass args = foldl appT (conT ''SafeCopy) args @@ -318,11 +319,11 @@ internalDeriveSafeCopyIndexedType deriveType versionId kindName typq tyIndex' = #if MIN_VERSION_template_haskell(2,15,0) DataInstD context _ nty _kind cons _derivs | nty == foldl AppT (ConT tyName) tyIndex -> - worker tyName (return nty) context [] (zip [0..] cons) + worker2 tyName nty context [] (zip [0..] cons) #else DataInstD context _name ty _kind cons _derivs | ty == tyIndex -> - worker tyName (foldl appT (conT tyName) (map return ty)) context [] (zip [0..] cons) + worker2 tyName (foldl AppT (ConT tyName) ty) context [] (zip [0..] cons) #endif | otherwise -> return [] @@ -330,11 +331,11 @@ internalDeriveSafeCopyIndexedType deriveType versionId kindName typq tyIndex' = #if MIN_VERSION_template_haskell(2,15,0) NewtypeInstD context _ nty _kind con _derivs | nty == foldl AppT (ConT tyName) tyIndex -> - worker tyName (return nty) context [] [(0, con)] + worker2 tyName nty context [] [(0, con)] #else NewtypeInstD context _name ty _kind con _derivs | ty == tyIndex -> - worker tyName (foldl appT (conT tyName) (map return ty)) context [] [(0, con)] + worker2 tyName (foldl AppT (ConT tyName) ty) context [] [(0, con)] #endif | otherwise -> return [] @@ -344,11 +345,12 @@ internalDeriveSafeCopyIndexedType deriveType versionId kindName typq tyIndex' = typ -> fail $ "Can't derive SafeCopy instance for: " ++ show typ where typeNameStr tyName = unwords $ map show (tyName:tyIndex') - worker tyName tyBase context tyvars cons = - let ty = foldl appT tyBase [ varT $ tyVarName var | var <- tyvars ] + worker2 :: Name -> Type -> Cxt -> [TyVarBndr] -> [(Integer, Con)] -> Q [Dec] + worker2 tyName tyBase context tyvars cons = + let ty = foldl AppT tyBase [ VarT $ tyVarName var | var <- tyvars ] safeCopyClass args = foldl appT (conT ''SafeCopy) args in (:[]) <$> instanceD (cxt $ [safeCopyClass [varT $ tyVarName var] | var <- tyvars] ++ map return context) - (conT ''SafeCopy `appT` ty) + (pure (ConT ''SafeCopy `AppT` ty)) [ mkPutCopy deriveType cons , mkGetCopy deriveType (typeNameStr tyName) cons , valD (varP 'version) (normalB $ litE $ integerL $ fromIntegral $ unVersion versionId) [] From ccf68b44978bc75322c850af54fdfb4bfd37955d Mon Sep 17 00:00:00 2001 From: David Fox Date: Sun, 1 Dec 2024 08:14:39 -0800 Subject: [PATCH 13/17] Factor out a function withInst to deal with a change in TH 2.15.0 --- src/Data/SafeCopy/Derive.hs | 79 ++++++++++++++----------------------- 1 file changed, 30 insertions(+), 49 deletions(-) diff --git a/src/Data/SafeCopy/Derive.hs b/src/Data/SafeCopy/Derive.hs index 8ce3e75..85eb8c6 100644 --- a/src/Data/SafeCopy/Derive.hs +++ b/src/Data/SafeCopy/Derive.hs @@ -273,23 +273,7 @@ internalDeriveSafeCopy deriveType versionId kindName typq = do worker1 tyName typ context tyvars [(0, con)] FamilyI _ insts -> do - decs <- forM insts $ \inst -> - case inst of -#if MIN_VERSION_template_haskell(2,15,0) - DataInstD context _ nty _kind cons _derivs -> - worker1 tyName (return nty) context [] (zip [0..] cons) - - NewtypeInstD context _ nty _kind con _derivs -> - worker1 tyName (return nty) context [] [(0, con)] -#else - DataInstD context _name ty _kind cons _derivs -> - worker1 tyName (foldl AppT (ConT tyName) ty) context [] (zip [0..] cons) - - NewtypeInstD context _name ty _kind con _derivs -> - worker1 tyName (foldl AppT (ConT tyName) ty) context [] [(0, con)] -#endif - _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, inst) - return $ concat decs + concat <$> (forM insts $ withInst typ (worker1 tyName)) info -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, info) typ -> fail $ "Can't derive SafeCopy instance for: " ++ show typ where @@ -311,45 +295,22 @@ internalDeriveSafeCopyIndexedType :: DeriveType -> Version a -> Name -> TypeQ -> internalDeriveSafeCopyIndexedType deriveType versionId kindName typq tyIndex' = do tyIndex <- mapM conT tyIndex' typq >>= \case - ConT tyName -> do + typ@(ConT tyName) -> do + let itype = foldl AppT (ConT tyName) tyIndex reify tyName >>= \case FamilyI _ insts -> do - decs <- forM insts $ \inst -> - case inst of -#if MIN_VERSION_template_haskell(2,15,0) - DataInstD context _ nty _kind cons _derivs - | nty == foldl AppT (ConT tyName) tyIndex -> - worker2 tyName nty context [] (zip [0..] cons) -#else - DataInstD context _name ty _kind cons _derivs - | ty == tyIndex -> - worker2 tyName (foldl AppT (ConT tyName) ty) context [] (zip [0..] cons) -#endif - | otherwise -> - return [] - -#if MIN_VERSION_template_haskell(2,15,0) - NewtypeInstD context _ nty _kind con _derivs - | nty == foldl AppT (ConT tyName) tyIndex -> - worker2 tyName nty context [] [(0, con)] -#else - NewtypeInstD context _name ty _kind con _derivs - | ty == tyIndex -> - worker2 tyName (foldl AppT (ConT tyName) ty) context [] [(0, con)] -#endif - | otherwise -> - return [] - _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, inst) - return $ concat decs + concat <$> (forM insts $ withInst typ (worker2 tyIndex' itype tyName)) info -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, info) typ -> fail $ "Can't derive SafeCopy instance for: " ++ show typ where - typeNameStr tyName = unwords $ map show (tyName:tyIndex') - worker2 :: Name -> Type -> Cxt -> [TyVarBndr] -> [(Integer, Con)] -> Q [Dec] - worker2 tyName tyBase context tyvars cons = + worker2 :: [Name] -> Type -> Name -> Type -> Cxt -> [TyVarBndr] -> [(Integer, Con)] -> Q [Dec] + worker2 _ itype _ tyBase _ _ _ | itype /= tyBase = + fail $ "Expected " <> show itype <> ", but found " <> show tyBase + worker2 tyIndex' _ tyName tyBase context tyvars cons = do let ty = foldl AppT tyBase [ VarT $ tyVarName var | var <- tyvars ] + typeNameStr tyName = unwords (pprWithoutSuffixes ppr ty : map show tyIndex') safeCopyClass args = foldl appT (conT ''SafeCopy) args - in (:[]) <$> instanceD (cxt $ [safeCopyClass [varT $ tyVarName var] | var <- tyvars] ++ map return context) + (:[]) <$> instanceD (cxt $ [safeCopyClass [varT $ tyVarName var] | var <- tyvars] ++ map return context) (pure (ConT ''SafeCopy `AppT` ty)) [ mkPutCopy deriveType cons , mkGetCopy deriveType (typeNameStr tyName) cons @@ -358,6 +319,26 @@ internalDeriveSafeCopyIndexedType deriveType versionId kindName typq tyIndex' = , funD 'errorTypeName [clause [wildP] (normalB $ litE $ StringL (typeNameStr tyName)) []] ] +withInst :: + Monad m + => Type + -> (Type -> Cxt -> [TyVarBndr] -> [(Integer, Con)] -> m r) + -> Dec + -> m r +#if MIN_VERSION_template_haskell(2,15,0) +withInst typ worker (DataInstD context _ nty _ cons _) = + worker nty context [] (zip [0..] cons) +withInst typ worker (NewtypeInstD context _ ty _ con _) = + worker nty context [] (zip [0..] [con]) +#else +withInst typ worker (DataInstD context _ ty _ cons _) = + worker (foldl AppT typ ty) context [] (zip [0..] cons) +withInst typ worker (NewtypeInstD context _ ty _ con _) = + worker (foldl AppT typ ty) context [] (zip [0..] [con]) +#endif +withInst typ _ _ = + fail $ "Can't derive SafeCopy instance for: " ++ show typ + mkPutCopy :: DeriveType -> [(Integer, Con)] -> DecQ mkPutCopy deriveType cons = funD 'putCopy $ map mkPutClause cons where From 7f9d3d8331d2ac2a31569b013da0ced39a5e0276 Mon Sep 17 00:00:00 2001 From: David Fox Date: Sun, 1 Dec 2024 08:39:13 -0800 Subject: [PATCH 14/17] Make worker functions top level --- src/Data/SafeCopy/Derive.hs | 66 ++++++++++++++++++------------------- 1 file changed, 33 insertions(+), 33 deletions(-) diff --git a/src/Data/SafeCopy/Derive.hs b/src/Data/SafeCopy/Derive.hs index 85eb8c6..83dab81 100644 --- a/src/Data/SafeCopy/Derive.hs +++ b/src/Data/SafeCopy/Derive.hs @@ -267,29 +267,16 @@ internalDeriveSafeCopy deriveType versionId kindName typq = do TyConI (DataD context _name tyvars _kind cons _derivs) | length cons > 255 -> fail $ "Can't derive SafeCopy instance for: " ++ show tyName ++ ". The datatype must have less than 256 constructors." - | otherwise -> worker1 tyName typ context tyvars (zip [0..] cons) + | otherwise -> worker1 deriveType versionId kindName tyName typ context tyvars (zip [0..] cons) TyConI (NewtypeD context _name tyvars _kind con _derivs) -> - worker1 tyName typ context tyvars [(0, con)] + worker1 deriveType versionId kindName tyName typ context tyvars [(0, con)] FamilyI _ insts -> do - concat <$> (forM insts $ withInst typ (worker1 tyName)) + concat <$> (forM insts $ withInst typ (worker1 deriveType versionId kindName tyName)) info -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, info) + -- typ@(Forall tyvars cxt' typ') -> undefined typ -> fail $ "Can't derive SafeCopy instance for: " ++ show typ - where - worker1 :: Name -> Type -> Cxt -> [TyVarBndr] -> [(Integer, Con)] -> Q [Dec] - worker1 tyName tyBase context tyvars cons = - let ty = foldl AppT tyBase [ VarT $ tyVarName var | var <- tyvars ] - typeNameStr = pprWithoutSuffixes ppr (ConT tyName) - safeCopyClass args = foldl appT (conT ''SafeCopy) args - in (:[]) <$> instanceD (cxt $ [safeCopyClass [varT $ tyVarName var] | var <- tyvars] ++ map return context) - (pure (ConT ''SafeCopy `AppT` ty)) - [ mkPutCopy deriveType cons - , mkGetCopy deriveType typeNameStr cons - , valD (varP 'version) (normalB $ litE $ integerL $ fromIntegral $ unVersion versionId) [] - , valD (varP 'kind) (normalB (varE kindName)) [] - , funD 'errorTypeName [clause [wildP] (normalB $ litE $ StringL typeNameStr) []] - ] internalDeriveSafeCopyIndexedType :: DeriveType -> Version a -> Name -> TypeQ -> [Name] -> Q [Dec] internalDeriveSafeCopyIndexedType deriveType versionId kindName typq tyIndex' = do @@ -299,25 +286,38 @@ internalDeriveSafeCopyIndexedType deriveType versionId kindName typq tyIndex' = let itype = foldl AppT (ConT tyName) tyIndex reify tyName >>= \case FamilyI _ insts -> do - concat <$> (forM insts $ withInst typ (worker2 tyIndex' itype tyName)) + concat <$> (forM insts $ withInst typ (worker2 deriveType versionId kindName tyIndex' itype)) info -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, info) typ -> fail $ "Can't derive SafeCopy instance for: " ++ show typ where - worker2 :: [Name] -> Type -> Name -> Type -> Cxt -> [TyVarBndr] -> [(Integer, Con)] -> Q [Dec] - worker2 _ itype _ tyBase _ _ _ | itype /= tyBase = - fail $ "Expected " <> show itype <> ", but found " <> show tyBase - worker2 tyIndex' _ tyName tyBase context tyvars cons = do - let ty = foldl AppT tyBase [ VarT $ tyVarName var | var <- tyvars ] - typeNameStr tyName = unwords (pprWithoutSuffixes ppr ty : map show tyIndex') - safeCopyClass args = foldl appT (conT ''SafeCopy) args - (:[]) <$> instanceD (cxt $ [safeCopyClass [varT $ tyVarName var] | var <- tyvars] ++ map return context) - (pure (ConT ''SafeCopy `AppT` ty)) - [ mkPutCopy deriveType cons - , mkGetCopy deriveType (typeNameStr tyName) cons - , valD (varP 'version) (normalB $ litE $ integerL $ fromIntegral $ unVersion versionId) [] - , valD (varP 'kind) (normalB (varE kindName)) [] - , funD 'errorTypeName [clause [wildP] (normalB $ litE $ StringL (typeNameStr tyName)) []] - ] + +worker1 :: DeriveType -> Version a -> Name -> Name -> Type -> Cxt -> [TyVarBndr] -> [(Integer, Con)] -> Q [Dec] +worker1 deriveType versionId kindName tyName tyBase context tyvars cons = + let ty = foldl AppT tyBase [ VarT $ tyVarName var | var <- tyvars ] + typeNameStr = pprWithoutSuffixes ppr (ConT tyName) + safeCopyClass args = foldl appT (conT ''SafeCopy) args + in (:[]) <$> instanceD (cxt $ [safeCopyClass [varT $ tyVarName var] | var <- tyvars] ++ map return context) + (pure (ConT ''SafeCopy `AppT` ty)) + [ mkPutCopy deriveType cons + , mkGetCopy deriveType typeNameStr cons + , valD (varP 'version) (normalB $ litE $ integerL $ fromIntegral $ unVersion versionId) [] + , valD (varP 'kind) (normalB (varE kindName)) [] + , funD 'errorTypeName [clause [wildP] (normalB $ litE $ StringL typeNameStr) []] ] + +worker2 :: DeriveType -> Version a -> Name -> [Name] -> Type -> Type -> Cxt -> [TyVarBndr] -> [(Integer, Con)] -> Q [Dec] +worker2 _ _ _ _ itype tyBase _ _ _ | itype /= tyBase = + fail $ "Expected " <> show itype <> ", but found " <> show tyBase +worker2 deriveType versionId kindName tyIndex' _ tyBase context tyvars cons = do + let ty = foldl AppT tyBase [ VarT $ tyVarName var | var <- tyvars ] + typeNameStr = unwords (pprWithoutSuffixes ppr ty : map show tyIndex') + safeCopyClass args = foldl appT (conT ''SafeCopy) args + (:[]) <$> instanceD (cxt $ [safeCopyClass [varT $ tyVarName var] | var <- tyvars] ++ map return context) + (pure (ConT ''SafeCopy `AppT` ty)) + [ mkPutCopy deriveType cons + , mkGetCopy deriveType typeNameStr cons + , valD (varP 'version) (normalB $ litE $ integerL $ fromIntegral $ unVersion versionId) [] + , valD (varP 'kind) (normalB (varE kindName)) [] + , funD 'errorTypeName [clause [wildP] (normalB $ litE $ StringL typeNameStr) []] ] withInst :: Monad m From 59285cb6e3ab392e60ded438dfda73778c058574 Mon Sep 17 00:00:00 2001 From: David Fox Date: Sun, 1 Dec 2024 08:50:03 -0800 Subject: [PATCH 15/17] Factor out the computation of the extra SafeCopy constraints --- src/Data/SafeCopy/Derive.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Data/SafeCopy/Derive.hs b/src/Data/SafeCopy/Derive.hs index 83dab81..db8a835 100644 --- a/src/Data/SafeCopy/Derive.hs +++ b/src/Data/SafeCopy/Derive.hs @@ -293,10 +293,10 @@ internalDeriveSafeCopyIndexedType deriveType versionId kindName typq tyIndex' = worker1 :: DeriveType -> Version a -> Name -> Name -> Type -> Cxt -> [TyVarBndr] -> [(Integer, Con)] -> Q [Dec] worker1 deriveType versionId kindName tyName tyBase context tyvars cons = - let ty = foldl AppT tyBase [ VarT $ tyVarName var | var <- tyvars ] + let ty = foldl AppT tyBase (fmap (\var -> VarT $ tyVarName var) tyvars) typeNameStr = pprWithoutSuffixes ppr (ConT tyName) - safeCopyClass args = foldl appT (conT ''SafeCopy) args - in (:[]) <$> instanceD (cxt $ [safeCopyClass [varT $ tyVarName var] | var <- tyvars] ++ map return context) + extraContext = fmap (\var -> AppT (ConT ''SafeCopy) (VarT $ tyVarName var)) tyvars + in (:[]) <$> instanceD (cxt (fmap pure (extraContext ++ context))) (pure (ConT ''SafeCopy `AppT` ty)) [ mkPutCopy deriveType cons , mkGetCopy deriveType typeNameStr cons @@ -308,10 +308,10 @@ worker2 :: DeriveType -> Version a -> Name -> [Name] -> Type -> Type -> Cxt -> [ worker2 _ _ _ _ itype tyBase _ _ _ | itype /= tyBase = fail $ "Expected " <> show itype <> ", but found " <> show tyBase worker2 deriveType versionId kindName tyIndex' _ tyBase context tyvars cons = do - let ty = foldl AppT tyBase [ VarT $ tyVarName var | var <- tyvars ] + let ty = foldl AppT tyBase (fmap (\var -> VarT $ tyVarName var) tyvars) typeNameStr = unwords (pprWithoutSuffixes ppr ty : map show tyIndex') - safeCopyClass args = foldl appT (conT ''SafeCopy) args - (:[]) <$> instanceD (cxt $ [safeCopyClass [varT $ tyVarName var] | var <- tyvars] ++ map return context) + extraContext = fmap (\var -> AppT (ConT ''SafeCopy) (VarT $ tyVarName var)) tyvars + (:[]) <$> instanceD (cxt (fmap pure (extraContext ++ context))) (pure (ConT ''SafeCopy `AppT` ty)) [ mkPutCopy deriveType cons , mkGetCopy deriveType typeNameStr cons From 14d91730f3f78b8bbbac608096ab28fa120c21e7 Mon Sep 17 00:00:00 2001 From: David Fox Date: Sun, 1 Dec 2024 09:17:06 -0800 Subject: [PATCH 16/17] Move the extra context code into an ExtraContext class. --- src/Data/SafeCopy/Derive.hs | 20 ++++++++++++++------ 1 file changed, 14 insertions(+), 6 deletions(-) diff --git a/src/Data/SafeCopy/Derive.hs b/src/Data/SafeCopy/Derive.hs index db8a835..fc7e2ac 100644 --- a/src/Data/SafeCopy/Derive.hs +++ b/src/Data/SafeCopy/Derive.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell, LambdaCase, CPP #-} +{-# LANGUAGE TemplateHaskell, LambdaCase, FlexibleInstances, CPP #-} module Data.SafeCopy.Derive where @@ -259,6 +259,14 @@ tyVarName (PlainTV n) = n tyVarName (KindedTV n _) = n #endif +class ExtraContext a where + extraContext :: a -> Q Cxt + +-- | Generate SafeCopy constraints for a list of type variables +instance ExtraContext [TyVarBndr] where + extraContext tyvars = + pure $ fmap (\var -> AppT (ConT ''SafeCopy) (VarT $ tyVarName var)) tyvars + internalDeriveSafeCopy :: DeriveType -> Version a -> Name -> TypeQ -> Q [Dec] internalDeriveSafeCopy deriveType versionId kindName typq = do typq >>= \case @@ -267,7 +275,9 @@ internalDeriveSafeCopy deriveType versionId kindName typq = do TyConI (DataD context _name tyvars _kind cons _derivs) | length cons > 255 -> fail $ "Can't derive SafeCopy instance for: " ++ show tyName ++ ". The datatype must have less than 256 constructors." - | otherwise -> worker1 deriveType versionId kindName tyName typ context tyvars (zip [0..] cons) + | otherwise -> do + extra <- extraContext tyvars + worker1 deriveType versionId kindName tyName typ (context ++ extra) tyvars (zip [0..] cons) TyConI (NewtypeD context _name tyvars _kind con _derivs) -> worker1 deriveType versionId kindName tyName typ context tyvars [(0, con)] @@ -295,8 +305,7 @@ worker1 :: DeriveType -> Version a -> Name -> Name -> Type -> Cxt -> [TyVarBndr] worker1 deriveType versionId kindName tyName tyBase context tyvars cons = let ty = foldl AppT tyBase (fmap (\var -> VarT $ tyVarName var) tyvars) typeNameStr = pprWithoutSuffixes ppr (ConT tyName) - extraContext = fmap (\var -> AppT (ConT ''SafeCopy) (VarT $ tyVarName var)) tyvars - in (:[]) <$> instanceD (cxt (fmap pure (extraContext ++ context))) + in (:[]) <$> instanceD (cxt (fmap pure context)) (pure (ConT ''SafeCopy `AppT` ty)) [ mkPutCopy deriveType cons , mkGetCopy deriveType typeNameStr cons @@ -310,8 +319,7 @@ worker2 _ _ _ _ itype tyBase _ _ _ | itype /= tyBase = worker2 deriveType versionId kindName tyIndex' _ tyBase context tyvars cons = do let ty = foldl AppT tyBase (fmap (\var -> VarT $ tyVarName var) tyvars) typeNameStr = unwords (pprWithoutSuffixes ppr ty : map show tyIndex') - extraContext = fmap (\var -> AppT (ConT ''SafeCopy) (VarT $ tyVarName var)) tyvars - (:[]) <$> instanceD (cxt (fmap pure (extraContext ++ context))) + (:[]) <$> instanceD (cxt (fmap pure context)) (pure (ConT ''SafeCopy `AppT` ty)) [ mkPutCopy deriveType cons , mkGetCopy deriveType typeNameStr cons From bd0147beb54abef7202a28bcd00c4ea11e0248d1 Mon Sep 17 00:00:00 2001 From: David Fox Date: Sun, 1 Dec 2024 10:41:43 -0800 Subject: [PATCH 17/17] * Add class ExtraContext(extraContext), used to compute extra constraints for different types. * Add an argument to the internal derive functions to pass a value which will be used by extraContext. * Add a test case that shows deriving SafeCopy for a type rather than a type name, and supplying extra context for the instance. --- src/Data/SafeCopy/Derive.hs | 82 ++++++++++++++++++++++++------------- test/instances.hs | 22 +++++++--- 2 files changed, 69 insertions(+), 35 deletions(-) diff --git a/src/Data/SafeCopy/Derive.hs b/src/Data/SafeCopy/Derive.hs index fc7e2ac..adbe625 100644 --- a/src/Data/SafeCopy/Derive.hs +++ b/src/Data/SafeCopy/Derive.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell, LambdaCase, FlexibleInstances, CPP #-} +{-# LANGUAGE TemplateHaskell, NoOverloadedStrings, LambdaCase, FlexibleInstances, CPP #-} module Data.SafeCopy.Derive where @@ -106,10 +106,10 @@ import Text.Regex.TDFA ((=~), MatchResult(MR)) -- version without any problems. deriveSafeCopy :: Version a -> Name -> Name -> Q [Dec] deriveSafeCopy versionId kindName tyName = - internalDeriveSafeCopy Normal versionId kindName (conT tyName) + internalDeriveSafeCopy Normal versionId kindName tyName (conT tyName) deriveSafeCopy' :: Version a -> Name -> TypeQ -> Q [Dec] -deriveSafeCopy' versionId kindName typ = internalDeriveSafeCopy Normal versionId kindName typ +deriveSafeCopy' versionId kindName typ = internalDeriveSafeCopy Normal versionId kindName typ typ deriveSafeCopyIndexedType :: Version a -> Name -> Name -> [Name] -> Q [Dec] deriveSafeCopyIndexedType versionId kindName tyName = @@ -174,7 +174,7 @@ deriveSafeCopySimple versionId kindName tyName = deriveSafeCopySimple' :: Version a -> Name -> TypeQ -> Q [Dec] deriveSafeCopySimple' versionId kindName typ = - internalDeriveSafeCopy Simple versionId kindName typ + internalDeriveSafeCopy Simple versionId kindName typ typ deriveSafeCopySimpleIndexedType :: Version a -> Name -> Name -> [Name] -> Q [Dec] deriveSafeCopySimpleIndexedType versionId kindName tyName = @@ -230,10 +230,11 @@ deriveSafeCopySimpleIndexedType' versionId kindName typ = -- without any problems. deriveSafeCopyHappstackData :: Version a -> Name -> Name -> Q [Dec] deriveSafeCopyHappstackData versionId kindName tyName = - deriveSafeCopyHappstackData' versionId kindName (conT tyName) + deriveSafeCopyHappstackData' versionId kindName (conT tyName) tyName -deriveSafeCopyHappstackData' :: Version a -> Name -> TypeQ -> Q [Dec] -deriveSafeCopyHappstackData' = internalDeriveSafeCopy HappstackData +deriveSafeCopyHappstackData' :: ExtraContext t => Version a -> Name -> TypeQ -> t -> Q [Dec] +deriveSafeCopyHappstackData' versionId kindName typq t = + internalDeriveSafeCopy HappstackData versionId kindName t typq deriveSafeCopyHappstackDataIndexedType :: Version a -> Name -> Name -> [Name] -> Q [Dec] deriveSafeCopyHappstackDataIndexedType versionId kindName tyName = @@ -263,30 +264,53 @@ class ExtraContext a where extraContext :: a -> Q Cxt -- | Generate SafeCopy constraints for a list of type variables +instance ExtraContext Cxt where + extraContext context = pure context + instance ExtraContext [TyVarBndr] where extraContext tyvars = pure $ fmap (\var -> AppT (ConT ''SafeCopy) (VarT $ tyVarName var)) tyvars -internalDeriveSafeCopy :: DeriveType -> Version a -> Name -> TypeQ -> Q [Dec] -internalDeriveSafeCopy deriveType versionId kindName typq = do +instance ExtraContext Name where + extraContext tyName = + reify tyName >>= \case + TyConI (DataD _ _ tyvars _ _ _) -> extraContext tyvars + TyConI (NewtypeD _ _ tyvars _ _ _) -> extraContext tyvars + FamilyI _ _ -> pure [] + info -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, info) + +instance ExtraContext TypeQ where + extraContext typq = + typq >>= \case + ConT tyName -> extraContext tyName + ForallT _ context _ -> pure context + typ -> fail $ "Can't derive SafeCopy instance for: " ++ show typ + +internalDeriveSafeCopy :: ExtraContext t => DeriveType -> Version a -> Name -> t -> TypeQ -> Q [Dec] +internalDeriveSafeCopy deriveType versionId kindName t typq = do typq >>= \case - typ@(ConT tyName) -> do - reify tyName >>= \case - TyConI (DataD context _name tyvars _kind cons _derivs) - | length cons > 255 -> fail $ "Can't derive SafeCopy instance for: " ++ show tyName ++ - ". The datatype must have less than 256 constructors." - | otherwise -> do - extra <- extraContext tyvars - worker1 deriveType versionId kindName tyName typ (context ++ extra) tyvars (zip [0..] cons) + ConT tyName -> doInfo deriveType versionId kindName t tyName =<< reify tyName + ForallT _ cxt' typ' -> internalDeriveSafeCopy deriveType versionId kindName cxt' (pure typ') + AppT t1 _t2 -> internalDeriveSafeCopy deriveType versionId kindName t (pure t1) + TupleT n -> let tyName = tupleTypeName n in doInfo deriveType versionId kindName t tyName =<< reify tyName + typ -> fail $ "Can't derive SafeCopy instance for: " ++ show typ - TyConI (NewtypeD context _name tyvars _kind con _derivs) -> - worker1 deriveType versionId kindName tyName typ context tyvars [(0, con)] +doInfo :: ExtraContext t => DeriveType -> Version a -> Name -> t -> Name -> Info -> Q [Dec] +doInfo deriveType versionId kindName t tyName info = + case info of + TyConI (DataD context _name tyvars _kind cons _derivs) + | length cons > 255 -> fail $ "Can't derive SafeCopy instance for: " ++ show tyName ++ + ". The datatype must have less than 256 constructors." + | otherwise -> do + extra <- extraContext t + worker1 deriveType versionId kindName tyName (ConT tyName) (context ++ extra) tyvars (zip [0..] cons) - FamilyI _ insts -> do - concat <$> (forM insts $ withInst typ (worker1 deriveType versionId kindName tyName)) - info -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, info) - -- typ@(Forall tyvars cxt' typ') -> undefined - typ -> fail $ "Can't derive SafeCopy instance for: " ++ show typ + TyConI (NewtypeD context _name tyvars _kind con _derivs) -> + worker1 deriveType versionId kindName tyName (ConT tyName) context tyvars [(0, con)] + + FamilyI _ insts -> do + concat <$> (forM insts $ withInst (ConT tyName) (worker1 deriveType versionId kindName tyName)) + _ -> fail $ "Can't derive SafeCopy instance for: " ++ show (tyName, info) internalDeriveSafeCopyIndexedType :: DeriveType -> Version a -> Name -> TypeQ -> [Name] -> Q [Dec] internalDeriveSafeCopyIndexedType deriveType versionId kindName typq tyIndex' = do @@ -517,11 +541,11 @@ fixChars s = -- * Remove suffixes on the four ids we export -- * Leave suffixes on all variables and type variables safeName :: Name -> Name -safeName (Name oc (NameG _ns _pn _mn)) = traceShowId $ Name oc NameS -safeName (Name oc (NameQ _mn)) = traceShowId $ Name oc NameS -safeName (Name oc@(OccName _) (NameU _)) = traceShowId $ Name oc NameS -safeName name@(Name _ (NameL _)) = traceShowId $ name -- Not seeing any of these -safeName name@(Name _ NameS) = traceShowId $ name +safeName (Name oc (NameG _ns _pn _mn)) = Name oc NameS +safeName (Name oc (NameQ _mn)) = Name oc NameS +safeName (Name oc@(OccName _) (NameU _)) = Name oc NameS +safeName name@(Name _ (NameL _)) = name -- Not seeing any of these +safeName name@(Name _ NameS) = name -- This will probably make the expression invalid, but it -- removes random elements that will make tests fail. diff --git a/test/instances.hs b/test/instances.hs index c51ea90..776d0d8 100644 --- a/test/instances.hs +++ b/test/instances.hs @@ -20,6 +20,7 @@ import Data.SafeCopy.Internal (pprWithoutSuffixes) import Data.Serialize (runPut, runGet) import Data.Time (UniversalTime(..), ZonedTime(..)) import Data.Tree (Tree) +import Data.Typeable (Typeable) import Language.Haskell.TH import Language.Haskell.TH.Instances () import Language.Haskell.TH.Syntax @@ -119,11 +120,20 @@ main = defaultMain $ testGroup "SafeCopy instances" [ testCase "deriveSafeCopy 0 'base ''(,,,,,,,)" $ do let decs = $(lift =<< deriveSafeCopy 0 'base ''(,,,,,,,)) pprWithoutSuffixes ppr decs @?= intercalate "\n" - ["instance (SafeCopy a, SafeCopy b, SafeCopy c, SafeCopy d, SafeCopy e, SafeCopy f, SafeCopy g, SafeCopy h) => SafeCopy ((,,,,,,,) a b c d e f g h)", - " where putCopy ((,,,,,,,) a1 a2 a3 a4 a5 a6 a7 a8) = contain (do {safePut_a <- getSafePut; safePut_b <- getSafePut; safePut_c <- getSafePut; safePut_d <- getSafePut; safePut_e <- getSafePut; safePut_f <- getSafePut; safePut_g <- getSafePut; safePut_h <- getSafePut; safePut_a a1; safePut_b a2; safePut_c a3; safePut_d a4; safePut_e a5; safePut_f a6; safePut_g a7; safePut_h a8; return ()})", - " getCopy = contain (label \"(,,,,,,,):\" (do {safeGet_a <- getSafeGet; safeGet_b <- getSafeGet; safeGet_c <- getSafeGet; safeGet_d <- getSafeGet; safeGet_e <- getSafeGet; safeGet_f <- getSafeGet; safeGet_g <- getSafeGet; safeGet_h <- getSafeGet; (((((((return (,,,,,,,) <*> safeGet_a) <*> safeGet_b) <*> safeGet_c) <*> safeGet_d) <*> safeGet_e) <*> safeGet_f) <*> safeGet_g) <*> safeGet_h}))", - " version = 0", - " kind = base", - " errorTypeName _ = \"(,,,,,,,)\""] + ["instance (SafeCopy a, SafeCopy b, SafeCopy c, SafeCopy d, SafeCopy e, SafeCopy f, SafeCopy g, SafeCopy h) => SafeCopy ((,,,,,,,) a b c d e f g h)", + " where putCopy ((,,,,,,,) a1 a2 a3 a4 a5 a6 a7 a8) = contain (do {safePut_a <- getSafePut; safePut_b <- getSafePut; safePut_c <- getSafePut; safePut_d <- getSafePut; safePut_e <- getSafePut; safePut_f <- getSafePut; safePut_g <- getSafePut; safePut_h <- getSafePut; safePut_a a1; safePut_b a2; safePut_c a3; safePut_d a4; safePut_e a5; safePut_f a6; safePut_g a7; safePut_h a8; return ()})", + " getCopy = contain (label \"(,,,,,,,):\" (do {safeGet_a <- getSafeGet; safeGet_b <- getSafeGet; safeGet_c <- getSafeGet; safeGet_d <- getSafeGet; safeGet_e <- getSafeGet; safeGet_f <- getSafeGet; safeGet_g <- getSafeGet; safeGet_h <- getSafeGet; (((((((return (,,,,,,,) <*> safeGet_a) <*> safeGet_b) <*> safeGet_c) <*> safeGet_d) <*> safeGet_e) <*> safeGet_f) <*> safeGet_g) <*> safeGet_h}))", + " version = 0", + " kind = base", + " errorTypeName _ = \"(,,,,,,,)\""] + , testCase "deriveSafeCopy' 0 'base [t(,,,,,,,)|]" $ do + let decs = $(lift =<< deriveSafeCopy' 0 'base [t|forall a b c d e f g h. (Show a, Typeable a, SafeCopy a, SafeCopy b, SafeCopy c, SafeCopy d, SafeCopy e, SafeCopy f, SafeCopy g, SafeCopy h) => (a,b,c,d,e,f,g,h)|]) + pprWithoutSuffixes ppr decs @?= intercalate "\n" + ["instance (Show a, Typeable a, SafeCopy a, SafeCopy b, SafeCopy c, SafeCopy d, SafeCopy e, SafeCopy f, SafeCopy g, SafeCopy h) => SafeCopy ((,,,,,,,) a b c d e f g h)", + " where putCopy ((,,,,,,,) a1 a2 a3 a4 a5 a6 a7 a8) = contain (do {safePut_a <- getSafePut; safePut_b <- getSafePut; safePut_c <- getSafePut; safePut_d <- getSafePut; safePut_e <- getSafePut; safePut_f <- getSafePut; safePut_g <- getSafePut; safePut_h <- getSafePut; safePut_a a1; safePut_b a2; safePut_c a3; safePut_d a4; safePut_e a5; safePut_f a6; safePut_g a7; safePut_h a8; return ()})", + " getCopy = contain (label \"(,,,,,,,):\" (do {safeGet_a <- getSafeGet; safeGet_b <- getSafeGet; safeGet_c <- getSafeGet; safeGet_d <- getSafeGet; safeGet_e <- getSafeGet; safeGet_f <- getSafeGet; safeGet_g <- getSafeGet; safeGet_h <- getSafeGet; (((((((return (,,,,,,,) <*> safeGet_a) <*> safeGet_b) <*> safeGet_c) <*> safeGet_d) <*> safeGet_e) <*> safeGet_f) <*> safeGet_g) <*> safeGet_h}))", + " version = 0", + " kind = base", + " errorTypeName _ = \"(,,,,,,,)\""] ] ]