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