Make eval plugin work at ghc 9.4

.github/workflows/test.yml

@@ -177,7 +177,7 @@ jobs:
         name: Test hls-pragmas-plugin
         run: cabal test hls-pragmas-plugin --test-options="$TEST_OPTS" || cabal test hls-pragmas-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-pragmas-plugin --test-options="$TEST_OPTS"
 
-      - if: matrix.test && matrix.ghc != '9.4.2'
+      - if: matrix.test
         name: Test hls-eval-plugin
         run: cabal test hls-eval-plugin --test-options="$TEST_OPTS" || cabal test hls-eval-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-eval-plugin --test-options="$TEST_OPTS"
 

ghcide/src/Development/IDE/GHC/Compat/Util.hs

@@ -24,7 +24,7 @@ module Development.IDE.GHC.Compat.Util (
     LBooleanFormula,
     BooleanFormula(..),
     -- * OverridingBool
-#if !MIN_VERSION_ghc(9,3,0)
+#if !MIN_VERSION_ghc(9,5,0)
     OverridingBool(..),
 #endif
     -- * Maybes
@@ -73,6 +73,10 @@ module Development.IDE.GHC.Compat.Util (
     atEnd,
     ) where
 
+#if MIN_VERSION_ghc(9,4,0)
+import           GHC.Data.Bool           (OverridingBool (..))
+#endif
+
 #if MIN_VERSION_ghc(9,0,0)
 import           Control.Exception.Safe  (MonadCatch, catch, try)
 import           GHC.Data.Bag

haskell-language-server.cabal

@@ -216,7 +216,7 @@ common haddockComments
     cpp-options: -Dhls_haddockComments
 
 common eval
-  if flag(eval) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
+  if flag(eval) && (impl(ghc < 9.5) || flag(ignore-plugins-ghc-bounds))
     build-depends: hls-eval-plugin ^>= 1.3
     cpp-options: -Dhls_eval
 

plugins/hls-eval-plugin/hls-eval-plugin.cabal

@@ -37,7 +37,7 @@ source-repository head
   location: https://github.com/haskell/haskell-language-server
 
 library
-  if impl(ghc >= 9.3)
+  if impl(ghc >= 9.5)
     buildable: False
   else
     buildable: True
@@ -101,7 +101,7 @@ library
     TypeOperators
 
 test-suite tests
-  if impl(ghc >= 9.3)
+  if impl(ghc >= 9.5)
     buildable: False
   else
     buildable: True

plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs

@@ -245,12 +245,6 @@ runEvalCmd plId st EvalParams{..} =
 
             now <- liftIO getCurrentTime
 
-            let modName = moduleName $ ms_mod ms
-                thisModuleTarget =
-                    Target
-                        (TargetFile fp Nothing)
-                        False
-                        (Just (textToStringBuffer mdlText, now))
 
             -- Setup environment for evaluation
             hscEnv' <- ExceptT $ fmap join $ liftIO . gStrictTry . evalGhcEnv session $ do
@@ -308,6 +302,15 @@ runEvalCmd plId st EvalParams{..} =
                 -- BUG: this fails for files that requires preprocessors (e.g. CPP) for ghc < 8.8
                 -- see https://gitlab.haskell.org/ghc/ghc/-/issues/17066
                 -- and https://hackage.haskell.org/package/ghc-8.10.1/docs/GHC.html#v:TargetFile
+                let modName = moduleName $ ms_mod ms
+                    thisModuleTarget =
+                        Target
+                            (TargetFile fp Nothing)
+                            False
+#if MIN_VERSION_ghc(9,3,0)
+                            (homeUnitId_ $ hsc_dflags session)
+#endif
+                            (Just (textToStringBuffer mdlText, now))
                 eSetTarget <- gStrictTry $ setTargets [thisModuleTarget]
                 dbg "setTarget" eSetTarget
 
@@ -331,8 +334,12 @@ runEvalCmd plId st EvalParams{..} =
             lbs <- liftIO $ runAction "eval: GetLinkables" st $ do
               linkables_needed <- reachableModules <$> use_ GetDependencyInformation nfp
               uses_ GetLinkable (filter (/= nfp) linkables_needed) -- We don't need the linkable for the current module
-            let hscEnv'' = hscEnv' { hsc_HPT  = addListToHpt (hsc_HPT hscEnv') [(moduleName $ mi_module $ hm_iface hm, hm) | lb <- lbs, let hm = linkableHomeMod lb] }
 
+#if MIN_VERSION_ghc(9,3,0)
+            let hscEnv'' = hscUpdateHPT (flip addListToHpt  [(moduleName $ mi_module $ hm_iface hm, hm) | lb <- lbs, let hm = linkableHomeMod lb] ) hscEnv'
+#else
+            let hscEnv'' = hscEnv' { hsc_HPT  = addListToHpt (hsc_HPT hscEnv') [(moduleName $ mi_module $ hm_iface hm, hm) | lb <- lbs, let hm = linkableHomeMod lb] }
+#endif
             edits <-
                 perf "edits" $
                     liftIO $
