Skip to content

Commit f8e2549

Browse files
ozkutukozkutuk
committed
Minor code reorganization
1 parent 3060535 commit f8e2549

File tree

1 file changed

+94
-96
lines changed

1 file changed

+94
-96
lines changed

‎plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs

Lines changed: 94 additions & 96 deletions
Original file line numberDiff line numberDiff line change
@@ -75,35 +75,6 @@ import Language.LSP.Types (CodeAction (..),
7575
import qualified Language.LSP.Types.Lens as L
7676

7777

78-
-- `Outputable` instance of `HsRecFields` does smart things to print
79-
-- the records that originally had wildcards with dots, even after they
80-
-- are removed by the renamer pass. Here `rec_dotdot` is set to
81-
-- `Nothing` so that fields are printed without such post-processing.
82-
preprocessRecord :: HsRecFields (GhcPass c) arg -> HsRecFields (GhcPass c) arg
83-
preprocessRecord flds = flds { rec_dotdot = Nothing , rec_flds = rec_flds' }
84-
where
85-
no_pun_count = maybe (length (rec_flds flds)) unLoc (rec_dotdot flds)
86-
-- Field binds of the explicit form (e.g. `{ a = a' }`) should be
87-
-- left as is, hence the split.
88-
(no_puns, puns) = splitAt no_pun_count (rec_flds flds)
89-
-- `hsRecPun` is set to `True` in order to pretty-print the fields as field
90-
-- puns (since there is similar mechanism in the `Outputable` instance as
91-
-- explained above).
92-
puns' = map (mapLoc (\fld -> fld { hfbPun = True })) puns
93-
rec_flds' = no_puns <> puns'
94-
95-
showRecordPat :: Outputable (Pat (GhcPass c)) => Pat (GhcPass c) -> Maybe Text
96-
showRecordPat pat@(ConPat _ _ (RecCon flds)) =
97-
Just $ printOutputable $
98-
pat { pat_args = RecCon (preprocessRecord flds) }
99-
showRecordPat _ = Nothing
100-
101-
showRecordCon :: Outputable (HsExpr (GhcPass c)) => HsExpr (GhcPass c) -> Maybe Text
102-
showRecordCon expr@(RecordCon _ _ flds) =
103-
Just $ printOutputable $
104-
expr { rcon_flds = preprocessRecord flds }
105-
showRecordCon _ = Nothing
106-
10778
data Log = LogShake Shake.Log
10879

10980
instance Pretty Log where
@@ -116,6 +87,71 @@ descriptor recorder plId = (defaultPluginDescriptor plId)
11687
, pluginRules = collectRecordsRule recorder
11788
}
11889

90+
codeActionProvider :: PluginMethodHandler IdeState 'TextDocumentCodeAction
91+
codeActionProvider ideState pId (CodeActionParams _ _ docId range _) = pluginResponse $ do
92+
nfp <- getNormalizedFilePath (docId ^. L.uri)
93+
pragma <- getFirstPragma pId ideState nfp
94+
CRR renderedRecs (map unExt -> exts) <- collectRecordsInRange range ideState nfp
95+
let actions = map (mkCodeAction nfp exts pragma) renderedRecs
96+
pure $ List actions
97+
98+
where
99+
mkCodeAction :: NormalizedFilePath -> [Extension] -> NextPragmaInfo -> RenderedRecordInfo -> Command |? CodeAction
100+
mkCodeAction nfp exts pragma rec = InR CodeAction
101+
{ _title = mkCodeActionTitle exts
102+
, _kind = Just CodeActionRefactorRewrite
103+
, _diagnostics = Nothing
104+
, _isPreferred = Nothing
105+
, _disabled = Nothing
106+
, _edit = Just $ mkWorkspaceEdit nfp edits
107+
, _command = Nothing
108+
, _xdata = Nothing
109+
}
110+
where
111+
edits = catMaybes [ mkTextEdit rec , pragmaEdit ]
112+
113+
mkTextEdit :: RenderedRecordInfo -> Maybe TextEdit
114+
mkTextEdit (RenderedRecordInfo ss r) = TextEdit <$> srcSpanToRange ss <*> pure r
115+
116+
-- NOTE(ozkutuk): `RecordPuns` extension is renamed to `NamedFieldPuns`
117+
-- in GHC 9.4, but we still want to insert `NamedFieldPuns` in pre-9.4
118+
-- GHC as well, hence the replacement.
119+
-- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/6156
120+
pragmaEdit :: Maybe TextEdit
121+
pragmaEdit = if NamedFieldPuns `elem` exts
122+
then Nothing
123+
else Just $ patchExtName $ insertNewPragma pragma NamedFieldPuns
124+
where
125+
patchExtName = L.newText %~ T.replace "Record" "NamedField"
126+
127+
mkWorkspaceEdit :: NormalizedFilePath -> [TextEdit] -> WorkspaceEdit
128+
mkWorkspaceEdit nfp edits = WorkspaceEdit changes Nothing Nothing
129+
where
130+
changes = Just $ HashMap.singleton (fromNormalizedUri (normalizedFilePathToUri nfp)) (List edits)
131+
132+
mkCodeActionTitle :: [Extension] -> Text
133+
mkCodeActionTitle exts =
134+
if NamedFieldPuns `elem` exts
135+
then title
136+
else title <> " (needs extension: NamedFieldPuns)"
137+
where
138+
title = "Expand record wildcard"
139+
140+
collectRecordsRule :: Recorder (WithPriority Log) -> Rules ()
141+
collectRecordsRule recorder = define (cmapWithPrio LogShake recorder) $ \CollectRecords nfp -> do
142+
tmr <- use TypeCheck nfp
143+
let exts = getEnabledExtensions <$> tmr
144+
recs = getRecords <$> tmr
145+
renderedRecs = mapMaybe renderRecordInfo <$> recs
146+
pure ([], CRR <$> renderedRecs <*> exts)
147+
148+
getEnabledExtensions :: TcModuleResult -> [GhcExtension]
149+
getEnabledExtensions = map GhcExtension . toList . extensionFlags . ms_hspp_opts . pm_mod_summary . tmrParsed
150+
151+
getRecords :: TcModuleResult -> [RecordInfo]
152+
getRecords (tmrRenamed -> (hs_valds -> valBinds,_,_,_)) =
153+
collectRecords valBinds
154+
119155
data CollectRecords = CollectRecords
120156
deriving (Eq, Show, Generic)
121157

@@ -156,7 +192,35 @@ renderRecordInfo :: RecordInfo -> Maybe RenderedRecordInfo
156192
renderRecordInfo (RecordInfoPat ss pat) = RenderedRecordInfo ss <$> showRecordPat pat
157193
renderRecordInfo (RecordInfoCon ss expr) = RenderedRecordInfo ss <$> showRecordCon expr
158194

159-
-- collectRecords :: GenericQ [LPat (GhcPass 'Renamed)]
195+
-- `Outputable` instance of `HsRecFields` does smart things to print
196+
-- the records that originally had wildcards with dots, even after they
197+
-- are removed by the renamer pass. Here `rec_dotdot` is set to
198+
-- `Nothing` so that fields are printed without such post-processing.
199+
preprocessRecord :: HsRecFields (GhcPass c) arg -> HsRecFields (GhcPass c) arg
200+
preprocessRecord flds = flds { rec_dotdot = Nothing , rec_flds = rec_flds' }
201+
where
202+
no_pun_count = maybe (length (rec_flds flds)) unLoc (rec_dotdot flds)
203+
-- Field binds of the explicit form (e.g. `{ a = a' }`) should be
204+
-- left as is, hence the split.
205+
(no_puns, puns) = splitAt no_pun_count (rec_flds flds)
206+
-- `hsRecPun` is set to `True` in order to pretty-print the fields as field
207+
-- puns (since there is similar mechanism in the `Outputable` instance as
208+
-- explained above).
209+
puns' = map (mapLoc (\fld -> fld { hfbPun = True })) puns
210+
rec_flds' = no_puns <> puns'
211+
212+
showRecordPat :: Outputable (Pat (GhcPass c)) => Pat (GhcPass c) -> Maybe Text
213+
showRecordPat pat@(ConPat _ _ (RecCon flds)) =
214+
Just $ printOutputable $
215+
pat { pat_args = RecCon (preprocessRecord flds) }
216+
showRecordPat _ = Nothing
217+
218+
showRecordCon :: Outputable (HsExpr (GhcPass c)) => HsExpr (GhcPass c) -> Maybe Text
219+
showRecordCon expr@(RecordCon _ _ flds) =
220+
Just $ printOutputable $
221+
expr { rcon_flds = preprocessRecord flds }
222+
showRecordCon _ = Nothing
223+
160224
collectRecords :: GenericQ [RecordInfo]
161225
collectRecords = everything (<>) (maybeToList . (Nothing `mkQ` getRecPatterns `extQ` getRecCons))
162226

@@ -176,21 +240,6 @@ getRecPatterns conPat@(unLoc -> ConPat _ _ (RecCon flds))
176240
mkRecInfo pat = RecordInfoPat (getLoc pat) (unLoc pat)
177241
getRecPatterns _ = Nothing
178242

179-
getEnabledExtensions :: TcModuleResult -> [GhcExtension]
180-
getEnabledExtensions = map GhcExtension . toList . extensionFlags . ms_hspp_opts . pm_mod_summary . tmrParsed
181-
182-
getRecords :: TcModuleResult -> [RecordInfo]
183-
getRecords (tmrRenamed -> (hs_valds -> valBinds,_,_,_)) =
184-
collectRecords valBinds
185-
186-
collectRecordsRule :: Recorder (WithPriority Log) -> Rules ()
187-
collectRecordsRule recorder = define (cmapWithPrio LogShake recorder) $ \CollectRecords nfp -> do
188-
tmr <- use TypeCheck nfp
189-
let exts = getEnabledExtensions <$> tmr
190-
recs = getRecords <$> tmr
191-
renderedRecs = mapMaybe renderRecordInfo <$> recs
192-
pure ([], CRR <$> renderedRecs <*> exts)
193-
194243
collectRecords' :: MonadIO m => IdeState -> NormalizedFilePath -> ExceptT String m CollectRecordsResult
195244
collectRecords' ideState =
196245
handleMaybeM "Unable to TypeCheck"
@@ -207,57 +256,6 @@ collectRecordsInRange range ideState nfp = do
207256
inRange :: RenderedRecordInfo -> Bool
208257
inRange (RenderedRecordInfo ss _) = maybe False (subRange range) (srcSpanToRange ss)
209258

210-
211-
codeActionProvider :: PluginMethodHandler IdeState 'TextDocumentCodeAction
212-
codeActionProvider ideState pId (CodeActionParams _ _ docId range _) = pluginResponse $ do
213-
nfp <- getNormalizedFilePath (docId ^. L.uri)
214-
pragma <- getFirstPragma pId ideState nfp
215-
CRR renderedRecs (map unExt -> exts) <- collectRecordsInRange range ideState nfp
216-
let actions = map (mkCodeAction nfp exts pragma) renderedRecs
217-
pure $ List actions
218-
219-
where
220-
mkCodeAction :: NormalizedFilePath -> [Extension] -> NextPragmaInfo -> RenderedRecordInfo -> Command |? CodeAction
221-
mkCodeAction nfp exts pragma rec = InR CodeAction
222-
{ _title = mkCodeActionTitle exts
223-
, _kind = Just CodeActionRefactorRewrite
224-
, _diagnostics = Nothing
225-
, _isPreferred = Nothing
226-
, _disabled = Nothing
227-
, _edit = Just $ mkWorkspaceEdit nfp edits
228-
, _command = Nothing
229-
, _xdata = Nothing
230-
}
231-
where
232-
edits = catMaybes [ mkTextEdit rec , pragmaEdit ]
233-
234-
mkTextEdit :: RenderedRecordInfo -> Maybe TextEdit
235-
mkTextEdit (RenderedRecordInfo ss r) = TextEdit <$> srcSpanToRange ss <*> pure r
236-
237-
-- NOTE(ozkutuk): `RecordPuns` extension is renamed to `NamedFieldPuns`
238-
-- in GHC 9.4, but we still want to insert `NamedFieldPuns` in pre-9.4
239-
-- GHC as well, hence the replacement.
240-
-- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/6156
241-
pragmaEdit :: Maybe TextEdit
242-
pragmaEdit = if NamedFieldPuns `elem` exts
243-
then Nothing
244-
else Just $ patchExtName $ insertNewPragma pragma NamedFieldPuns
245-
where
246-
patchExtName = L.newText %~ T.replace "Record" "NamedField"
247-
248-
mkWorkspaceEdit :: NormalizedFilePath -> [TextEdit] -> WorkspaceEdit
249-
mkWorkspaceEdit nfp edits = WorkspaceEdit changes Nothing Nothing
250-
where
251-
changes = Just $ HashMap.singleton (fromNormalizedUri (normalizedFilePathToUri nfp)) (List edits)
252-
253-
mkCodeActionTitle :: [Extension] -> Text
254-
mkCodeActionTitle exts =
255-
if NamedFieldPuns `elem` exts
256-
then title
257-
else title <> " (needs extension: NamedFieldPuns)"
258-
where
259-
title = "Expand record wildcard"
260-
261259
-- Copied from hls-alternate-number-format-plugin
262260
getFirstPragma :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT String m NextPragmaInfo
263261
getFirstPragma (PluginId pId) state nfp = handleMaybeM "Could not get NextPragmaInfo" $ do

0 commit comments

Comments
 (0)