Skip to content

Commit

Permalink
Reintroduce ghc-lib flag
Browse files Browse the repository at this point in the history 
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.

Cleared out a lot of the HLINT_ON_GHC_LIB gated code which has probably
been bitrotting since this flag was removed, there shouldn't be a
difference in the API anyway.
  • Loading branch information
@RaoulHC
RaoulHC committed Aug 15, 2023
1 parent 9ec58f5 commit a2117c9
Show file tree
Hide file tree
Showing 3 changed files with 35 additions and 76 deletions.
13 changes: 10 additions & 3 deletions configuration-ghc-94.nix
View file
Original file line number Diff line number Diff line change
Expand Up @@ -17,18 +17,25 @@ let

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

stylish-haskell = appendConfigureFlag hsuper.stylish-haskell "-fghc-lib";
stylish-haskell = appendConfigureFlag hsuper.stylish-haskell "-f-ghc-lib";

ghc-lib-parser-ex = appendConfigureFlag hsuper.ghc-lib-parser-ex "-fno-ghc-lib";
hlint = hself.callCabal2nixWithOptions "hlint" inputs.hlint-35 "-f-ghc-lib" {};

hls-hlint-plugin = (hself.callCabal2nixWithOptions "hls-hlint-plugin"
./plugins/hls-hlint-plugin "-f-ghc-lib" {})
.overrideAttrs (_: { doCheck = false; });

lsp = hself.callCabal2nix "lsp" inputs.lsp {};
lsp-types = hself.callCabal2nix "lsp-types" inputs.lsp-types {};
lsp-test = dontCheck (hself.callCabal2nix "lsp-test" inputs.lsp-test {});

