From c4413deac22d816f4822792457af4ad91b1603e7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Pawe=C5=82=20Dybiec?= Date: Sun, 9 Oct 2022 12:03:12 +0200 Subject: [PATCH 1/5] Make eval plugin compile at 94 This is work in progress, it will likely not compile for older ghc version, and so far it doesn't handle unit ids at all. It is hardcoded for package "blah" version 0.1.0.0 now. Proper solutions for those issues will show up in separate commits --- ghcide/src/Development/IDE/GHC/Compat/Util.hs | 6 +++++- haskell-language-server.cabal | 2 +- plugins/hls-eval-plugin/hls-eval-plugin.cabal | 2 +- .../src/Ide/Plugin/Eval/CodeLens.hs | 14 ++++++++------ 4 files changed, 15 insertions(+), 9 deletions(-) diff --git a/ghcide/src/Development/IDE/GHC/Compat/Util.hs b/ghcide/src/Development/IDE/GHC/Compat/Util.hs index 7c521e88e8..4db160aca7 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..ab3725354d 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 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..b58a3a6a75 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -250,6 +250,7 @@ runEvalCmd plId st EvalParams{..} = Target (TargetFile fp Nothing) False + (stringToUnitId "blah-0.1.0.0-inplace") (Just (textToStringBuffer mdlText, now)) -- Setup environment for evaluation @@ -331,7 +332,8 @@ 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] } + --let hscEnv'' = hscEnv' { hsc_HPT = addListToHpt (hsc_HPT hscEnv') [(moduleName $ mi_module $ hm_iface hm, hm) | lb <- lbs, let hm = linkableHomeMod lb] } + let hscEnv'' =hscUpdateHPT (flip addListToHpt [(moduleName $ mi_module $ hm_iface hm, hm) | lb <- lbs, let hm = linkableHomeMod lb] ) hscEnv' edits <- perf "edits" $ @@ -703,20 +705,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 +727,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) From 787dd742d77b281dfbe5375e59f0e619724bd36a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Pawe=C5=82=20Dybiec?= Date: Sun, 9 Oct 2022 21:34:43 +0200 Subject: [PATCH 2/5] Provide proper home unit id when using ghc 9.4 Also makes code compile (and still work) on ghc 9.2. --- .../src/Ide/Plugin/Eval/CodeLens.hs | 23 +++++++++++-------- 1 file changed, 14 insertions(+), 9 deletions(-) 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 b58a3a6a75..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,13 +245,6 @@ runEvalCmd plId st EvalParams{..} = now <- liftIO getCurrentTime - let modName = moduleName $ ms_mod ms - thisModuleTarget = - Target - (TargetFile fp Nothing) - False - (stringToUnitId "blah-0.1.0.0-inplace") - (Just (textToStringBuffer mdlText, now)) -- Setup environment for evaluation hscEnv' <- ExceptT $ fmap join $ liftIO . gStrictTry . evalGhcEnv session $ do @@ -309,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 @@ -332,9 +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] } - let hscEnv'' =hscUpdateHPT (flip addListToHpt [(moduleName $ mi_module $ hm_iface hm, hm) | lb <- lbs, let hm = linkableHomeMod lb] ) hscEnv' +#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 $ From 8af4d1cc61225a1d3c160224c6af83894999cbad Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Pawe=C5=82=20Dybiec?= Date: Thu, 13 Oct 2022 21:59:30 +0100 Subject: [PATCH 3/5] Enable eval tests for 9.4 --- .github/workflows/test.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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" From a19c09c43159e7b0b9a418b557e094c1658eaff1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Pawe=C5=82=20Dybiec?= Date: Thu, 13 Oct 2022 22:56:47 +0100 Subject: [PATCH 4/5] Fix formatting --- ghcide/src/Development/IDE/GHC/Compat/Util.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/GHC/Compat/Util.hs b/ghcide/src/Development/IDE/GHC/Compat/Util.hs index 4db160aca7..7d74909ac0 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Util.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Util.hs @@ -74,7 +74,7 @@ module Development.IDE.GHC.Compat.Util ( ) where #if MIN_VERSION_ghc(9,4,0) -import GHC.Data.Bool (OverridingBool(..)) +import GHC.Data.Bool (OverridingBool (..)) #endif #if MIN_VERSION_ghc(9,0,0) From 692ade2c4a8777a0f8f7cb4d539daab8dc1dbc6a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Pawe=C5=82=20Dybiec?= Date: Sat, 15 Oct 2022 00:15:11 +0100 Subject: [PATCH 5/5] Update partially hls-eval-plugin tests to ghc94 --- plugins/hls-eval-plugin/hls-eval-plugin.cabal | 2 +- plugins/hls-eval-plugin/test/Main.hs | 24 +++++++++---------- .../testdata/TPropertyError.ghc94.expected.hs | 13 ++++++++++ 3 files changed, 26 insertions(+), 13 deletions(-) create mode 100644 plugins/hls-eval-plugin/test/testdata/TPropertyError.ghc94.expected.hs diff --git a/plugins/hls-eval-plugin/hls-eval-plugin.cabal b/plugins/hls-eval-plugin/hls-eval-plugin.cabal index ab3725354d..3f585b33ed 100644 --- a/plugins/hls-eval-plugin/hls-eval-plugin.cabal +++ b/plugins/hls-eval-plugin/hls-eval-plugin.cabal @@ -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/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 +-- []