Skip to content

Commit 5b0e7e9

Browse files
drsoochdrsooch
committed
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.
1 parent 9a0684e commit 5b0e7e9

File tree

4 files changed

+63
-39
lines changed

4 files changed

+63
-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
@@ -205,6 +205,7 @@ module Development.IDE.GHC.Compat.Core (
205205
getLocA,
206206
locA,
207207
noLocA,
208+
unLocA,
208209
LocatedAn,
209210
#if MIN_VERSION_ghc(9,2,0)
210211
GHC.AnnListItem(..),
@@ -1044,6 +1045,13 @@ locA = GHC.locA
10441045
locA = id
10451046
#endif
10461047

1048+
#if MIN_VERSION_ghc(9,2,0)
1049+
unLocA :: forall pass a. XRec (GhcPass pass) a -> a
1050+
unLocA = unXRec @(GhcPass pass)
1051+
#else
1052+
unLocA = id
1053+
#endif
1054+
10471055
#if MIN_VERSION_ghc(9,2,0)
10481056
getLocA :: SrcLoc.GenLocated (SrcSpanAnn' a) e -> SrcSpan
10491057
getLocA = GHC.getLocA

‎haskell-language-server.cabal

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

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

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

Lines changed: 2 additions & 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>
@@ -25,6 +25,7 @@ library
2525
, extra
2626
, ghc
2727
, ghcide ^>=1.7
28+
, ghc-paths
2829
, hashable
2930
, hls-plugin-api ^>=1.4
3031
, lsp

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

Lines changed: 52 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,45 +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,
7369
nameModule_maybe,
74-
nameRdrName, occNameFS,
75-
occNameString,
76-
parseModule,
70+
nameRdrName, noLocA,
71+
occNameFS, occNameString,
7772
pattern IsBoot,
7873
pattern NotBoot,
7974
pattern RealSrcSpan,
75+
pm_parsed_source,
8076
rdrNameOcc, rds_rules,
81-
srcSpanFile)
77+
srcSpanFile, unLocA)
8278
import Development.IDE.GHC.Compat.Util hiding (catch, try)
83-
import qualified GHC (parseModule)
79+
import qualified GHC (Module,
80+
ParsedModule (..),
81+
moduleName, parseModule)
8482
import GHC.Generics (Generic)
83+
import GHC.Paths (libdir)
8584
import Ide.PluginUtils
8685
import Ide.Types
8786
import Language.LSP.Server (LspM,
@@ -94,8 +93,13 @@ import Language.LSP.Types as J hiding
9493
SemanticTokenRelative (length),
9594
SemanticTokensEdit (_start))
9695
import Retrie.CPP (CPP (NoCPP), parseCPP)
97-
import Retrie.ExactPrint (fix, relativiseApiAnns,
96+
import Retrie.ExactPrint (Annotated, fix,
9897
transformA, unsafeMkA)
98+
#if MIN_VERSION_ghc(9,2,0)
99+
import Retrie.ExactPrint (makeDeltaAst)
100+
#else
101+
import Retrie.ExactPrint (relativiseApiAnns)
102+
#endif
99103
import Retrie.Fixity (mkFixityEnv)
100104
import qualified Retrie.GHC as GHC
101105
import Retrie.Monad (addImports, apply,
@@ -202,7 +206,7 @@ provider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range ca)
202206
++ concatMap (suggestRuleRewrites uri pos ms_mod) hs_ruleds
203207
++ [ r
204208
| TyClGroup {group_tyclds} <- hs_tyclds,
205-
L l g <- group_tyclds,
209+
L (locA -> l) g <- group_tyclds,
206210
pos `isInsideSrcSpan` l,
207211
r <- suggestTypeRewrites uri ms_mod g
208212

@@ -225,7 +229,7 @@ getBinds nfp = runMaybeT $ do
225229
( HsGroup
226230
{ hs_valds =
227231
XValBindsLR
228-
(NValBinds binds _sigs :: NHsValBindsLR GHC.GhcRn),
232+
(GHC.NValBinds binds _sigs :: GHC.NHsValBindsLR GhcRn),
229233
hs_ruleds,
230234
hs_tyclds
231235
},
@@ -247,7 +251,7 @@ suggestBindRewrites ::
247251
GHC.Module ->
248252
HsBindLR GhcRn GhcRn ->
249253
[(T.Text, CodeActionKind, RunRetrieParams)]
250-
suggestBindRewrites originatingFile pos ms_mod FunBind {fun_id = L l' rdrName}
254+
suggestBindRewrites originatingFile pos ms_mod FunBind {fun_id = L (locA -> l') rdrName}
251255
| pos `isInsideSrcSpan` l' =
252256
let pprNameText = printOutputable rdrName
253257
pprName = T.unpack pprNameText
@@ -267,13 +271,13 @@ describeRestriction restrictToOriginatingFile =
267271
if restrictToOriginatingFile then " in current file" else ""
268272

269273
suggestTypeRewrites ::
270-
(Outputable (IdP pass)) =>
274+
(Outputable (IdP GhcRn)) =>
271275
Uri ->
272276
GHC.Module ->
273-
TyClDecl pass ->
277+
TyClDecl GhcRn ->
274278
[(T.Text, CodeActionKind, RunRetrieParams)]
275-
suggestTypeRewrites originatingFile ms_mod SynDecl {tcdLName = L _ rdrName} =
276-
let pprNameText = printOutputable rdrName
279+
suggestTypeRewrites originatingFile ms_mod SynDecl {tcdLName} =
280+
let pprNameText = printOutputable (unLocA tcdLName)
277281
pprName = T.unpack pprNameText
278282
unfoldRewrite restrictToOriginatingFile =
279283
let rewrites = [TypeForward (qualify ms_mod pprName)]
@@ -290,7 +294,7 @@ suggestRuleRewrites ::
290294
Uri ->
291295
Position ->
292296
GHC.Module ->
293-
LRuleDecls pass ->
297+
LRuleDecls GhcRn ->
294298
[(T.Text, CodeActionKind, RunRetrieParams)]
295299
suggestRuleRewrites originatingFile pos ms_mod (L _ HsRules {rds_rules}) =
296300
concat
@@ -299,7 +303,7 @@ suggestRuleRewrites originatingFile pos ms_mod (L _ HsRules {rds_rules}) =
299303
, backwardsRewrite ruleName True
300304
, backwardsRewrite ruleName False
301305
]
302-
| L l r <- rds_rules,
306+
| L (locA -> l) r <- rds_rules,
303307
pos `isInsideSrcSpan` l,
304308
#if MIN_VERSION_ghc(8,8,0)
305309
let HsRule {rd_name = L _ (_, rn)} = r,
@@ -327,8 +331,6 @@ suggestRuleRewrites originatingFile pos ms_mod (L _ HsRules {rds_rules}) =
327331
RunRetrieParams {..}
328332
)
329333

330-
suggestRuleRewrites _ _ _ _ = []
331-
332334
qualify :: GHC.Module -> String -> String
333335
qualify ms_mod x = T.unpack (printOutputable ms_mod) <> "." <> x
334336

@@ -360,10 +362,9 @@ callRetrie ::
360362
callRetrie state session rewrites origin restrictToOriginatingFile = do
361363
knownFiles <- toKnownFiles . unhashed <$> readTVarIO (knownTargetsVar $ shakeExtras state)
362364
let reuseParsedModule f = do
363-
pm <-
364-
useOrFail "GetParsedModule" NoParse GetParsedModule f
365-
(fixities, pm) <- fixFixities f (fixAnns pm)
366-
return (fixities, pm)
365+
pm <- useOrFail "GetParsedModule" NoParse GetParsedModule f
366+
(fixities, pm') <- fixFixities f (fixAnns pm)
367+
return (fixities, pm')
367368
getCPPmodule t = do
368369
nt <- toNormalizedFilePath' <$> makeAbsolute t
369370
let getParsedModule f contents = do
@@ -375,8 +376,7 @@ callRetrie state session rewrites origin restrictToOriginatingFile = do
375376
Just (stringToStringBuffer contents)
376377
}
377378
logPriority (ideLogger state) Info $ T.pack $ "Parsing module: " <> t
378-
parsed <-
379-
evalGhcEnv session (GHC.parseModule ms')
379+
parsed <- evalGhcEnv session (GHC.parseModule ms')
380380
`catch` \e -> throwIO (GHCParseError nt (show @SomeException e))
381381
(fixities, parsed) <- fixFixities f (fixAnns parsed)
382382
return (fixities, parsed)
@@ -416,12 +416,19 @@ callRetrie state session rewrites origin restrictToOriginatingFile = do
416416
(theImports, theRewrites) = partitionEithers rewrites
417417

418418
annotatedImports =
419-
unsafeMkA (map (GHC.noLoc . toImportDecl) theImports) mempty 0
419+
#if MIN_VERSION_ghc(9,2,0)
420+
unsafeMkA (map (noLocA . toImportDecl) theImports) 0
421+
#else
422+
unsafeMkA (map (noLocA . toImportDecl) theImports) mempty 0
423+
#endif
420424

421425
(originFixities, originParsedModule) <- reuseParsedModule origin
422426
retrie <-
423427
(\specs -> apply specs >> addImports annotatedImports)
424428
<$> parseRewriteSpecs
429+
#if MIN_VERSION_ghc(9,2,0)
430+
libdir -- TODO: does this actualy get the proper libdir?
431+
#endif
425432
(\_f -> return $ NoCPP originParsedModule)
426433
originFixities
427434
theRewrites
@@ -463,9 +470,13 @@ callRetrie state session rewrites origin restrictToOriginatingFile = do
463470
let fixities = fixityEnvFromModIface hirModIface
464471
res <- transformA pm (fix fixities)
465472
return (fixities, res)
466-
fixAnns ParsedModule {..} =
473+
#if MIN_VERSION_ghc(9,2,0)
474+
fixAnns GHC.ParsedModule{pm_parsed_source} = unsafeMkA (makeDeltaAst pm_parsed_source) 0
475+
#else
476+
fixAnns GHC.ParsedModule {..} =
467477
let ranns = relativiseApiAnns pm_parsed_source pm_annotations
468478
in unsafeMkA pm_parsed_source ranns 0
479+
#endif
469480

470481
asEditMap :: [[(Uri, TextEdit)]] -> WorkspaceEditMap
471482
asEditMap = coerce . HM.fromListWith (++) . concatMap (map (second pure))
@@ -533,14 +544,18 @@ toImportDecl :: ImportSpec -> GHC.ImportDecl GHC.GhcPs
533544
toImportDecl AddImport {..} = GHC.ImportDecl {ideclSource = ideclSource', ..}
534545
where
535546
ideclSource' = if ideclSource then IsBoot else NotBoot
536-
toMod = GHC.noLoc . GHC.mkModuleName
547+
toMod = noLocA . GHC.mkModuleName
537548
ideclName = toMod ideclNameString
538549
ideclPkgQual = Nothing
539550
ideclSafe = False
540551
ideclImplicit = False
541552
ideclHiding = Nothing
542553
ideclSourceSrc = NoSourceText
554+
#if MIN_VERSION_ghc(9,2,0)
555+
ideclExt = GHC.EpAnnNotUsed
556+
#else
543557
ideclExt = GHC.noExtField
558+
#endif
544559
ideclAs = toMod <$> ideclAsString
545560
#if MIN_VERSION_ghc(8,10,0)
546561
ideclQualified = if ideclQualifiedBool then GHC.QualifiedPre else GHC.NotQualified

0 commit comments

Comments
 (0)