Best-effort support of Qualified Imports in GHC 9.4

hls-plugin-api/src/Ide/PluginUtils.hs

@@ -19,7 +19,8 @@ module Ide.PluginUtils
     getPluginConfig,
     configForPlugin,
     pluginEnabled,
-    extractRange,
+    extractOverlappingLinesWithRange,
+    extractTextInRange,
     fullRange,
     mkLspCommand,
     mkLspCmdId,
@@ -41,7 +42,7 @@ where
 
 
 import           Control.Arrow                 ((&&&))
-import           Control.Lens                  (re, (^.))
+import           Control.Lens                  (_head, _last, re, (%~), (^.))
 import           Control.Monad.Extra           (maybeM)
 import           Control.Monad.Trans.Class     (lift)
 import           Control.Monad.Trans.Except    (ExceptT, runExceptT, throwE)
@@ -223,11 +224,27 @@ usePropertyLsp kn pId p = do
 
 -- ---------------------------------------------------------------------
 
-extractRange :: Range -> T.Text -> T.Text
-extractRange (Range (Position sl _) (Position el _)) s = newS
+-- | Extracts lines in the text overlapping the given range.
+--
+-- See also: 'extractTextInRange'
+extractOverlappingLinesWithRange :: Range -> T.Text -> T.Text
+extractOverlappingLinesWithRange (Range (Position sl _) (Position el _)) s = newS
   where focusLines = take (fromIntegral $ el-sl+1) $ drop (fromIntegral sl) $ T.lines s
         newS = T.unlines focusLines
 
+-- | Extracts strictly matching text in the range.
+--
+-- See also: 'extractOverlappingLinesWithRange'
+extractTextInRange :: Range -> T.Text -> T.Text
+extractTextInRange (Range (Position sl sc) (Position el ec)) s = newS
+  where focusLines = take (fromIntegral $ el-sl+1) $ drop (fromIntegral sl) $ T.lines s
+        -- NOTE: We have to trim the last line first to handle the single-line case
+        newS = focusLines
+            & _last %~ T.take (fromIntegral ec)
+            & _head %~ T.drop (fromIntegral sc)
+            & T.unlines
+
+
 -- | Gets the range that covers the entire text
 fullRange :: T.Text -> Range
 fullRange s = Range startPos endPos

plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs

@@ -33,7 +33,7 @@ provider _ideState typ contents fp _ = liftIO $ do
     config <- findConfigOrDefault file
     let (range, selectedContents) = case typ of
           FormatText    -> (fullRange contents, contents)
-          FormatRange r -> (normalize r, extractRange r contents)
+          FormatRange r -> (normalize r, extractOverlappingLinesWithRange r contents)
         result = reformat config (Just file) . TL.encodeUtf8 $ TL.fromStrict selectedContents
     case result of
       Left  err -> pure $ Left $ responseError $ T.pack $ "floskellCmd: " ++ err

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

@@ -86,6 +86,9 @@ library
     , lens
     , data-default
     , time
+    -- FIXME: Only needed to workaround for qualified imports in GHC 9.4
+    , regex-applicative
+    , parser-combinators
   ghc-options: -Wall -Wno-name-shadowing
   default-language: Haskell2010
 

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

@@ -15,6 +15,7 @@ module Development.IDE.Plugin.CodeAction
     ) where
 
 import           Control.Applicative                               ((<|>))
+import           Control.Applicative.Combinators.NonEmpty          (sepBy1)
 import           Control.Arrow                                     (second,
                                                                     (&&&),
                                                                     (>>>))
@@ -69,10 +70,12 @@ import           Development.IDE.Types.Logger                      hiding
 import           Development.IDE.Types.Options
 import           GHC.Exts                                          (fromList)
 import qualified GHC.LanguageExtensions                            as Lang
+import qualified Text.Regex.Applicative                            as RE
 #if MIN_VERSION_ghc(9,4,0)
 import           GHC.Parser.Annotation                             (TokenLocation (..))
 #endif
-import           Ide.PluginUtils                                   (subRange)
+import           Ide.PluginUtils                                   (extractTextInRange,
+                                                                    subRange)
 import           Ide.Types
 import           Language.LSP.Protocol.Message                     (ResponseError,
                                                                     SMethod (..))
@@ -1473,7 +1476,7 @@ suggestNewOrExtendImportForClassMethod packageExportsMap ps fileContents Diagnos
         where moduleText = moduleNameText identInfo
 
 suggestNewImport :: DynFlags -> ExportsMap -> Annotated ParsedSource -> T.Text -> Diagnostic -> [(T.Text, CodeActionKind, TextEdit)]
