Skip to content

Commit

Permalink
Allow import all constructors (haskell#2782)
Browse files Browse the repository at this point in the history 
* Import all constructors

* Rewrite the test

* Exact print wildcard

* Rerun circleci
  • Loading branch information
@July541
July541 committed Mar 29, 2022
1 parent a3bebd5 commit 4c18651
Show file tree
Hide file tree
Showing 3 changed files with 175 additions and 18 deletions.
15 changes: 14 additions & 1 deletion ghcide/src/Development/IDE/Plugin/CodeAction.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1733,6 +1733,13 @@ data ImportStyle
--
-- @P@ and @?@ can be a data type and a constructor, a class and a method,
-- a class and an associated type/data family, etc.

| ImportAllConstructors T.Text
-- ^ Import all constructors for a specific data type.
--
-- import M (P(..))
--
-- @P@ can be a data type or a class.
deriving Show

importStyles :: IdentInfo -> NonEmpty ImportStyle
Expand All @@ -1741,7 +1748,9 @@ importStyles IdentInfo {parent, rendered, isDatacon}
-- 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]
= ImportViaParent rendered p
:| [ImportTopLevel rendered | not isDatacon]
<> [ImportAllConstructors p]
| otherwise
= ImportTopLevel rendered :| []

Expand All @@ -1750,15 +1759,19 @@ renderImportStyle :: ImportStyle -> T.Text
renderImportStyle (ImportTopLevel x) = x
renderImportStyle (ImportViaParent x p@(T.uncons -> Just ('(', _))) = "type " <> p <> "(" <> x <> ")"
renderImportStyle (ImportViaParent x p) = p <> "(" <> x <> ")"
renderImportStyle (ImportAllConstructors p) = p <> "(..)"

-- | Used for extending import lists
unImportStyle :: ImportStyle -> (Maybe String, String)
unImportStyle (ImportTopLevel x) = (Nothing, T.unpack x)
unImportStyle (ImportViaParent x y) = (Just $ T.unpack y, T.unpack x)
unImportStyle (ImportAllConstructors x) = (Just $ T.unpack x, wildCardSymbol)


quickFixImportKind' :: T.Text -> ImportStyle -> CodeActionKind
quickFixImportKind' x (ImportTopLevel _) = CodeActionUnknown $ "quickfix.import." <> x <> ".list.topLevel"
quickFixImportKind' x (ImportViaParent _ _) = CodeActionUnknown $ "quickfix.import." <> x <> ".list.withParent"
quickFixImportKind' x (ImportAllConstructors _) = CodeActionUnknown $ "quickfix.import." <> x <> ".list.allConstructors"

quickFixImportKind :: T.Text -> CodeActionKind
quickFixImportKind x = CodeActionUnknown $ "quickfix.import." <> x
28 changes: 25 additions & 3 deletions ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -19,6 +19,8 @@ module Development.IDE.Plugin.CodeAction.ExactPrint (
extendImport,
hideSymbol,
liftParseAST,

wildCardSymbol
) where

import Control.Applicative
Expand Down Expand Up @@ -330,6 +332,7 @@ extendImport :: Maybe String -> String -> LImportDecl GhcPs -> Rewrite
extendImport mparent identifier lDecl@(L l _) =
Rewrite (locA l) $ \df -> do
case mparent of
-- This will also work for `ImportAllConstructors`
Just parent -> extendImportViaParent df parent identifier lDecl
_ -> extendImportTopLevel identifier lDecl

Expand Down Expand Up @@ -379,6 +382,9 @@ extendImportTopLevel thing (L l it@ImportDecl{..})
#endif
extendImportTopLevel _ _ = lift $ Left "Unable to extend the import list"

wildCardSymbol :: String
wildCardSymbol = ".."

