Skip to content

Commit d84b6f0

Browse files
berbermanberberman
committed
Fix importing type operators (haskell#1644)
* Fix importing type operators * Update test * Add expected failure tests
1 parent bc0fb80 commit d84b6f0

File tree

4 files changed

+81
-31
lines changed

4 files changed

+81
-31
lines changed

‎ghcide/src/Development/IDE/Plugin/CodeAction.hs‎

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1557,10 +1557,13 @@ importStyles IdentInfo {parent, rendered, isDatacon}
15571557
| otherwise
15581558
= ImportTopLevel rendered :| []
15591559

1560+
-- | Used for adding new imports
15601561
renderImportStyle :: ImportStyle -> T.Text
1561-
renderImportStyle (ImportTopLevel x) = x
1562+
renderImportStyle (ImportTopLevel x) = x
1563+
renderImportStyle (ImportViaParent x p@(T.uncons -> Just ('(', _))) = "type " <> p <> "(" <> x <> ")"
15621564
renderImportStyle (ImportViaParent x p) = p <> "(" <> x <> ")"
15631565

1566+
-- | Used for extending import lists
15641567
unImportStyle :: ImportStyle -> (Maybe String, String)
15651568
unImportStyle (ImportTopLevel x) = (Nothing, T.unpack x)
15661569
unImportStyle (ImportViaParent x y) = (Just $ T.unpack y, T.unpack x)

‎ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs‎

Lines changed: 38 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -35,7 +35,7 @@ import Development.IDE.GHC.ExactPrint (ASTElement (parseAST),
3535
import Development.IDE.Spans.Common
3636
import FieldLabel (flLabel)
3737
import GHC.Exts (IsList (fromList))
38-
import GhcPlugins (sigPrec)
38+
import GhcPlugins (mkRdrUnqual, sigPrec)
3939
import Language.Haskell.GHC.ExactPrint
4040
import Language.Haskell.GHC.ExactPrint.Types (DeltaPos (DP),
4141
KeywordId (G), mkAnnKey)
@@ -200,44 +200,48 @@ extendImport mparent identifier lDecl@(L l _) =
200200
Rewrite l $ \df -> do
201201
case mparent of
202202
Just parent -> extendImportViaParent df parent identifier lDecl
203-
_ -> extendImportTopLevel df identifier lDecl
203+
_ -> extendImportTopLevel identifier lDecl
204204

205-
-- | Add an identifier to import list
205+
-- | Add an identifier or a data type to import list
206206
--
207207
-- extendImportTopLevel "foo" AST:
208208
--
209209
-- import A --> Error
210210
-- import A (foo) --> Error
211211
-- import A (bar) --> import A (bar, foo)
212-
extendImportTopLevel :: DynFlags -> String -> LImportDecl GhcPs -> TransformT (Either String) (LImportDecl GhcPs)
213-
extendImportTopLevel df idnetifier (L l it@ImportDecl{..})
212+
extendImportTopLevel ::
213+
-- | rendered
214+
String ->
215+
LImportDecl GhcPs ->
216+
TransformT (Either String) (LImportDecl GhcPs)
217+
extendImportTopLevel thing (L l it@ImportDecl{..})
214218
| Just (hide, L l' lies) <- ideclHiding
215219
, hasSibling <- not $ null lies = do
216220
src <- uniqueSrcSpanT
217221
top <- uniqueSrcSpanT
218-
rdr <- liftParseAST df idnetifier
222+
let rdr = L src $ mkRdrUnqual $ mkVarOcc thing
219223

220224
let alreadyImported =
221225
showNameWithoutUniques (occName (unLoc rdr))
222226
`elem` map (showNameWithoutUniques @OccName) (listify (const True) lies)
223227
when alreadyImported $
224-
lift (Left $ idnetifier <> " already imported")
228+
lift (Left $ thing <> " already imported")
225229

226230
let lie = L src $ IEName rdr
227231
x = L top $ IEVar noExtField lie
228232
if x `elem` lies
229-
then lift (Left $ idnetifier <> " already imported")
233+
then lift (Left $ thing <> " already imported")
230234
else do
231235
when hasSibling $
232236
addTrailingCommaT (last lies)
233237
addSimpleAnnT x (DP (0, if hasSibling then 1 else 0)) []
234-
addSimpleAnnT rdr dp00 $ unqalDP $ hasParen idnetifier
238+
addSimpleAnnT rdr dp00 [(G AnnVal, dp00)]
235239
-- Parens are attachted to `lies`, so if `lies` was empty previously,
236240
-- we need change the ann key from `[]` to `:` to keep parens and other anns.
237241
unless hasSibling $
238242
transferAnn (L l' lies) (L l' [x]) id
239243
return $ L l it{ideclHiding = Just (hide, L l' $ lies ++ [x])}
240-
extendImportTopLevel _ _ _ = lift $ Left "Unable to extend the import list"
244+
extendImportTopLevel _ _ = lift $ Left "Unable to extend the import list"
241245

242246
-- | Add an identifier with its parent to import list
243247
--
@@ -249,7 +253,14 @@ extendImportTopLevel _ _ _ = lift $ Left "Unable to extend the import list"
249253
-- import A () --> import A (Bar(Cons))
250254
-- import A (Foo, Bar) --> import A (Foo, Bar(Cons))
251255
-- import A (Foo, Bar()) --> import A (Foo, Bar(Cons))
252-
extendImportViaParent :: DynFlags -> String -> String -> LImportDecl GhcPs -> TransformT (Either String) (LImportDecl GhcPs)
256+
extendImportViaParent ::
257+
DynFlags ->
258+
-- | parent (already parenthesized if needs)
259+
String ->
260+
-- | rendered child
261+
String ->
262+
LImportDecl GhcPs ->
263+
TransformT (Either String) (LImportDecl GhcPs)
253264
extendImportViaParent df parent child (L l it@ImportDecl{..})
254265
| Just (hide, L l' lies) <- ideclHiding = go hide l' [] lies
255266
where
@@ -260,8 +271,8 @@ extendImportViaParent df parent child (L l it@ImportDecl{..})
260271
-- ThingAbs ie => ThingWith ie child
261272
| parent == unIEWrappedName ie = do
262273
srcChild <- uniqueSrcSpanT
263-
childRdr <- liftParseAST df child
264-
let childLIE = L srcChild $ IEName childRdr
274+
let childRdr = L srcChild $ mkRdrUnqual $ mkVarOcc child
275+
childLIE = L srcChild $ IEName childRdr
265276
x :: LIE GhcPs = L ll' $ IEThingWith noExtField absIE NoIEWildcard [childLIE] []
266277
-- take anns from ThingAbs, and attatch parens to it
267278
transferAnn lAbs x $ \old -> old{annsDP = annsDP old ++ [(G AnnOpenP, DP (0, 1)), (G AnnCloseP, dp00)]}
@@ -273,7 +284,7 @@ extendImportViaParent df parent child (L l it@ImportDecl{..})
273284
, hasSibling <- not $ null lies' =
274285
do
275286
srcChild <- uniqueSrcSpanT
276-
childRdr <- liftParseAST df child
287+
let childRdr = L srcChild $ mkRdrUnqual $ mkVarOcc child
277288

278289
let alreadyImported =
279290
showNameWithoutUniques (occName (unLoc childRdr))
@@ -284,7 +295,7 @@ extendImportViaParent df parent child (L l it@ImportDecl{..})
284295
when hasSibling $
285296
addTrailingCommaT (last lies')
286297
let childLIE = L srcChild $ IEName childRdr
287-
addSimpleAnnT childRdr (DP (0, if hasSibling then 1 else 0)) $ unqalDP $ hasParen child
298+
addSimpleAnnT childRdr (DP (0, if hasSibling then 1 else 0)) [(G AnnVal, dp00)]
288299
return $ L l it{ideclHiding = Just (hide, L l' $ reverse pre ++ [L l'' (IEThingWith noExtField twIE NoIEWildcard (lies' ++ [childLIE]) [])] ++ xs)}
289300
go hide l' pre (x : xs) = go hide l' (x : pre) xs
290301
go hide l' pre []
@@ -294,14 +305,18 @@ extendImportViaParent df parent child (L l it@ImportDecl{..})
294305
srcParent <- uniqueSrcSpanT
295306
srcChild <- uniqueSrcSpanT
296307
parentRdr <- liftParseAST df parent
297-
childRdr <- liftParseAST df child
308+
let childRdr = L srcChild $ mkRdrUnqual $ mkVarOcc child
309+
isParentOperator = hasParen parent
298310
when hasSibling $
299311
addTrailingCommaT (head pre)
300-
let parentLIE = L srcParent $ IEName parentRdr
312+
let parentLIE = L srcParent $ (if isParentOperator then IEType else IEName) parentRdr
301313
childLIE = L srcChild $ IEName childRdr
302314
x :: LIE GhcPs = L l'' $ IEThingWith noExtField parentLIE NoIEWildcard [childLIE] []
303-
addSimpleAnnT parentRdr (DP (0, if hasSibling then 1 else 0)) $ unqalDP $ hasParen parent
304-
addSimpleAnnT childRdr (DP (0, 0)) $ unqalDP $ hasParen child
315+
-- Add AnnType for the parent if it's parenthesized (type operator)
316+
when isParentOperator $
317+
addSimpleAnnT parentLIE (DP (0, 0)) [(G AnnType, DP (0, 0))]
318+
addSimpleAnnT parentRdr (DP (0, if hasSibling then 1 else 0)) $ unqalDP 1 isParentOperator
319+
addSimpleAnnT childRdr (DP (0, 0)) [(G AnnVal, dp00)]
305320
addSimpleAnnT x (DP (0, 0)) [(G AnnOpenP, DP (0, 1)), (G AnnCloseP, DP (0, 0))]
306321
-- Parens are attachted to `pre`, so if `pre` was empty previously,
307322
-- we need change the ann key from `[]` to `:` to keep parens and other anns.
@@ -317,10 +332,10 @@ hasParen :: String -> Bool
317332
hasParen ('(' : _) = True
318333
hasParen _ = False
319334

320-
unqalDP :: Bool -> [(KeywordId, DeltaPos)]
321-
unqalDP paren =
335+
unqalDP :: Int -> Bool -> [(KeywordId, DeltaPos)]
336+
unqalDP c paren =
322337
( if paren
323-
then \x -> (G AnnOpenP, dp00) : x : [(G AnnCloseP, dp00)]
338+
then \x -> (G AnnOpenP, DP (0, c)) : x : [(G AnnCloseP, dp00)]
324339
else pure
325340
)
326341
(G AnnVal, dp00)
@@ -364,7 +379,7 @@ extendHiding symbol (L l idecls) mlies df = do
364379
, (G AnnCloseP, DP (0, 0))
365380
]
366381
addSimpleAnnT x (DP (0, 0)) []
367-
addSimpleAnnT rdr dp00 $ unqalDP $ isOperator $ unLoc rdr
382+
addSimpleAnnT rdr dp00 $ unqalDP 0 $ isOperator $ unLoc rdr
368383
if hasSibling
369384
then when hasSibling $ do
370385
addTrailingCommaT x

‎ghcide/src/Development/IDE/Types/Exports.hs‎

Lines changed: 13 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -56,21 +56,30 @@ instance NFData IdentInfo where
5656
-- deliberately skip the rendered field
5757
rnf name `seq` rnf parent `seq` rnf isDatacon `seq` rnf moduleNameText
5858

59+
-- | Render an identifier as imported or exported style.
60+
-- TODO: pattern synonym
61+
renderIEWrapped :: Name -> Text
62+
renderIEWrapped n
63+
| isTcOcc occ && isSymOcc occ = "type " <> pack (printName n)
64+
| otherwise = pack $ printName n
65+
where
66+
occ = occName n
67+
5968
mkIdentInfos :: Text -> AvailInfo -> [IdentInfo]
6069
mkIdentInfos mod (Avail n) =
61-
[IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n) mod]
70+
[IdentInfo (pack (prettyPrint n)) (renderIEWrapped n) Nothing (isDataConName n) mod]
6271
mkIdentInfos mod (AvailTC parent (n:nn) flds)
6372
-- Following the GHC convention that parent == n if parent is exported
6473
| n == parent
65-
= [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) (Just $! parentP) (isDataConName n) mod
74+
= [ IdentInfo (pack (prettyPrint n)) (renderIEWrapped n) (Just $! parentP) (isDataConName n) mod
6675
| n <- nn ++ map flSelector flds
6776
] ++
68-
[ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n) mod]
77+
[ IdentInfo (pack (prettyPrint n)) (renderIEWrapped n) Nothing (isDataConName n) mod]
6978
where
7079
parentP = pack $ printName parent
7180

7281
mkIdentInfos mod (AvailTC _ nn flds)
73-
= [ IdentInfo (pack (prettyPrint n)) (pack (printName n)) Nothing (isDataConName n) mod
82+
= [ IdentInfo (pack (prettyPrint n)) (renderIEWrapped n) Nothing (isDataConName n) mod
7483
| n <- nn ++ map flSelector flds
7584
]
7685

‎ghcide/test/exe/Main.hs‎

Lines changed: 26 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1380,13 +1380,33 @@ extendImportTests = testGroup "extend import actions"
13801380
, "x = Refl"
13811381
])
13821382
(Range (Position 3 17) (Position 3 18))
1383-
["Add (:~:)(Refl) to the import list of Data.Type.Equality"]
1383+
["Add type (:~:)(Refl) to the import list of Data.Type.Equality"]
13841384
(T.unlines
13851385
[ "module ModuleA where"
13861386
, "import Data.Type.Equality ((:~:) (Refl))"
13871387
, "x :: (:~:) [] []"
13881388
, "x = Refl"
13891389
])
1390+
, expectFailBecause "importing pattern synonyms is unsupported"
1391+
$ testSession "extend import list with pattern synonym" $ template
1392+
[("ModuleA.hs", T.unlines
1393+
[ "{-# LANGUAGE PatternSynonyms #-}"
1394+
, "module ModuleA where"
1395+
, "pattern Some x = Just x"
1396+
])
1397+
]
1398+
("ModuleB.hs", T.unlines
1399+
[ "module ModuleB where"
1400+
, "import A ()"
1401+
, "k (Some x) = x"
1402+
])
1403+
(Range (Position 2 3) (Position 2 7))
1404+
["Add pattern Some to the import list of A"]
1405+
(T.unlines
1406+
[ "module ModuleB where"
1407+
, "import A (pattern Some)"
1408+
, "k (Some x) = x"
1409+
])
13901410
]
13911411
where
13921412
codeActionTitle CodeAction{_title=x} = x
@@ -1549,6 +1569,7 @@ suggestImportTests = testGroup "suggest import actions"
15491569
, test True [] "f = (&) [] id" [] "import Data.Function ((&))"
15501570
, test True [] "f = (.|.)" [] "import Data.Bits (Bits((.|.)))"
15511571
, test True [] "f = (.|.)" [] "import Data.Bits ((.|.))"
1572+
, test True [] "f :: a ~~ b" [] "import Data.Type.Equality (type (~~))"
15521573
, test True
15531574
["qualified Data.Text as T"
15541575
] "f = T.putStrLn" [] "import qualified Data.Text.IO as T"
@@ -1563,15 +1584,17 @@ suggestImportTests = testGroup "suggest import actions"
15631584
, "qualified Data.Data as T"
15641585
] "f = T.putStrLn" [] "import qualified Data.Text.IO as T"
15651586
]
1587+
, expectFailBecause "importing pattern synonyms is unsupported" $ test True [] "k (Some x) = x" [] "import B (pattern Some)"
15661588
]
15671589
where
15681590
test = test' False
15691591
wantWait = test' True True
15701592
test' waitForCheckProject wanted imps def other newImp = testSessionWithExtraFiles "hover" (T.unpack def) $ \dir -> do
15711593
let before = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ def : other
15721594
after = T.unlines $ "module A where" : ["import " <> x | x <- imps] ++ [newImp] ++ def : other
1573-
cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -, A, Bar, Foo]}}"
1595+
cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -, A, Bar, Foo, B]}}"
15741596
liftIO $ writeFileUTF8 (dir </> "hie.yaml") cradle
1597+
liftIO $ writeFileUTF8 (dir </> "B.hs") $ unlines ["{-# LANGUAGE PatternSynonyms #-}", "module B where", "pattern Some x = Just x"]
15751598
doc <- createDoc "Test.hs" "haskell" before
15761599
waitForProgressDone
15771600
_diags <- waitForDiagnostics
@@ -3987,7 +4010,7 @@ nonLocalCompletionTests =
39874010
["module A where", "import Data.Type.Equality ()", "f = Ref"]
39884011
(Position 2 8)
39894012
"Refl"
3990-
["module A where", "import Data.Type.Equality ((:~:) (Refl))", "f = Ref"]
4013+
["module A where", "import Data.Type.Equality (type (:~:) (Refl))", "f = Ref"]
39914014
]
39924015
, testGroup "Record completion"
39934016
[ completionCommandTest

0 commit comments

Comments
 (0)