Skip to content

Commit ab638e8

Browse files
RaoulHCRaoulHC
committed
Reintroduce ghc-lib flag for hlint plugin
The ghc-lib flag was removed in haskell#3015, but it's still useful to be able to compile hls-hlint-plugin using the GHC API if you've done so for hlint and ghc-lib-parser-ex, rather than using ghc-lib-parser. A lot of the HLINT_ON_GHC_LIB gated code which has probably been bitrotting so this has been updated to allow hlint to work again directly on the parsed AST.
1 parent ed64561 commit ab638e8

File tree

6 files changed

+116
-57
lines changed

6 files changed

+116
-57
lines changed

‎configuration-ghc-94.nix

Lines changed: 12 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,4 @@
1-
{ pkgs, inputs }:
1+
{ pkgs, inputs, ghc-lib ? false }:
22

33
let
44
disabledPlugins = [
@@ -7,17 +7,25 @@ let
77
# in the nix shell.
88
"shake-bench"
99
];
10+
ghc-lib-opt = if ghc-lib then "-fghc-lib" else "-f-ghc-lib";
1011

1112
hpkgsOverride = hself: hsuper:
1213
with pkgs.haskell.lib;
1314
{
1415
hlsDisabledPlugins = disabledPlugins;
1516
} // (builtins.mapAttrs (_: drv: disableLibraryProfiling drv) {
16-
apply-refact = hsuper.apply-refact_0_13_0_0;
17+
apply-refact = dontCheck (hself.callCabal2nix "apply-refact" inputs.apply-refact {});
1718

1819
fourmolu = dontCheck (hself.callCabal2nix "fourmolu" inputs.fourmolu-011 {});
1920

20-
stylish-haskell = appendConfigureFlag hsuper.stylish-haskell "-fghc-lib";
21+
stylish-haskell = appendConfigureFlag hsuper.stylish-haskell ghc-lib-opt;
22+
23+
ghc-lib-parser-ex = appendConfigureFlag hsuper.ghc-lib-parser-ex (if ghc-lib then "-f-no-ghc-lib" else "-fno-ghc-lib");
24+
hlint = hself.callCabal2nixWithOptions "hlint" inputs.hlint-35 ghc-lib-opt {};
25+
26+
hls-hlint-plugin =
27+
hself.callCabal2nixWithOptions "hls-hlint-plugin" ./plugins/hls-hlint-plugin
28+
(pkgs.lib.concatStringsSep " " [ "--no-check" ghc-lib-opt ]) { };
2129

2230
lsp = hself.callCabal2nix "lsp" inputs.lsp {};
2331
lsp-types = hself.callCabal2nix "lsp-types" inputs.lsp-types {};
@@ -28,7 +36,7 @@ let
2836
hself.callCabal2nixWithOptions "haskell-language-server" ./.
2937
# Pedantic cannot be used due to -Werror=unused-top-binds
3038
# Check must be disabled due to some missing required files
31-
(pkgs.lib.concatStringsSep " " [ "--no-check" "-f-pedantic" "-f-hlint" ]) { };
39+
(pkgs.lib.concatStringsSep " " [ "--no-check" "-f-pedantic" ]) { };
3240
});
3341
in {
3442
inherit disabledPlugins;

‎flake.lock

Lines changed: 24 additions & 5 deletions
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

‎flake.nix

Lines changed: 8 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -59,14 +59,19 @@
5959
flake = false;
6060
};
6161
lsp-test = {
62-
url = "https://hackage.haskell.org/package/lsp-test-0.15.0.1/lsp-test-0.15.0.1.tar.gz";
62+
url = "/home/rhidalgochar/haskell/lsp/lsp-test";
6363
flake = false;
6464
};
6565

6666
haskell-hie-bios = {
6767
url = "github:haskell/hie-bios";
6868
flake = false;
6969
};
70+
71+
apply-refact = {
72+
url = "github:raoulhc/apply-refact?ref=explicit-dynflags";
73+
flake = false;
74+
};
7075
# smunix: github:haskell/hie-bios defines
7176
# 'CabalType :: Maybe String -> Maybe FilePath -> CabalType'
7277
# while the original githcom:Avi-D-coder/hie-bios still has this:
@@ -253,6 +258,8 @@
253258
# our compiling toolchain
254259
hpkgs.ghc
255260
hpkgs.cabal-install
261+
# @guibou: I'm not sure this is needed.
262+
hpkgs.hlint
256263
# @guibou: I'm not sure hie-bios is needed
257264
# pkgs.haskellPackages.hie-bios
258265
# Dependencies needed to build some parts of hackage
@@ -261,8 +268,6 @@
261268
(gen-hls-changelogs pkgs.haskellPackages)
262269
# For the documentation
263270
pythonWithPackages
264-
# @guibou: I'm not sure this is needed.
265-
hlint
266271
(pkgs.haskell.lib.justStaticExecutables (pkgs.haskell.lib.dontCheck pkgs.haskellPackages.opentelemetry-extra))
267272
capstone
268273
# ormolu

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

