diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 78bcf83e15..e38529378e 100644 --- a/.github/workflows/test.yml +++ b/.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" diff --git a/ghcide/src/Development/IDE/GHC/Compat/Util.hs b/ghcide/src/Development/IDE/GHC/Compat/Util.hs index 7c521e88e8..7d74909ac0 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Util.hs +++ b/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 diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index d44b072928..56c47d75c2 100644 --- a/haskell-language-server.cabal +++ b/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 diff --git a/plugins/hls-eval-plugin/hls-eval-plugin.cabal b/plugins/hls-eval-plugin/hls-eval-plugin.cabal index b923cf6517..3f585b33ed 100644 --- a/plugins/hls-eval-plugin/hls-eval-plugin.cabal +++ b/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 diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index 2ed90bab48..4b64ee894c 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/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) diff --git a/plugins/hls-eval-plugin/test/Main.hs b/plugins/hls-eval-plugin/test/Main.hs index cc2baa3ac6..2a2e11a1bc 100644 --- a/plugins/hls-eval-plugin/test/Main.hs +++ b/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" diff --git a/plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc94.expected.hs b/plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc94.expected.hs new file mode 100644 index 0000000000..5699e7517e --- /dev/null +++ b/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 :1:27 in interactive:Ghci2 +-- []