Skip to content

Commit

Permalink
Reintroduce ghc-lib flag for hlint plugin
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.

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.
  • Loading branch information
@RaoulHC
RaoulHC committed Aug 22, 2023
1 parent ed64561 commit ab638e8
Show file tree
Hide file tree
Showing 6 changed files with 116 additions and 57 deletions.
16 changes: 12 additions & 4 deletions configuration-ghc-94.nix
View file
Original file line number Diff line number Diff line change
@@ -1,4 +1,4 @@
{ pkgs, inputs }:
{ pkgs, inputs, ghc-lib ? false }:

let
disabledPlugins = [
Expand All @@ -7,17 +7,25 @@ let
# in the nix shell.
"shake-bench"
];
ghc-lib-opt = if ghc-lib then "-fghc-lib" else "-f-ghc-lib";

hpkgsOverride = hself: hsuper:
with pkgs.haskell.lib;
{
hlsDisabledPlugins = disabledPlugins;
} // (builtins.mapAttrs (_: drv: disableLibraryProfiling drv) {
apply-refact = hsuper.apply-refact_0_13_0_0;
apply-refact = dontCheck (hself.callCabal2nix "apply-refact" inputs.apply-refact {});

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

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

ghc-lib-parser-ex = appendConfigureFlag hsuper.ghc-lib-parser-ex (if ghc-lib then "-f-no-ghc-lib" else "-fno-ghc-lib");
hlint = hself.callCabal2nixWithOptions "hlint" inputs.hlint-35 ghc-lib-opt {};

hls-hlint-plugin =
hself.callCabal2nixWithOptions "hls-hlint-plugin" ./plugins/hls-hlint-plugin
(pkgs.lib.concatStringsSep " " [ "--no-check" ghc-lib-opt ]) { };

lsp = hself.callCabal2nix "lsp" inputs.lsp {};
lsp-types = hself.callCabal2nix "lsp-types" inputs.lsp-types {};
Expand All @@ -28,7 +36,7 @@ let
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
29 changes: 24 additions & 5 deletions flake.lock
View file

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

11 changes: 8 additions & 3 deletions flake.nix
View file
Original file line number Diff line number Diff line change
Expand Up @@ -59,14 +59,19 @@
flake = false;
};
lsp-test = {
url = "https://hackage.haskell.org/package/lsp-test-0.15.0.1/lsp-test-0.15.0.1.tar.gz";
url = "/home/rhidalgochar/haskell/lsp/lsp-test";
flake = false;
};

haskell-hie-bios = {
url = "github:haskell/hie-bios";
flake = false;
};

apply-refact = {
url = "github:raoulhc/apply-refact?ref=explicit-dynflags";
flake = false;
};
# smunix: github:haskell/hie-bios defines
# 'CabalType :: Maybe String -> Maybe FilePath -> CabalType'
# while the original githcom:Avi-D-coder/hie-bios still has this:
Expand Down Expand Up @@ -253,6 +258,8 @@
# our compiling toolchain
hpkgs.ghc
hpkgs.cabal-install
# @guibou: I'm not sure this is needed.
hpkgs.hlint
# @guibou: I'm not sure hie-bios is needed
# pkgs.haskellPackages.hie-bios
# Dependencies needed to build some parts of hackage
Expand All @@ -261,8 +268,6 @@
(gen-hls-changelogs pkgs.haskellPackages)
# For the documentation
pythonWithPackages
# @guibou: I'm not sure this is needed.
hlint
(pkgs.haskell.lib.justStaticExecutables (pkgs.haskell.lib.dontCheck pkgs.haskellPackages.opentelemetry-extra))
capstone
# ormolu
Expand Down
21 changes: 19 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: True

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: -DHLINT_ON_GHC_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 Expand Up @@ -94,3 +109,5 @@ test-suite tests
, lsp-types
, row-types
, text
if flag(ghc-lib)
cpp-options: -DHLINT_ON_GHC_LIB
84 changes: 42 additions & 42 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 Down Expand Up @@ -77,22 +76,22 @@ import Development.IDE.GHC.Compat (DynFlags,
topDir,
wopt)
import qualified Development.IDE.GHC.Compat.Util as EnumSet
import qualified GHC.Data.Strict as Strict
import System.FilePath (takeFileName)
import System.IO.Temp

