Merge pull request #114 from con-kitty/fixing-9.2.1

Fix concat-satisfy on GHC 9.2.1
compiling-to-categories · Dec 14, 2023 · d95c79d · d95c79d
2 parents 83f06ae + 5aa593b
commit d95c79d
Show file tree

Hide file tree

Showing 7 changed files with 41 additions and 37 deletions.
diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml
@@ -11,11 +11,13 @@ jobs:
   build:
     runs-on: ubuntu-latest
     strategy:
+      fail-fast: false
       matrix:
         ghc:
-          - "9.0.2"
-          - "9.2.4"
-          - "9.4.8"
+          - "9.0.1"
+          - "9.2.1"
+          - "9.2.2" # has breaking changes relative to 9.2.1
+          - "9.4.1"
     steps:
       - uses: actions/checkout@v2
       - uses: haskell/actions/setup@v1

diff --git a/classes/concat-classes.cabal b/classes/concat-classes.cabal
@@ -1,4 +1,4 @@
--- Initial concat.cabal generated by cabal init.  For further 
+-- Initial concat.cabal generated by cabal init.  For further
 -- documentation, see http://haskell.org/cabal/users-guide/
 
 name:                concat-classes
@@ -25,7 +25,7 @@ library
   include-dirs:        src
   install-includes:    ConCat/Ops.inc
   build-depends:       base >=4.9
-                     , constraints >= 0.8
+                     , constraints >= 0.8 && < 0.14
                      , containers >= 0.5.7.1
                      , ghc-prim >= 0.5.0.0
                      , newtype-generics >= 0.5.3
@@ -38,7 +38,7 @@ library
                      , concat-inline
                      , concat-satisfy
                      , concat-known
-  exposed-modules:     
+  exposed-modules:
                        ConCat.Orphans
                        ConCat.Misc
                        ConCat.Rep

diff --git a/examples/concat-examples.cabal b/examples/concat-examples.cabal
@@ -29,7 +29,7 @@ library
   install-includes:    ConCat/AbsTy.inc
   build-depends:       base >=4.9
                      , newtype-generics >= 0.5.3
-                     , constraints >= 0.8
+                     , constraints >= 0.8 && < 0.14
                      , containers >= 0.5.7.1
                      , keys >= 3.11
                      , pointed

diff --git a/plugin/concat-plugin.cabal b/plugin/concat-plugin.cabal
@@ -1,4 +1,4 @@
--- Initial concat.cabal generated by cabal init.  For further 
+-- Initial concat.cabal generated by cabal init.  For further
 -- documentation, see http://haskell.org/cabal/users-guide/
 
 name:                concat-plugin
@@ -36,7 +36,7 @@ library
                      , finite-typelits, vector-sized >= 1.0.0.0
                      , concat-classes
                      , concat-satisfy
-  exposed-modules:     
+  exposed-modules:
                        ConCat
                        ConCat.Translators
                        ConCat.OkType
@@ -60,18 +60,16 @@ Executable misc-examples
   Build-Depends:    base<5
                   , Cabal >= 1.24.0.0
                   , ghc-prim
-                  , constraints >= 0.8
+                  , constraints >= 0.8 && < 0.14
                   , newtype-generics >= 0.5.3
                   , pointed, keys
                   , distributive, adjunctions
                   , concat-inline
                   , concat-classes
                   , concat-plugin
                   , concat-examples
-                  , ghc-prim
                   , integer-gmp
-                  , distributive, adjunctions
-                  , constraints >= 0.8
+                  , constraints >= 0.8 && < 0.14
                   -- Array/vector experiments
                   , finite-typelits, vector-sized >= 1.0.0.0
   ghc-options:      -O2
@@ -88,19 +86,15 @@ Executable misc-trace
   Build-Depends:    base<5
                   , Cabal >= 1.24.0.0
                   , ghc-prim
-                  , constraints >= 0.8
+                  , constraints >= 0.8 && < 0.14
                   , newtype-generics >= 0.5.3
                   , pointed, keys
                   , distributive, adjunctions
                   , concat-inline
                   , concat-classes
                   , concat-plugin
                   , concat-examples
-                  , ghc-prim
                   , integer-gmp
-                  , keys
-                  , distributive, adjunctions
-                  , constraints >= 0.8
                   -- Array/vector experiments
                   , finite-typelits, vector-sized
   ghc-options:      -O2
@@ -119,7 +113,7 @@ Test-Suite gold-tests
   Build-Depends:    base<5
                   , Cabal >= 1.24.0.0
                   , ghc-prim
