Exactprint plugins for 9.8 (#3973)

* Exactprint plugins for 9.8

* Fix last test

* comments

* fix borked cpp

* Don't use CPP in refactor plugin tests

* Fix -Wall, -Wunused-packages and hlint warnings in call-hierarchy plugin (#3979)

* Fix -Wall and -Wunused-packages in call-hierarchy plugin

* Make tests more uniform

* accept func test differences

* Run tests for 9.8 plugins in CI

* Fix another test

---------

Co-authored-by: Jan Hrcek <[email protected]>
Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com>

Author: 3 people

.github/workflows/test.yml

@@ -135,15 +135,15 @@ jobs:
           HLS_WRAPPER_TEST_EXE: hls-wrapper
         run: cabal test wrapper-test --test-options="$TEST_OPTS --rerun-log-file .tasty-rerun-log-wrapper"
 
-      - if: matrix.test && !startsWith(matrix.ghc,'9.8')
+      - if: matrix.test
         name: Test hls-refactor-plugin
         run: cabal test hls-refactor-plugin --test-options="$TEST_OPTS" || cabal test hls-refactor-plugin --test-options="$TEST_OPTS"
 
       - if: matrix.test && matrix.ghc != '9.6' && !startsWith(matrix.ghc,'9.8')
         name: Test hls-floskell-plugin
         run: cabal test hls-floskell-plugin --test-options="$TEST_OPTS" || cabal test hls-floskell-plugin --test-options="$TEST_OPTS"
 
-      - if: matrix.test && !startsWith(matrix.ghc,'9.8')
+      - if: matrix.test
         name: Test hls-class-plugin
         run: cabal test hls-class-plugin --test-options="$TEST_OPTS" || cabal test hls-class-plugin --test-options="$TEST_OPTS"
 
@@ -155,7 +155,7 @@ jobs:
         name: Test hls-eval-plugin
         run: cabal test hls-eval-plugin --test-options="$TEST_OPTS" || cabal test hls-eval-plugin --test-options="$TEST_OPTS"
 
-      - if: matrix.test && !startsWith(matrix.ghc,'9.8')
+      - if: matrix.test
         name: Test hls-splice-plugin
         run: cabal test hls-splice-plugin --test-options="$TEST_OPTS" || cabal test hls-splice-plugin --test-options="$TEST_OPTS"
 
@@ -183,7 +183,7 @@ jobs:
         name: Test hls-call-hierarchy-plugin test suite
         run: cabal test hls-call-hierarchy-plugin --test-options="$TEST_OPTS" || cabal test hls-call-hierarchy-plugin --test-options="$TEST_OPTS"
 
-      - if: matrix.test && matrix.os != 'windows-latest' && !startsWith(matrix.ghc,'9.8')
+      - if: matrix.test && matrix.os != 'windows-latest'
         name: Test hls-rename-plugin test suite
         run: cabal test hls-rename-plugin --test-options="$TEST_OPTS" || cabal test hls-rename-plugin --test-options="$TEST_OPTS"
 
@@ -211,7 +211,7 @@ jobs:
         name: Test hls-change-type-signature test suite
         run: cabal test hls-change-type-signature-plugin --test-options="$TEST_OPTS" || cabal test hls-change-type-signature-plugin --test-options="$TEST_OPTS"
 
-      - if: matrix.test && !startsWith(matrix.ghc,'9.8')
+      - if: matrix.test
         name: Test hls-gadt-plugin test suit
         run: cabal test hls-gadt-plugin --test-options="$TEST_OPTS" || cabal test hls-gadt-plugin --test-options="$TEST_OPTS"
 
@@ -232,7 +232,7 @@ jobs:
         name: Test hls-cabal-plugin test suite
         run: cabal test hls-cabal-plugin --test-options="$TEST_OPTS" || cabal test hls-cabal-plugin --test-options="$TEST_OPTS"
 
-      - if: matrix.test && !startsWith(matrix.ghc,'9.8')
+      - if: matrix.test
         name: Test hls-retrie-plugin test suite
         run: cabal test hls-retrie-plugin --test-options="$TEST_OPTS" || cabal test hls-retrie-plugin --test-options="$TEST_OPTS"
 

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

@@ -408,6 +408,7 @@ module Development.IDE.GHC.Compat.Core (
 #endif
     groupOrigin,
     isVisibleFunArg,
+    lookupGlobalRdrEnv,
     ) where
 
 import qualified GHC
@@ -825,3 +826,7 @@ mkSimpleTarget df fp = Target (TargetFile fp Nothing) True (homeUnitId_ df) Noth
 #else
 mkSimpleTarget _ fp = Target (TargetFile fp Nothing) True Nothing
 #endif
+
+#if MIN_VERSION_ghc(9,7,0)
+lookupGlobalRdrEnv gre_env occ = lookupGRE gre_env (LookupOccName occ AllRelevantGREs)
+#endif

haskell-language-server.cabal

@@ -217,7 +217,7 @@ common cabal
     cpp-options: -Dhls_cabal
 
 common class
-  if flag(class) && (impl(ghc < 9.8.0) || flag(ignore-plugins-ghc-bounds))
+  if flag(class)
     build-depends: hls-class-plugin == 2.6.0.0
     cpp-options: -Dhls_class
 
@@ -237,12 +237,12 @@ common importLens
     cpp-options: -Dhls_importLens
 
 common rename
-  if flag(rename) && (impl(ghc < 9.8.0) || flag(ignore-plugins-ghc-bounds))
+  if flag(rename)
     build-depends: hls-rename-plugin == 2.6.0.0
     cpp-options: -Dhls_rename
 
 common retrie
-  if flag(retrie) && (impl(ghc < 9.8.0) || flag(ignore-plugins-ghc-bounds))
+  if flag(retrie)
     build-depends: hls-retrie-plugin == 2.6.0.0
     cpp-options: -Dhls_retrie
 
@@ -267,7 +267,7 @@ common pragmas
     cpp-options: -Dhls_pragmas
 
 common splice
-  if flag(splice) && (impl(ghc < 9.8.0) || flag(ignore-plugins-ghc-bounds))
+  if flag(splice)
     build-depends: hls-splice-plugin == 2.6.0.0
     cpp-options: -Dhls_splice
 
@@ -292,7 +292,7 @@ common changeTypeSignature
     cpp-options: -Dhls_changeTypeSignature
 
 common gadt
-  if flag(gadt) && (impl(ghc < 9.8.0) || flag(ignore-plugins-ghc-bounds))
+  if flag(gadt)
     build-depends: hls-gadt-plugin == 2.6.0.0
     cpp-options: -Dhls_gadt
 
@@ -334,7 +334,7 @@ common stylishHaskell
     cpp-options: -Dhls_stylishHaskell
 
 common refactor
-  if flag(refactor) && (impl(ghc < 9.8.0) || flag(ignore-plugins-ghc-bounds))
+  if flag(refactor)
     build-depends: hls-refactor-plugin == 2.6.0.0
     cpp-options: -Dhls_refactor
 

plugins/hls-class-plugin/hls-class-plugin.cabal

@@ -29,11 +29,6 @@ common warnings
 
 library
   import: warnings
-  -- Plugins that need exactprint have not been updated for 9.8 yet
-  if impl(ghc >= 9.8)
-    buildable: False
-  else
-    buildable: True
   exposed-modules:    Ide.Plugin.Class
   other-modules:      Ide.Plugin.Class.CodeAction
                     , Ide.Plugin.Class.CodeLens
@@ -66,10 +61,6 @@ library
 
 test-suite tests
   import: warnings
-  if impl(ghc >= 9.8)
-    buildable: False
-  else
-    buildable: True
   type:             exitcode-stdio-1.0
   default-language: Haskell2010
   hs-source-dirs:   test

plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE RecordWildCards  #-}
 {-# LANGUAGE TypeFamilies     #-}
 {-# LANGUAGE ViewPatterns     #-}
+{-# LANGUAGE CPP              #-}
 
 module Ide.Plugin.Class.Types where
 
@@ -207,7 +208,11 @@ getInstanceBindTypeSigsRule recorder = do
         (hscEnv -> hsc) <- useMT GhcSession nfp
         let binds = collectHsBindsBinders $ tcg_binds gblEnv
         (_, maybe [] catMaybes -> instanceBinds) <- liftIO $
-            initTcWithGbl hsc gblEnv ghostSpan $ traverse bindToSig binds
+            initTcWithGbl hsc gblEnv ghostSpan
+#if MIN_VERSION_ghc(9,7,0)
+              $ liftZonkM
+#endif
+              $ traverse bindToSig binds
         pure $ InstanceBindTypeSigsResult instanceBinds
     where
         bindToSig id = do

plugins/hls-gadt-plugin/hls-gadt-plugin.cabal

@@ -20,11 +20,6 @@ source-repository head
     location: https://github.com/haskell/haskell-language-server.git
 
 library
-  -- Plugins that need exactprint have not been updated for 9.8 yet
-  if impl(ghc >= 9.8)
-    buildable: False
-  else
-    buildable: True
   exposed-modules:    Ide.Plugin.GADT
   other-modules:      Ide.Plugin.GHC
 
@@ -55,10 +50,6 @@ library
   default-extensions: DataKinds
 
 test-suite tests
-  if impl(ghc >= 9.8)
-    buildable: False
-  else
-    buildable: True
   type:             exitcode-stdio-1.0
   default-language: Haskell2010
   hs-source-dirs:   test

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

@@ -35,14 +35,8 @@ tests = testGroup "GADT"
     , runTest "ConstructorContext" "ConstructorContext" 2 0 2 38
     , runTest "Context" "Context" 2 0 4 41
     , runTest "Pragma" "Pragma" 2 0 3 29
-    , onlyWorkForGhcVersions (`elem`[GHC92, GHC94, GHC96]) "Single deriving has different output on ghc9.2+" $
-        runTest "SingleDerivingGHC92" "SingleDerivingGHC92" 2 0 3 14
-    , knownBrokenForGhcVersions [GHC92,GHC94,GHC96] "Single deriving has different output on ghc9.2+" $
-        runTest "SingleDeriving" "SingleDeriving" 2 0 3 14
-    , onlyWorkForGhcVersions (`elem`[GHC92, GHC94, GHC96]) "only ghc-9.2+ enabled GADTs pragma implicitly" $
-        gadtPragmaTest "ghc-9.2 don't need to insert GADTs pragma" False
-    , knownBrokenForGhcVersions [GHC92,GHC94,GHC96] "ghc-9.2 has enabled GADTs pragma implicitly" $
-        gadtPragmaTest "insert pragma" True
+    , runTest "SingleDerivingGHC92" "SingleDerivingGHC92" 2 0 3 14
+    , gadtPragmaTest "ghc-9.2 don't need to insert GADTs pragma" False
     ]
 
 gadtPragmaTest :: TestName -> Bool -> TestTree

plugins/hls-refactor-plugin/hls-refactor-plugin.cabal

@@ -26,11 +26,6 @@ common warnings
 
 library
   import: warnings
-  -- Plugins that need exactprint have not been updated for 9.8 yet
-  if impl(ghc >= 9.8)
-    buildable: False
-  else
-    buildable: True
   exposed-modules:  Development.IDE.GHC.ExactPrint
                     Development.IDE.GHC.Compat.ExactPrint
                     Development.IDE.Plugin.CodeAction
@@ -102,10 +97,6 @@ library
 
 test-suite tests
   import: warnings
-  if impl(ghc >= 9.8)
-    buildable: False
-  else
-    buildable: True
   type:             exitcode-stdio-1.0
   default-language: Haskell2010
   hs-source-dirs:   test

plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs

@@ -123,7 +123,11 @@ showAstDataHtml a0 = html $
 
             sourceText :: SourceText -> SDoc
             sourceText NoSourceText     = text "NoSourceText"
+#if MIN_VERSION_ghc(9,7,0)
+            sourceText (SourceText src) = text "SourceText" <+> ftext src
+#else
             sourceText (SourceText src) = text "SourceText" <+> text src
+#endif
 
             epaAnchor :: EpaLocation -> SDoc
 #if MIN_VERSION_ghc(9,5,0)

plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs

@@ -938,7 +938,11 @@ suggestExtendImport :: ExportsMap -> ParsedSource -> Diagnostic -> [(T.Text, Cod
 suggestExtendImport exportsMap (L _ HsModule {hsmodImports}) Diagnostic{_range=_range,..}
     | Just [binding, mod, srcspan] <-
       matchRegexUnifySpaces _message
+#if MIN_VERSION_ghc(9,7,0)
+      "Add ‘([^’]*)’ to the import list in the import of ‘([^’]*)’ *\\(at (.*)\\)."
+#else
       "Perhaps you want to add ‘([^’]*)’ to the import list in the import of ‘([^’]*)’ *\\((.*)\\)."
+#endif
     = suggestions hsmodImports binding mod srcspan
     | Just (binding, mod_srcspan) <-
       matchRegExMultipleImports _message
@@ -965,9 +969,13 @@ suggestExtendImport exportsMap (L _ HsModule {hsmodImports}) Diagnostic{_range=_
           | otherwise = []
         lookupExportMap binding mod
           | let em = getExportsMap exportsMap
+#if MIN_VERSION_ghc(9,7,0)
+                match = mconcat $ lookupOccEnv_AllNameSpaces em (mkVarOrDataOcc binding)
+#else
                 match1 = lookupOccEnv em (mkVarOrDataOcc binding)
                 match2 = lookupOccEnv em (mkTypeOcc binding)
           , Just match <- match1 <> match2
+#endif
           -- Only for the situation that data constructor name is same as type constructor name,
           -- let ident with parent be in front of the one without.
           , sortedMatch <- sortBy (\ident1 ident2 -> parent ident2 `compare` parent ident1) (Set.toList match)
@@ -1165,9 +1173,20 @@ suggestFixConstructorImport Diagnostic{_range=_range,..}
     -- import Data.Aeson.Types( Result( Success ) )
     -- or
     -- import Data.Aeson.Types( Result(..) ) (lsp-ui)
+    --
+    -- On 9.8+
+    --
+    -- In the import of ‘ModuleA’:
+    -- an item called ‘Constructor’
+    -- is exported, but it is a data constructor of
+    -- ‘A’.
   | Just [constructor, typ] <-
     matchRegexUnifySpaces _message
+#if MIN_VERSION_ghc(9,7,0)
+    "an item called ‘([^’]*)’ is exported, but it is a data constructor of ‘([^’]*)’"
+#else
     "‘([^’]*)’ is a data constructor of ‘([^’]*)’ To import it use"
+#endif
   = let fixedImport = typ <> "(" <> constructor <> ")"
     in [("Fix import of " <> fixedImport, TextEdit _range fixedImport)]
   | otherwise = []
@@ -1434,7 +1453,11 @@ suggestNewImport df packageExportsMap ps fileContents Diagnostic{..}
             *> extractQualifiedModuleNameFromMissingName (extractTextInRange _range fileContents)
   , Just (range, indent) <- newImportInsertRange ps fileContents
   , extendImportSuggestions <- matchRegexUnifySpaces msg
+#if MIN_VERSION_ghc(9,7,0)
+    "Add ‘[^’]*’ to the import list in the import of ‘([^’]*)’"
+#else
     "Perhaps you want to add ‘[^’]*’ to the import list in the import of ‘([^’]*)’"
+#endif
   = let qis = qualifiedImportStyle df
         -- FIXME: we can use thingMissing once the support for GHC 9.4 is dropped.
         -- In what fllows, @missing@ is assumed to be qualified name.
@@ -1952,30 +1975,32 @@ regexSingleMatch msg regex = case matchRegexUnifySpaces msg regex of
     Just (h:_) -> Just h
     _          -> Nothing
 
--- | Parses tuples like (‘Data.Map’, (app/ModuleB.hs:2:1-18)) and
--- | return (Data.Map, app/ModuleB.hs:2:1-18)
-regExPair :: (T.Text, T.Text) -> Maybe (T.Text, T.Text)
-regExPair (modname, srcpair) = do
-  x <- regexSingleMatch modname "‘([^’]*)’"
-  y <- regexSingleMatch srcpair "\\((.*)\\)"
-  return (x, y)
-
 -- | Process a list of (module_name, filename:src_span) values
 -- | Eg. [(Data.Map, app/ModuleB.hs:2:1-18), (Data.HashMap.Strict, app/ModuleB.hs:3:1-29)]
 regExImports :: T.Text -> Maybe [(T.Text, T.Text)]
-regExImports msg = result
-  where
-    parts = T.words msg
-    isPrefix = not . T.isPrefixOf "("
-    (mod, srcspan) = partition isPrefix  parts
-    -- check we have matching pairs like (Data.Map, (app/src.hs:1:2-18))
-    result = if length mod == length srcspan then
-               regExPair `traverse` zip mod srcspan
-             else Nothing
+regExImports msg
+    | Just mods' <- allMatchRegex msg "‘([^’]*)’"
+    , Just srcspans' <- allMatchRegex msg
+#if MIN_VERSION_ghc(9,7,0)
+                          "\\(at ([^)]*)\\)"
+#else
+                          "\\(([^)]*)\\)"
+#endif
+    , mods <- [mod | [_,mod] <- mods']
+    , srcspans <- [srcspan | [_,srcspan] <- srcspans']
+      -- check we have matching pairs like (Data.Map, (app/src.hs:1:2-18))
+    , let result = if length mods == length srcspans then
+                   Just (zip mods srcspans) else Nothing
+    = result
+    | otherwise = Nothing
 
 matchRegExMultipleImports :: T.Text -> Maybe (T.Text, [(T.Text, T.Text)])
 matchRegExMultipleImports message = do
+#if MIN_VERSION_ghc(9,7,0)
+  let pat = T.pack "Add ‘([^’]*)’ to one of these import lists: *(‘.*\\))$"
+#else
   let pat = T.pack "Perhaps you want to add ‘([^’]*)’ to one of these import lists: *(‘.*\\))$"
+#endif
   (binding, imports) <- case matchRegexUnifySpaces message pat of
                             Just [x, xs] -> Just (x, xs)
                             _            -> Nothing