Merge pull request #76 from Bodigrim/master

Support GHC HEAD
nomeata · Dec 29, 2023 · a9b0c86 · a9b0c86
2 parents 56d9e34 + 3900229
commit a9b0c86
Show file tree

Hide file tree

Showing 4 changed files with 42 additions and 25 deletions.
diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml
@@ -8,9 +8,9 @@
 #
 # For more information, see https://github.com/haskell-CI/haskell-ci
 #
-# version: 0.16.3
+# version: 0.17.20231219
 #
-# REGENDATA ("0.16.3",["github","inspection-testing.cabal","--ghcup-jobs","--last-in-series","--no-cabal-check"])
+# REGENDATA ("0.17.20231219",["github","inspection-testing.cabal","--ghcup-jobs","--last-in-series","--no-cabal-check"])
 #
 name: Haskell-CI
 on:
@@ -28,19 +28,24 @@ jobs:
     strategy:
       matrix:
         include:
-          - compiler: ghc-9.6.2
+          - compiler: ghc-9.8.1
             compilerKind: ghc
-            compilerVersion: 9.6.2
+            compilerVersion: 9.8.1
             setup-method: ghcup
             allow-failure: false
-          - compiler: ghc-9.4.5
+          - compiler: ghc-9.6.3
             compilerKind: ghc
-            compilerVersion: 9.4.5
+            compilerVersion: 9.6.3
             setup-method: ghcup
             allow-failure: false
-          - compiler: ghc-9.2.7
+          - compiler: ghc-9.4.8
             compilerKind: ghc
-            compilerVersion: 9.2.7
+            compilerVersion: 9.4.8
+            setup-method: ghcup
+            allow-failure: false
+          - compiler: ghc-9.2.8
+            compilerKind: ghc
+            compilerVersion: 9.2.8
             setup-method: ghcup
             allow-failure: false
           - compiler: ghc-9.0.2
@@ -85,10 +90,10 @@ jobs:
           apt-get update
           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.19.2/x86_64-linux-ghcup-0.1.19.2 > "$HOME/.ghcup/bin/ghcup"
+          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" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false)
-          "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
+          "$HOME/.ghcup/bin/ghcup" install cabal 3.10.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
         env:
           HCKIND: ${{ matrix.compilerKind }}
           HCNAME: ${{ matrix.compiler }}
@@ -100,11 +105,13 @@ jobs:
           echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV"
           echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV"
           HCDIR=/opt/$HCKIND/$HCVER
-          HC=$HOME/.ghcup/bin/$HCKIND-$HCVER
+          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=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV"
-          echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV"
-          echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV"
+          echo "HCPKG=$HCPKG" >> "$GITHUB_ENV"
+          echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV"
+          echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.2.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"