@@ -703,20 +710,20 @@ doKindCmd :: Bool -> DynFlags -> Text -> Ghc (Maybe Text)
 doKindCmd False df arg = do
     let input = T.strip arg
     (_, kind) <- typeKind False $ T.unpack input
-    let kindText = text (T.unpack input) <+> "::" <+> pprTypeForUser kind
+    let kindText = text (T.unpack input) <+> "::" <+> pprSigmaType kind
     pure $ Just $ T.pack (showSDoc df kindText)
 doKindCmd True df arg = do
     let input = T.strip arg
     (ty, kind) <- typeKind True $ T.unpack input
-    let kindDoc = text (T.unpack input) <+> "::" <+> pprTypeForUser kind
-        tyDoc = "=" <+> pprTypeForUser ty
+    let kindDoc = text (T.unpack input) <+> "::" <+> pprSigmaType kind
+        tyDoc = "=" <+> pprSigmaType ty
     pure $ Just $ T.pack (showSDoc df $ kindDoc $$ tyDoc)
 
 doTypeCmd :: DynFlags -> Text -> Ghc (Maybe Text)
 doTypeCmd dflags arg = do
     let (emod, expr) = parseExprMode arg
     ty <- GHC.exprType emod $ T.unpack expr
-    let rawType = T.strip $ T.pack $ showSDoc dflags $ pprTypeForUser ty
+    let rawType = T.strip $ T.pack $ showSDoc dflags $ pprSigmaType ty
         broken = T.any (\c -> c == '\r' || c == '\n') rawType
     pure $
         Just $
@@ -725,7 +732,7 @@ doTypeCmd dflags arg = do
                     T.pack $
                         showSDoc dflags $
                             text (T.unpack expr)
-                                $$ nest 2 ("::" <+> pprTypeForUser ty)
+                                $$ nest 2 ("::" <+> pprSigmaType ty)
                 else expr <> " :: " <> rawType <> "\n"
 
 parseExprMode :: Text -> (TcRnExprMode, T.Text)

plugins/hls-eval-plugin/test/Main.hs

@@ -73,29 +73,29 @@ tests =
       evalInFile "T8.hs" "-- >>> noFunctionWithThisName" "-- Variable not in scope: noFunctionWithThisName"
       evalInFile "T8.hs" "-- >>> res = \"a\" + \"bc\"" $
         if
-           | ghcVersion == GHC92 -> "-- No instance for (Num String) arising from a use of `+'\n-- In the expression: \"a\" + \"bc\"\n-- In an equation for `res': res = \"a\" + \"bc\""
+           | ghcVersion >= GHC92 -> "-- No instance for (Num String) arising from a use of `+'\n-- In the expression: \"a\" + \"bc\"\n-- In an equation for `res': res = \"a\" + \"bc\""
            | ghcVersion == GHC90 -> "-- No instance for (Num String) arising from a use of ‘+’"
            | otherwise -> "-- No instance for (Num [Char]) arising from a use of ‘+’"
       evalInFile "T8.hs" "-- >>> \"" "-- lexical error in string/character literal at end of input"
       evalInFile "T8.hs" "-- >>> 3 `div` 0" "-- divide by zero" -- The default for marking exceptions is False
   , goldenWithEval "Applies file LANGUAGE extensions" "T9" "hs"
-  , goldenWithEval' "Evaluate a type with :kind!" "T10" "hs" (if ghcVersion == GHC92 then "ghc92.expected" else "expected")
-  , goldenWithEval' "Reports an error for an incorrect type with :kind!" "T11" "hs" (if ghcVersion == GHC92 then "ghc92.expected" else "expected")
-  , goldenWithEval' "Shows a kind with :kind" "T12" "hs" (if ghcVersion == GHC92 then "ghc92.expected" else "expected")
-  , goldenWithEval' "Reports an error for an incorrect type with :kind" "T13" "hs" (if ghcVersion == GHC92 then "ghc92.expected" else "expected")
+  , goldenWithEval' "Evaluate a type with :kind!" "T10" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected")
+  , goldenWithEval' "Reports an error for an incorrect type with :kind!" "T11" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected")
+  , goldenWithEval' "Shows a kind with :kind" "T12" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected")
+  , goldenWithEval' "Reports an error for an incorrect type with :kind" "T13" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected")
   , goldenWithEval "Returns a fully-instantiated type for :type" "T14" "hs"
   , knownBrokenForGhcVersions [GHC92] "type +v does not work anymore with 9.2" $ goldenWithEval "Returns an uninstantiated type for :type +v, admitting multiple whitespaces around arguments" "T15" "hs"
   , goldenWithEval "Returns defaulted type for :type +d, admitting multiple whitespaces around arguments" "T16" "hs"
