Skip to content

Commit aad896c

Browse files
drsoochpepeiborra
drsooch
and
pepeiborra
authored
Update hls-retrie-plugin to be usable with 9.2.4. (#3120)
* Update hls-retrie-plugin to be usable with 9.2.4. This is the first pass at getting hls-retrie-plugin enabled. Much of the changes were updating to match the changes in the upstream `retrie` package. * Replace GHC.Paths.libdir by querying a ModSummary for the LibDir * Looks like formatting was missed * Revert "Looks like formatting was missed" This reverts commit 4f6eee5. * Don't build retrie for 9.4 Co-authored-by: Pepe Iborra <[email protected]>
1 parent 163ebfe commit aad896c

File tree

4 files changed

+68
-39
lines changed

4 files changed

+68
-39
lines changed

‎ghcide/src/Development/IDE/GHC/Compat/Core.hs‎

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -215,6 +215,7 @@ module Development.IDE.GHC.Compat.Core (
215215
getLocA,
216216
locA,
217217
noLocA,
218+
unLocA,
218219
LocatedAn,
219220
#if MIN_VERSION_ghc(9,2,0)
220221
GHC.AnnListItem(..),
@@ -1125,6 +1126,13 @@ locA = GHC.locA
11251126
locA = id
11261127
#endif
11271128

1129+
#if MIN_VERSION_ghc(9,2,0)
1130+
unLocA :: forall pass a. XRec (GhcPass pass) a -> a
1131+
unLocA = unXRec @(GhcPass pass)
1132+
#else
1133+
unLocA = id
1134+
#endif
1135+
11281136
#if MIN_VERSION_ghc(9,2,0)
11291137
getLocA :: SrcLoc.GenLocated (SrcSpanAnn' a) e -> SrcSpan
11301138
getLocA = GHC.getLocA

‎haskell-language-server.cabal‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -274,7 +274,7 @@ common rename
274274
cpp-options: -Dhls_rename
275275

276276
common retrie
277-
if flag(retrie) && (impl(ghc < 9.2.1) || flag(ignore-plugins-ghc-bounds))
277+
if flag(retrie) && (impl(ghc < 9.4.1) || flag(ignore-plugins-ghc-bounds))
278278
build-depends: hls-retrie-plugin ^>= 1.0
279279
cpp-options: -Dhls_retrie
280280

‎plugins/hls-retrie-plugin/hls-retrie-plugin.cabal‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
11
cabal-version: 2.2
22
name: hls-retrie-plugin
3-
version: 1.0.2.1
3+
version: 1.0.2.2
44
synopsis: Retrie integration plugin for Haskell Language Server
55
description:
66
Please see the README on GitHub at <https://github.com/haskell/haskell-language-server#readme>

‎plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs‎

Lines changed: 58 additions & 37 deletions
Original file line numberDiff line numberDiff line change
@@ -11,12 +11,12 @@
1111
{-# LANGUAGE StandaloneDeriving #-}
1212
{-# LANGUAGE TypeApplications #-}
1313
{-# LANGUAGE TypeFamilies #-}
14+
{-# LANGUAGE ViewPatterns #-}
1415

1516
{-# OPTIONS -Wno-orphans #-}
1617

1718
module Ide.Plugin.Retrie (descriptor) where
1819

19-
import Control.Concurrent.Extra (readVar)
2020
import Control.Concurrent.STM (readTVarIO)
2121
import Control.Exception.Safe (Exception (..),
2222
SomeException, catch,
@@ -29,11 +29,8 @@ import Control.Monad.Trans.Except (ExceptT (ExceptT),
2929
import Control.Monad.Trans.Maybe
3030
import Data.Aeson (FromJSON (..),
3131
ToJSON (..),
32-
Value (Null),
33-
genericParseJSON)
34-
import qualified Data.Aeson as Aeson
35-
import Data.Bifunctor (Bifunctor (first),
36-
second)
32+
Value (Null))
33+
import Data.Bifunctor (second)
3734
import qualified Data.ByteString as BS
3835
import Data.Coerce
3936
import Data.Either (partitionEithers)
@@ -43,44 +40,47 @@ import qualified Data.HashSet as Set
4340
import Data.IORef.Extra (atomicModifyIORef'_,
4441
newIORef, readIORef)
4542
import Data.List.Extra (find, nubOrdOn)
46-
import Data.String (IsString (fromString))
43+
import Data.String (IsString)
4744
import qualified Data.Text as T
4845
import qualified Data.Text.Encoding as T
4946
import Data.Typeable (Typeable)
5047
import Development.IDE hiding (pluginHandlers)
5148
import Development.IDE.Core.PositionMapping
5249
import Development.IDE.Core.Shake (ShakeExtras (knownTargetsVar),
5350
toKnownFiles)
54-
import Development.IDE.GHC.Compat (GenLocated (L), GhcRn,
51+
import Development.IDE.GHC.Compat (GenLocated (L), GhcPs,
52+
GhcRn, GhcTc,
5553
HsBindLR (FunBind),
5654
HsGroup (..),
5755
HsValBindsLR (..),
5856
HscEnv, IdP, LRuleDecls,
5957
ModSummary (ModSummary, ms_hspp_buf, ms_mod),
60-
NHsValBindsLR (..),
6158
Outputable,
6259
ParsedModule (..),
6360
RuleDecl (HsRule),
6461
RuleDecls (HsRules),
6562
SourceText (..),
66-
SrcSpan (..),
6763
TyClDecl (SynDecl),
6864
TyClGroup (..), fun_id,
6965
hm_iface, isQual,
70-
isQual_maybe,
66+
isQual_maybe, locA,
7167
mi_fixities,
7268
moduleNameString,
69+
ms_hspp_opts,
7370
nameModule_maybe,
74-
nameRdrName, occNameFS,
75-
occNameString,
76-
parseModule,
71+
nameRdrName, noLocA,
72+
occNameFS, occNameString,
7773
pattern IsBoot,
7874
pattern NotBoot,
7975
pattern RealSrcSpan,
76+
pm_parsed_source,
8077
rdrNameOcc, rds_rules,
81-
srcSpanFile)
78+
srcSpanFile, topDir,
79+
unLocA)
8280
import Development.IDE.GHC.Compat.Util hiding (catch, try)
83-
import qualified GHC (parseModule)
81+
import qualified GHC (Module,
82+
ParsedModule (..),
83+
moduleName, parseModule)
8484
import GHC.Generics (Generic)
8585
import Ide.PluginUtils
8686
import Ide.Types
@@ -94,8 +94,13 @@ import Language.LSP.Types as J hiding
9494
SemanticTokenRelative (length),
9595
SemanticTokensEdit (_start))
9696
import Retrie.CPP (CPP (NoCPP), parseCPP)
97-
import Retrie.ExactPrint (fix, relativiseApiAnns,
97+
import Retrie.ExactPrint (Annotated, fix,
9898
transformA, unsafeMkA)
99+
#if MIN_VERSION_ghc(9,2,0)
100+
import Retrie.ExactPrint (makeDeltaAst)
101+
#else
102+
import Retrie.ExactPrint (relativiseApiAnns)
103+
#endif
99104
import Retrie.Fixity (mkFixityEnv)
100105
import qualified Retrie.GHC as GHC
101106
import Retrie.Monad (addImports, apply,
@@ -202,7 +207,7 @@ provider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range ca)
202207
++ concatMap (suggestRuleRewrites uri pos ms_mod) hs_ruleds
203208
++ [ r
204209
| TyClGroup {group_tyclds} <- hs_tyclds,
205-
L l g <- group_tyclds,
210+
L (locA -> l) g <- group_tyclds,
206211
pos `isInsideSrcSpan` l,
207212
r <- suggestTypeRewrites uri ms_mod g
208213

@@ -225,7 +230,7 @@ getBinds nfp = runMaybeT $ do
225230
( HsGroup
226231
{ hs_valds =
227232
XValBindsLR
228-
(NValBinds binds _sigs :: NHsValBindsLR GHC.GhcRn),
233+
(GHC.NValBinds binds _sigs :: GHC.NHsValBindsLR GhcRn),
229234
hs_ruleds,
230235
hs_tyclds
231236
},
@@ -247,7 +252,7 @@ suggestBindRewrites ::
247252
GHC.Module ->
248253
HsBindLR GhcRn GhcRn ->
249254
[(T.Text, CodeActionKind, RunRetrieParams)]
250-
suggestBindRewrites originatingFile pos ms_mod FunBind {fun_id = L l' rdrName}
255+
suggestBindRewrites originatingFile pos ms_mod FunBind {fun_id = L (locA -> l') rdrName}
251256
| pos `isInsideSrcSpan` l' =
252257
let pprNameText = printOutputable rdrName
253258
pprName = T.unpack pprNameText
@@ -267,13 +272,13 @@ describeRestriction restrictToOriginatingFile =
267272
if restrictToOriginatingFile then " in current file" else ""
268273

269274
suggestTypeRewrites ::
270-
(Outputable (IdP pass)) =>
275+
(Outputable (IdP GhcRn)) =>
271276
Uri ->
272277
GHC.Module ->
273-
TyClDecl pass ->
278+
TyClDecl GhcRn ->
274279
[(T.Text, CodeActionKind, RunRetrieParams)]
275-
suggestTypeRewrites originatingFile ms_mod SynDecl {tcdLName = L _ rdrName} =
276-
let pprNameText = printOutputable rdrName
280+
suggestTypeRewrites originatingFile ms_mod SynDecl {tcdLName} =
281+
let pprNameText = printOutputable (unLocA tcdLName)
277282
pprName = T.unpack pprNameText
278283
unfoldRewrite restrictToOriginatingFile =
279284
let rewrites = [TypeForward (qualify ms_mod pprName)]
@@ -290,7 +295,7 @@ suggestRuleRewrites ::
290295
Uri ->
291296
Position ->
292297
GHC.Module ->
293-
LRuleDecls pass ->
298+
LRuleDecls GhcRn ->
294299
[(T.Text, CodeActionKind, RunRetrieParams)]
295300
suggestRuleRewrites originatingFile pos ms_mod (L _ HsRules {rds_rules}) =
296301
concat
@@ -299,7 +304,7 @@ suggestRuleRewrites originatingFile pos ms_mod (L _ HsRules {rds_rules}) =
299304
, backwardsRewrite ruleName True
300305
, backwardsRewrite ruleName False
301306
]
302-
| L l r <- rds_rules,
307+
| L (locA -> l) r <- rds_rules,
303308
pos `isInsideSrcSpan` l,
304309
#if MIN_VERSION_ghc(8,8,0)
305310
let HsRule {rd_name = L _ (_, rn)} = r,
@@ -326,7 +331,6 @@ suggestRuleRewrites originatingFile pos ms_mod (L _ HsRules {rds_rules}) =
326331
CodeActionRefactor,
327332
RunRetrieParams {..}
328333
)
329-
330334
suggestRuleRewrites _ _ _ _ = []
331335

332336
qualify :: GHC.Module -> String -> String
@@ -359,24 +363,26 @@ callRetrie ::
359363
IO ([CallRetrieError], WorkspaceEdit)
360364
callRetrie state session rewrites origin restrictToOriginatingFile = do
361365
knownFiles <- toKnownFiles . unhashed <$> readTVarIO (knownTargetsVar $ shakeExtras state)
366+
#if MIN_VERSION_ghc(9,2,0)
367+
-- retrie needs the libdir for `parseRewriteSpecs`
368+
libdir <- topDir . ms_hspp_opts . msrModSummary <$> useOrFail "Retrie.GetModSummary" (CallRetrieInternalError "file not found") GetModSummary origin
369+
#endif
362370
let reuseParsedModule f = do
363-
pm <-
364-
useOrFail "GetParsedModule" NoParse GetParsedModule f
365-
(fixities, pm) <- fixFixities f (fixAnns pm)
366-
return (fixities, pm)
371+
pm <- useOrFail "Retrie.GetParsedModule" NoParse GetParsedModule f
372+
(fixities, pm') <- fixFixities f (fixAnns pm)
373+
return (fixities, pm')
367374
getCPPmodule t = do
368375
nt <- toNormalizedFilePath' <$> makeAbsolute t
369376
let getParsedModule f contents = do
370377
modSummary <- msrModSummary <$>
371-
useOrFail "GetModSummary" (CallRetrieInternalError "file not found") GetModSummary nt
378+
useOrFail "Retrie.GetModSummary" (CallRetrieInternalError "file not found") GetModSummary nt
372379
let ms' =
373380
modSummary
374381
{ ms_hspp_buf =
375382
Just (stringToStringBuffer contents)
376383
}
377384
logPriority (ideLogger state) Info $ T.pack $ "Parsing module: " <> t
378-
parsed <-
379-
evalGhcEnv session (GHC.parseModule ms')
385+
parsed <- evalGhcEnv session (GHC.parseModule ms')
380386
`catch` \e -> throwIO (GHCParseError nt (show @SomeException e))
381387
(fixities, parsed) <- fixFixities f (fixAnns parsed)
382388
return (fixities, parsed)
@@ -416,12 +422,19 @@ callRetrie state session rewrites origin restrictToOriginatingFile = do
416422
(theImports, theRewrites) = partitionEithers rewrites
417423

418424
annotatedImports =
419-
unsafeMkA (map (GHC.noLoc . toImportDecl) theImports) mempty 0
425+
#if MIN_VERSION_ghc(9,2,0)
426+
unsafeMkA (map (noLocA . toImportDecl) theImports) 0
427+
#else
428+
unsafeMkA (map (noLocA . toImportDecl) theImports) mempty 0
429+
#endif
420430

421431
(originFixities, originParsedModule) <- reuseParsedModule origin
422432
retrie <-
423433
(\specs -> apply specs >> addImports annotatedImports)
424434
<$> parseRewriteSpecs
435+
#if MIN_VERSION_ghc(9,2,0)
436+
libdir
437+
#endif
425438
(\_f -> return $ NoCPP originParsedModule)
426439
originFixities
427440
theRewrites
@@ -463,9 +476,13 @@ callRetrie state session rewrites origin restrictToOriginatingFile = do
463476
let fixities = fixityEnvFromModIface hirModIface
464477
res <- transformA pm (fix fixities)
465478
return (fixities, res)
466-
fixAnns ParsedModule {..} =
479+
#if MIN_VERSION_ghc(9,2,0)
480+
fixAnns GHC.ParsedModule{pm_parsed_source} = unsafeMkA (makeDeltaAst pm_parsed_source) 0
481+
#else
482+
fixAnns GHC.ParsedModule {..} =
467483
let ranns = relativiseApiAnns pm_parsed_source pm_annotations
468484
in unsafeMkA pm_parsed_source ranns 0
485+
#endif
469486

470487
asEditMap :: [[(Uri, TextEdit)]] -> WorkspaceEditMap
471488
asEditMap = coerce . HM.fromListWith (++) . concatMap (map (second pure))
@@ -533,14 +550,18 @@ toImportDecl :: ImportSpec -> GHC.ImportDecl GHC.GhcPs
533550
toImportDecl AddImport {..} = GHC.ImportDecl {ideclSource = ideclSource', ..}
534551
where
535552
ideclSource' = if ideclSource then IsBoot else NotBoot
536-
toMod = GHC.noLoc . GHC.mkModuleName
553+
toMod = noLocA . GHC.mkModuleName
537554
ideclName = toMod ideclNameString
538555
ideclPkgQual = Nothing
539556
ideclSafe = False
540557
ideclImplicit = False
541558
ideclHiding = Nothing
542559
ideclSourceSrc = NoSourceText
560+
#if MIN_VERSION_ghc(9,2,0)
561+
ideclExt = GHC.EpAnnNotUsed
562+
#else
543563
ideclExt = GHC.noExtField
564+
#endif
544565
ideclAs = toMod <$> ideclAsString
545566
#if MIN_VERSION_ghc(8,10,0)
546567
ideclQualified = if ideclQualifiedBool then GHC.QualifiedPre else GHC.NotQualified

0 commit comments

Comments
 (0)