diff --git a/examples/NS_NP.hs b/examples/NS_NP.hs
@@ -3,13 +3,14 @@
 {-# OPTIONS_GHC -O -fplugin-opt=Test.Inspection.Plugin:quiet -Wno-overlapping-patterns #-}
 module NS_NP (main) where
 
+import Data.Kind
 import Test.Inspection
 
-data NS (f :: k -> *) (xs :: [k]) where
+data NS (f :: k -> Type) (xs :: [k]) where
   Z :: f x -> NS f (x : xs)
   S :: !(NS f xs) -> NS f (x : xs)
 
-data NP (f :: k -> *) (xs :: [k]) where
+data NP (f :: k -> Type) (xs :: [k]) where
   Nil  :: NP f '[]
   (:*) :: f x -> !(NP f xs) -> NP f (x : xs)
 

diff --git a/inspection-testing.cabal b/inspection-testing.cabal
@@ -34,7 +34,7 @@ copyright:           2017 Joachim Breitner
 build-type:          Simple
 extra-source-files:  ChangeLog.md, README.md
 cabal-version:       >=1.10
-Tested-With:         GHC == 8.0.2, GHC == 8.2.*, GHC == 8.4.*, GHC ==8.6.*, GHC ==8.8.*, GHC ==8.10.*, GHC ==9.0.*, GHC ==9.2.*, GHC ==9.4.*, GHC ==9.6.*
+Tested-With:         GHC == 8.0.2, GHC == 8.2.*, GHC == 8.4.*, GHC ==8.6.*, GHC ==8.8.*, GHC ==8.10.*, GHC ==9.0.*, GHC ==9.2.*, GHC ==9.4.*, GHC ==9.6.*, GHC ==9.8.*
 
 source-repository head
   type:     git
@@ -45,8 +45,8 @@ library
                        Test.Inspection.Plugin
                        Test.Inspection.Core
   hs-source-dirs:      src
-  build-depends:       base >=4.9 && <4.20
-  build-depends:       ghc >= 8.0.2 && <9.9
+  build-depends:       base >=4.9 && <4.21
+  build-depends:       ghc >= 8.0.2 && <9.11
   build-depends:       template-haskell
   build-depends:       containers
   build-depends:       transformers

diff --git a/src/Test/Inspection/Core.hs b/src/Test/Inspection/Core.hs
@@ -188,9 +188,11 @@ type VarPairSet = S.Set VarPair
 -- (This is mostly to work-around the buggy CSE in GHC-8.0)
 -- It also breaks if there is shadowing.
 eqSlice :: Equivalence -> Slice -> Slice -> Bool
-eqSlice _ slice1 slice2 | null slice1 || null slice2 = null slice1 == null slice2
+eqSlice _ [] [] = True
+eqSlice _ _ [] = False
+eqSlice _ [] _ = False
   -- Mostly defensive programming (slices should not be empty)
-eqSlice eqv slice1 slice2
+eqSlice eqv slice1@((head1, _) : _) slice2@((head2, _) : _)
     -- slices are equal if there exist any result with no "unification" obligations left.
     = any (S.null . snd) results
   where
@@ -210,7 +212,7 @@ eqSlice eqv slice1 slice2
 
     -- results. If there are no pairs to be equated, all is fine.
     results :: [((), VarPairSet)]
-    results = runStateT (loop' (mkRnEnv2 emptyInScopeSet) S.empty (fst (head slice1)) (fst (head slice2))) S.empty
+    results = runStateT (loop' (mkRnEnv2 emptyInScopeSet) S.empty head1 head2) S.empty
 
     -- while there are obligations left, try to equate them.
     loop :: RnEnv2 -> VarPairSet -> StateT VarPairSet [] ()
@@ -266,7 +268,7 @@ eqSlice eqv slice1 slice2
     essentiallyVar (Lam v e)  | it, isTyCoVar v = essentiallyVar e
     essentiallyVar (Cast e _) | it              = essentiallyVar e
 #if MIN_VERSION_ghc(9,0,0)
-    essentiallyVar (Case s _ _ [Alt _ _ e]) | it, isUnsafeEqualityProof s = essentiallyVar e
+    essentiallyVar (Case s b _ alts) | it, Just e <- isUnsafeEqualityCase s b alts = essentiallyVar e
 #endif
     essentiallyVar (Var v)                      = Just v
     essentiallyVar (Tick HpcTick{} e) | it      = essentiallyVar e
@@ -294,8 +296,8 @@ eqSlice eqv slice1 slice2
     go lv env (Cast e1 _) e2 | it             = go lv env e1 e2
     go lv env e1 (Cast e2 _) | it             = go lv env e1 e2
 #if MIN_VERSION_ghc(9,0,0)
-    go lv env (Case s _ _ [Alt _ _ e1]) e2 | it, isUnsafeEqualityProof s = go lv env e1 e2
-    go lv env e1 (Case s _ _ [Alt _ _ e2]) | it, isUnsafeEqualityProof s = go lv env e1 e2
+    go lv env (Case s b _ alts) e2 | it, Just e1 <- isUnsafeEqualityCase s b alts = go lv env e1 e2
+    go lv env e1 (Case s b _ alts) | it, Just e2 <- isUnsafeEqualityCase s b alts = go lv env e1 e2
 #endif
     go lv env (Cast e1 co1) (Cast e2 co2)     = traceBlock lv "CAST" "" $ \lv -> do
                                                    guard (eqCoercionX env co1 co2)
@@ -382,6 +384,13 @@ eqSlice eqv slice1 slice2
         -- continue with the rest of bindings, adding a pair as matching one.
         goBinds lv (rnBndr2 env v1 v2) xs ys
 
+#if !MIN_VERSION_ghc(9,9,0) && MIN_VERSION_ghc(9,0,0)
+isUnsafeEqualityCase :: CoreExpr -> Id -> [CoreAlt] -> Maybe CoreExpr
+isUnsafeEqualityCase scrut _bndr [Alt _ _ rhs]
+  | isUnsafeEqualityProof scrut = Just rhs
+isUnsafeEqualityCase _ _ _ = Nothing
+#endif
+
 #if !MIN_VERSION_ghc(9,2,0)
 type CoreTickish = Tickish Id
 #endif