Lines changed: 19 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -29,6 +29,13 @@ flag pedantic
2929
default: False
3030
manual: True
3131

32+
flag ghc-lib
33+
description:
34+
Use ghc-lib-parser rather than the ghc library (requires hlint and
35+
ghc-lib-parser-ex to also be built with it)
36+
default: True
37+
manual: True
38+
3239
library
3340
exposed-modules: Ide.Plugin.Hlint
3441
hs-source-dirs: src
@@ -59,11 +66,19 @@ library
5966
, text
6067
, transformers
6168
, unordered-containers
62-
, ghc-lib-parser
6369
, ghc-lib-parser-ex
6470
, apply-refact
6571

66-
cpp-options: -DHLINT_ON_GHC_LIB
72+
if flag(ghc-lib)
73+
cpp-options: -DHLINT_ON_GHC_LIB
74+
build-depends:
75+
ghc-lib-parser
76+
else
77+
build-depends:
78+
ghc
79+
, ghc-boot
80+
, ghc-boot-th
81+
6782
ghc-options:
6883
-Wall -Wredundant-constraints -Wno-name-shadowing
6984
-Wno-unticked-promoted-constructors
@@ -94,3 +109,5 @@ test-suite tests
94109
, lsp-types
95110
, row-types
96111
, text
112+
if flag(ghc-lib)
113+
cpp-options: -DHLINT_ON_GHC_LIB

‎plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs

