diff --git a/configuration-ghc-94.nix b/configuration-ghc-94.nix index e561496955..3fd10e5813 100644 --- a/configuration-ghc-94.nix +++ b/configuration-ghc-94.nix @@ -1,4 +1,4 @@ -{ pkgs, inputs }: +{ pkgs, inputs, ghc-lib ? false }: let disabledPlugins = [ @@ -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 {}; @@ -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; diff --git a/flake.lock b/flake.lock index c3d8f1b878..288643c0c2 100644 --- a/flake.lock +++ b/flake.lock @@ -1,5 +1,22 @@ { "nodes": { + "apply-refact": { + "flake": false, + "locked": { + "lastModified": 1692708206, + "narHash": "sha256-01GYsCIU2yVMzbjY0tJwbZG2QIlNUc/+Fb8+IalzHEg=", + "owner": "raoulhc", + "repo": "apply-refact", + "rev": "d1a5d385a7fafbf01ffbe5dddb93a1e4c7638bf8", + "type": "github" + }, + "original": { + "owner": "raoulhc", + "ref": "explicit-dynflags", + "repo": "apply-refact", + "type": "github" + } + }, "flake-compat": { "flake": false, "locked": { @@ -146,13 +163,14 @@ "lsp-test": { "flake": false, "locked": { - "narHash": "sha256-48gVUVsDPR+RYl+K0ZN15N9EIdTQP8ma5nGPvzE6uoQ=", - "type": "tarball", - "url": "https://hackage.haskell.org/package/lsp-test-0.15.0.1/lsp-test-0.15.0.1.tar.gz" + "lastModified": 1692639108, + "narHash": "sha256-cCPPHN4ELaTI0IXqj8WDlle7CGxCepaY+9wNINZ4fAw=", + "path": "/home/rhidalgochar/haskell/lsp/lsp-test", + "type": "path" }, "original": { - "type": "tarball", - "url": "https://hackage.haskell.org/package/lsp-test-0.15.0.1/lsp-test-0.15.0.1.tar.gz" + "path": "/home/rhidalgochar/haskell/lsp/lsp-test", + "type": "path" } }, "lsp-types": { @@ -209,6 +227,7 @@ }, "root": { "inputs": { + "apply-refact": "apply-refact", "flake-compat": "flake-compat", "flake-utils": "flake-utils", "fourmolu-011": "fourmolu-011", diff --git a/flake.nix b/flake.nix index 5556a81454..1524838749 100644 --- a/flake.nix +++ b/flake.nix @@ -59,7 +59,7 @@ 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; }; @@ -67,6 +67,11 @@ 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: @@ -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 @@ -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 diff --git a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal index 0035934ef2..d0658ecf81 100644 --- a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal +++ b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal @@ -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 @@ -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 @@ -94,3 +109,5 @@ test-suite tests , lsp-types , row-types , text + if flag(ghc-lib) + cpp-options: -DHLINT_ON_GHC_LIB diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 2c02c6c6e0..40190f5800 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -10,7 +10,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -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, @@ -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) @@ -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), @@ -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 = () @@ -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 = @@ -315,12 +317,10 @@ 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 @@ -328,9 +328,9 @@ getIdeas recorder nfp = do 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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 -- --------------------------------------------------------------------------- @@ -679,3 +678,4 @@ applyRefactorings = withRuntimeLibdir libdir = bracket_ (setEnv key libdir) (unsetEnv key) where key = "GHC_EXACTPRINT_GHC_LIBDIR" #endif +#endif diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs index 9fca15bfb1..940e4f5114 100644 --- a/plugins/hls-hlint-plugin/test/Main.hs +++ b/plugins/hls-hlint-plugin/test/Main.hs @@ -1,12 +1,17 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeOperators #-} + module Main ( main ) where +import Data.Text.IO as T +import System.IO + import Control.Lens ((^.)) import Control.Monad (when) import Data.Aeson (Value (..), object, toJSON, (.=)) @@ -91,7 +96,7 @@ suggestionsTests = testGroup "hlint suggestions" [ testCase "provides 3.8 code actions including apply all" $ runHlintSession "" $ do doc <- openDoc "Base.hs" "haskell" - diags@(reduceDiag:_) <- waitForDiagnosticsFromSource doc "hlint" + diags@(reduceDiag:_) <- waitForDiagnosticsFromSourceWithTimeout 1 doc "hlint" liftIO $ do length diags @?= 2 -- "Eta Reduce" and "Redundant Id" @@ -100,6 +105,7 @@ suggestionsTests = reduceDiag ^. L.code @?= Just (InR "refact:Eta reduce") reduceDiag ^. L.source @?= Just "hlint" + cas <- map fromAction <$> getAllCodeActions doc let redundantIdHintName = "Redundant id" @@ -386,7 +392,11 @@ disableHlint = sendConfigurationChanged $ toJSON $ def { Plugin.plugins = Map.fr -- Although a given hlint version supports one direct ghc, we could use several versions of hlint -- each one supporting a different ghc version. It should be a temporary situation though. knownBrokenForHlintOnGhcLib :: String -> TestTree -> TestTree +#ifdef HLINT_ON_GHC_LIB knownBrokenForHlintOnGhcLib = expectFailBecause +#else +knownBrokenForHlintOnGhcLib _ x = x +#endif -- 1's based data Point = Point {