Merge pull request #2838 from xsebek/qualified-completion

Fix completion for qualified import
haskell · Dec 2, 2023 · 51db1f2 · 51db1f2
2 parents 7db6215 + 62129bf
commit 51db1f2
Show file tree

Hide file tree

Showing 3 changed files with 101 additions and 59 deletions.
diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs
@@ -215,7 +215,7 @@ getCompletionsLSP ide plId
                     plugins = idePlugins $ shakeExtras ide
                 config <- liftIO $ runAction "" ide $ getCompletionsConfig plId
 
-                allCompletions <- liftIO $ getCompletions plugins ideOpts cci' parsedMod astres bindMap pfix clientCaps config moduleExports uri
+                let allCompletions = getCompletions plugins ideOpts cci' parsedMod astres bindMap pfix clientCaps config moduleExports uri
                 pure $ InL (orderedCompletions allCompletions)
           _ -> return (InL [])
       _ -> return (InL [])

diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs
@@ -559,10 +559,54 @@ getCompletions
     -> CompletionsConfig
     -> ModuleNameEnv (HashSet.HashSet IdentInfo)
     -> Uri
-    -> IO [Scored CompletionItem]
-getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qualCompls, importableModules}
-               maybe_parsed maybe_ast_res (localBindings, bmapping) prefixInfo caps config moduleExportsMap uri = do
-  let PosPrefixInfo { fullLine, prefixScope, prefixText } = prefixInfo
+    -> [Scored CompletionItem]
+getCompletions
+    plugins
+    ideOpts
+    CC {allModNamesAsNS, anyQualCompls, unqualCompls, qualCompls, importableModules}
+    maybe_parsed
+    maybe_ast_res
+    (localBindings, bmapping)
+    prefixInfo@(PosPrefixInfo { fullLine, prefixScope, prefixText })
+    caps
+    config
+    moduleExportsMap
+    uri
+    -- ------------------------------------------------------------------------
+    -- IMPORT MODULENAME (NAM|)
+    | Just (ImportListContext moduleName) <- maybeContext
+    = moduleImportListCompletions moduleName
+
+    | Just (ImportHidingContext moduleName) <- maybeContext
+    = moduleImportListCompletions moduleName
+
+    -- ------------------------------------------------------------------------
+    -- IMPORT MODULENAM|
+    | Just (ImportContext _moduleName) <- maybeContext
+    = filtImportCompls
+
+    -- ------------------------------------------------------------------------
+    -- {-# LA| #-}
+    -- we leave this condition here to avoid duplications and return empty list
+    -- since HLS implements these completions (#haskell-language-server/pull/662)
+    | "{-# " `T.isPrefixOf` fullLine
+    = []
+
+    -- ------------------------------------------------------------------------
+    | otherwise =
+        -- assumes that nubOrdBy is stable
+        let uniqueFiltCompls = nubOrdBy (uniqueCompl `on` snd . Fuzzy.original) filtCompls
+            compls = (fmap.fmap.fmap) (mkCompl pId ideOpts uri) uniqueFiltCompls
+            pId = lookupCommandProvider plugins (CommandId extendImportCommandId)
+        in
+          (fmap.fmap) snd $
+          sortBy (compare `on` lexicographicOrdering) $
+          mergeListsBy (flip compare `on` score)
+            [ (fmap.fmap) (notQual,) filtModNameCompls
+            , (fmap.fmap) (notQual,) filtKeywordCompls
+            , (fmap.fmap.fmap) (toggleSnippets caps config) compls
+            ]
+    where
       enteredQual = if T.null prefixScope then "" else prefixScope <> "."
       fullPrefix  = enteredQual <> prefixText
 
@@ -585,11 +629,9 @@ getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls,
           $ Fuzzy.simpleFilter chunkSize maxC fullPrefix
           $ (if T.null enteredQual then id else mapMaybe (T.stripPrefix enteredQual))
             allModNamesAsNS
-
-      filtCompls = Fuzzy.filter chunkSize maxC prefixText ctxCompls (label . snd)
-        where
-
-          mcc = case maybe_parsed of
+      -- If we have a parsed module, use it to determine which completion to show.
+      maybeContext :: Maybe Context
+      maybeContext = case maybe_parsed of
             Nothing -> Nothing
             Just (pm, pmapping) ->
               let PositionMapping pDelta = pmapping
@@ -598,7 +640,9 @@ getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls,
                   hpos = upperRange position'
               in getCContext lpos pm <|> getCContext hpos pm
 
-
+      filtCompls :: [Scored (Bool, CompItem)]
+      filtCompls = Fuzzy.filter chunkSize maxC prefixText ctxCompls (label . snd)
+        where
           -- We need the hieast to be "fresh". We can't get types from "stale" hie files, so hasfield won't work,
           -- since it gets the record fields from the types.
           -- Perhaps this could be fixed with a refactor to GHC's IfaceTyCon, to have it also contain record fields.
@@ -636,7 +680,7 @@ getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls,
                 })
 
           -- completions specific to the current context
-          ctxCompls' = case mcc of
+          ctxCompls' = case maybeContext of
                         Nothing           -> compls
                         Just TypeContext  -> filter ( isTypeCompl . snd) compls
                         Just ValueContext -> filter (not . isTypeCompl . snd) compls
@@ -677,54 +721,36 @@ getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls,
         , enteredQual `T.isPrefixOf` original label
         ]
 
+      moduleImportListCompletions :: String -> [Scored CompletionItem]
+      moduleImportListCompletions moduleNameS =
+        let moduleName = T.pack moduleNameS
+            funcs = lookupWithDefaultUFM moduleExportsMap HashSet.empty $ mkModuleName moduleNameS
+            funs = map (show . name) $ HashSet.toList funcs
+        in filterModuleExports moduleName $ map T.pack funs
+
+      filtImportCompls :: [Scored CompletionItem]
       filtImportCompls = filtListWith (mkImportCompl enteredQual) importableModules
