Skip to content

Commit 38ce4c5

Browse files
pepeiborrapepeiborra
committed
appendConstraint + Rewrite abstraction
The Rewrite abstraction is similar to D.IDE.GHC.ExactPrint.Graft but it does fewer things more efficiently: - It doesn't annotate things for you (so it doesn't destroy user format) - It doesn't provide a Monoid instance (for now) - It doesn't need a fully parsed source - It doesn't use SYB to perform the replacement - It doesn't diff to compute the result The use case is code actions where you don't have the SrcSpan that you need to edit at hand, and instead you need to traverse the AST manually to locate the declaration to edit
1 parent de1b0e8 commit 38ce4c5

File tree

3 files changed

+183
-0
lines changed

3 files changed

+183
-0
lines changed

‎ghcide/ghcide.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -169,6 +169,7 @@ library
169169
Development.IDE.Plugin
170170
Development.IDE.Plugin.Completions
171171
Development.IDE.Plugin.CodeAction
172+
Development.IDE.Plugin.CodeAction.ExactPrint
172173
Development.IDE.Plugin.HLS
173174
Development.IDE.Plugin.HLS.GhcIde
174175
Development.IDE.Plugin.Test

‎ghcide/src/Development/IDE/GHC/ExactPrint.hs

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -10,6 +10,7 @@ module Development.IDE.GHC.ExactPrint
1010
graft,
1111
graftDecls,
1212
graftDeclsWithM,
13+
annotate,
1314
hoistGraft,
1415
graftWithM,
1516
graftWithSmallestM,
@@ -22,6 +23,9 @@ module Development.IDE.GHC.ExactPrint
2223
ASTElement (..),
2324
ExceptStringT (..),
2425
Annotated(..),
26+
TransformT,
27+
Anns,
28+
Annotate,
2529
)
2630
where
2731

@@ -325,6 +329,7 @@ fixAnns ParsedModule {..} =
325329
------------------------------------------------------------------------------
326330

327331
-- | Given an 'LHSExpr', compute its exactprint annotations.
332+
-- Note that this function will throw away any existing annotations (and format)
328333
annotate :: ASTElement ast => DynFlags -> Located ast -> TransformT (Either String) (Anns, Located ast)
329334
annotate dflags ast = do
330335
uniq <- show <$> uniqueSrcSpanT

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

