Merge pull request #6 from obsidiansystems/aa/th-218

Compatibility with template-haskell 2.18-2.20; Drop ghc 9.2 and 9.4
obsidiansystems · Aug 2, 2023 · c6b916a · c6b916a
2 parents 9a83b0a + a1ce14d
commit c6b916a
Show file tree

Hide file tree

Showing 16 changed files with 211 additions and 38 deletions.
diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml
@@ -6,7 +6,7 @@ jobs:
   build:
     strategy:
       matrix:
-        ghc: ['8.6.5', '8.8.4', '8.10.2', '9.0.1']
+        ghc: ['8.4.4', '8.6.5', '8.8.4', '8.10.7', '9.0.2', '9.6.1']
         os: ['ubuntu-latest', 'macos-latest']
     runs-on: ${{ matrix.os }}
 
@@ -16,8 +16,9 @@ jobs:
     - uses: haskell/actions/setup@v2
       with:
         ghc-version: ${{ matrix.ghc }}
+        cabal-version: '3.10.1.0'
     - name: Cache
-      uses: actions/cache@v1
+      uses: actions/cache@v3
       env:
         cache-name: cache-cabal
       with:
@@ -30,12 +31,10 @@ jobs:
           ${{ runner.os }}
 
     - name: Install dependencies
-      run: |
-        cabal update
-        cabal build all --only-dependencies --enable-tests --enable-benchmarks
+      run: cabal build --only-dependencies --enable-tests --enable-benchmarks
     - name: Build
       run: cabal build --enable-tests --enable-benchmarks all
     - name: Run tests
-      run: cabal test all
+      run: cabal test --enable-tests all
     - name: Build Docs
-      run: cabal haddock all
+      run: cabal haddock
diff --git a/ChangeLog.md b/ChangeLog.md
@@ -1,5 +1,11 @@
 # Revision history for dependent-sum-template
 