# Re-generate HLS drv excluding some plugins
haskell-language-server =
hself.callCabal2nixWithOptions "haskell-language-server" ./.
(hself.callCabal2nixWithOptions "haskell-language-server" ./.
# Pedantic cannot be used due to -Werror=unused-top-binds
# Check must be disabled due to some missing required files
(pkgs.lib.concatStringsSep " " [ "--no-check" "-f-pedantic" "-f-hlint" ]) { };
(pkgs.lib.concatStringsSep " " [ "--no-check" "-f-pedantic" ]) { });
});
in {
inherit disabledPlugins;
Expand Down
19 changes: 17 additions & 2 deletions plugins/hls-hlint-plugin/hls-hlint-plugin.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -29,6 +29,13 @@ flag pedantic
default: False
manual: True

flag ghc-lib
description:
Use ghc-lib-parser rather than the ghc library (requires hlint and
ghc-lib-parser-ex to also be built with it)
default: True
manual: False

library
exposed-modules: Ide.Plugin.Hlint
hs-source-dirs: src
Expand Down Expand Up @@ -59,11 +66,19 @@ library
, text
, transformers
, unordered-containers
, ghc-lib-parser
, ghc-lib-parser-ex
, apply-refact

cpp-options: -DHLINT_ON_GHC_LIB
if flag(ghc-lib)
cpp-options: -DGHC_LIB
build-depends:
ghc-lib-parser
else
build-depends:
ghc
, ghc-boot
, ghc-boot-th

ghc-options:
-Wall -Wredundant-constraints -Wno-name-shadowing
-Wno-unticked-promoted-constructors
Expand Down
79 changes: 8 additions & 71 deletions plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -10,7 +10,6 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
Expand All @@ -26,7 +25,7 @@
-- lots of CPP, we just disable the warning until later.
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

#ifdef HLINT_ON_GHC_LIB
#ifdef GHC_LIB
#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc_lib_parser(x,y,z)
#else
#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc(x,y,z)
Expand Down Expand Up @@ -69,7 +68,6 @@ import Development.IDE.Core.Shake (getDiagnost
import qualified Refact.Apply as Refact
import qualified Refact.Types as Refact

#ifdef HLINT_ON_GHC_LIB
import Development.IDE.GHC.Compat (DynFlags,
WarningFlag (Opt_WarnUnrecognisedPragmas),
extensionFlags,
Expand All @@ -79,18 +77,18 @@ import Development.IDE.GHC.Compat (DynFlags,
import qualified Development.IDE.GHC.Compat.Util as EnumSet

#if MIN_GHC_API_VERSION(9,4,0)
import qualified "ghc-lib-parser" GHC.Data.Strict as Strict
import qualified GHC.Data.Strict as Strict
#endif
#if MIN_GHC_API_VERSION(9,0,0)
import "ghc-lib-parser" GHC.Types.SrcLoc hiding
import GHC.Types.SrcLoc hiding
(RealSrcSpan)
import qualified "ghc-lib-parser" GHC.Types.SrcLoc as GHC
import qualified GHC.Types.SrcLoc as GHC
#else
import "ghc-lib-parser" SrcLoc hiding
import qualified SrcLoc as GHC
import SrcLoc hiding
(RealSrcSpan)
import qualified "ghc-lib-parser" SrcLoc as GHC
#endif
import "ghc-lib-parser" GHC.LanguageExtensions (Extension)
import GHC.LanguageExtensions (Extension)
import Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx (readExtension)
import System.FilePath (takeFileName)
import System.IO (IOMode (WriteMode),
Expand All @@ -102,21 +100,7 @@ import System.IO (IOMode (Wri
utf8,
withFile)
import System.IO.Temp
#else
import Development.IDE.GHC.Compat hiding
(setEnv,
(<+>))
import GHC.Generics (Associativity (LeftAssociative, NotAssociative, RightAssociative))
#if MIN_GHC_API_VERSION(9,2,0)
import Language.Haskell.GHC.ExactPrint.ExactPrint (deltaOptions)
#else
import Language.Haskell.GHC.ExactPrint.Delta (deltaOptions)
#endif
import Language.Haskell.GHC.ExactPrint.Parsers (postParseTransform)
import Language.Haskell.GHC.ExactPrint.Types (Rigidity (..))
import Language.Haskell.GhclibParserEx.Fixity as GhclibParserEx (applyFixities)
import qualified Refact.Fixity as Refact
#endif

import Ide.Plugin.Config hiding
(Config)
import Ide.Plugin.Error
Expand Down Expand Up @@ -169,7 +153,6 @@ instance Pretty Log where
LogGetIdeas fp -> "Getting hlint ideas for " <+> viaShow fp
LogResolve msg -> pretty msg

#ifdef HLINT_ON_GHC_LIB
-- Reimplementing this, since the one in Development.IDE.GHC.Compat isn't for ghc-lib
#if !MIN_GHC_API_VERSION(9,0,0)
type BufSpan = ()
Expand All @@ -183,7 +166,6 @@ pattern RealSrcSpan x y = GHC.RealSrcSpan x y
pattern RealSrcSpan x y <- ((,Nothing) -> (GHC.RealSrcSpan x, y))
#endif
{-# COMPLETE RealSrcSpan, UnhelpfulSpan #-}
#endif

#if MIN_GHC_API_VERSION(9,4,0)
fromStrictMaybe :: Strict.Maybe a -> Maybe a
Expand Down Expand Up @@ -310,28 +292,6 @@ getIdeas recorder nfp = do
fmap applyHints' (moduleEx flags)

where moduleEx :: ParseFlags -> Action (Maybe (Either ParseError ModuleEx))
#ifndef HLINT_ON_GHC_LIB
moduleEx _flags = do
mbpm <- getParsedModuleWithComments nfp
return $ createModule <$> mbpm
where
createModule pm = Right (createModuleEx anns (applyParseFlagsFixities modu))
where anns = pm_annotations pm
modu = pm_parsed_source pm

applyParseFlagsFixities :: ParsedSource -> ParsedSource
applyParseFlagsFixities modul = GhclibParserEx.applyFixities (parseFlagsToFixities _flags) modul

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

toFixity :: FixityInfo -> (String, Fixity)
toFixity (name, dir, i) = (name, Fixity NoSourceText i $ f dir)
where
f LeftAssociative = InfixL
f RightAssociative = InfixR
f NotAssociative = InfixN
#else
moduleEx flags = do
mbpm <- getParsedModuleWithComments nfp
-- If ghc was not able to parse the module, we disable hlint diagnostics
Expand All @@ -354,11 +314,6 @@ getIdeas recorder nfp = do
-- and the ModSummary dynflags. However using the parsedFlags extensions
-- can sometimes interfere with the hlint parsing of the file.
-- See https://github.com/haskell/haskell-language-server/issues/1279
--
-- Note: this is used when HLINT_ON_GHC_LIB is defined. We seem to need
-- these extensions to construct dynflags to parse the file again. Therefore
-- using hlint default extensions doesn't seem to be a problem when
-- HLINT_ON_GHC_LIB is not defined because we don't parse the file again.
getExtensions :: NormalizedFilePath -> Action [Extension]
getExtensions nfp = do
dflags <- getFlags
Expand All @@ -369,7 +324,6 @@ getExtensions nfp = do
getFlags = do
modsum <- use_ GetModSummary nfp
return $ ms_hspp_opts $ msrModSummary modsum
#endif

-- ---------------------------------------------------------------------

Expand Down Expand Up @@ -567,7 +521,6 @@ applyHint recorder ide nfp mhint verTxtDocId =
-- But "Idea"s returned by HLint point to starting position of the expressions
-- that contain refactorings, so they are often outside the refactorings' boundaries.
let position = Nothing
#ifdef HLINT_ON_GHC_LIB
let writeFileUTF8NoNewLineTranslation file txt =
withFile file WriteMode $ \h -> do
hSetEncoding h utf8
Expand All @@ -583,22 +536,6 @@ applyHint recorder ide nfp mhint verTxtDocId =
let refactExts = map show $ enabled ++ disabled
(Right <$> applyRefactorings (topDir dflags) position commands temp refactExts)
`catches` errorHandlers
#else
mbParsedModule <- liftIO $ runAction' $ getParsedModuleWithComments nfp
res <-
case mbParsedModule of
Nothing -> throwError "Apply hint: error parsing the module"
Just pm -> do
let anns = pm_annotations pm
let modu = pm_parsed_source pm
-- apply-refact uses RigidLayout
let rigidLayout = deltaOptions RigidLayout
(anns', modu') <-
ExceptT $ mapM (uncurry Refact.applyFixities)
$ postParseTransform (Right (anns, [], dflags, modu)) rigidLayout
liftIO $ (Right <$> Refact.applyRefactorings' position commands anns' modu')
`catches` errorHandlers
#endif
case res of
Right appliedFile -> do
let wsEdit = diffText' True (verTxtDocId, oldContent) (T.pack appliedFile) IncludeDeletions
Expand Down

0 comments on commit a2117c9

Please sign in to comment.