-- | Add an identifier with its parent to import list
--
-- extendImportViaParent "Bar" "Cons" AST:
Expand All @@ -389,6 +395,11 @@ extendImportTopLevel _ _ = lift $ Left "Unable to extend the import list"
-- import A () --> import A (Bar(Cons))
-- import A (Foo, Bar) --> import A (Foo, Bar(Cons))
-- import A (Foo, Bar()) --> import A (Foo, Bar(Cons))
--
-- extendImportViaParent "Bar" ".." AST:
-- import A () --> import A (Bar(..))
-- import A (Foo, Bar) -> import A (Foo, Bar(..))
-- import A (Foo, Bar()) -> import A (Foo, Bar(..))
extendImportViaParent ::
DynFlags ->
-- | parent (already parenthesized if needs)
Expand Down Expand Up @@ -423,6 +434,19 @@ extendImportViaParent df parent child (L l it@ImportDecl{..})
go hide l' pre ((L l'' (IEThingWith l''' twIE@(L _ ie) _ lies')) : xs)
#endif
-- ThingWith ie lies' => ThingWith ie (lies' ++ [child])
| parent == unIEWrappedName ie
, child == wildCardSymbol = do
#if MIN_VERSION_ghc(9,2,0)
let it' = it{ideclHiding = Just (hide, lies)}
thing = IEThingWith newl twIE (IEWildcard 2) []
newl = (\ann -> ann ++ [(AddEpAnn AnnDotdot d0)]) <$> l'''
lies = L l' $ reverse pre ++ [L l'' thing] ++ xs
return $ L l it'
#else
let thing = L l'' (IEThingWith noExtField twIE (IEWildcard 2) [] [])
modifyAnnsT (Map.map (\ann -> ann{annsDP = (G AnnDotdot, dp00) : annsDP ann}))
return $ L l it{ideclHiding = Just (hide, L l' $ reverse pre ++ [thing] ++ xs)}
#endif
| parent == unIEWrappedName ie
, hasSibling <- not $ null lies' =
do
Expand All @@ -448,9 +472,7 @@ extendImportViaParent df parent child (L l it@ImportDecl{..})
lies = L l' $ reverse pre ++
[L l'' (IEThingWith l''' twIE NoIEWildcard (over _last fixLast lies' ++ [childLIE]))] ++ xs
fixLast = if hasSibling then first addComma else id
return $ if hasSibling
then L l it'
else L l it'
return $ L l it'
#endif
go hide l' pre (x : xs) = go hide l' (x : pre) xs
go hide l' pre []
Expand Down
150 changes: 136 additions & 14 deletions ghcide/test/exe/Main.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1513,7 +1513,108 @@ extendImportTests = testGroup "extend import actions"
]
where
tests overrideCheckProject =
[ testSession "extend single line import with value" $ template
[ testSession "extend all constructors for record field" $ template
[("ModuleA.hs", T.unlines
[ "module ModuleA where"
, "data A = B { a :: Int }"
])]
("ModuleB.hs", T.unlines
[ "module ModuleB where"
, "import ModuleA (A(B))"
, "f = a"
])
(Range (Position 2 4) (Position 2 5))
[ "Add A(..) to the import list of ModuleA"
, "Add A(a) to the import list of ModuleA"
, "Add a to the import list of ModuleA"
]
(T.unlines
[ "module ModuleB where"
, "import ModuleA (A(..))"
, "f = a"
])
, testSession "extend all constructors with sibling" $ template
[("ModuleA.hs", T.unlines
[ "module ModuleA where"
, "data Foo"
, "data Bar"
, "data A = B | C"
])]
("ModuleB.hs", T.unlines
[ "module ModuleB where"
, "import ModuleA ( Foo, A (C) , Bar ) "
, "f = B"
])
(Range (Position 2 4) (Position 2 5))
[ "Add A(..) to the import list of ModuleA"
, "Add A(B) to the import list of ModuleA"
]
(T.unlines
[ "module ModuleB where"
, "import ModuleA ( Foo, A (..) , Bar ) "
, "f = B"
])
, testSession "extend all constructors with comment" $ template
[("ModuleA.hs", T.unlines
[ "module ModuleA where"
, "data Foo"
, "data Bar"
, "data A = B | C"
])]
("ModuleB.hs", T.unlines
[ "module ModuleB where"
, "import ModuleA ( Foo, A (C{-comment--}) , Bar ) "
, "f = B"
])
(Range (Position 2 4) (Position 2 5))
[ "Add A(..) to the import list of ModuleA"
, "Add A(B) to the import list of ModuleA"
]
(T.unlines
[ "module ModuleB where"
, "import ModuleA ( Foo, A (..{-comment--}) , Bar ) "
, "f = B"
])
, testSession "extend all constructors for type operator" $ template
[]
("ModuleA.hs", T.unlines
[ "module ModuleA where"
, "import Data.Type.Equality ((:~:))"
, "x :: (:~:) [] []"
, "x = Refl"
])
(Range (Position 3 17) (Position 3 18))
[ "Add (:~:)(..) to the import list of Data.Type.Equality"
, "Add type (:~:)(Refl) to the import list of Data.Type.Equality"]
(T.unlines
[ "module ModuleA where"
, "import Data.Type.Equality ((:~:) (..))"
, "x :: (:~:) [] []"
, "x = Refl"
])
, testSession "extend all constructors for 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(..) to the import list of ModuleA"
, "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(..))"
, "b = m2"
])
, testSession "extend single line import with value" $ template
[("ModuleA.hs", T.unlines
[ "module ModuleA where"
, "stuffA :: Double"
Expand Down Expand Up @@ -1561,7 +1662,9 @@ extendImportTests = testGroup "extend import actions"
, "main = case (fromList []) of _ :| _ -> pure ()"
])
(Range (Position 2 5) (Position 2 6))
["Add NonEmpty((:|)) to the import list of Data.List.NonEmpty"]
[ "Add NonEmpty((:|)) to the import list of Data.List.NonEmpty"
, "Add NonEmpty(..) to the import list of Data.List.NonEmpty"
]
(T.unlines
[ "module ModuleB where"
, "import Data.List.NonEmpty (fromList, NonEmpty ((:|)))"
Expand All @@ -1576,7 +1679,9 @@ extendImportTests = testGroup "extend import actions"
, "x = Just 10"
])
(Range (Position 3 5) (Position 2 6))
["Add Maybe(Just) to the import list of Data.Maybe"]
[ "Add Maybe(Just) to the import list of Data.Maybe"
, "Add Maybe(..) to the import list of Data.Maybe"
]
(T.unlines
[ "module ModuleB where"
, "import Prelude hiding (Maybe(..))"
Expand Down Expand Up @@ -1614,7 +1719,9 @@ extendImportTests = testGroup "extend import actions"
, "b = Constructor"
])
(Range (Position 3 5) (Position 3 5))
["Add A(Constructor) to the import list of ModuleA"]
[ "Add A(Constructor) to the import list of ModuleA"
, "Add A(..) to the import list of ModuleA"
]
(T.unlines
[ "module ModuleB where"
, "import ModuleA (A (Constructor))"
Expand All @@ -1633,7 +1740,9 @@ extendImportTests = testGroup "extend import actions"
, "b = Constructor"
])
(Range (Position 3 5) (Position 3 5))
["Add A(Constructor) to the import list of ModuleA"]
[ "Add A(Constructor) to the import list of ModuleA"
, "Add A(..) to the import list of ModuleA"
]
(T.unlines
[ "module ModuleB where"
, "import ModuleA (A (Constructor{-Constructor-}))"
Expand All @@ -1653,7 +1762,9 @@ extendImportTests = testGroup "extend import actions"
, "b = ConstructorFoo"
])
(Range (Position 3 5) (Position 3 5))
["Add A(ConstructorFoo) to the import list of ModuleA"]
[ "Add A(ConstructorFoo) to the import list of ModuleA"
, "Add A(..) to the import list of ModuleA"
]
(T.unlines
[ "module ModuleB where"
, "import ModuleA (A (ConstructorBar, ConstructorFoo), a)"
Expand Down Expand Up @@ -1715,8 +1826,10 @@ extendImportTests = testGroup "extend import actions"
, "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"]
[ "Add C(m2) to the import list of ModuleA"
, "Add m2 to the import list of ModuleA"
, "Add C(..) to the import list of ModuleA"
]
(T.unlines
[ "module ModuleB where"
, "import ModuleA (C(m1, m2))"
Expand All @@ -1735,8 +1848,10 @@ extendImportTests = testGroup "extend import actions"
, "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"]
[ "Add m2 to the import list of ModuleA"
, "Add C(m2) to the import list of ModuleA"
, "Add C(..) to the import list of ModuleA"
]
(T.unlines
[ "module ModuleB where"
, "import ModuleA (C(m1), m2)"
Expand Down Expand Up @@ -1777,7 +1892,8 @@ extendImportTests = testGroup "extend import actions"
, "x = Refl"
])
(Range (Position 3 17) (Position 3 18))
["Add type (:~:)(Refl) to the import list of Data.Type.Equality"]
[ "Add type (:~:)(Refl) to the import list of Data.Type.Equality"
, "Add (:~:)(..) to the import list of Data.Type.Equality"]
(T.unlines
[ "module ModuleA where"
, "import Data.Type.Equality ((:~:) (Refl))"
Expand Down Expand Up @@ -1817,7 +1933,7 @@ extendImportTests = testGroup "extend import actions"
, "f = Foo 1"
])
(Range (Position 3 4) (Position 3 6))
["Add Foo(Foo) to the import list of ModuleA"]
["Add Foo(Foo) to the import list of ModuleA", "Add Foo(..) to the import list of ModuleA"]
(T.unlines
[ "module ModuleB where"
, "import ModuleA(Foo (Foo))"
Expand Down Expand Up @@ -1997,11 +2113,14 @@ suggestImportTests = testGroup "suggest import actions"
, test False [] "f ExitSuccess = ()" [] "import System.Exit (ExitSuccess)"
-- don't suggest data constructor when we only need the type
, test False [] "f :: Bar" [] "import Bar (Bar(Bar))"
-- don't suggest all data constructors for the data type
, test False [] "f :: Bar" [] "import Bar (Bar(..))"
]
, testGroup "want suggestion"
[ wantWait [] "f = foo" [] "import Foo (foo)"
, wantWait [] "f = Bar" [] "import Bar (Bar(Bar))"
, wantWait [] "f :: Bar" [] "import Bar (Bar)"
, wantWait [] "f = Bar" [] "import Bar (Bar(..))"
, test True [] "f = nonEmpty" [] "import Data.List.NonEmpty (nonEmpty)"
, test True [] "f = (:|)" [] "import Data.List.NonEmpty (NonEmpty((:|)))"
, test True [] "f :: Natural" ["f = undefined"] "import Numeric.Natural (Natural)"
Expand Down Expand Up @@ -2043,12 +2162,15 @@ suggestImportTests = testGroup "suggest import actions"
, "qualified Data.Functor as T"
, "qualified Data.Data as T"
] "f = T.putStrLn" [] "import qualified Data.Text.IO as T"
, test True [] "f = (.|.)" [] "import Data.Bits (Bits(..))"
, test True [] "f = empty" [] "import Control.Applicative (Alternative(..))"
]
, expectFailBecause "importing pattern synonyms is unsupported" $ test True [] "k (Some x) = x" [] "import B (pattern Some)"
, expectFailBecause "importing pattern synonyms is unsupported" $ test True [] "k (Some x) = x" [] "import B (pattern Some)"
]
where
test = test' False
wantWait = test' True True

test' waitForCheckProject wanted imps def other newImp = testSessionWithExtraFiles "hover" (T.unpack def) $ \dir -> do
configureCheckProject waitForCheckProject
let before = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ def : other
Expand All @@ -2058,7 +2180,7 @@ suggestImportTests = testGroup "suggest import actions"
liftIO $ writeFileUTF8 (dir </> "B.hs") $ unlines ["{-# LANGUAGE PatternSynonyms #-}", "module B where", "pattern Some x = Just x"]
doc <- createDoc "Test.hs" "haskell" before
waitForProgressDone
_diags <- waitForDiagnostics
_ <- waitForDiagnostics
-- there isn't a good way to wait until the whole project is checked atm
when waitForCheckProject $ liftIO $ sleep 0.5
let defLine = fromIntegral $ length imps + 1
Expand Down

0 comments on commit 4c18651

Please sign in to comment.