Lines changed: 177 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,177 @@
1+
{-# LANGUAGE CPP #-}
2+
{-# LANGUAGE DerivingStrategies #-}
3+
{-# LANGUAGE GADTs #-}
4+
{-# LANGUAGE OverloadedStrings #-}
5+
{-# LANGUAGE RankNTypes #-}
6+
7+
module Development.IDE.Plugin.CodeAction.ExactPrint
8+
( Rewrite (..),
9+
rewriteToEdit,
10+
11+
-- * Utilities
12+
appendConstraint,
13+
)
14+
where
15+
16+
import Control.Applicative
17+
import Control.Monad
18+
import Control.Monad.Trans
19+
import Data.Data (Data)
20+
import Data.Functor
21+
import qualified Data.HashMap.Strict as HMap
22+
import qualified Data.Map.Strict as Map
23+
import Data.Maybe (fromJust)
24+
import qualified Data.Text as T
25+
import Development.IDE.GHC.Compat hiding (parseExpr)
26+
import Development.IDE.GHC.ExactPrint
27+
import Development.IDE.Types.Location
28+
import GhcPlugins (realSrcSpanEnd, realSrcSpanStart, sigPrec)
29+
import Language.Haskell.GHC.ExactPrint
30+
import Language.Haskell.GHC.ExactPrint.Types (DeltaPos (DP), KeywordId (G), mkAnnKey)
31+
import Language.Haskell.LSP.Types
32+
33+
------------------------------------------------------------------------------
34+
35+
-- | Construct a 'Rewrite', replacing the node at the given 'SrcSpan' with the
36+
-- given 'ast'.
37+
data Rewrite where
38+
Rewrite ::
39+
Annotate ast =>
40+
-- | The 'SrcSpan' that we want to rewrite
41+
SrcSpan ->
42+
-- | The ast that we want to graft
43+
(DynFlags -> TransformT (Either String) (Located ast)) ->
44+
Rewrite
45+
46+
------------------------------------------------------------------------------
47+
48+
-- | Convert a 'Rewrite' into a 'WorkspaceEdit'.
49+
rewriteToEdit ::
50+
DynFlags ->
51+
Uri ->
52+
Anns ->
53+
Rewrite ->
54+
Either String WorkspaceEdit
55+
rewriteToEdit dflags uri anns (Rewrite dst f) = do
56+
(ast, (anns, _), _) <- runTransformT anns $ f dflags
57+
let editMap =
58+
HMap.fromList
59+
[ ( uri,
60+
List
61+
[ ( TextEdit (fromJust $ srcSpanToRange dst) $
62+
T.pack $ tail $ exactPrint ast anns
63+
)
64+
]
65+
)
66+
]
67+
pure $ WorkspaceEdit (Just editMap) Nothing
68+
69+
srcSpanToRange :: SrcSpan -> Maybe Range
70+
srcSpanToRange (UnhelpfulSpan _) = Nothing
71+
srcSpanToRange (RealSrcSpan real) = Just $ realSrcSpanToRange real
72+
73+
realSrcSpanToRange :: RealSrcSpan -> Range
74+
realSrcSpanToRange real =
75+
Range
76+
(realSrcLocToPosition $ realSrcSpanStart real)
77+
(realSrcLocToPosition $ realSrcSpanEnd real)
78+
79+
realSrcLocToPosition :: RealSrcLoc -> Position
80+
realSrcLocToPosition real =
81+
Position (srcLocLine real - 1) (srcLocCol real - 1)
82+
83+
------------------------------------------------------------------------------
84+
85+
-- | Fix the parentheses around a type context
86+
fixParens ::
87+
(Monad m, Data (HsType pass)) =>
88+
Maybe DeltaPos ->
89+
Maybe DeltaPos ->
90+
LHsContext pass ->
91+
TransformT m [LHsType pass]
92+
fixParens openDP closeDP ctxt@(L _ elems) = do
93+
-- Paren annotation for type contexts are usually quite screwed up
94+
-- we remove duplicates and fix negative DPs
95+
modifyAnnsT $
96+
Map.adjust
97+
( \x ->
98+
let annsMap = Map.fromList (annsDP x)
99+
in x
100+
{ annsDP =
101+
Map.toList $
102+
Map.alter (\_ -> openDP <|> Just dp00) (G AnnOpenP) $
103+
Map.alter (\_ -> closeDP <|> Just dp00) (G AnnCloseP) $
104+
annsMap <> parens
105+
}
106+
)
107+
(mkAnnKey ctxt)
108+
return $ map dropHsParTy elems
109+
where
110+
parens = Map.fromList [(G AnnOpenP, dp00), (G AnnCloseP, dp00)]
111+
112+
dropHsParTy :: LHsType pass -> LHsType pass
113+
dropHsParTy (L _ (HsParTy _ ty)) = ty
114+
dropHsParTy other = other
115+
116+
-- | Append a constraint at the end of a type context.
117+
-- If no context is present, a new one will be created.
118+
appendConstraint ::
119+
-- | The new constraint to append
120+
String ->
121+
-- | The type signature where the constraint is to be inserted, also assuming annotated
122+
LHsType GhcPs ->
123+
Rewrite
124+
appendConstraint constraintT = go
125+
where
126+
go (L l it@HsQualTy {hst_ctxt = L l' ctxt}) = Rewrite l $ \df -> do
127+
constraint <- liftParseAST df constraintT
128+
setEntryDPT constraint (DP (0, 1))
129+
130+
-- Paren annotations are usually attached to the first and last constraints,
131+
-- rather than to the constraint list itself, so to preserve them we need to reposition them
132+
closeParenDP <- lookupAnn (G AnnCloseP) `mapM` lastMaybe ctxt
133+
openParenDP <- lookupAnn (G AnnOpenP) `mapM` headMaybe ctxt
134+
ctxt' <- fixParens (join openParenDP) (join closeParenDP) (L l' ctxt)
135+
136+
addTrailingCommaT (last ctxt')
137+
138+
return $ L l $ it {hst_ctxt = L l' $ ctxt' ++ [constraint]}
139+
go (L _ HsForAllTy {hst_body}) = go hst_body
140+
go (L _ (HsParTy _ ty)) = go ty
141+
go (L l other) = Rewrite l $ \df -> do
142+
-- there isn't a context, so we must create one
143+
constraint <- liftParseAST df constraintT
144+
lContext <- uniqueSrcSpanT
145+
lTop <- uniqueSrcSpanT
146+
let context = L lContext [constraint]
147+
addSimpleAnnT context (DP (0, 1)) $
148+
[ (G AnnDarrow, DP (0, 1))
149+
]
150+
++ concat
151+
[ [ (G AnnOpenP, dp00),
152+
(G AnnCloseP, dp00)
153+
]
154+
| hsTypeNeedsParens sigPrec $ unLoc constraint
155+
]
156+
return $ L lTop $ HsQualTy NoExtField context (L l other)
157+
158+
liftParseAST :: ASTElement ast => DynFlags -> String -> TransformT (Either String) (Located ast)
159+
liftParseAST df s = case parseAST df "" s of
160+
Right (anns, x) -> modifyAnnsT (anns <>) $> x
161+
Left _ -> lift $ Left $ "No parse: " <> s
162+
163+
lookupAnn :: (Data a, Monad m) => KeywordId -> Located a -> TransformT m (Maybe DeltaPos)
164+
lookupAnn comment la = do
165+
anns <- getAnnsT
166+
return $ Map.lookup (mkAnnKey la) anns >>= lookup comment . annsDP
167+
168+
dp00 :: DeltaPos
169+
dp00 = DP (0, 0)
170+
171+
headMaybe :: [a] -> Maybe a
172+
headMaybe [] = Nothing
173+
headMaybe (a : _) = Just a
174+
175+
lastMaybe :: [a] -> Maybe a
176+
lastMaybe [] = Nothing
177+
lastMaybe other = Just $ last other

0 commit comments

Comments
 (0)