+## 0.2.0.0 - 2023-08-01
+
+* Recover compatibility with template-haskell 2.18, which was lost in 0.1.2.0
+* deriveGShow will generate code that uses Show instances for every argument to a constructor, apart from those of the type that it is generating an instance for.
+* Drop support for GHC 9.2 and 9.4 due to [a bug in reifyInstances](https://gitlab.haskell.org/ghc/ghc/-/issues/23743)
+
 ## 0.1.2.0 - 2023-07-11
 
 * Rework a lot of the logic using th-abstraction to get structural information about data types and to

diff --git a/dep/nixpkgs/default.nix b/dep/nixpkgs/default.nix
@@ -0,0 +1,2 @@
+# DO NOT HAND-EDIT THIS FILE
+import (import ./thunk.nix)
diff --git a/dep/nixpkgs/github.json b/dep/nixpkgs/github.json
@@ -0,0 +1,8 @@
+{
+  "owner": "NixOS",
+  "repo": "nixpkgs",
+  "branch": "nixpkgs-unstable",
+  "private": false,
+  "rev": "c7eb65213bd7d95eafb8c5e2e181f04da103d054",
+  "sha256": "1glf6j13hbwi459qrc8kkkhfw27a08vdg17sr3zwhadg4bkxz5ia"
+}
diff --git a/dep/nixpkgs/thunk.nix b/dep/nixpkgs/thunk.nix
@@ -0,0 +1,12 @@
+# DO NOT HAND-EDIT THIS FILE
+let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:
+  if !fetchSubmodules && !private then builtins.fetchTarball {
+    url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;
+  } else (import (builtins.fetchTarball {
+  url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz";
+  sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr";
+}) {}).fetchFromGitHub {
+    inherit owner repo rev sha256 fetchSubmodules private;
+  };
+  json = builtins.fromJSON (builtins.readFile ./github.json);
+in fetch json
diff --git a/dep/reflex-platform/default.nix b/dep/reflex-platform/default.nix
@@ -0,0 +1,2 @@
+# DO NOT HAND-EDIT THIS FILE
+import (import ./thunk.nix)
diff --git a/dep/reflex-platform/github.json b/dep/reflex-platform/github.json
@@ -0,0 +1,8 @@
+{
+  "owner": "reflex-frp",
+  "repo": "reflex-platform",
+  "branch": "release/1.0.1.0",
+  "private": false,
+  "rev": "50099ce2bca93ef69cea615ec72152b4a7648de4",
+  "sha256": "1ldzf3qznpysf4drkrvj7ysmdvrv6ddprnniylvcxccpp0f4krb7"
+}
diff --git a/dep/reflex-platform/thunk.nix b/dep/reflex-platform/thunk.nix
@@ -0,0 +1,12 @@
+# DO NOT HAND-EDIT THIS FILE
+let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:
+  if !fetchSubmodules && !private then builtins.fetchTarball {
+    url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;
+  } else (import (builtins.fetchTarball {
+  url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz";
+  sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr";
+}) {}).fetchFromGitHub {
+    inherit owner repo rev sha256 fetchSubmodules private;
+  };
+  json = builtins.fromJSON (builtins.readFile ./github.json);
+in fetch json
diff --git a/dependent-sum-template.cabal b/dependent-sum-template.cabal
@@ -1,5 +1,5 @@
 name:                   dependent-sum-template
-version:                0.1.2.0
+version:                0.2.0.0
 stability:              experimental
 
 cabal-version:          >= 1.10
@@ -14,12 +14,12 @@ category:               Unclassified
 synopsis:               Template Haskell code to generate instances of classes in some package
 description:            Template Haskell code to generate instances of classes in some package, such as 'GEq' and 'GCompare'.
 
-tested-with:            GHC == 8.0.2,
-                        GHC == 8.2.2,
-                        GHC == 8.4.4,
+tested-with:            GHC == 8.4.4,
                         GHC == 8.6.5,
-                        GHC == 8.8.3,
-                        GHC == 9.0.1
+                        GHC == 8.8.4,
+                        GHC == 8.10.7,
+                        GHC == 9.0.2,
+                        GHC == 9.6.1
 
 extra-source-files:     ChangeLog.md
                       , ReadMe.md
@@ -41,7 +41,7 @@ Library
                         some >= 1.0.1 && < 1.1,
                         containers >= 0.5.9.2,
                         mtl,
-                        template-haskell,
+                        template-haskell >= 2.11 && < 2.21,
                         th-abstraction >= 0.4
 
 test-suite test

diff --git a/release.nix b/release.nix
@@ -0,0 +1,100 @@
+{ reflex-platform ? import ./dep/reflex-platform
+, supportedSystems ? [ "x86_64-linux" "x86_64-darwin" ]
+}:
+let
+  name = "dependent-sum-template";
+  pkgs = (reflex-platform {}).nixpkgs;
+  inherit (pkgs) lib;
+  haskellLib = pkgs.haskell.lib;
+  commonOverrides = self: super: {
+    vty = self.callHackageDirect {
+      pkg = "vty";
+      ver = "5.38";
+      sha256 = "0kcd3ln9xmc62ka0i7habzvjjar8z63mlvl15rdhf8hqmda0b7r7";
+    } {};
+    reflex-vty = self.callHackageDirect {
+      pkg = "reflex-vty";
+      ver = "0.4.1.1";
+      sha256 = "1dzkfhfwifl47fvvzd40yqvyckpc3q6d9g18az9mqlbxfhszfb45";
+    } {};
+  };
+  ghcs = lib.genAttrs supportedSystems (system: let
+    rp = reflex-platform { inherit system; __useNewerCompiler = true; };
+    rpGhc810 = rp.ghc.override {
+      overrides = commonOverrides;
+    };
+    rpOld = reflex-platform { inherit system; __useNewerCompiler = false; };
+    rpGhc865 = rpOld.ghc.override {
+      overrides = commonOverrides;
+    };
+
+    nixGhc884 = (import ./dep/nixpkgs { inherit system; }).haskell.packages.ghc884;
+    nixGhc902 = (import ./dep/nixpkgs { inherit system; }).haskell.packages.ghc902;
+    nixGhc925 = (import ./dep/nixpkgs { inherit system; }).haskell.packages.ghc925;
+    nixGhc945 = (import ./dep/nixpkgs { inherit system; }).haskell.packages.ghc945;
+    nixGhc961 = (import ./dep/nixpkgs { inherit system; }).haskell.packages.ghc961.override {
+      overrides = self: super: commonOverrides self super // {
+        patch = self.callHackageDirect {
+          pkg = "patch";
+          ver = "0.0.8.2";
+          sha256 = "160zqqhjg48fr3a33gffd82qm3728c8hwf8sn37pbpv82fw71rzg";
+        } {};
+
+        reflex = self.callHackageDirect {
+          pkg = "reflex";
+          ver = "0.9.0.1";
+          sha256 = "1yrcashxxclvlvv3cs5gv75rvlsg1gb0m36kssnk2zvhbh94240y";
+        } {};
+        these-lens = self.callHackageDirect {
+          pkg = "these-lens";
+          ver = "1.0.1.3";
+          sha256 = "0n1vkr57jz5yvy4jm15v5cs42rp342ni0gisib7aqyhibpicqs5c";
+        } {};
+        these = self.callHackageDirect {
+          pkg = "these";
+          ver = "1.2";
+          sha256 = "1iaaq1fsvg8c3l0czcicshkmbbr00hnwkdamjbkljsa1qvlilaf0";
+        } {};
+        lens = self.callHackageDirect {
+          pkg = "lens";
+          ver = "5.2.2";
+          sha256 = "0c4a421sxfjm1cj3nvgwkr4glll23mqnsvs2iv5qh85931h2f3cy";
+        } {};
+
+        assoc = self.callHackageDirect {
+          pkg = "assoc";
+          ver = "1.1";
+          sha256 = "1krvcafrbj98z5hv55gq4zb1in5yd71nmz9zdiqgnywjzbrvpf75";
+        } {};
+
+        strict = self.callHackageDirect {
+          pkg = "strict";
+          ver = "0.5";
+          sha256 = "02iyvrr7nd7fnivz78lzdchy8zw1cghqj1qx2yzbbb9869h1mny7";
+        } {};
+        vty = self.callHackageDirect {
+          pkg = "vty";
+          ver = "5.38";
+          sha256 = "0kcd3ln9xmc62ka0i7habzvjjar8z63mlvl15rdhf8hqmda0b7r7";
+        } {};
+
+
+        # Jailbroken until https://github.com/audreyt/string-qq/pull/3
+        string-qq = haskellLib.dontCheck super.string-qq;
+        # Tests aren't compatible with transformers-0.6
+        bimap = haskellLib.dontCheck super.bimap;
+        exception-transformers = haskellLib.doJailbreak (haskellLib.dontCheck super.exception-transformers);
+
+      };
+    };
+  in
+  {
+    recurseForDerivations = true;
+    ghc865 = rpGhc865.callCabal2nix name (import ./src.nix) {};
+    ghc884 = rpGhc865.callCabal2nix name (import ./src.nix) {};
+    ghc810 = rpGhc810.callCabal2nix name (import ./src.nix) {};
+    ghc902 = nixGhc902.callCabal2nix name (import ./src.nix) {};
+    ghc961 = nixGhc961.callCabal2nix name (import ./src.nix) {};
+  });
+  in
+    ghcs
diff --git a/shell.nix b/shell.nix
@@ -0,0 +1,4 @@
+{ system ? builtins.currentSystem
+, ghc ? "ghc810" # or ghc961
+}:
+(import ./release.nix {}).${system}.${ghc}.env
diff --git a/src.nix b/src.nix
@@ -0,0 +1,8 @@
+builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [
+  "release.nix"
+  ".git"
+  "dist"
+  "cabal.haskell-ci"
+  "cabal.project"
+  ".travis.yml"
+])) ./.
diff --git a/src/Data/GADT/Compare/TH.hs b/src/Data/GADT/Compare/TH.hs
@@ -85,10 +85,12 @@ geqClause paramVars con = do
       _ -> lift $ noBindS [| guard ($(varE l) == $(varE r)) |]
   ret <- lift $ noBindS [| return Refl |]
 
