Skip to content

Update hls-retrie-plugin to be usable with 9.2.4. #3120

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 11 commits into from
Sep 7, 2022
Merged

Update hls-retrie-plugin to be usable with 9.2.4. #3120

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
11 commits
Select commit Hold shift + click to select a range
5b0e7e9
Update hls-retrie-plugin to be usable with 9.2.4.
drsooch Aug 23, 2022
868ebed
Replace GHC.Paths.libdir by querying a ModSummary for the LibDir
drsooch Aug 24, 2022
7dcd4ec
Merge branch 'master' into retrie-9.2
pepeiborra Aug 28, 2022
cffc9ce
Merge branch 'master' into retrie-9.2
drsooch Sep 1, 2022
4f6eee5
Looks like formatting was missed
drsooch Sep 1, 2022
a60d4a2
Revert "Looks like formatting was missed"
drsooch Sep 1, 2022
d31655b
Merge branch 'master' into retrie-9.2
drsooch Sep 2, 2022
33225ea
Merge branch 'retrie-9.2' of github.com:drsooch/haskell-language-serv…
drsooch Sep 3, 2022
3bd638e
Merge remote-tracking branch 'upstream' into retrie-9.2
drsooch Sep 3, 2022
2acec5a
Don't build retrie for 9.4
drsooch Sep 3, 2022
47b6b83
Merge branch 'master' into retrie-9.2
drsooch Sep 7, 2022
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
8 changes: 8 additions & 0 deletions ghcide/src/Development/IDE/GHC/Compat/Core.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -215,6 +215,7 @@ module Development.IDE.GHC.Compat.Core (
getLocA,
locA,
noLocA,
unLocA,
LocatedAn,
#if MIN_VERSION_ghc(9,2,0)
GHC.AnnListItem(..),
Expand Down Expand Up @@ -1125,6 +1126,13 @@ locA = GHC.locA
locA = id
#endif

#if MIN_VERSION_ghc(9,2,0)
unLocA :: forall pass a. XRec (GhcPass pass) a -> a
unLocA = unXRec @(GhcPass pass)
#else
unLocA = id
#endif

#if MIN_VERSION_ghc(9,2,0)
getLocA :: SrcLoc.GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA = GHC.getLocA
Expand Down
2 changes: 1 addition & 1 deletion haskell-language-server.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -274,7 +274,7 @@ common rename
cpp-options: -Dhls_rename

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

Expand Down
2 changes: 1 addition & 1 deletion plugins/hls-retrie-plugin/hls-retrie-plugin.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,6 +1,6 @@
cabal-version: 2.2
name: hls-retrie-plugin
version: 1.0.2.1
version: 1.0.2.2
synopsis: Retrie integration plugin for Haskell Language Server
description:
Please see the README on GitHub at <https://github.com/haskell/haskell-language-server#readme>
Expand Down
95 changes: 58 additions & 37 deletions plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -11,12 +11,12 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

{-# OPTIONS -Wno-orphans #-}

module Ide.Plugin.Retrie (descriptor) where

import Control.Concurrent.Extra (readVar)
import Control.Concurrent.STM (readTVarIO)
import Control.Exception.Safe (Exception (..),
SomeException, catch,
Expand All @@ -29,11 +29,8 @@ import Control.Monad.Trans.Except (ExceptT (ExceptT),
import Control.Monad.Trans.Maybe
import Data.Aeson (FromJSON (..),
ToJSON (..),
Value (Null),
genericParseJSON)
import qualified Data.Aeson as Aeson
import Data.Bifunctor (Bifunctor (first),
second)
Value (Null))
import Data.Bifunctor (second)
import qualified Data.ByteString as BS
import Data.Coerce
import Data.Either (partitionEithers)
Expand All @@ -43,44 +40,47 @@ import qualified Data.HashSet as Set
import Data.IORef.Extra (atomicModifyIORef'_,
newIORef, readIORef)
import Data.List.Extra (find, nubOrdOn)
import Data.String (IsString (fromString))
import Data.String (IsString)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Typeable (Typeable)
import Development.IDE hiding (pluginHandlers)
import Development.IDE.Core.PositionMapping
import Development.IDE.Core.Shake (ShakeExtras (knownTargetsVar),
toKnownFiles)
import Development.IDE.GHC.Compat (GenLocated (L), GhcRn,
import Development.IDE.GHC.Compat (GenLocated (L), GhcPs,
GhcRn, GhcTc,
HsBindLR (FunBind),
HsGroup (..),
HsValBindsLR (..),
HscEnv, IdP, LRuleDecls,
ModSummary (ModSummary, ms_hspp_buf, ms_mod),
NHsValBindsLR (..),
Outputable,
ParsedModule (..),
RuleDecl (HsRule),
RuleDecls (HsRules),
SourceText (..),
SrcSpan (..),
TyClDecl (SynDecl),
TyClGroup (..), fun_id,
hm_iface, isQual,
isQual_maybe,
isQual_maybe, locA,
mi_fixities,
moduleNameString,
ms_hspp_opts,
nameModule_maybe,
nameRdrName, occNameFS,
occNameString,
parseModule,
nameRdrName, noLocA,
occNameFS, occNameString,
pattern IsBoot,
pattern NotBoot,
pattern RealSrcSpan,
pm_parsed_source,
rdrNameOcc, rds_rules,
srcSpanFile)
srcSpanFile, topDir,
unLocA)
import Development.IDE.GHC.Compat.Util hiding (catch, try)
import qualified GHC (parseModule)
import qualified GHC (Module,
ParsedModule (..),
moduleName, parseModule)
import GHC.Generics (Generic)
import Ide.PluginUtils
import Ide.Types
Expand All @@ -94,8 +94,13 @@ import Language.LSP.Types as J hiding
SemanticTokenRelative (length),
SemanticTokensEdit (_start))
import Retrie.CPP (CPP (NoCPP), parseCPP)
import Retrie.ExactPrint (fix, relativiseApiAnns,
import Retrie.ExactPrint (Annotated, fix,
transformA, unsafeMkA)
#if MIN_VERSION_ghc(9,2,0)
import Retrie.ExactPrint (makeDeltaAst)
#else
import Retrie.ExactPrint (relativiseApiAnns)
#endif
import Retrie.Fixity (mkFixityEnv)
import qualified Retrie.GHC as GHC
import Retrie.Monad (addImports, apply,
Expand Down Expand Up @@ -202,7 +207,7 @@ provider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range ca)
++ concatMap (suggestRuleRewrites uri pos ms_mod) hs_ruleds
++ [ r
| TyClGroup {group_tyclds} <- hs_tyclds,
L l g <- group_tyclds,
L (locA -> l) g <- group_tyclds,
pos `isInsideSrcSpan` l,
r <- suggestTypeRewrites uri ms_mod g

Expand All @@ -225,7 +230,7 @@ getBinds nfp = runMaybeT $ do
( HsGroup
{ hs_valds =
XValBindsLR
(NValBinds binds _sigs :: NHsValBindsLR GHC.GhcRn),
(GHC.NValBinds binds _sigs :: GHC.NHsValBindsLR GhcRn),
hs_ruleds,
hs_tyclds
},
Expand All @@ -247,7 +252,7 @@ suggestBindRewrites ::
GHC.Module ->
HsBindLR GhcRn GhcRn ->
[(T.Text, CodeActionKind, RunRetrieParams)]
suggestBindRewrites originatingFile pos ms_mod FunBind {fun_id = L l' rdrName}
suggestBindRewrites originatingFile pos ms_mod FunBind {fun_id = L (locA -> l') rdrName}
| pos `isInsideSrcSpan` l' =
let pprNameText = printOutputable rdrName
pprName = T.unpack pprNameText
Expand All @@ -267,13 +272,13 @@ describeRestriction restrictToOriginatingFile =
if restrictToOriginatingFile then " in current file" else ""

suggestTypeRewrites ::
(Outputable (IdP pass)) =>
(Outputable (IdP GhcRn)) =>
Uri ->
GHC.Module ->
TyClDecl pass ->
TyClDecl GhcRn ->
[(T.Text, CodeActionKind, RunRetrieParams)]
suggestTypeRewrites originatingFile ms_mod SynDecl {tcdLName = L _ rdrName} =
let pprNameText = printOutputable rdrName
suggestTypeRewrites originatingFile ms_mod SynDecl {tcdLName} =
let pprNameText = printOutputable (unLocA tcdLName)
pprName = T.unpack pprNameText
unfoldRewrite restrictToOriginatingFile =
let rewrites = [TypeForward (qualify ms_mod pprName)]
Expand All @@ -290,7 +295,7 @@ suggestRuleRewrites ::
Uri ->
Position ->
GHC.Module ->
LRuleDecls pass ->
LRuleDecls GhcRn ->
[(T.Text, CodeActionKind, RunRetrieParams)]
suggestRuleRewrites originatingFile pos ms_mod (L _ HsRules {rds_rules}) =
concat
Expand All @@ -299,7 +304,7 @@ suggestRuleRewrites originatingFile pos ms_mod (L _ HsRules {rds_rules}) =
, backwardsRewrite ruleName True
, backwardsRewrite ruleName False
]
| L l r <- rds_rules,
| L (locA -> l) r <- rds_rules,
pos `isInsideSrcSpan` l,
#if MIN_VERSION_ghc(8,8,0)
let HsRule {rd_name = L _ (_, rn)} = r,
Expand All @@ -326,7 +331,6 @@ suggestRuleRewrites originatingFile pos ms_mod (L _ HsRules {rds_rules}) =
CodeActionRefactor,
RunRetrieParams {..}
)

suggestRuleRewrites _ _ _ _ = []

qualify :: GHC.Module -> String -> String
Expand Down Expand Up @@ -359,24 +363,26 @@ callRetrie ::
IO ([CallRetrieError], WorkspaceEdit)
callRetrie state session rewrites origin restrictToOriginatingFile = do
knownFiles <- toKnownFiles . unhashed <$> readTVarIO (knownTargetsVar $ shakeExtras state)
#if MIN_VERSION_ghc(9,2,0)
-- retrie needs the libdir for `parseRewriteSpecs`
libdir <- topDir . ms_hspp_opts . msrModSummary <$> useOrFail "Retrie.GetModSummary" (CallRetrieInternalError "file not found") GetModSummary origin
#endif
let reuseParsedModule f = do
pm <-
useOrFail "GetParsedModule" NoParse GetParsedModule f
(fixities, pm) <- fixFixities f (fixAnns pm)
return (fixities, pm)
pm <- useOrFail "Retrie.GetParsedModule" NoParse GetParsedModule f
(fixities, pm') <- fixFixities f (fixAnns pm)
return (fixities, pm')
getCPPmodule t = do
nt <- toNormalizedFilePath' <$> makeAbsolute t
let getParsedModule f contents = do
modSummary <- msrModSummary <$>
useOrFail "GetModSummary" (CallRetrieInternalError "file not found") GetModSummary nt
useOrFail "Retrie.GetModSummary" (CallRetrieInternalError "file not found") GetModSummary nt
let ms' =
modSummary
{ ms_hspp_buf =
Just (stringToStringBuffer contents)
}
logPriority (ideLogger state) Info $ T.pack $ "Parsing module: " <> t
parsed <-
evalGhcEnv session (GHC.parseModule ms')
parsed <- evalGhcEnv session (GHC.parseModule ms')
`catch` \e -> throwIO (GHCParseError nt (show @SomeException e))
(fixities, parsed) <- fixFixities f (fixAnns parsed)
return (fixities, parsed)
Expand Down Expand Up @@ -416,12 +422,19 @@ callRetrie state session rewrites origin restrictToOriginatingFile = do
(theImports, theRewrites) = partitionEithers rewrites

annotatedImports =
unsafeMkA (map (GHC.noLoc . toImportDecl) theImports) mempty 0
#if MIN_VERSION_ghc(9,2,0)
unsafeMkA (map (noLocA . toImportDecl) theImports) 0
#else
unsafeMkA (map (noLocA . toImportDecl) theImports) mempty 0
#endif

(originFixities, originParsedModule) <- reuseParsedModule origin
retrie <-
(\specs -> apply specs >> addImports annotatedImports)
<$> parseRewriteSpecs
#if MIN_VERSION_ghc(9,2,0)
libdir
#endif
(\_f -> return $ NoCPP originParsedModule)
originFixities
theRewrites
Expand Down Expand Up @@ -463,9 +476,13 @@ callRetrie state session rewrites origin restrictToOriginatingFile = do
let fixities = fixityEnvFromModIface hirModIface
res <- transformA pm (fix fixities)
return (fixities, res)
fixAnns ParsedModule {..} =
#if MIN_VERSION_ghc(9,2,0)
fixAnns GHC.ParsedModule{pm_parsed_source} = unsafeMkA (makeDeltaAst pm_parsed_source) 0
#else
fixAnns GHC.ParsedModule {..} =
let ranns = relativiseApiAnns pm_parsed_source pm_annotations
in unsafeMkA pm_parsed_source ranns 0
#endif

asEditMap :: [[(Uri, TextEdit)]] -> WorkspaceEditMap
asEditMap = coerce . HM.fromListWith (++) . concatMap (map (second pure))
Expand Down Expand Up @@ -533,14 +550,18 @@ toImportDecl :: ImportSpec -> GHC.ImportDecl GHC.GhcPs
toImportDecl AddImport {..} = GHC.ImportDecl {ideclSource = ideclSource', ..}
where
ideclSource' = if ideclSource then IsBoot else NotBoot
toMod = GHC.noLoc . GHC.mkModuleName
toMod = noLocA . GHC.mkModuleName
ideclName = toMod ideclNameString
ideclPkgQual = Nothing
ideclSafe = False
ideclImplicit = False
ideclHiding = Nothing
ideclSourceSrc = NoSourceText
#if MIN_VERSION_ghc(9,2,0)
ideclExt = GHC.EpAnnNotUsed
#else
ideclExt = GHC.noExtField
#endif
ideclAs = toMod <$> ideclAsString
#if MIN_VERSION_ghc(8,10,0)
ideclQualified = if ideclQualifiedBool then GHC.QualifiedPre else GHC.NotQualified
Expand Down