-  , goldenWithEval' ":type reports an error when given with unknown +x option" "T17" "hs" (if ghcVersion == GHC92 then "ghc92.expected" else "expected")
+  , goldenWithEval' ":type reports an error when given with unknown +x option" "T17" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected")
   , goldenWithEval "Reports an error when given with unknown command" "T18" "hs"
   , goldenWithEval "Returns defaulted type for :type +d reflecting the default declaration specified in the >>> prompt" "T19" "hs"
   , expectFailBecause "known issue - see a note in P.R. #361" $
-      goldenWithEval' ":type +d reflects the `default' declaration of the module" "T20" "hs" (if ghcVersion == GHC92 then "ghc92.expected" else "expected")
+      goldenWithEval' ":type +d reflects the `default' declaration of the module" "T20" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected")
   , testCase ":type handles a multilined result properly" $
       evalInFile "T21.hs" "-- >>> :type fun" $ T.unlines [
         "-- fun",
         if
-           | ghcVersion == GHC92 -> "--   :: forall {k1} (k2 :: Nat) (n :: Nat) (a :: k1)."
+           | ghcVersion >= GHC92 -> "--   :: forall {k1} (k2 :: Nat) (n :: Nat) (a :: k1)."
            | ghcVersion == GHC90 -> "--   :: forall {k1} {k2 :: Nat} {n :: Nat} {a :: k1}."
            | otherwise -> "--   :: forall k1 (k2 :: Nat) (n :: Nat) (a :: k1).",
         "--      (KnownNat k2, KnownNat n, Typeable a) =>",
@@ -105,7 +105,7 @@ tests =
   , testCase ":type does \"dovetails\" for short identifiers" $
       evalInFile "T23.hs" "-- >>> :type f" $ T.unlines [
         if
-          | ghcVersion == GHC92 -> "-- f :: forall {k1} (k2 :: Nat) (n :: Nat) (a :: k1)."
+          | ghcVersion >= GHC92 -> "-- f :: forall {k1} (k2 :: Nat) (n :: Nat) (a :: k1)."
           | ghcVersion == GHC90 -> "-- f :: forall {k1} {k2 :: Nat} {n :: Nat} {a :: k1}."
           | otherwise -> "-- f :: forall k1 (k2 :: Nat) (n :: Nat) (a :: k1).",
         "--      (KnownNat k2, KnownNat n, Typeable a) =>",
@@ -124,17 +124,17 @@ tests =
   , goldenWithEval "Transitive local dependency" "TTransitive" "hs"
   -- , goldenWithEval "Local Modules can be imported in a test" "TLocalImportInTest" "hs"
   , goldenWithEval "Setting language option TupleSections" "TLanguageOptionsTupleSections" "hs"
-  , goldenWithEval' ":set accepts ghci flags" "TFlags" "hs" (if ghcVersion == GHC92 then "ghc92.expected" else "expected")
+  , goldenWithEval' ":set accepts ghci flags" "TFlags" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected")
   , testCase ":set -fprint-explicit-foralls works" $ do
       evalInFile "T8.hs" "-- >>> :t id" "-- id :: a -> a"
       evalInFile "T8.hs" "-- >>> :set -fprint-explicit-foralls\n-- >>> :t id"
-        (if ghcVersion == GHC92
+        (if ghcVersion >= GHC92
            then "-- id :: forall a. a -> a"
            else "-- id :: forall {a}. a -> a")
   , goldenWithEval "The default language extensions for the eval plugin are the same as those for ghci" "TSameDefaultLanguageExtensionsAsGhci" "hs"
   , goldenWithEval "IO expressions are supported, stdout/stderr output is ignored" "TIO" "hs"
   , goldenWithEval "Property checking" "TProperty" "hs"
-  , goldenWithEval "Property checking with exception" "TPropertyError" "hs"
+  , goldenWithEval' "Property checking with exception" "TPropertyError" "hs"  (if ghcVersion >= GHC94 then "ghc94.expected" else "expected")
   , goldenWithEval "Prelude has no special treatment, it is imported as stated in the module" "TPrelude" "hs"
   , goldenWithEval "Don't panic on {-# UNPACK #-} pragma" "TUNPACK" "hs"
   , goldenWithEval "Can handle eval inside nested comment properly" "TNested" "hs"

plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc94.expected.hs

@@ -0,0 +1,13 @@
+-- Support for property checking
+module TProperty where
+
+-- prop> \(l::[Bool]) -> head l
+-- *** Failed! (after 1 test):
+-- Exception:
+--   Prelude.head: empty list
+--   CallStack (from HasCallStack):
+--     error, called at libraries/base/GHC/List.hs:1646:3 in base:GHC.List
+--     errorEmptyList, called at libraries/base/GHC/List.hs:85:11 in base:GHC.List
+--     badHead, called at libraries/base/GHC/List.hs:81:28 in base:GHC.List
+--     head, called at <interactive>:1:27 in interactive:Ghci2
+-- []