Lines changed: 42 additions & 42 deletions
Original file line numberDiff line numberDiff line change
@@ -10,7 +10,6 @@
1010
{-# LANGUAGE NamedFieldPuns #-}
1111
{-# LANGUAGE OverloadedLabels #-}
1212
{-# LANGUAGE OverloadedStrings #-}
13-
{-# LANGUAGE PackageImports #-}
1413
{-# LANGUAGE PatternSynonyms #-}
1514
{-# LANGUAGE RecordWildCards #-}
1615
{-# LANGUAGE ScopedTypeVariables #-}
@@ -77,22 +76,22 @@ import Development.IDE.GHC.Compat (DynFlags,
7776
topDir,
7877
wopt)
7978
import qualified Development.IDE.GHC.Compat.Util as EnumSet
79+
import qualified GHC.Data.Strict as Strict
80+
import System.FilePath (takeFileName)
81+
import System.IO.Temp
8082

81-
#if MIN_GHC_API_VERSION(9,4,0)
82-
import qualified "ghc-lib-parser" GHC.Data.Strict as Strict
83-
#endif
83+
-- TODO make this work for GHC < 9.2.8?
8484
#if MIN_GHC_API_VERSION(9,0,0)
85-
import "ghc-lib-parser" GHC.Types.SrcLoc hiding
85+
import GHC.Types.SrcLoc hiding
8686
(RealSrcSpan)
87-
import qualified "ghc-lib-parser" GHC.Types.SrcLoc as GHC
87+
import qualified GHC.Types.SrcLoc as GHC
8888
#else
89-
import "ghc-lib-parser" SrcLoc hiding
89+
import qualified SrcLoc as GHC
90+
import SrcLoc hiding
9091
(RealSrcSpan)
91-
import qualified "ghc-lib-parser" SrcLoc as GHC
9292
#endif
93-
import "ghc-lib-parser" GHC.LanguageExtensions (Extension)
93+
import GHC.LanguageExtensions (Extension)
9494
import Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx (readExtension)
95-
import System.FilePath (takeFileName)
9695
import System.IO (IOMode (WriteMode),
9796
hClose,
9897
hPutStr,
@@ -101,21 +100,23 @@ import System.IO (IOMode (Wri
101100
noNewlineTranslation,
102101
utf8,
103102
withFile)
104-
import System.IO.Temp
105103
#else
106104
import Development.IDE.GHC.Compat hiding
107105
(setEnv,
108106
(<+>))
109107
import GHC.Generics (Associativity (LeftAssociative, NotAssociative, RightAssociative))
108+
import Language.Haskell.GHC.ExactPrint (makeDeltaAst)
109+
import Language.Haskell.GHC.ExactPrint.Parsers (postParseTransform)
110110
#if MIN_GHC_API_VERSION(9,2,0)
111-
import Language.Haskell.GHC.ExactPrint.ExactPrint (deltaOptions)
111+
import qualified GHC.Types.Fixity as GHC
112112
#else
113113
import Language.Haskell.GHC.ExactPrint.Delta (deltaOptions)
114+
import System.IO.Temp
114115
#endif
115-
import Language.Haskell.GHC.ExactPrint.Parsers (postParseTransform)
116-
import Language.Haskell.GHC.ExactPrint.Types (Rigidity (..))
117116
import Language.Haskell.GhclibParserEx.Fixity as GhclibParserEx (applyFixities)
118117
import qualified Refact.Fixity as Refact
118+
#if MIN_GHC_API_VERSION(9,2,0)
119+
#endif
119120
#endif
120121
import Ide.Plugin.Config hiding
121122
(Config)
@@ -132,7 +133,8 @@ import Language.LSP.Protocol.Message
132133
import Language.LSP.Protocol.Types hiding
133134
(Null)
134135
import qualified Language.LSP.Protocol.Types as LSP
135-
import Language.LSP.Server (getVersionedTextDoc)
136+
import Language.LSP.Server (getClientCapabilities,
137+
getVersionedTextDoc)
136138

137139
import qualified Development.IDE.Core.Shake as Shake
138140
import Development.IDE.Spans.Pragmas (LineSplitTextEdits (LineSplitTextEdits),
@@ -170,6 +172,11 @@ instance Pretty Log where
170172
LogResolve msg -> pretty msg
171173

172174
#ifdef HLINT_ON_GHC_LIB
175+
#if MIN_GHC_API_VERSION(9,4,0)
176+
fromStrictMaybe :: Strict.Maybe a -> Maybe a
177+
fromStrictMaybe (Strict.Just a ) = Just a
178+
fromStrictMaybe Strict.Nothing = Nothing
179+
#endif
173180
-- Reimplementing this, since the one in Development.IDE.GHC.Compat isn't for ghc-lib
174181
#if !MIN_GHC_API_VERSION(9,0,0)
175182
type BufSpan = ()
@@ -185,11 +192,6 @@ pattern RealSrcSpan x y <- ((,Nothing) -> (GHC.RealSrcSpan x, y))
185192
{-# COMPLETE RealSrcSpan, UnhelpfulSpan #-}
186193
#endif
187194

188-
#if MIN_GHC_API_VERSION(9,4,0)
189-
fromStrictMaybe :: Strict.Maybe a -> Maybe a
190-
fromStrictMaybe (Strict.Just a ) = Just a
191-
fromStrictMaybe Strict.Nothing = Nothing
192-
#endif
193195

194196
descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
195197
descriptor recorder plId =
@@ -315,22 +317,20 @@ getIdeas recorder nfp = do
315317
mbpm <- getParsedModuleWithComments nfp
316318
return $ createModule <$> mbpm
317319
where
318-
createModule pm = Right (createModuleEx anns (applyParseFlagsFixities modu))
319-
where anns = pm_annotations pm
320-
modu = pm_parsed_source pm
320+
createModule = Right . createModuleEx . applyParseFlagsFixities . pm_parsed_source
321321

322322
applyParseFlagsFixities :: ParsedSource -> ParsedSource
323-
applyParseFlagsFixities modul = GhclibParserEx.applyFixities (parseFlagsToFixities _flags) modul
323+
applyParseFlagsFixities = GhclibParserEx.applyFixities (parseFlagsToFixities _flags)
324324

325325
parseFlagsToFixities :: ParseFlags -> [(String, Fixity)]
326326
parseFlagsToFixities = map toFixity . Hlint.fixities
327327

328328
toFixity :: FixityInfo -> (String, Fixity)
329329
toFixity (name, dir, i) = (name, Fixity NoSourceText i $ f dir)
330330
where
331-
f LeftAssociative = InfixL
332-
f RightAssociative = InfixR
333-
f NotAssociative = InfixN
331+
f LeftAssociative = GHC.InfixL
332+
f RightAssociative = GHC.InfixR
333+
f NotAssociative = GHC.InfixN
334334
#else
335335
moduleEx flags = do
336336
mbpm <- getParsedModuleWithComments nfp
@@ -443,9 +443,10 @@ codeActionProvider ideState _pluginId (CodeActionParams _ _ documentId _ context
443443
resolveProvider :: Recorder (WithPriority Log) -> ResolveFunction IdeState HlintResolveCommands Method_CodeActionResolve
444444
resolveProvider recorder ideState _plId ca uri resolveValue = do
445445
file <- getNormalizedFilePathE uri
446+
clientCapabilities <- lift getClientCapabilities
446447
case resolveValue of
447448
(ApplyHint verTxtDocId oneHint) -> do
448-
edit <- ExceptT $ liftIO $ applyHint recorder ideState file oneHint verTxtDocId
449+
edit <- ExceptT $ liftIO $ applyHint clientCapabilities recorder ideState file oneHint verTxtDocId
449450
pure $ ca & LSP.edit ?~ edit
450451
(IgnoreHint verTxtDocId hintTitle ) -> do
451452
edit <- ExceptT $ liftIO $ ignoreHint recorder ideState file verTxtDocId hintTitle
@@ -543,8 +544,8 @@ data OneHint =
543544
, oneHintTitle :: HintTitle
544545
} deriving (Generic, Eq, Show, ToJSON, FromJSON)
545546

546-
applyHint :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> Maybe OneHint -> VersionedTextDocumentIdentifier -> IO (Either PluginError WorkspaceEdit)
547-
applyHint recorder ide nfp mhint verTxtDocId =
547+
applyHint :: ClientCapabilities -> Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> Maybe OneHint -> VersionedTextDocumentIdentifier -> IO (Either PluginError WorkspaceEdit)
548+
applyHint clientCapabilities recorder ide nfp mhint verTxtDocId =
548549
runExceptT $ do
549550
let runAction' :: Action a -> IO a
550551
runAction' = runAction "applyHint" ide
@@ -573,7 +574,7 @@ applyHint recorder ide nfp mhint verTxtDocId =
573574
hSetEncoding h utf8
574575
hSetNewlineMode h noNewlineTranslation
575576
hPutStr h (T.unpack txt)
576-
res <-
577+
res <- do
577578
liftIO $ withSystemTempFile (takeFileName fp) $ \temp h -> do
578579
hClose h
579580
writeFileUTF8NoNewLineTranslation temp oldContent
@@ -587,22 +588,19 @@ applyHint recorder ide nfp mhint verTxtDocId =
587588
mbParsedModule <- liftIO $ runAction' $ getParsedModuleWithComments nfp
588589
res <-
589590
case mbParsedModule of
590-
Nothing -> throwError "Apply hint: error parsing the module"
591+
Nothing -> throwError $ PluginInternalError "Apply hint: error parsing the module"
591592
Just pm -> do
592-
let anns = pm_annotations pm
593-
let modu = pm_parsed_source pm
594-
-- apply-refact uses RigidLayout
595-
let rigidLayout = deltaOptions RigidLayout
596-
(anns', modu') <-
597-
ExceptT $ mapM (uncurry Refact.applyFixities)
598-
$ postParseTransform (Right (anns, [], dflags, modu)) rigidLayout
599-
liftIO $ (Right <$> Refact.applyRefactorings' position commands anns' modu')
593+
let modu = makeDeltaAst $ pm_parsed_source pm
594+
modu' <-
595+
ExceptT $ mapM Refact.applyFixities
596+
$ postParseTransform (Right ([], dflags, modu))
597+
liftIO $ (Right <$> Refact.applyRefactorings' dflags position commands modu')
600598
`catches` errorHandlers
601599
#endif
602600
case res of
603601
Right appliedFile -> do
604-
let wsEdit = diffText' True (verTxtDocId, oldContent) (T.pack appliedFile) IncludeDeletions
605-
ExceptT $ return (Right wsEdit)
602+
let wsEdit = diffText clientCapabilities (verTxtDocId, oldContent) (T.pack appliedFile) IncludeDeletions
603+
ExceptT $ pure $ Right wsEdit
606604
Left err ->
607605
throwError $ PluginInternalError $ T.pack err
608606
where
@@ -628,6 +626,7 @@ bimapExceptT f g (ExceptT m) = ExceptT (fmap h m) where
628626
h (Right a) = Right (g a)
629627
{-# INLINE bimapExceptT #-}
630628

629+
#ifdef HLINT_ON_GHC_LIB
631630
-- ---------------------------------------------------------------------------
632631
-- Apply-refact compatability, documentation copied from upstream apply-refact
633632
-- ---------------------------------------------------------------------------
@@ -679,3 +678,4 @@ applyRefactorings =
679678
withRuntimeLibdir libdir = bracket_ (setEnv key libdir) (unsetEnv key)
680679
where key = "GHC_EXACTPRINT_GHC_LIBDIR"
681680
#endif
681+
#endif

0 commit comments

Comments
 (0)