Skip to content

Commit a57c400

Browse files
RaoulHCRaoulHC
committed
Reintroduce ghc-lib flag
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 since this flag was removed has also been removed, ghc-lib-parser API is exactly the same as GHC by design.
1 parent 783905f commit a57c400

File tree

3 files changed

+53
-94
lines changed

3 files changed

+53
-94
lines changed

‎configuration-ghc-94.nix‎

Lines changed: 9 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -15,14 +15,21 @@ let
1515
} // (builtins.mapAttrs (_: drv: disableLibraryProfiling drv) {
1616
apply-refact = hsuper.apply-refact_0_12_0_0;
1717

18-
stylish-haskell = appendConfigureFlag hsuper.stylish-haskell "-fghc-lib";
18+
stylish-haskell = appendConfigureFlag hsuper.stylish-haskell "-f-ghc-lib";
19+
20+
ghc-lib-parser-ex = appendConfigureFlag hsuper.ghc-lib-parser-ex "-fno-ghc-lib";
21+
hlint = hself.callCabal2nixWithOptions "hlint" inputs.hlint-35 "-f-ghc-lib" {};
22+
23+
hls-hlint-plugin =
24+
hself.callCabal2nixWithOptions "hls-hlint-plugin" ./plugins/hls-hlint-plugin
25+
(pkgs.lib.concatStringsSep " " [ "--no-check" "-f-ghc-lib" ]) { };
1926