#if MIN_GHC_API_VERSION(9,4,0)
import qualified "ghc-lib-parser" GHC.Data.Strict as Strict
#endif
-- TODO make this work for GHC < 9.2.8?
#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),
hClose,
hPutStr,
Expand All @@ -101,21 +100,23 @@ import System.IO (IOMode (Wri
noNewlineTranslation,
utf8,
withFile)
import System.IO.Temp
#else
import Development.IDE.GHC.Compat hiding
(setEnv,
(<+>))
import GHC.Generics (Associativity (LeftAssociative, NotAssociative, RightAssociative))
import Language.Haskell.GHC.ExactPrint (makeDeltaAst)
import Language.Haskell.GHC.ExactPrint.Parsers (postParseTransform)
#if MIN_GHC_API_VERSION(9,2,0)
import Language.Haskell.GHC.ExactPrint.ExactPrint (deltaOptions)
import qualified GHC.Types.Fixity as GHC
#else
import Language.Haskell.GHC.ExactPrint.Delta (deltaOptions)
import System.IO.Temp
#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
#if MIN_GHC_API_VERSION(9,2,0)
#endif
#endif
import Ide.Plugin.Config hiding
(Config)
Expand All @@ -132,7 +133,8 @@ import Language.LSP.Protocol.Message
import Language.LSP.Protocol.Types hiding
(Null)
import qualified Language.LSP.Protocol.Types as LSP
import Language.LSP.Server (getVersionedTextDoc)
import Language.LSP.Server (getClientCapabilities,
getVersionedTextDoc)

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

#ifdef HLINT_ON_GHC_LIB
#if MIN_GHC_API_VERSION(9,4,0)
fromStrictMaybe :: Strict.Maybe a -> Maybe a
fromStrictMaybe (Strict.Just a ) = Just a
fromStrictMaybe Strict.Nothing = Nothing
#endif
-- 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 @@ -185,11 +192,6 @@ pattern RealSrcSpan x y <- ((,Nothing) -> (GHC.RealSrcSpan x, y))
{-# COMPLETE RealSrcSpan, UnhelpfulSpan #-}
#endif

#if MIN_GHC_API_VERSION(9,4,0)
fromStrictMaybe :: Strict.Maybe a -> Maybe a
fromStrictMaybe (Strict.Just a ) = Just a
fromStrictMaybe Strict.Nothing = Nothing
#endif

descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
descriptor recorder plId =
Expand Down Expand Up @@ -315,22 +317,20 @@ getIdeas recorder nfp = 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
createModule = Right . createModuleEx . applyParseFlagsFixities . pm_parsed_source

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

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
f LeftAssociative = GHC.InfixL
f RightAssociative = GHC.InfixR
f NotAssociative = GHC.InfixN
#else
moduleEx flags = do
mbpm <- getParsedModuleWithComments nfp
Expand Down Expand Up @@ -443,9 +443,10 @@ codeActionProvider ideState _pluginId (CodeActionParams _ _ documentId _ context
resolveProvider :: Recorder (WithPriority Log) -> ResolveFunction IdeState HlintResolveCommands Method_CodeActionResolve
resolveProvider recorder ideState _plId ca uri resolveValue = do
file <- getNormalizedFilePathE uri
clientCapabilities <- lift getClientCapabilities
case resolveValue of
(ApplyHint verTxtDocId oneHint) -> do
edit <- ExceptT $ liftIO $ applyHint recorder ideState file oneHint verTxtDocId
edit <- ExceptT $ liftIO $ applyHint clientCapabilities recorder ideState file oneHint verTxtDocId
pure $ ca & LSP.edit ?~ edit
(IgnoreHint verTxtDocId hintTitle ) -> do
edit <- ExceptT $ liftIO $ ignoreHint recorder ideState file verTxtDocId hintTitle
Expand Down Expand Up @@ -543,8 +544,8 @@ data OneHint =
, oneHintTitle :: HintTitle
} deriving (Generic, Eq, Show, ToJSON, FromJSON)

applyHint :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> Maybe OneHint -> VersionedTextDocumentIdentifier -> IO (Either PluginError WorkspaceEdit)
applyHint recorder ide nfp mhint verTxtDocId =
applyHint :: ClientCapabilities -> Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> Maybe OneHint -> VersionedTextDocumentIdentifier -> IO (Either PluginError WorkspaceEdit)
applyHint clientCapabilities recorder ide nfp mhint verTxtDocId =
runExceptT $ do
let runAction' :: Action a -> IO a
runAction' = runAction "applyHint" ide
Expand Down Expand Up @@ -573,7 +574,7 @@ applyHint recorder ide nfp mhint verTxtDocId =
hSetEncoding h utf8
hSetNewlineMode h noNewlineTranslation
hPutStr h (T.unpack txt)
res <-
res <- do
liftIO $ withSystemTempFile (takeFileName fp) $ \temp h -> do
hClose h
writeFileUTF8NoNewLineTranslation temp oldContent
Expand All @@ -587,22 +588,19 @@ applyHint recorder ide nfp mhint verTxtDocId =
mbParsedModule <- liftIO $ runAction' $ getParsedModuleWithComments nfp
res <-
case mbParsedModule of
Nothing -> throwError "Apply hint: error parsing the module"
Nothing -> throwError $ PluginInternalError "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')
let modu = makeDeltaAst $ pm_parsed_source pm
modu' <-
ExceptT $ mapM Refact.applyFixities
$ postParseTransform (Right ([], dflags, modu))
liftIO $ (Right <$> Refact.applyRefactorings' dflags position commands modu')
`catches` errorHandlers
#endif
case res of
Right appliedFile -> do
let wsEdit = diffText' True (verTxtDocId, oldContent) (T.pack appliedFile) IncludeDeletions
ExceptT $ return (Right wsEdit)
let wsEdit = diffText clientCapabilities (verTxtDocId, oldContent) (T.pack appliedFile) IncludeDeletions
ExceptT $ pure $ Right wsEdit
Left err ->
throwError $ PluginInternalError $ T.pack err
where
Expand All @@ -628,6 +626,7 @@ bimapExceptT f g (ExceptT m) = ExceptT (fmap h m) where
h (Right a) = Right (g a)
{-# INLINE bimapExceptT #-}

#ifdef HLINT_ON_GHC_LIB
-- ---------------------------------------------------------------------------
-- Apply-refact compatability, documentation copied from upstream apply-refact
-- ---------------------------------------------------------------------------
Expand Down Expand Up @@ -679,3 +678,4 @@ applyRefactorings =
withRuntimeLibdir libdir = bracket_ (setEnv key libdir) (unsetEnv key)
where key = "GHC_EXACTPRINT_GHC_LIBDIR"
#endif
#endif
Loading

0 comments on commit ab638e8

Please sign in to comment.