-
-
Notifications
You must be signed in to change notification settings - Fork 439
Expand file tree
/
Copy pathExactPrint.hs
More file actions
634 lines (586 loc) · 24.1 KB
/
Copy pathExactPrint.hs
File metadata and controls
634 lines (586 loc) · 24.1 KB
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
module Development.IDE.Plugin.CodeAction.ExactPrint (
Rewrite (..),
rewriteToEdit,
rewriteToWEdit,
-- * Utilities
appendConstraint,
removeConstraint,
extendImport,
hideSymbol,
liftParseAST,
wildCardSymbol,
-- * Re-exports
balanceCommentsList,
) where
import Control.Monad
import Control.Monad.Trans
import Data.Char (isAlphaNum)
import Data.Data (Data)
import Data.Generics (listify)
import qualified Data.Text as T
import Development.IDE.GHC.Compat hiding (Annotation)
import Development.IDE.GHC.Error
import Development.IDE.GHC.ExactPrint
import Development.IDE.GHC.Util
import Development.IDE.Spans.Common
import GHC.Exts (IsList (fromList))
import GHC.Stack (HasCallStack)
import Language.Haskell.GHC.ExactPrint
import Language.LSP.Protocol.Types
import Control.Lens (_head, _last, over)
import Data.Bifunctor (first)
import Data.Maybe (fromMaybe, mapMaybe)
import Development.IDE.Plugin.CodeAction.Util
import GHC (AnnContext (..),
AnnList (..),
DeltaPos (SameLine),
EpAnn (..),
IsUnicodeSyntax (NormalSyntax),
NameAdornment (NameParens),
TrailingAnn (AddCommaAnn),
emptyComments
#if !MIN_VERSION_ghc(9,13,0)
, reAnnL
#endif
)
-- See Note [Guidelines For Using CPP In GHCIDE Import Statements]
#if MIN_VERSION_ghc(9,11,0)
import GHC (EpToken (..)
, AnnListBrackets (..)
, EpUniToken (..))
#else
import GHC (AddEpAnn (..),
AnnParen (..))
#endif
#if !MIN_VERSION_ghc(9,9,0)
import Data.Default (Default (..))
import GHC (addAnns, ann)
#endif
#if MIN_VERSION_ghc(9,9,0)
import GHC (NoAnn (..))
import GHC (EpAnnComments (..))
#endif
#if MIN_VERSION_ghc(9,13,0)
import GHC (spanAsAnchor)
reAnnL :: ann -> EpAnnComments -> Located e -> GenLocated (EpAnn ann) e
reAnnL anns cs (L l a) = L (EpAnn (spanAsAnchor l) anns cs) a
#endif
------------------------------------------------------------------------------
-- | Construct a 'Rewrite', replacing the node at the given 'SrcSpan' with the
-- given 'ast'.
data Rewrite where
Rewrite ::
(ExactPrint (GenLocated (Anno ast) ast), ResetEntryDP (Anno ast), Outputable (GenLocated (Anno ast) ast), Data (GenLocated (Anno ast) ast)) =>
-- | The 'SrcSpan' that we want to rewrite
SrcSpan ->
-- | The ast that we want to graft
(DynFlags -> TransformT (Either String) (GenLocated (Anno ast) ast)) ->
Rewrite
------------------------------------------------------------------------------
class ResetEntryDP ann where
resetEntryDP :: GenLocated ann ast -> GenLocated ann ast
#if MIN_VERSION_ghc(9,9,0)
instance {-# OVERLAPPING #-} NoAnn an => ResetEntryDP (EpAnn an) where
resetEntryDP (L srcAnn x) = setEntryDP (L srcAnn{anns=noAnn} x) (SameLine 0)
#else
instance {-# OVERLAPPING #-} Default an => ResetEntryDP (SrcAnn an) where
resetEntryDP (L srcAnn x) = setEntryDP (L srcAnn{ann=EpAnnNotUsed} x) (SameLine 0)
#endif
instance {-# OVERLAPPABLE #-} ResetEntryDP fallback where
resetEntryDP = id
-- | Convert a 'Rewrite' into a list of '[TextEdit]'.
rewriteToEdit :: HasCallStack =>
DynFlags ->
Rewrite ->
Either String [TextEdit]
rewriteToEdit dflags
(Rewrite dst f) = do
(ast, _ , _) <- runTransformT $ do
ast <- f dflags
pure $ traceAst "REWRITE_result" $ resetEntryDP ast
let edits = case srcSpanToRange dst of
Just range -> [ TextEdit range $ T.pack $ exactPrint ast ]
Nothing -> []
pure edits
-- | Convert a 'Rewrite' into a 'WorkspaceEdit'
rewriteToWEdit :: DynFlags
-> Uri
-> Rewrite
-> Either String WorkspaceEdit
rewriteToWEdit dflags uri
r = do
edits <- rewriteToEdit dflags
r
return $
WorkspaceEdit
{ _changes = Just (fromList [(uri, edits)])
, _documentChanges = Nothing
, _changeAnnotations = Nothing
}
------------------------------------------------------------------------------
dropHsParTy :: LHsType (GhcPass pass) -> LHsType (GhcPass pass)
dropHsParTy (L _ (HsParTy _ ty)) = ty
dropHsParTy other = other
normalizeConstraintDP :: [LocatedAn AnnListItem (HsType GhcPs)] -> [LocatedAn AnnListItem (HsType GhcPs)]
normalizeConstraintDP [] = []
normalizeConstraintDP xs = normalizeFirst xs
where
normalizeFirst (x:rest) = setEntryDP x (SameLine 0) : rest
normalizeFirst [] = []
removeConstraint ::
-- | Predicate: Which context to drop.
(LHsType GhcPs -> Bool) ->
LHsType GhcPs ->
Rewrite
removeConstraint toRemove = go . traceAst "REMOVE_CONSTRAINT_input"
where
go :: LHsType GhcPs -> Rewrite
#if MIN_VERSION_ghc(9,9,0)
go lHsType@(makeDeltaAst -> L l it@HsQualTy{hst_ctxt = L l' ctxt, hst_body}) = Rewrite (locA lHsType) $ \_ -> do
#else
go (L l it@HsQualTy{hst_ctxt = L l' ctxt, hst_body}) = Rewrite (locA l) $ \_ -> do
#endif
let ctxt' = normalizeConstraintDP $ filter (not . toRemove) ctxt
return $ case ctxt' of
[] -> hst_body
_ -> do
let ctxt'' = over _last (first removeComma) ctxt'
L l $ it{ hst_ctxt = L l' ctxt''
, hst_body = hst_body
}
go (L _ (HsParTy _ ty)) = go ty
go (L _ HsForAllTy{hst_body}) = go hst_body
go (L l other) = Rewrite (locA l) $ \_ -> return $ L l other
-- | Append a constraint at the end of a type context.
-- If no context is present, a new one will be created.
appendConstraint ::
-- | The new constraint to append
String ->
-- | The type signature where the constraint is to be inserted, also assuming annotated
LHsType GhcPs ->
Rewrite
appendConstraint constraintT = go . traceAst "appendConstraint"
where
go (L l it@HsQualTy{hst_ctxt = L l' ctxt}) = Rewrite (locA l) $ \df -> do
constraint <- liftParseAST df constraintT
constraint <- pure $ setEntryDP constraint (SameLine 1)
#if MIN_VERSION_ghc(9,9,0)
let l'' = moveCommentsToTheEnd $ fmap (addParensToCtxt close_dp) l'
#else
let l'' = (fmap.fmap) (addParensToCtxt close_dp) l'
#endif
-- For singleton constraints, the close Paren DP is attached to an HsPar wrapping the constraint
-- we have to reposition it manually into the AnnContext
close_dp = case ctxt of
#if MIN_VERSION_ghc(9,11,0)
[L _ (HsParTy (_, (EpTok ap_close)) _)] -> Just ap_close
#elif MIN_VERSION_ghc(9,9,0)
[L _ (HsParTy AnnParen{ap_close} _)] -> Just ap_close
#else
[L _ (HsParTy EpAnn{anns=AnnParen{ap_close}} _)] -> Just ap_close
#endif
_ -> Nothing
ctxt' = over _last (first addComma) $ map dropHsParTy ctxt
return $ L l $ it{hst_ctxt = L l'' $ ctxt' ++ [constraint]}
go (L _ HsForAllTy{hst_body}) = go hst_body
go (L _ (HsParTy _ ty)) = go ty
go ast@(L l _) = Rewrite (locA l) $ \df -> do
-- there isn't a context, so we must create one
constraint <- liftParseAST df constraintT
lContext <- uniqueSrcSpanT
lTop <- uniqueSrcSpanT
let context = reAnnL annCtxt emptyComments $ L lContext [resetEntryDP constraint]
#if MIN_VERSION_ghc(9,11,0)
annCtxt = AnnContext (Just (EpUniTok (epl 1) NormalSyntax)) [EpTok (epl 0) | needsParens] [EpTok (epl 0) | needsParens]
#else
annCtxt = AnnContext (Just (NormalSyntax, epl 1)) [epl 0 | needsParens] [epl 0 | needsParens]
#endif
needsParens = hsTypeNeedsParens sigPrec $ unLoc constraint
ast <- pure $ setEntryDP (makeDeltaAst ast) (SameLine 1)
return $ reLocA $ L lTop $ HsQualTy noExtField context ast
#if MIN_VERSION_ghc(9,9,0)
-- | This moves comment annotation toward the end of the block
-- This is useful when extending a block, so the comment correctly appears
-- after.
--
-- See https://github.com/haskell/haskell-language-server/issues/4648 for
-- discussion.
--
-- For example, the following element, @(Foo) => -- hello@, when introducing an
-- additionnal constraint, `Bar`, instead of getting `@(Foo, Bar) => -- hello@,
-- we get @(Foo, -- hello Bar) =>@
--
-- This is a bit painful that the pretty printer is not able to realize that it
-- introduces the token `=>` inside the comment and instead does something with
-- meaning, but that's another story.
moveCommentsToTheEnd :: EpAnn ann -> EpAnn ann
moveCommentsToTheEnd (EpAnn entry anns (EpaComments priors)) = EpAnn entry anns (EpaCommentsBalanced { priorComments = [], followingComments = priors})
moveCommentsToTheEnd (EpAnn entry anns (EpaCommentsBalanced priors following)) = EpAnn entry anns (EpaCommentsBalanced { priorComments = [], followingComments = priors <> following})
#endif
liftParseAST
:: forall ast l. (ASTElement l ast)
=> DynFlags -> String -> TransformT (Either String) (LocatedAn l ast)
liftParseAST df s = case parseAST df "" s of
Right x -> pure (makeDeltaAst x)
Left _ -> TransformT $ lift $ Left $ "No parse: " <> s
lastMaybe :: [a] -> Maybe a
lastMaybe [] = Nothing
lastMaybe other = Just $ last other
------------------------------------------------------------------------------
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`
-- Parsed source in GHC 9.4 uses absolute position annotation (RealSrcSpan),
-- while rewriting relies on relative positions. ghc-exactprint has the utility
-- makeDeltaAst for relativization.
Just parent -> extendImportViaParent df parent identifier (makeDeltaAst lDecl)
_ -> extendImportTopLevel identifier (makeDeltaAst lDecl)
-- | Add an identifier or a data type to import list. Expects a Delta AST
--
-- extendImportTopLevel "foo" AST:
--
-- import A --> Error
-- import A (foo) --> Error
-- import A (bar) --> import A (bar, foo)
extendImportTopLevel ::
-- | rendered
String ->
LImportDecl GhcPs ->
TransformT (Either String) (LImportDecl GhcPs)
extendImportTopLevel thing (L l it@ImportDecl{..})
| Just (hide, L l' lies) <- ideclImportList
= do
src <- uniqueSrcSpanT
top <- uniqueSrcSpanT
let rdr = reLocA $ L src $ mkRdrUnqual $ mkVarOcc thing
let alreadyImported =
printOutputable (occName (unLoc rdr))
`elem` map (printOutputable @OccName) (listify (const True) lies)
when alreadyImported $
TransformT $ lift (Left $ thing <> " already imported")
let lie = reLocA $ L src $ IEName
noExtField
rdr
x = reLocA $ L top $ IEVar
#if MIN_VERSION_ghc(9,8,0)
Nothing -- no deprecated
#else
noExtField
#endif
lie
#if MIN_VERSION_ghc(9,9,0)
Nothing
#endif
if x `elem` lies
then TransformT $ lift (Left $ thing <> " already imported")
else do
let lies' = addCommaInImportList lies x
return $ L l it{ideclImportList = Just (hide, L l' lies')}
extendImportTopLevel _ _ = TransformT $ lift $ Left "Unable to extend the import list"
wildCardSymbol :: String
wildCardSymbol = ".."
-- | Add an identifier with its parent to import list
--
-- extendImportViaParent "Bar" "Cons" AST:
--
-- import A --> Error
-- import A (Bar(..)) --> Error
-- import A (Bar(Cons)) --> Error
-- 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)
String ->
-- | rendered child
String ->
LImportDecl GhcPs ->
TransformT (Either String) (LImportDecl GhcPs)
extendImportViaParent df parent child (L l it@ImportDecl{..})
| Just (hide, L l' lies) <- ideclImportList = go hide l' [] lies
where
#if MIN_VERSION_ghc(9,9,0)
go _hide _l' _pre ((L _ll' (IEThingAll _ (L _ ie) _)) : _xs)
#else
go _hide _l' _pre ((L _ll' (IEThingAll _ (L _ ie))) : _xs)
#endif
| parent == unIEWrappedName ie = TransformT $ lift . Left $ child <> " already included in " <> parent <> " imports"
#if MIN_VERSION_ghc(9,9,0)
go hide l' pre ((L ll' (IEThingAbs _ absIE@(L _ ie) docs)) : xs)
#else
go hide l' pre ((L ll' (IEThingAbs _ absIE@(L _ ie))) : xs)
#endif
-- ThingAbs ie => ThingWith ie child
| parent == unIEWrappedName ie = do
srcChild <- uniqueSrcSpanT
let childRdr = reLocA $ L srcChild $ mkRdrUnqual $ mkVarOcc child
childLIE = reLocA $ L srcChild $ IEName
noExtField
childRdr
x :: LIE GhcPs = L ll' $ IEThingWith
#if MIN_VERSION_ghc(9,11,0)
(Nothing, (EpTok d1, NoEpTok, NoEpTok, EpTok noAnn))
#elif MIN_VERSION_ghc(9,9,0)
(Nothing, [AddEpAnn AnnOpenP d1, AddEpAnn AnnCloseP noAnn])
#elif MIN_VERSION_ghc(9,7,0)
(Nothing, addAnns mempty [AddEpAnn AnnOpenP d1, AddEpAnn AnnCloseP def] emptyComments)
#else
(addAnns mempty [AddEpAnn AnnOpenP d1, AddEpAnn AnnCloseP def] emptyComments)
#endif
absIE NoIEWildcard [childLIE]
#if MIN_VERSION_ghc(9,9,0)
docs
#endif
return $ L l it{ideclImportList = Just (hide, L l' $ reverse pre ++ [x] ++ xs)}
#if MIN_VERSION_ghc(9,9,0)
go hide l' pre ((L l'' (IEThingWith l''' twIE@(L _ ie) _ lies' docs)) : xs)
#else
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
let it' = it{ideclImportList = Just (hide, lies)}
thing = IEThingWith newl twIE (IEWildcard 2) []
#if MIN_VERSION_ghc(9,9,0)
docs
#endif
#if MIN_VERSION_ghc(9,7,0) && !MIN_VERSION_ghc(9,9,0)
newl = fmap (\ann -> ann ++ [AddEpAnn AnnDotdot d0]) <$> l'''
#elif MIN_VERSION_ghc(9,11,0)
newl = (\(open, _, comma, close) -> (open, EpTok d0, comma, close)) <$> l'''
#else
newl = (\ann -> ann ++ [AddEpAnn AnnDotdot d0]) <$> l'''
#endif
lies = L l' $ reverse pre ++ [L l'' thing] ++ xs
return $ L l it'
| parent == unIEWrappedName ie = do
let hasSibling = not $ null lies'
srcChild <- uniqueSrcSpanT
let childRdr = reLocA $ L srcChild $ mkRdrUnqual $ mkVarOcc child
childRdr <- pure $ setEntryDP childRdr $ SameLine $ if hasSibling then 1 else 0
let alreadyImported =
printOutputable (occName (unLoc childRdr))
`elem` map (printOutputable @OccName) (listify (const True) lies')
when alreadyImported $
TransformT $ lift (Left $ child <> " already included in " <> parent <> " imports")
let childLIE = reLocA $ L srcChild $ IEName
noExtField
childRdr
let it' = it{ideclImportList = Just (hide, lies)}
lies = L l' $ reverse pre ++
[L l'' (IEThingWith l''' twIE NoIEWildcard (over _last fixLast lies' ++ [childLIE])
#if MIN_VERSION_ghc(9,9,0)
docs
#endif
)] ++ xs
fixLast = if hasSibling then first addComma else id
return $ L l it'
go hide l' pre (x : xs) = go hide l' (x : pre) xs
go hide l' pre [] = do
-- [] => ThingWith parent [child]
l'' <- uniqueSrcSpanT
srcParent <- uniqueSrcSpanT
srcChild <- uniqueSrcSpanT
parentRdr <- liftParseAST df parent
let childRdr = reLocA $ L srcChild $ mkRdrUnqual $ mkVarOcc child
isParentOperator = hasParen parent
#if MIN_VERSION_ghc(9,11,0)
let parentLIE = reLocA $ L srcParent $ if isParentOperator then IEType (EpTok (epl 0)) parentRdr'
#else
let parentLIE = reLocA $ L srcParent $ if isParentOperator then IEType (epl 0) parentRdr'
#endif
else IEName
noExtField
parentRdr'
parentRdr' = modifyAnns parentRdr $ \case
#if MIN_VERSION_ghc(9,11,0)
it@NameAnn{nann_adornment = NameParens _ _} -> it{nann_adornment=NameParens (EpTok (epl 1)) (EpTok (epl 0))}
#else
it@NameAnn{nann_adornment = NameParens} -> it{nann_open = epl 1, nann_close = epl 0}
#endif
other -> other
childLIE = reLocA $ L srcChild $ IEName
noExtField
childRdr
#if MIN_VERSION_ghc(9,11,0)
listAnn = (Nothing, (EpTok (epl 1), NoEpTok, NoEpTok, EpTok (epl 0)))
#elif MIN_VERSION_ghc(9,9,0)
listAnn = (Nothing, [AddEpAnn AnnOpenP (epl 1), AddEpAnn AnnCloseP (epl 0)])
#elif MIN_VERSION_ghc(9,7,0)
listAnn = (Nothing, epAnn srcParent [AddEpAnn AnnOpenP (epl 1), AddEpAnn AnnCloseP (epl 0)])
#else
listAnn = epAnn srcParent [AddEpAnn AnnOpenP (epl 1), AddEpAnn AnnCloseP (epl 0)]
#endif
x :: LIE GhcPs = reLocA $ L l'' $ IEThingWith listAnn parentLIE NoIEWildcard [childLIE]
#if MIN_VERSION_ghc(9,9,0)
Nothing -- TODO preserve docs?
#endif
lies' = addCommaInImportList (reverse pre) x
return $ L l it{ideclImportList = Just (hide, L l' lies')}
extendImportViaParent _ _ _ _ = TransformT $ lift $ Left "Unable to extend the import list via parent"
-- Add an item in an import list, taking care of adding comma if needed.
addCommaInImportList ::
-- | Initial list
[LocatedAn AnnListItem a]
-- | Additional item
-> LocatedAn AnnListItem a
-> [LocatedAn AnnListItem a]
addCommaInImportList lies x =
fixLast lies ++ [newItem]
where
isTrailingAnnComma :: TrailingAnn -> Bool
isTrailingAnnComma (AddCommaAnn _) = True
isTrailingAnnComma _ = False
-- check if there is an existing trailing comma
existingTrailingComma = fromMaybe False $ do
L lastItemSrcAnn _ <- lastMaybe lies
#if MIN_VERSION_ghc(9,9,0)
lastItemAnn <- case lastItemSrcAnn of
EpAnn _ lastItemAnn _ -> pure lastItemAnn
#else
lastItemAnn <- case ann lastItemSrcAnn of
EpAnn _ lastItemAnn _ -> pure lastItemAnn
_ -> Nothing
#endif
pure $ any isTrailingAnnComma (lann_trailing lastItemAnn)
hasSibling = not $ null lies
-- Setup the new item. It should have a preceding whitespace if it has siblings, and a trailing comma if the
-- preceding item already has one.
newItem = first (if existingTrailingComma then addComma else id) $
setEntryDP x (SameLine $ if hasSibling then 1 else 0)
-- Add the comma (if needed)
fixLast :: [LocatedAn AnnListItem a] -> [LocatedAn AnnListItem a]
fixLast = over _last (first (if existingTrailingComma then id else addComma))
unIEWrappedName :: IEWrappedName GhcPs -> String
unIEWrappedName (occName -> occ) = T.unpack $ printOutputable $ parenSymOcc occ (ppr occ)
hasParen :: String -> Bool
hasParen ('(' : _) = True
hasParen _ = False
------------------------------------------------------------------------------
-- | Hide a symbol from import declaration
hideSymbol ::
String -> LImportDecl GhcPs -> Rewrite
hideSymbol symbol lidecl@(L loc ImportDecl{..}) =
case ideclImportList of
Nothing -> Rewrite (locA loc) $ extendHiding symbol lidecl Nothing
Just (EverythingBut, hides) -> Rewrite (locA loc) $ extendHiding symbol lidecl (Just hides)
Just (Exactly, imports) -> Rewrite (locA loc) $ deleteFromImport symbol lidecl $ setEntryDP (makeDeltaAst imports) (SameLine 1)
extendHiding ::
String ->
LImportDecl GhcPs ->
Maybe (XRec GhcPs [LIE GhcPs]) ->
DynFlags ->
TransformT (Either String) (LImportDecl GhcPs)
extendHiding symbol (L l idecls) mlies df = do
L l' lies <- case mlies of
Nothing -> do
#if MIN_VERSION_ghc(9,11,0)
let ann :: EpAnn (AnnList (EpToken "hiding", [EpToken ","]))
ann = noAnnSrcSpanDP0
#elif MIN_VERSION_ghc(9,9,0)
let ann = noAnnSrcSpanDP0
#else
src <- uniqueSrcSpanT
let ann = noAnnSrcSpanDP0 src
#endif
#if MIN_VERSION_ghc(9,9,0)
ann' = flip fmap ann $ \x -> x
#else
ann' = flip (fmap.fmap) ann $ \x -> x
#endif
#if MIN_VERSION_ghc(9,11,0)
{al_rest = (EpTok (epl 1), [NoEpTok])
,al_brackets=ListParens (EpTok (epl 1)) (EpTok (epl 0))
#else
{al_rest = [AddEpAnn AnnHiding (epl 1)]
,al_open = Just $ AddEpAnn AnnOpenP (epl 1)
,al_close = Just $ AddEpAnn AnnCloseP (epl 0)
#endif
}
return $ L ann' []
Just pr -> pure pr
let hasSibling = not $ null lies
src <- uniqueSrcSpanT
top <- uniqueSrcSpanT
rdr <- liftParseAST df symbol
rdr <- pure $ modifyAnns rdr $ addParens (isOperator $ unLoc rdr)
let lie = reLocA $ L src $ IEName
noExtField
rdr
x = reLocA $ L top $ IEVar
#if MIN_VERSION_ghc(9,7,0)
Nothing
#else
noExtField
#endif
lie
#if MIN_VERSION_ghc(9,9,0)
Nothing
#endif
x <- pure $ if hasSibling then first addComma x else x
lies <- pure $ over _head (`setEntryDP` SameLine 1) lies
return $ L l idecls{ideclImportList = Just (EverythingBut, L l' $ x : lies)}
where
isOperator = not . all isAlphaNum . occNameString . rdrNameOcc
deleteFromImport ::
String ->
LImportDecl GhcPs ->
XRec GhcPs [LIE GhcPs] ->
DynFlags ->
TransformT (Either String) (LImportDecl GhcPs)
deleteFromImport (T.pack -> symbol) (L l idecl) (L lieLoc lies) _ = do
let edited = L lieLoc deletedLies
lidecl' =
L l $
idecl
{ ideclImportList = Just (Exactly, edited) }
pure lidecl'
where
deletedLies =
over _last removeTrailingComma $
mapMaybe killLie lies
killLie :: LIE GhcPs -> Maybe (LIE GhcPs)
#if MIN_VERSION_ghc(9,9,0)
killLie v@(L _ (IEVar _ (L _ (unqualIEWrapName -> nam)) _))
#else
killLie v@(L _ (IEVar _ (L _ (unqualIEWrapName -> nam))))
#endif
| nam == symbol = Nothing
| otherwise = Just v
#if MIN_VERSION_ghc(9,9,0)
killLie v@(L _ (IEThingAbs _ (L _ (unqualIEWrapName -> nam)) _))
#else
killLie v@(L _ (IEThingAbs _ (L _ (unqualIEWrapName -> nam))))
#endif
| nam == symbol = Nothing
| otherwise = Just v
#if MIN_VERSION_ghc(9,9,0)
killLie (L lieL (IEThingWith xt ty@(L _ (unqualIEWrapName -> nam)) wild cons docs))
#else
killLie (L lieL (IEThingWith xt ty@(L _ (unqualIEWrapName -> nam)) wild cons))
#endif
| nam == symbol = Nothing
| otherwise =
Just $
L lieL $
IEThingWith
xt
ty
wild
(filter ((/= symbol) . unqualIEWrapName . unLoc) cons)
#if MIN_VERSION_ghc(9,9,0)
docs
#endif
killLie v = Just v