2027
# Re-generate HLS drv excluding some plugins
2128
haskell-language-server =
2229
hself.callCabal2nixWithOptions "haskell-language-server" ./.
2330
# Pedantic cannot be used due to -Werror=unused-top-binds
2431
# Check must be disabled due to some missing required files
25-
(pkgs.lib.concatStringsSep " " [ "--no-check" "-f-pedantic" "-f-hlint" ]) { };
32+
(pkgs.lib.concatStringsSep " " [ "--no-check" "-f-pedantic" ]) { };
2633
});
2734
in {
2835
inherit disabledPlugins;

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

Lines changed: 17 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: False
38+
3239
library
3340
if impl(ghc >= 9.5)
3441
buildable: False
@@ -60,11 +67,19 @@ library
6067
, text
6168
, transformers
6269
, unordered-containers
63-
, ghc-lib-parser
6470
, ghc-lib-parser-ex
6571
, apply-refact
6672

67-
cpp-options: -DHLINT_ON_GHC_LIB
73+
if flag(ghc-lib)
74+
cpp-options: -DGHC_LIB
75+
build-depends:
76+
ghc-lib-parser
77+
else
78+
build-depends:
79+
ghc
80+
, ghc-boot
81+
, ghc-boot-th
82+
6883
ghc-options:
6984
-Wall -Wredundant-constraints -Wno-name-shadowing
7085
-Wno-unticked-promoted-constructors

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

Lines changed: 27 additions & 90 deletions
Original file line numberDiff line numberDiff line change
@@ -1,31 +1,31 @@
1-
{-# LANGUAGE CPP #-}
2-
{-# LANGUAGE DeriveAnyClass #-}
3-
{-# LANGUAGE DeriveGeneric #-}
4-
{-# LANGUAGE DuplicateRecordFields #-}
5-
{-# LANGUAGE FlexibleContexts #-}
6-
{-# LANGUAGE FlexibleInstances #-}
7-
{-# LANGUAGE LambdaCase #-}
8-
{-# LANGUAGE MultiWayIf #-}
9-
{-# LANGUAGE NamedFieldPuns #-}
10-
{-# LANGUAGE OverloadedLabels #-}
11-
{-# LANGUAGE OverloadedStrings #-}
12-
{-# LANGUAGE PackageImports #-}
13-
{-# LANGUAGE PatternSynonyms #-}
14-
{-# LANGUAGE RecordWildCards #-}
15-
{-# LANGUAGE ScopedTypeVariables #-}
16-
{-# LANGUAGE StrictData #-}
17-
{-# LANGUAGE TupleSections #-}
18-
{-# LANGUAGE TypeFamilies #-}
19-
{-# LANGUAGE ViewPatterns #-}
20-
1+
{-# LANGUAGE CPP #-}
2+
{-# LANGUAGE DeriveAnyClass #-}
3+
{-# LANGUAGE DeriveGeneric #-}
4+
{-# LANGUAGE DuplicateRecordFields #-}
5+
{-# LANGUAGE ExistentialQuantification #-}
6+
{-# LANGUAGE FlexibleContexts #-}
7+
{-# LANGUAGE FlexibleInstances #-}
8+
{-# LANGUAGE LambdaCase #-}
9+
{-# LANGUAGE MultiWayIf #-}
10+
{-# LANGUAGE NamedFieldPuns #-}
11+
{-# LANGUAGE OverloadedLabels #-}
12+
{-# LANGUAGE OverloadedStrings #-}
13+
{-# LANGUAGE PatternSynonyms #-}
14+
{-# LANGUAGE RecordWildCards #-}
15+
{-# LANGUAGE ScopedTypeVariables #-}
16+
{-# LANGUAGE StrictData #-}
17+
{-# LANGUAGE TupleSections #-}
18+
{-# LANGUAGE TypeApplications #-}
19+
{-# LANGUAGE TypeFamilies #-}
20+
{-# LANGUAGE ViewPatterns #-}
2121
{-# OPTIONS_GHC -Wno-orphans #-}
2222

2323
-- On 9.4 we get a new redundant constraint warning, but deleting the
2424
-- constraint breaks the build on earlier versions. Rather than apply
2525
-- lots of CPP, we just disable the warning until later.
2626
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
2727

28-
#ifdef HLINT_ON_GHC_LIB
28+
#ifdef GHC_LIB
2929
#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc_lib_parser(x,y,z)
3030
#else
3131
#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc(x,y,z)
@@ -63,7 +63,6 @@ import Development.IDE.Core.Shake (getDiagnost
6363
import qualified Refact.Apply as Refact
6464
import qualified Refact.Types as Refact
6565

66-
#ifdef HLINT_ON_GHC_LIB
6766
import Development.IDE.GHC.Compat (DynFlags,
6867
WarningFlag (Opt_WarnUnrecognisedPragmas),
6968
extensionFlags,
@@ -73,18 +72,18 @@ import Development.IDE.GHC.Compat (DynFlags,
7372
import qualified Development.IDE.GHC.Compat.Util as EnumSet
7473

7574
#if MIN_GHC_API_VERSION(9,4,0)
76-
import qualified "ghc-lib-parser" GHC.Data.Strict as Strict
75+
import qualified GHC.Data.Strict as Strict
7776
#endif
7877
#if MIN_GHC_API_VERSION(9,0,0)
79-
import "ghc-lib-parser" GHC.Types.SrcLoc hiding
78+
import GHC.Types.SrcLoc hiding
8079
(RealSrcSpan)
81-
import qualified "ghc-lib-parser" GHC.Types.SrcLoc as GHC
80+
import qualified GHC.Types.SrcLoc as GHC
8281
#else
83-
import "ghc-lib-parser" SrcLoc hiding
82+
import qualified SrcLoc as GHC
83+
import SrcLoc hiding
8484
(RealSrcSpan)
85-
import qualified "ghc-lib-parser" SrcLoc as GHC
8685
#endif
87-
import "ghc-lib-parser" GHC.LanguageExtensions (Extension)
86+
import GHC.LanguageExtensions (Extension)
8887
import Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx (readExtension)
8988
import System.FilePath (takeFileName)
9089
import System.IO (IOMode (WriteMode),
@@ -96,21 +95,6 @@ import System.IO (IOMode (Wri
9695
utf8,
9796
withFile)
9897
import System.IO.Temp
99-
#else
100-
import Development.IDE.GHC.Compat hiding
101-
(setEnv,
102-
(<+>))
103-
import GHC.Generics (Associativity (LeftAssociative, NotAssociative, RightAssociative))
104-
#if MIN_GHC_API_VERSION(9,2,0)
105-
import Language.Haskell.GHC.ExactPrint.ExactPrint (deltaOptions)
106-
#else
107-
import Language.Haskell.GHC.ExactPrint.Delta (deltaOptions)
108-
#endif
109-
import Language.Haskell.GHC.ExactPrint.Parsers (postParseTransform)
110-
import Language.Haskell.GHC.ExactPrint.Types (Rigidity (..))
111-
import Language.Haskell.GhclibParserEx.Fixity as GhclibParserEx (applyFixities)
112-
import qualified Refact.Fixity as Refact
113-
#endif
11498

11599
import Ide.Plugin.Config hiding
116100
(Config)
@@ -163,7 +147,6 @@ instance Pretty Log where
163147
LogUsingExtensions fp exts -> "Using extensions for " <+> viaShow fp <> ":" <+> pretty exts
164148
LogGetIdeas fp -> "Getting hlint ideas for " <+> viaShow fp
165149

166-
#ifdef HLINT_ON_GHC_LIB
167150
-- Reimplementing this, since the one in Development.IDE.GHC.Compat isn't for ghc-lib
168151
#if !MIN_GHC_API_VERSION(9,0,0)
169152
type BufSpan = ()
@@ -177,7 +160,6 @@ pattern RealSrcSpan x y = GHC.RealSrcSpan x y
177160
pattern RealSrcSpan x y <- ((,Nothing) -> (GHC.RealSrcSpan x, y))
178161
#endif
179162
{-# COMPLETE RealSrcSpan, UnhelpfulSpan #-}
180-
#endif
181163

182164
#if MIN_GHC_API_VERSION(9,4,0)
183165
fromStrictMaybe :: Strict.Maybe a -> Maybe a
@@ -300,28 +282,6 @@ getIdeas recorder nfp = do
300282
fmap applyHints' (moduleEx flags)
301283

302284
where moduleEx :: ParseFlags -> Action (Maybe (Either ParseError ModuleEx))
303-
#ifndef HLINT_ON_GHC_LIB
304-
moduleEx _flags = do
305-
mbpm <- getParsedModuleWithComments nfp
306-
return $ createModule <$> mbpm
307-
where
308-
createModule pm = Right (createModuleEx anns (applyParseFlagsFixities modu))
309-
where anns = pm_annotations pm
310-
modu = pm_parsed_source pm
311-
312-
applyParseFlagsFixities :: ParsedSource -> ParsedSource
313-
applyParseFlagsFixities modul = GhclibParserEx.applyFixities (parseFlagsToFixities _flags) modul
314-
315-
parseFlagsToFixities :: ParseFlags -> [(String, Fixity)]
316-
parseFlagsToFixities = map toFixity . Hlint.fixities
317-
318-
toFixity :: FixityInfo -> (String, Fixity)
319-
toFixity (name, dir, i) = (name, Fixity NoSourceText i $ f dir)
320-
where
321-
f LeftAssociative = InfixL
322-
f RightAssociative = InfixR
323-
f NotAssociative = InfixN
324-
#else
325285
moduleEx flags = do
326286
mbpm <- getParsedModuleWithComments nfp
327287
-- If ghc was not able to parse the module, we disable hlint diagnostics
@@ -344,11 +304,6 @@ getIdeas recorder nfp = do
344304
-- and the ModSummary dynflags. However using the parsedFlags extensions
345305
-- can sometimes interfere with the hlint parsing of the file.
346306
-- See https://github.com/haskell/haskell-language-server/issues/1279
347-
--
348-
-- Note: this is used when HLINT_ON_GHC_LIB is defined. We seem to need
349-
-- these extensions to construct dynflags to parse the file again. Therefore
350-
-- using hlint default extensions doesn't seem to be a problem when
351-
-- HLINT_ON_GHC_LIB is not defined because we don't parse the file again.
352307
getExtensions :: NormalizedFilePath -> Action [Extension]
353308
getExtensions nfp = do
354309
dflags <- getFlags
@@ -359,7 +314,6 @@ getExtensions nfp = do
359314
getFlags = do
360315
modsum <- use_ GetModSummary nfp
361316
return $ ms_hspp_opts $ msrModSummary modsum
362-
#endif
363317

364318
-- ---------------------------------------------------------------------
365319

@@ -580,7 +534,6 @@ applyHint recorder ide nfp mhint =
580534
-- But "Idea"s returned by HLint point to starting position of the expressions
581535
-- that contain refactorings, so they are often outside the refactorings' boundaries.
582536
let position = Nothing
583-
#ifdef HLINT_ON_GHC_LIB
584537
let writeFileUTF8NoNewLineTranslation file txt =
585538
withFile file WriteMode $ \h -> do
586539
hSetEncoding h utf8
@@ -596,22 +549,6 @@ applyHint recorder ide nfp mhint =
596549
let refactExts = map show $ enabled ++ disabled
597550
(Right <$> applyRefactorings (topDir dflags) position commands temp refactExts)
598551
`catches` errorHandlers
599-
#else
600-
mbParsedModule <- liftIO $ runAction' $ getParsedModuleWithComments nfp
601-
res <-
602-
case mbParsedModule of
603-
Nothing -> throwE "Apply hint: error parsing the module"
604-
Just pm -> do
605-
let anns = pm_annotations pm
606-
let modu = pm_parsed_source pm
607-
-- apply-refact uses RigidLayout
608-
let rigidLayout = deltaOptions RigidLayout
609-
(anns', modu') <-
610-
ExceptT $ mapM (uncurry Refact.applyFixities)
611-
$ postParseTransform (Right (anns, [], dflags, modu)) rigidLayout
612-
liftIO $ (Right <$> Refact.applyRefactorings' position commands anns' modu')
613-
`catches` errorHandlers
614-
#endif
615552
case res of
616553
Right appliedFile -> do
617554
let uri = fromNormalizedUri (filePathToUri' nfp)

0 commit comments

Comments
 (0)