-  return $ Clause
-    [ ConP conName (map VarP lArgNames)
-    , ConP conName (map VarP rArgNames) ]
-    ( NormalB (doUnqualifiedE (stmts ++ [ret])))
+  pats <- lift $ sequence
+    [ conP conName (map varP lArgNames)
+    , conP conName (map varP rArgNames)
+    ]
+  pure $ Clause pats
+    (NormalB (doUnqualifiedE (stmts ++ [ret])))
     []
 
 class DeriveGCompare t where
@@ -150,10 +152,13 @@ gcompareClauses paramVars con = do
 
   ret <- lift $ noBindS [| return GEQ |]
 
-  let main = Clause
-        [ ConP conName (map VarP lArgNames)
-        , ConP conName (map VarP rArgNames) ]
-        ( NormalB (AppE (VarE 'runGComparing) (doUnqualifiedE (stmts ++ [ret]))))
+
+  pats <- lift $ sequence
+        [ conP conName (map varP lArgNames)
+        , conP conName (map varP rArgNames)
+        ]
+  let main = Clause pats
+        (NormalB (AppE (VarE 'runGComparing) (doUnqualifiedE (stmts ++ [ret]))))
         []
       lt = Clause [RecP conName [], WildP] (NormalB (ConE 'GLT)) []
       gt = Clause [WildP, RecP conName []] (NormalB (ConE 'GGT)) []

diff --git a/src/Data/GADT/Show/TH.hs b/src/Data/GADT/Show/TH.hs
@@ -66,24 +66,16 @@ gshowClause typeName paramVars con = do
 
   argShowExprs <- forM (zip argNames argTypes) $ \(n,t) -> do
     let useShow = do
-          tell [AppT (ConT ''Show) t]
+          u <- lift $ reifyInstancesWithRigids paramVars ''Show [t]
+          case u of
+            (_:_) -> return ()
+            _ -> tell [AppT (ConT ''Show) t]
           return [| showsPrec 11 $(varE n) |]
     case t of
       AppT tyFun tyArg -> do
-        let useGShow = do
-              tell [AppT (ConT ''GShow) tyFun]
-              return [| gshowsPrec 11 $(varE n) |]
         if isApplicationOf (ConT typeName) tyFun
           then return [| gshowsPrec 11 $(varE n) |]
-          else do
-            v <- lift $ reifyInstancesWithRigids paramVars ''GShow [tyFun]
-            case v of
-              (_:_) -> useGShow
-              _ -> do
-                u <- lift $ reifyInstancesWithRigids paramVars ''Show [t]
-                case u of
-                  (_:_) -> useShow
-                  [] -> useGShow
+          else useShow
       _ -> useShow
 
   let precPat = if null argNames

diff --git a/src/Data/GADT/TH/Internal.hs b/src/Data/GADT/TH/Internal.hs
@@ -6,12 +6,14 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DataKinds #-}
 
 -- | Shared functions for dependent-sum-template
 module Data.GADT.TH.Internal where
 
 import Control.Monad
 import Control.Monad.Writer
+import qualified Data.Kind
 import Data.List (foldl', drop)
 import Data.Maybe
 import Data.Map (Map)
@@ -50,8 +52,21 @@ skolemize rigids t = case t of
   ParensT t -> ParensT (skolemize rigids t)
   _ -> t
 
+reifyInstancesBroken :: Q Bool
+reifyInstancesBroken = do
+  a <- newName "a"
+  ins <- reifyInstancesWithRigids' (Set.singleton a) ''Show [VarT a]
+  pure $ not $ null ins
+
+reifyInstancesWithRigids' :: Set Name -> Name -> [Type] -> Q [InstanceDec]
+reifyInstancesWithRigids' rigids cls tys = reifyInstances cls (map (skolemize rigids) tys)
+
 reifyInstancesWithRigids :: Set Name -> Name -> [Type] -> Q [InstanceDec]
-reifyInstancesWithRigids rigids cls tys = reifyInstances cls (map (skolemize rigids) tys)
+reifyInstancesWithRigids rigids cls tys = do
+  isBroken <- reifyInstancesBroken
+  if isBroken
+    then fail "Unsupported GHC version: 'reifyInstances' in this version of GHC returns instances when we expect an empty list. See https://gitlab.haskell.org/ghc/ghc/-/issues/23743"
+    else reifyInstancesWithRigids' rigids cls tys
 
 -- | Determine the type variables which occur freely in a type.
 freeTypeVariables :: Type -> Set Name

diff --git a/test/test.hs b/test/test.hs
@@ -180,7 +180,7 @@ do
         [d|
             instance GEq a => GEq (SpleebHard a)
             instance GCompare a => GCompare (SpleebHard a)
-            instance GShow a => GShow (SpleebHard a)
+            instance (Show (a Double), Show (a Int), GShow Qux, GShow Foo) => GShow (SpleebHard a)
           |]
 
     concat <$> sequence
@@ -189,7 +189,7 @@ do
         , deriveGShow    gshowInst
         ]
 
-instance GShow a => Show (SpleebHard a b) where showsPrec = gshowsPrec
+instance (Show (a Double), Show (a Int), GShow Qux, GShow Foo) => Show (SpleebHard a b) where showsPrec = gshowsPrec
 
 data SpleebHard2 a b where
     PH2 :: a Double -> Qux b -> SpleebHard2 a b