+
+      filterModuleExports :: T.Text -> [T.Text] -> [Scored CompletionItem]
       filterModuleExports moduleName = filtListWith $ mkModuleFunctionImport moduleName
+
+      filtKeywordCompls :: [Scored CompletionItem]
       filtKeywordCompls
           | T.null prefixScope = filtListWith mkExtCompl (optKeywords ideOpts)
           | otherwise = []
 
-  if
-    -- TODO: handle multiline imports
-    | "import " `T.isPrefixOf` fullLine
-      && (List.length (words (T.unpack fullLine)) >= 2)
-      && "(" `isInfixOf` T.unpack fullLine
-    -> do
-      let moduleName = words (T.unpack fullLine) !! 1
-          funcs = lookupWithDefaultUFM moduleExportsMap HashSet.empty $ mkModuleName moduleName
-          funs = map (renderOcc . name) $ HashSet.toList funcs
-      return $ filterModuleExports (T.pack moduleName) funs
-    | "import " `T.isPrefixOf` fullLine
-    -> return filtImportCompls
-    -- we leave this condition here to avoid duplications and return empty list
-    -- since HLS implements these completions (#haskell-language-server/pull/662)
-    | "{-# " `T.isPrefixOf` fullLine
-    -> return []
-    | otherwise -> do
-        -- assumes that nubOrdBy is stable
-        let uniqueFiltCompls = nubOrdBy (uniqueCompl `on` snd . Fuzzy.original) filtCompls
-        let compls = (fmap.fmap.fmap) (mkCompl pId ideOpts uri) uniqueFiltCompls
-            pId = lookupCommandProvider plugins (CommandId extendImportCommandId)
-        return $
-          (fmap.fmap) snd $
-          sortBy (compare `on` lexicographicOrdering) $
-          mergeListsBy (flip compare `on` score)
-            [ (fmap.fmap) (notQual,) filtModNameCompls
-            , (fmap.fmap) (notQual,) filtKeywordCompls
-            , (fmap.fmap.fmap) (toggleSnippets caps config) compls
-            ]
-    where
-        -- We use this ordering to alphabetically sort suggestions while respecting
-        -- all the previously applied ordering sources. These are:
-        --  1. Qualified suggestions go first
-        --  2. Fuzzy score ranks next
-        --  3. In-scope completions rank next
-        --  4. label alphabetical ordering next
-        --  4. detail alphabetical ordering (proxy for module)
-        lexicographicOrdering Fuzzy.Scored{score, original} =
-          case original of
-            (isQual, CompletionItem{_label,_detail}) -> do
-              let isLocal = maybe False (":" `T.isPrefixOf`) _detail
-              (Down isQual, Down score, Down isLocal, _label, _detail)
+      -- We use this ordering to alphabetically sort suggestions while respecting
+      -- all the previously applied ordering sources. These are:
+      --  1. Qualified suggestions go first
+      --  2. Fuzzy score ranks next
+      --  3. In-scope completions rank next
+      --  4. label alphabetical ordering next
+      --  4. detail alphabetical ordering (proxy for module)
+      lexicographicOrdering Fuzzy.Scored{score, original} =
+        case original of
+          (isQual, CompletionItem{_label,_detail}) -> do
+            let isLocal = maybe False (":" `T.isPrefixOf`) _detail
+            (Down isQual, Down score, Down isLocal, _label, _detail)
 
 
 

diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs
@@ -176,6 +176,25 @@ completionTests =
             "join"
             ["{-# LANGUAGE NoImplicitPrelude #-}",
             "module A where", "import Control.Monad as M ()", "import Control.Monad as N (join)", "f = N.joi"]
+        -- Regression test for https://github.com/haskell/haskell-language-server/issues/2824
+        , completionNoCommandTest
+            "explicit qualified"
+            ["{-# LANGUAGE NoImplicitPrelude #-}",
+            "module A where", "import qualified Control.Monad as M (j)"]
+            (Position 2 38)
+            "join"
+        , completionNoCommandTest
+            "explicit qualified post"
+            ["{-# LANGUAGE NoImplicitPrelude, ImportQualifiedPost #-}",
+            "module A where", "import Control.Monad qualified as M (j)"]
+            (Position 2 38)
+            "join"
+        , completionNoCommandTest
+            "multiline import"
+            [ "{-# LANGUAGE NoImplicitPrelude #-}"
+            , "module A where", "import Control.Monad", "    (fore)"]
+            (Position 3 9)
+            "forever"
         ]
       , testGroup "Data constructor"
         [ completionCommandTest
@@ -288,11 +307,8 @@ completionNoCommandTest name src pos wanted = testSession name $ do
   docId <- createDoc "A.hs" "haskell" (T.unlines src)
   _ <- waitForDiagnostics
   compls <- getCompletions docId pos
-  let wantedC = find ( \case
-            CompletionItem {_insertText = Just x} -> wanted `T.isPrefixOf` x
-            _                                     -> False
-            ) compls
-  case wantedC of
+  let isPrefixOfInsertOrLabel ci = any (wanted `T.isPrefixOf`) [fromMaybe "" (ci ^. L.insertText), ci ^. L.label]
+  case find isPrefixOfInsertOrLabel compls of
     Nothing ->
       liftIO $ assertFailure $ "Cannot find expected completion in: " <> show [_label | CompletionItem {_label} <- compls]
     Just CompletionItem{..} -> liftIO . assertBool ("Expected no command but got: " <> show _command) $ null _command