diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index f75d653ae1..3c1a73e752 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -48,6 +48,8 @@ import Data.Aeson.Types (toJSON, fromJSON, Value(..), Result(..)) import Data.Char import Data.Maybe import Data.List.Extra +import Data.List.NonEmpty (NonEmpty((:|))) +import qualified Data.List.NonEmpty as NE import qualified Data.Text as T import Text.Regex.TDFA (mrAfter, (=~), (=~~)) import Outputable (ppr, showSDocUnsafe) @@ -622,9 +624,13 @@ suggestExtendImport exportsMap contents Diagnostic{_range=_range,..} in x{_end = (_end x){_character = succ (_character (_end x))}} _ -> error "bug in srcspan parser", importLine <- textInRange range c, - Just ident <- lookupExportMap binding mod, - Just result <- addBindingToImportList ident importLine - = [("Add " <> renderIdentInfo ident <> " to the import list of " <> mod, [TextEdit range result])] + Just ident <- lookupExportMap binding mod + = [ ( "Add " <> rendered <> " to the import list of " <> mod + , [TextEdit range result] + ) + | importStyle <- NE.toList $ importStyles ident + , let rendered = renderImportStyle importStyle + , result <- maybeToList $ addBindingToImportList importStyle importLine] | otherwise = [] lookupExportMap binding mod | Just match <- Map.lookup binding (getExportsMap exportsMap) @@ -933,13 +939,15 @@ constructNewImportSuggestions exportsMap (qual, thingMissing) notTheseModules = , suggestion <- renderNewImport identInfo m ] where + renderNewImport :: IdentInfo -> T.Text -> [T.Text] renderNewImport identInfo m | Just q <- qual , asQ <- if q == m then "" else " as " <> q = ["import qualified " <> m <> asQ] | otherwise - = ["import " <> m <> " (" <> renderIdentInfo identInfo <> ")" - ,"import " <> m ] + = ["import " <> m <> " (" <> renderImportStyle importStyle <> ")" + | importStyle <- NE.toList $ importStyles identInfo] ++ + ["import " <> m ] canUseIdent :: NotInScope -> IdentInfo -> Bool canUseIdent NotInScopeDataConstructor{} = isDatacon @@ -1080,15 +1088,18 @@ rangesForBinding' _ _ = [] -- import (qualified) A (..) .. -- Places the new binding first, preserving whitespace. -- Copes with multi-line import lists -addBindingToImportList :: IdentInfo -> T.Text -> Maybe T.Text -addBindingToImportList IdentInfo {parent = _parent, ..} importLine = +addBindingToImportList :: ImportStyle -> T.Text -> Maybe T.Text +addBindingToImportList importStyle importLine = case T.breakOn "(" importLine of (pre, T.uncons -> Just (_, rest)) -> - case _parent of - -- the binding is not a constructor, add it to the head of import list - Nothing -> Just $ T.concat [pre, "(", rendered, addCommaIfNeeds rest] - Just parent -> case T.breakOn parent rest of - -- the binding is a constructor, and current import list contains its parent + case importStyle of + ImportTopLevel rendered -> + -- the binding has no parent, add it to the head of import list + Just $ T.concat [pre, "(", rendered, addCommaIfNeeds rest] + ImportViaParent rendered parent -> case T.breakOn parent rest of + -- the binding has a parent, and the current import list contains the + -- parent + -- -- `rest'` could be 1. `,...)` -- or 2. `(),...)` -- or 3. `(ConsA),...)` @@ -1180,7 +1191,43 @@ matchRegExMultipleImports message = do imps <- regExImports imports return (binding, imps) -renderIdentInfo :: IdentInfo -> T.Text -renderIdentInfo IdentInfo {parent, rendered} - | Just p <- parent = p <> "(" <> rendered <> ")" - | otherwise = rendered +-- | Possible import styles for an 'IdentInfo'. +-- +-- The first 'Text' parameter corresponds to the 'rendered' field of the +-- 'IdentInfo'. +data ImportStyle + = ImportTopLevel T.Text + -- ^ Import a top-level export from a module, e.g., a function, a type, a + -- class. + -- + -- > import M (?) + -- + -- Some exports that have a parent, like a type-class method or an + -- associated type/data family, can still be imported as a top-level + -- import. + -- + -- Note that this is not the case for constructors, they must always be + -- imported as part of their parent data type. + + | ImportViaParent T.Text T.Text + -- ^ Import an export (first parameter) through its parent (second + -- parameter). + -- + -- import M (P(?)) + -- + -- @P@ and @?@ can be a data type and a constructor, a class and a method, + -- a class and an associated type/data family, etc. + +importStyles :: IdentInfo -> NonEmpty ImportStyle +importStyles IdentInfo {parent, rendered, isDatacon} + | Just p <- parent + -- Constructors always have to be imported via their parent data type, but + -- methods and associated type/data families can also be imported as + -- top-level exports. + = ImportViaParent rendered p :| [ImportTopLevel rendered | not isDatacon] + | otherwise + = ImportTopLevel rendered :| [] + +renderImportStyle :: ImportStyle -> T.Text +renderImportStyle (ImportTopLevel x) = x +renderImportStyle (ImportViaParent x p) = p <> "(" <> x <> ")" diff --git a/ghcide/src/Development/IDE/Types/Exports.hs b/ghcide/src/Development/IDE/Types/Exports.hs index 8a42bc950e..d8f5c35233 100644 --- a/ghcide/src/Development/IDE/Types/Exports.hs +++ b/ghcide/src/Development/IDE/Types/Exports.hs @@ -53,15 +53,15 @@ mkIdentInfos (Avail n) = mkIdentInfos (AvailTC parent (n:nn) flds) -- Following the GHC convention that parent == n if parent is exported | n == parent - = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) (Just $! parentP) True + = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) (Just $! parentP) (isDataConName n) | n <- nn ++ map flSelector flds ] ++ - [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing False] + [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n)] where parentP = pack $ prettyPrint parent mkIdentInfos (AvailTC _ nn flds) - = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing True + = [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n) | n <- nn ++ map flSelector flds ] diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 8750dad37e..4d9dacd600 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -1207,6 +1207,46 @@ extendImportTests = testGroup "extend import actions" , " )" , "main = print (stuffA, stuffB)" ]) + , testSession "extend single line import with method within class" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "class C a where" + , " m1 :: a -> a" + , " m2 :: a -> a" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA (C(m1))" + , "b = m2" + ]) + (Range (Position 2 5) (Position 2 5)) + ["Add C(m2) to the import list of ModuleA", + "Add m2 to the import list of ModuleA"] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (C(m2, m1))" + , "b = m2" + ]) + , testSession "extend single line import with method without class" $ template + [("ModuleA.hs", T.unlines + [ "module ModuleA where" + , "class C a where" + , " m1 :: a -> a" + , " m2 :: a -> a" + ])] + ("ModuleB.hs", T.unlines + [ "module ModuleB where" + , "import ModuleA (C(m1))" + , "b = m2" + ]) + (Range (Position 2 5) (Position 2 5)) + ["Add m2 to the import list of ModuleA", + "Add C(m2) to the import list of ModuleA"] + (T.unlines + [ "module ModuleB where" + , "import ModuleA (m2, C(m1))" + , "b = m2" + ]) , testSession "extend import list with multiple choices" $ template [("ModuleA.hs", T.unlines -- this is just a dummy module to help the arguments needed for this test @@ -1235,7 +1275,9 @@ extendImportTests = testGroup "extend import actions" ]) ] where - template setUpModules moduleUnderTest range expectedActions expectedContentB = do + codeActionTitle CodeAction{_title=x} = x + + template setUpModules moduleUnderTest range expectedTitles expectedContentB = do sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams $ toJSON def{checkProject = overrideCheckProject}) @@ -1245,14 +1287,23 @@ extendImportTests = testGroup "extend import actions" docB <- createDoc (fst moduleUnderTest) "haskell" (snd moduleUnderTest) _ <- waitForDiagnostics void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification) - codeActions <- filter (\(CACodeAction CodeAction{_title=x}) -> T.isPrefixOf "Add" x) - <$> getCodeActions docB range - let expectedTitles = (\(CACodeAction CodeAction{_title=x}) ->x) <$> codeActions - liftIO $ expectedActions @=? expectedTitles - - -- Get the first action and execute the first action - let CACodeAction action : _ - = sortOn (\(CACodeAction CodeAction{_title=x}) -> x) codeActions + actionsOrCommands <- getCodeActions docB range + let codeActions = + filter + (T.isPrefixOf "Add" . codeActionTitle) + [ca | CACodeAction ca <- actionsOrCommands] + actualTitles = codeActionTitle <$> codeActions + -- Note that we are not testing the order of the actions, as the + -- order of the expected actions indicates which one we'll execute + -- in this test, i.e., the first one. + liftIO $ sort expectedTitles @=? sort actualTitles + + -- Execute the action with the same title as the first expected one. + -- Since we tested that both lists have the same elements (possibly + -- in a different order), this search cannot fail. + let firstTitle:_ = expectedTitles + action = fromJust $ + find ((firstTitle ==) . codeActionTitle) codeActions executeCodeAction action contentAfterAction <- documentContents docB liftIO $ expectedContentB @=? contentAfterAction @@ -1285,6 +1336,8 @@ suggestImportTests = testGroup "suggest import actions" , test False [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable.Internal (Typeable)" -- package not in scope , test False [] "f = quickCheck" [] "import Test.QuickCheck (quickCheck)" + -- don't omit the parent data type of a constructor + , test False [] "f ExitSuccess = ()" [] "import System.Exit (ExitSuccess)" ] , testGroup "want suggestion" [ wantWait [] "f = foo" [] "import Foo (foo)" @@ -1305,6 +1358,7 @@ suggestImportTests = testGroup "suggest import actions" , test True [] "f :: Alternative f => f ()" ["f = undefined"] "import Control.Applicative (Alternative)" , test True [] "f :: Alternative f => f ()" ["f = undefined"] "import Control.Applicative" , test True [] "f = empty" [] "import Control.Applicative (Alternative(empty))" + , test True [] "f = empty" [] "import Control.Applicative (empty)" , test True [] "f = empty" [] "import Control.Applicative" , test True [] "f = (&)" [] "import Data.Function ((&))" , test True [] "f = NE.nonEmpty" [] "import qualified Data.List.NonEmpty as NE" @@ -1315,6 +1369,7 @@ suggestImportTests = testGroup "suggest import actions" , test True [] "f = [] & id" [] "import Data.Function ((&))" , test True [] "f = (&) [] id" [] "import Data.Function ((&))" , test True [] "f = (.|.)" [] "import Data.Bits (Bits((.|.)))" + , test True [] "f = (.|.)" [] "import Data.Bits ((.|.))" ] ] where