-suggestNewImport df packageExportsMap ps fileContents Diagnostic{_message}
+suggestNewImport df packageExportsMap ps fileContents Diagnostic{_message, ..}
   | msg <- unifySpaces _message
   , Just thingMissing <- extractNotInScopeName msg
   , qual <- extractQualifiedModuleName msg
@@ -1482,17 +1485,62 @@ suggestNewImport df packageExportsMap ps fileContents Diagnostic{_message}
         >>= (findImportDeclByModuleName hsmodImports . T.unpack)
         >>= ideclAs . unLoc
         <&> T.pack . moduleNameString . unLoc
+  , -- tentative workaround for detecting qualification in GHC 9.4
+    -- FIXME: We can delete this after dropping the support for GHC 9.4
+    qualGHC94 <-
+        guard (ghcVersion == GHC94)
+            *> extractQualifiedModuleNameFromMissingName (extractTextInRange _range fileContents)
   , Just (range, indent) <- newImportInsertRange ps fileContents
   , extendImportSuggestions <- matchRegexUnifySpaces msg
     "Perhaps you want to add ‘[^’]*’ to the import list in the import of ‘([^’]*)’"
   = let qis = qualifiedImportStyle df
+        -- FIXME: we can use thingMissing once the support for GHC 9.4 is dropped.
+        missing
+            | GHC94 <- ghcVersion
+            , isNothing (qual <|> qual')
+            , Just q <- qualGHC94 =
+                mapNotInScope ((q <> ".") <>) thingMissing
+            | otherwise = thingMissing
         suggestions = nubSortBy simpleCompareImportSuggestion
-          (constructNewImportSuggestions packageExportsMap (qual <|> qual', thingMissing) extendImportSuggestions qis) in
+          (constructNewImportSuggestions packageExportsMap (qual <|> qual' <|> qualGHC94, missing) extendImportSuggestions qis) in
     map (\(ImportSuggestion _ kind (unNewImport -> imp)) -> (imp, kind, TextEdit range (imp <> "\n" <> T.replicate indent " "))) suggestions
   where
     L _ HsModule {..} = astA ps
 suggestNewImport _ _ _ _ _ = []
 
+-- tentative workaround for detecting qualification in GHC 9.4
+-- FIXME: We can delete this after dropping the support for GHC 9.4
+extractQualifiedModuleNameFromMissingName :: T.Text -> Maybe T.Text
+extractQualifiedModuleNameFromMissingName (T.strip -> missing)
+    = T.pack <$> (T.unpack missing RE.=~ qualIdentP)
+    where
+        {-
+        NOTE: Haskell 2010 allows /unicode/ upper & lower letters
+        as a module name component; otoh, regex-tdfa only allows
+        /ASCII/ letters to be matched with @[[:upper:]]@ and/or @[[:lower:]]@.
+        Hence we use regex-applicative(-text) for finer-grained predicates.
+
+        RULES (from [Section 10 of Haskell 2010 Report](https://www.haskell.org/onlinereport/haskell2010/haskellch10.html)):
+            modid	→	{conid .} conid
+            conid	→	large {small | large | digit | ' }
+            small	→	ascSmall | uniSmall | _
+            ascSmall	→	a | b | … | z
+            uniSmall	→	any Unicode lowercase letter
+            large	→	ascLarge | uniLarge
+            ascLarge	→	A | B | … | Z
+            uniLarge	→	any uppercase or titlecase Unicode letter
+        -}
+
+        qualIdentP = parensQualOpP <|> qualVarP
+        parensQualOpP = RE.sym '(' *> modNameP <* RE.sym '.' <* RE.anySym <* RE.few RE.anySym <* RE.sym ')'
+        qualVarP = modNameP <* RE.sym '.' <* RE.some RE.anySym
+        conIDP = RE.withMatched $
+            RE.psym isUpper
+            *> RE.many
+                (RE.psym $ \c -> c == '\'' || c == '_' || isUpper c || isLower c || isDigit c)
+        modNameP = fmap snd $ RE.withMatched $ conIDP `sepBy1` RE.sym '.'
+
+
 constructNewImportSuggestions
   :: ExportsMap -> (Maybe T.Text, NotInScope) -> Maybe [T.Text] -> QualifiedImportStyle -> [ImportSuggestion]
 constructNewImportSuggestions exportsMap (qual, thingMissing) notTheseModules qis = nubOrdBy simpleCompareImportSuggestion
@@ -1740,6 +1788,11 @@ data NotInScope
     | NotInScopeThing T.Text
     deriving Show
 
+mapNotInScope :: (T.Text -> T.Text) -> NotInScope -> NotInScope
+mapNotInScope f (NotInScopeDataConstructor d) = NotInScopeDataConstructor (f d)
+mapNotInScope f (NotInScopeTypeConstructorOrClass d) = NotInScopeTypeConstructorOrClass (f d)
+mapNotInScope f (NotInScopeThing d) = NotInScopeThing (f d)
+
 notInScope :: NotInScope -> T.Text
 notInScope (NotInScopeDataConstructor t)        = t
 notInScope (NotInScopeTypeConstructorOrClass t) = t

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

@@ -1670,10 +1670,11 @@ suggestImportTests = testGroup "suggest import actions"
     , test True []          "f = empty"                   []                "import Control.Applicative (empty)"
     , test True []          "f = empty"                   []                "import Control.Applicative"
     , test True []          "f = (&)"                     []                "import Data.Function ((&))"
-    , ignoreForGHC94 "On GHC 9.4 the error message doesn't contain the qualified module name: https://gitlab.haskell.org/ghc/ghc/-/issues/20472"
-      $ test True []          "f = NE.nonEmpty"             []                "import qualified Data.List.NonEmpty as NE"
-    , ignoreForGHC94 "On GHC 9.4 the error message doesn't contain the qualified module name: https://gitlab.haskell.org/ghc/ghc/-/issues/20472"
-      $ test True []          "f = Data.List.NonEmpty.nonEmpty" []            "import qualified Data.List.NonEmpty"
+    , test True []          "f = NE.nonEmpty"             []                "import qualified Data.List.NonEmpty as NE"
+    , test True []          "f = (NE.:|)"             []                "import qualified Data.List.NonEmpty as NE"
+    , test True []          "f = (Data.List.NonEmpty.:|)" []            "import qualified Data.List.NonEmpty"
+    , test True []          "f = (B..|.)"             []                "import qualified Data.Bits as B"
+    , test True []          "f = (Data.Bits..|.)" []            "import qualified Data.Bits"
     , test True []          "f :: Typeable a => a"        ["f = undefined"] "import Data.Typeable (Typeable)"
     , test True []          "f = pack"                    []                "import Data.Text (pack)"
     , test True []          "f :: Text"                   ["f = undefined"] "import Data.Text (Text)"
@@ -1682,17 +1683,14 @@ suggestImportTests = testGroup "suggest import actions"
     , test True []          "f = (.|.)"                   []                "import Data.Bits (Bits((.|.)))"
     , test True []          "f = (.|.)"                   []                "import Data.Bits ((.|.))"
     , test True []          "f :: a ~~ b"                 []                "import Data.Type.Equality ((~~))"
-    , ignoreForGHC94 "On GHC 9.4 the error message doesn't contain the qualified module name: https://gitlab.haskell.org/ghc/ghc/-/issues/20472"
-      $ test True
+    , test True
       ["qualified Data.Text as T"
       ]                     "f = T.putStrLn"              []                "import qualified Data.Text.IO as T"
-    , ignoreForGHC94 "On GHC 9.4 the error message doesn't contain the qualified module name: https://gitlab.haskell.org/ghc/ghc/-/issues/20472"
-      $ test True
+    , test True
       [ "qualified Data.Text as T"
       , "qualified Data.Function as T"
       ]                     "f = T.putStrLn"              []                "import qualified Data.Text.IO as T"
-    , ignoreForGHC94 "On GHC 9.4 the error message doesn't contain the qualified module name: https://gitlab.haskell.org/ghc/ghc/-/issues/20472"
-      $ test True
+    , test True
       [ "qualified Data.Text as T"
       , "qualified Data.Function as T"
       , "qualified Data.Functor as T"

plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs

@@ -36,7 +36,7 @@ provider ide typ contents fp _opts = do
   mergedConfig <- liftIO $ getMergedConfig dyn config
   let (range, selectedContents) = case typ of
         FormatText    -> (fullRange contents, contents)
-        FormatRange r -> (normalize r, extractRange r contents)
+        FormatRange r -> (normalize r, extractOverlappingLinesWithRange r contents)
       result = runStylishHaskell file mergedConfig selectedContents
   case result of
     Left  err -> return $ Left $ responseError $ T.pack $ "stylishHaskellCmd: " ++ err