-                  , constraints >= 0.8
+                  , constraints >= 0.8 && < 0.14
                   , newtype-generics >= 0.5.3
                   , pointed, keys
                   , distributive, adjunctions
@@ -128,10 +122,7 @@ Test-Suite gold-tests
                   , concat-classes
                   , concat-plugin
                   , concat-examples
-                  , ghc-prim
                   , integer-gmp
-                  , distributive, adjunctions
-                  , constraints >= 0.8
                   , bytestring
                   , tasty
                   , tasty-golden

diff --git a/plugin/src/ConCat/NormaliseType.hs b/plugin/src/ConCat/NormaliseType.hs
@@ -1,7 +1,10 @@
+{-# LANGUAGE CPP #-}
+
 -- | Utility functions for normalising, comparing types modulo type families.
-module ConCat.NormaliseType(runDsM, normaliseTypeM, eqTypeM, runTcForSolver) where
+module ConCat.NormaliseType (eqTypeM) where
 
 import GHC.Plugins
+#if MIN_VERSION_GLASGOW_HASKELL(9,4,0,0)
 import GHC.HsToCore.Monad
 import Data.Maybe (maybe)
 import GHC.HsToCore.Monad
@@ -10,6 +13,20 @@ import GHC.Tc.Instance.Family (tcGetFamInstEnvs)
 import GHC.Core.FamInstEnv (normaliseType)
 import GHC.Core.Reduction (reductionReducedType)
 import GHC.Tc.Types (TcM)
+#endif
+
+-- | compare two types after first normalising out type families
+eqTypeM :: HscEnv -> DynFlags -> ModGuts -> Type -> Type -> IO Bool
+#if MIN_VERSION_GLASGOW_HASKELL(9,4,0,0)
+eqTypeM env dflags guts ty1 ty2 =
+  if ty1 `eqType` ty2
+  then return True
+  else
+  runTcForSolver env dflags guts $ do
+    famInstEnvs <- tcGetFamInstEnvs
+    let reduction1 = normaliseType famInstEnvs Nominal ty1
+    let reduction2 = normaliseType famInstEnvs Nominal ty2
+    return (reductionReducedType reduction1 `eqType` reductionReducedType reduction2)
 
 -- | run a DsM program inside IO
 runDsM :: HscEnv -> DynFlags -> ModGuts -> DsM a -> IO a
@@ -31,16 +48,6 @@ normaliseTypeM env dflags guts ty =
     famInstEnvs <- tcGetFamInstEnvs
     let reduction = normaliseType famInstEnvs Nominal ty
     return (reductionReducedType reduction)
-
--- | compare two types after first normalising out type families
-eqTypeM :: HscEnv -> DynFlags -> ModGuts -> Type -> Type -> IO Bool
-eqTypeM env dflags guts ty1 ty2 =
-  if ty1 `eqType` ty2
-  then return True
-  else
-  runTcForSolver env dflags guts $ do
-    famInstEnvs <- tcGetFamInstEnvs
-    let reduction1 = normaliseType famInstEnvs Nominal ty1
-    let reduction2 = normaliseType famInstEnvs Nominal ty2
-    return (reductionReducedType reduction1 `eqType` reductionReducedType reduction2)
-
+#else
+eqTypeM _ _ _ ty1 ty2 = pure $ ty1 `eqType` ty2
+#endif
diff --git a/plugin/src/ConCat/Plugin.hs b/plugin/src/ConCat/Plugin.hs
@@ -1682,9 +1682,11 @@ install opts todos =
                     , sm_eta_expand = False -- ??
                     , sm_case_case  = True
                     , sm_dflags     = dflags
+#if MIN_VERSION_GLASGOW_HASKELL(9,2,2,0)
+                    , sm_cast_swizzle = True
+#endif
 #if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
                     , sm_uf_opts    = unfoldingOpts dflags
-                    , sm_cast_swizzle = True
                     , sm_pre_inline = gopt Opt_SimplPreInlining dflags
                     , sm_logger     = hsc_logger hsc_env
 #endif

diff --git a/satisfy/src/ConCat/Satisfy/Plugin.hs b/satisfy/src/ConCat/Satisfy/Plugin.hs
@@ -80,6 +80,8 @@ install _opts todos =
                             , sm_case_case  = True
 #if MIN_VERSION_GLASGOW_HASKELL(9,2,2,0)
                             , sm_cast_swizzle  = True
+#endif
+#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0)
                             , sm_uf_opts = defaultUnfoldingOpts
                             , sm_pre_inline = False
                             , sm_logger = logger