diff --git a/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal b/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal index 94e6e807e4..0b0f818922 100644 --- a/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal +++ b/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal @@ -19,7 +19,16 @@ source-repository head type: git location: https://github.com/haskell/haskell-language-server.git +flag pedantic + description: Enable -Werror + default: False + manual: True + +common warnings + ghc-options: -Wall + library + import: warnings buildable: True exposed-modules: Ide.Plugin.ExplicitImports hs-source-dirs: src @@ -32,8 +41,10 @@ library , ghcide == 2.1.0.0 , hls-graph , hls-plugin-api == 2.1.0.0 + , lens , lsp , text + , transformers , unordered-containers default-language: Haskell2010 @@ -41,7 +52,11 @@ library DataKinds TypeOperators + if flag(pedantic) + ghc-options: -Werror + test-suite tests + import: warnings buildable: True type: exitcode-stdio-1.0 default-language: Haskell2010 @@ -50,8 +65,11 @@ test-suite tests ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: , base + , extra , filepath , hls-explicit-imports-plugin , hls-test-utils + , lens , lsp-types - , text + , row-types + , text \ No newline at end of file diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index 0a929bf4f3..c99ff2ee1d 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -6,6 +6,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} @@ -19,27 +20,39 @@ module Ide.Plugin.ExplicitImports ) where import Control.DeepSeq +import Control.Lens ((&), (?~)) import Control.Monad.IO.Class -import Data.Aeson (ToJSON (toJSON), - Value ()) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (ExceptT) +import Control.Monad.Trans.Maybe +import qualified Data.Aeson as A (Result (..), + ToJSON (toJSON), + fromJSON) import Data.Aeson.Types (FromJSON) -import qualified Data.HashMap.Strict as HashMap +import qualified Data.IntMap as IM (IntMap, elems, + fromList, (!?)) import Data.IORef (readIORef) import qualified Data.Map.Strict as Map -import Data.Maybe (catMaybes, fromMaybe, - isJust) import Data.String (fromString) import qualified Data.Text as T +import Data.Traversable (for) +import qualified Data.Unique as U (hashUnique, + newUnique) import Development.IDE hiding (pluginHandlers, pluginRules) import Development.IDE.Core.PositionMapping import qualified Development.IDE.Core.Shake as Shake -import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat hiding ((<+>)) import Development.IDE.Graph.Classes -import Development.IDE.Types.Logger as Logger (Pretty (pretty)) import GHC.Generics (Generic) -import Ide.PluginUtils (mkLspCommand) +import Ide.Plugin.RangeMap (filterByRange) +import qualified Ide.Plugin.RangeMap as RM (RangeMap, fromList) +import Ide.PluginUtils (getNormalizedFilePath, + handleMaybe, + handleMaybeM, + pluginResponse) import Ide.Types +import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types import Language.LSP.Server @@ -47,13 +60,15 @@ import Language.LSP.Server importCommandId :: CommandId importCommandId = "ImportLensCommand" -newtype Log +data Log = LogShake Shake.Log + | LogWAEResponseError ResponseError deriving Show instance Pretty Log where pretty = \case - LogShake log -> pretty log + LogShake logMsg -> pretty logMsg + LogWAEResponseError rspErr -> "RequestWorkspaceApplyEdit Failed with " <+> viaShow rspErr -- | The "main" function of a plugin descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState @@ -67,37 +82,34 @@ descriptorForModules -- ^ Predicate to select modules that will be annotated -> PluginId -> PluginDescriptor IdeState -descriptorForModules recorder pred plId = +descriptorForModules recorder modFilter plId = (defaultPluginDescriptor plId) { -- This plugin provides a command handler - pluginCommands = [importLensCommand], + pluginCommands = [PluginCommand importCommandId "Explicit import command" (runImportCommand recorder)], -- This plugin defines a new rule - pluginRules = minimalImportsRule recorder, - pluginHandlers = mconcat - [ -- This plugin provides code lenses - mkPluginHandler SMethod_TextDocumentCodeLens $ lensProvider pred + pluginRules = minimalImportsRule recorder modFilter, + pluginHandlers = + -- This plugin provides code lenses + mkPluginHandler SMethod_TextDocumentCodeLens (lensProvider recorder) + <> mkPluginHandler SMethod_CodeLensResolve (lensResolveProvider recorder) -- This plugin provides code actions - , mkPluginHandler SMethod_TextDocumentCodeAction $ codeActionProvider pred - ] - } - --- | The command descriptor -importLensCommand :: PluginCommand IdeState -importLensCommand = - PluginCommand importCommandId "Explicit import command" runImportCommand + <> mkCodeActionHandlerWithResolve (codeActionProvider recorder) (codeActionResolveProvider recorder) --- | The type of the parameters accepted by our command -newtype ImportCommandParams = ImportCommandParams WorkspaceEdit - deriving (Generic) - deriving anyclass (FromJSON, ToJSON) + } -- | The actual command handler -runImportCommand :: CommandFunction IdeState ImportCommandParams -runImportCommand _state (ImportCommandParams edit) = do - -- This command simply triggers a workspace edit! - _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) - return (Right $ InR Null) +runImportCommand :: Recorder (WithPriority Log) -> CommandFunction IdeState EIResolveData +runImportCommand recorder ideState eird@(ResolveOne _ _) = pluginResponse $ do + wedit <- resolveWTextEdit ideState eird + _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) logErrors + return $ InR Null + where logErrors (Left re@(ResponseError{})) = do + logWith recorder Error (LogWAEResponseError re) + pure () + logErrors (Right _) = pure () +runImportCommand _ _ (ResolveAll _) = do + pure $ Left $ ResponseError (InR ErrorCodes_InvalidParams) "Unexpected argument for command handler: ResolveAll" Nothing -- | For every implicit import statement, return a code lens of the corresponding explicit import -- Example - for the module below: @@ -109,75 +121,111 @@ runImportCommand _state (ImportCommandParams edit) = do -- the provider should produce one code lens associated to the import statement: -- -- > import Data.List (intercalate, sortBy) -lensProvider :: (ModuleName -> Bool) -> PluginMethodHandler IdeState Method_TextDocumentCodeLens -lensProvider - pred - state -- ghcide state, used to retrieve typechecking artifacts - pId -- plugin Id - CodeLensParams {_textDocument = TextDocumentIdentifier {_uri}} - -- VSCode uses URIs instead of file paths - -- haskell-lsp provides conversion functions - | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri _uri = liftIO $ - do - mbMinImports <- runAction "MinimalImports" state $ useWithStale MinimalImports nfp - case mbMinImports of - -- Implement the provider logic: - -- for every import, if it's lacking a explicit list, generate a code lens - Just (MinimalImportsResult minImports, posMapping) -> do - commands <- - sequence - [ generateLens pId _uri edit - | (imp, Just minImport) <- minImports, - Just edit <- [mkExplicitEdit pred posMapping imp minImport] - ] - return $ Right $ InL $ catMaybes commands - _ -> - return $ Right $ InL [] - | otherwise = - return $ Right $ InL [] - --- | If there are any implicit imports, provide one code action to turn them all +lensProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentCodeLens +lensProvider _ state _ CodeLensParams {_textDocument = TextDocumentIdentifier {_uri}} + = pluginResponse $ do + nfp <- getNormalizedFilePath _uri + mbMinImports <- liftIO $ runAction "MinimalImports" state $ use MinimalImports nfp + case mbMinImports of + Just (MinimalImportsResult{forLens}) -> do + let lens = [ generateLens _uri range int + | (range, int) <- forLens] + pure $ InL lens + _ -> + pure $ InL [] + where generateLens :: Uri -> Range -> Int -> CodeLens + generateLens uri range int = + CodeLens { _data_ = Just $ A.toJSON $ ResolveOne uri int + , _range = range + , _command = Nothing } + +lensResolveProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_CodeLensResolve +lensResolveProvider _ ideState plId cl@(CodeLens {_data_ = Just data_@(A.fromJSON -> A.Success (ResolveOne uri uid))}) + = pluginResponse $ do + nfp <- getNormalizedFilePath uri + (MinimalImportsResult{forResolve}) <- + handleMaybeM "Unable to run Minimal Imports" + $ liftIO + $ runAction "MinimalImports" ideState $ use MinimalImports nfp + target <- handleMaybe "Unable to resolve lens" $ forResolve IM.!? uid + let updatedCodeLens = cl & L.command ?~ mkCommand plId target + pure updatedCodeLens + where mkCommand :: PluginId -> TextEdit -> Command + mkCommand pId TextEdit{_newText} = + let title = abbreviateImportTitle _newText + _arguments = Just [data_] + in mkLspCommand pId importCommandId title _arguments +lensResolveProvider _ _ _ (CodeLens {_data_ = Just (A.fromJSON -> A.Success (ResolveAll _))}) = do + pure $ Left $ ResponseError (InR ErrorCodes_InvalidParams) "Unexpected argument for lens resolve handler: ResolveAll" Nothing +lensResolveProvider _ _ _ (CodeLens {_data_ = Just (A.fromJSON @EIResolveData -> (A.Error (T.pack -> str)))}) = + pure $ Left $ ResponseError (InR ErrorCodes_ParseError) str Nothing +lensResolveProvider _ _ _ (CodeLens {_data_ = v}) = do + pure $ Left $ ResponseError (InR ErrorCodes_InvalidParams) ("Unexpected argument for lens resolve handler: " <> (T.pack $ show v)) Nothing + +-- | If there are any implicit imports, provide both one code action per import +-- to make that specific import explicit, and one code action to turn them all -- into explicit imports. -codeActionProvider :: (ModuleName -> Bool) -> PluginMethodHandler IdeState Method_TextDocumentCodeAction -codeActionProvider pred ideState _pId (CodeActionParams _ _ docId range _context) - | TextDocumentIdentifier {_uri} <- docId, - Just nfp <- uriToNormalizedFilePath $ toNormalizedUri _uri = liftIO $ - do - pm <- runIde ideState $ use GetParsedModule nfp - let insideImport = case pm of - Just ParsedModule {pm_parsed_source} - | locImports <- hsmodImports (unLoc pm_parsed_source), - rangesImports <- map getLoc locImports -> - any (within range) rangesImports - _ -> False - if not insideImport - then return (Right (InL [])) - else do - minImports <- runAction "MinimalImports" ideState $ use MinimalImports nfp - let edits = - [ e - | (imp, Just explicit) <- - maybe [] getMinimalImportsResult minImports, - Just e <- [mkExplicitEdit pred zeroMapping imp explicit] - ] - caExplicitImports = InR CodeAction {..} - _title = "Make all imports explicit" - _kind = Just CodeActionKind_QuickFix - _command = Nothing - _edit = Just WorkspaceEdit {_changes, _documentChanges, _changeAnnotations} - _changes = Just $ Map.singleton _uri edits - _documentChanges = Nothing - _diagnostics = Nothing - _isPreferred = Nothing - _disabled = Nothing - _data_ = Nothing - _changeAnnotations = Nothing - return $ Right $ InL [caExplicitImports | not (null edits)] - | otherwise = - return $ Right $ InL [] - +codeActionProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentCodeAction +codeActionProvider _ ideState _pId (CodeActionParams _ _ TextDocumentIdentifier {_uri} range _context) + = pluginResponse $ do + nfp <- getNormalizedFilePath _uri + (MinimalImportsResult{forCodeActions}) <- + handleMaybeM "Unable to run Minimal Imports" + $ liftIO + $ runAction "MinimalImports" ideState $ use MinimalImports nfp + let relevantCodeActions = filterByRange range forCodeActions + allExplicit = + [InR $ mkCodeAction "Make all imports explicit" (Just $ A.toJSON $ ResolveAll _uri) + | not $ null relevantCodeActions ] + toCodeAction uri (_, int) = + mkCodeAction "Make this import explicit" (Just $ A.toJSON $ ResolveOne uri int) + pure $ InL ((InR . toCodeAction _uri <$> relevantCodeActions) <> allExplicit) + where mkCodeAction title data_ = + CodeAction + { _title = title + , _kind = Just CodeActionKind_QuickFix + , _command = Nothing + , _edit = Nothing + , _diagnostics = Nothing + , _isPreferred = Nothing + , _disabled = Nothing + , _data_ = data_} + +codeActionResolveProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_CodeActionResolve +codeActionResolveProvider _ ideState _ ca@(CodeAction{_data_= Just (A.fromJSON -> A.Success rd)}) = + pluginResponse $ do + wedit <- resolveWTextEdit ideState rd + pure $ ca & L.edit ?~ wedit +codeActionResolveProvider _ _ _ (CodeAction{_data_= Just (A.fromJSON @EIResolveData -> A.Error (T.pack -> str))}) = + pure $ Left $ ResponseError (InR ErrorCodes_ParseError) str Nothing +codeActionResolveProvider _ _ _ (CodeAction {_data_ = v}) = do + pure $ Left $ ResponseError (InR ErrorCodes_InvalidParams) ("Unexpected argument for code action resolve handler: " <> (T.pack $ show v)) Nothing -------------------------------------------------------------------------------- +resolveWTextEdit :: IdeState -> EIResolveData -> ExceptT String (LspT Config IO) WorkspaceEdit +resolveWTextEdit ideState (ResolveOne uri int) = do + nfp <- getNormalizedFilePath uri + (MinimalImportsResult{forResolve}) <- + handleMaybeM "Unable to run Minimal Imports" + $ liftIO + $ runAction "MinimalImports" ideState $ use MinimalImports nfp + tedit <- handleMaybe "Unable to resolve text edit" $ forResolve IM.!? int + pure $ mkWorkspaceEdit uri [tedit] +resolveWTextEdit ideState (ResolveAll uri) = do + nfp <- getNormalizedFilePath uri + (MinimalImportsResult{forResolve}) <- + handleMaybeM "Unable to run Minimal Imports" + $ liftIO + $ runAction "MinimalImports" ideState $ use MinimalImports nfp + let edits = IM.elems forResolve + pure $ mkWorkspaceEdit uri edits + +mkWorkspaceEdit :: Uri -> [TextEdit] -> WorkspaceEdit +mkWorkspaceEdit uri edits = + WorkspaceEdit {_changes = Just $ Map.fromList [(uri, edits)] + , _documentChanges = Nothing + , _changeAnnotations = Nothing} + data MinimalImports = MinimalImports deriving (Show, Generic, Eq, Ord) @@ -187,13 +235,31 @@ instance NFData MinimalImports type instance RuleResult MinimalImports = MinimalImportsResult -newtype MinimalImportsResult = MinimalImportsResult - {getMinimalImportsResult :: [(LImportDecl GhcRn, Maybe T.Text)]} +data MinimalImportsResult = MinimalImportsResult + { -- |For providing the code lenses we need to have a range, and a unique id + -- that is later resolved to the new text for each import. It is stored in + -- a list, because we always need to provide all the code lens in a file. + forLens :: [(Range, Int)] + -- |For the code actions we have the same data as for the code lenses, but + -- we store it in a RangeMap, because that allows us to filter on a specific + -- range with better performance, and code actions are almost always only + -- requested for a specific range + , forCodeActions :: RM.RangeMap (Range, Int) + -- |For resolve we have an intMap where for every previously provided unique id + -- we provide a textEdit to allow our code actions or code lens to be resolved + , forResolve :: IM.IntMap TextEdit } instance Show MinimalImportsResult where show _ = "" instance NFData MinimalImportsResult where rnf = rwhnf +data EIResolveData = ResolveOne + { uri :: Uri + , importId :: Int } + | ResolveAll + { uri :: Uri } + deriving (Generic, A.ToJSON, FromJSON) + exportedModuleStrings :: ParsedModule -> [String] exportedModuleStrings ParsedModule{pm_parsed_source = L _ HsModule{..}} | Just export <- hsmodExports, @@ -201,62 +267,66 @@ exportedModuleStrings ParsedModule{pm_parsed_source = L _ HsModule{..}} = map (T.unpack . printOutputable) exports exportedModuleStrings _ = [] -minimalImportsRule :: Recorder (WithPriority Log) -> Rules () -minimalImportsRule recorder = define (cmapWithPrio LogShake recorder) $ \MinimalImports nfp -> do +minimalImportsRule :: Recorder (WithPriority Log) -> (ModuleName -> Bool) -> Rules () +minimalImportsRule recorder modFilter = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \MinimalImports nfp -> runMaybeT $ do -- Get the typechecking artifacts from the module - tmr <- use TypeCheck nfp + (tmr, tmrpm) <- MaybeT $ useWithStale TypeCheck nfp -- We also need a GHC session with all the dependencies - hsc <- use GhcSessionDeps nfp + (hsc, _) <- MaybeT $ useWithStale GhcSessionDeps nfp -- Use the GHC api to extract the "minimal" imports - (imports, mbMinImports) <- liftIO $ extractMinimalImports hsc tmr + (imports, mbMinImports) <- MaybeT $ liftIO $ extractMinimalImports hsc tmr let importsMap = Map.fromList [ (realSrcSpanStart l, printOutputable i) - | L (locA -> RealSrcSpan l _) i <- fromMaybe [] mbMinImports - , not (isImplicitPrelude i) + | L (locA -> RealSrcSpan l _) i <- mbMinImports ] res = - [ (i, Map.lookup (realSrcSpanStart l) importsMap) - | i <- imports - , RealSrcSpan l _ <- [getLoc i] + [ (newRange, minImport) + | imp@(L _ impDecl) <- imports + , not (isQualifiedImport impDecl) + , not (isExplicitImport impDecl) + , let L _ moduleName = ideclName impDecl + , modFilter moduleName + , RealSrcSpan location _ <- [getLoc imp] + , let range = realSrcSpanToRange location + , Just minImport <- [Map.lookup (realSrcSpanStart location) importsMap] + , Just newRange <- [toCurrentRange tmrpm range] ] - return ([], MinimalImportsResult res <$ mbMinImports) - where - isImplicitPrelude :: (Outputable a) => a -> Bool - isImplicitPrelude importDecl = - T.isPrefixOf implicitPreludeImportPrefix (printOutputable importDecl) - --- | This is the prefix of an implicit prelude import which should be ignored, --- when considering the minimal imports rule -implicitPreludeImportPrefix :: T.Text -implicitPreludeImportPrefix = "import (implicit) Prelude" + uniqueAndRangeAndText <- liftIO $ for res $ \rt -> do + u <- U.hashUnique <$> U.newUnique + pure (u, rt) + let rangeAndUnique = [ (r, u) | (u, (r, _)) <- uniqueAndRangeAndText ] + pure MinimalImportsResult + { forLens = rangeAndUnique + , forCodeActions = RM.fromList fst rangeAndUnique + , forResolve = IM.fromList ((\(i, (r, t)) -> (i, TextEdit r t)) <$> uniqueAndRangeAndText) } -------------------------------------------------------------------------------- -- | Use the ghc api to extract a minimal, explicit set of imports for this module extractMinimalImports :: - Maybe HscEnvEq -> - Maybe TcModuleResult -> - IO ([LImportDecl GhcRn], Maybe [LImportDecl GhcRn]) -extractMinimalImports (Just hsc) (Just TcModuleResult {..}) = do + HscEnvEq -> + TcModuleResult -> + IO (Maybe ([LImportDecl GhcRn], [LImportDecl GhcRn])) +extractMinimalImports hsc TcModuleResult {..} = runMaybeT $ do -- extract the original imports and the typechecking environment let tcEnv = tmrTypechecked (_, imports, _, _) = tmrRenamed ParsedModule {pm_parsed_source = L loc _} = tmrParsed emss = exportedModuleStrings tmrParsed - span = fromMaybe (error "expected real") $ realSpan loc + Just srcSpan <- pure $ realSpan loc -- Don't make suggestions for modules which are also exported, the user probably doesn't want this! -- See https://github.com/haskell/haskell-language-server/issues/2079 let notExportedImports = filter (notExported emss) imports -- GHC is secretly full of mutable state - gblElts <- readIORef (tcg_used_gres tcEnv) + gblElts <- liftIO $ readIORef (tcg_used_gres tcEnv) -- call findImportUsage does exactly what we need -- GHC is full of treats like this let usage = findImportUsage notExportedImports gblElts - (_, minimalImports) <- - initTcWithGbl (hscEnv hsc) tcEnv span $ getMinimalImports usage + (_, Just minimalImports) <- liftIO $ + initTcWithGbl (hscEnv hsc) tcEnv srcSpan $ getMinimalImports usage -- return both the original imports and the computed minimal ones return (imports, minimalImports) @@ -265,25 +335,17 @@ extractMinimalImports (Just hsc) (Just TcModuleResult {..}) = do notExported [] _ = True notExported exports (L _ ImportDecl{ideclName = L _ name}) = not $ any (\e -> ("module " ++ moduleNameString name) == e) exports -extractMinimalImports _ _ = return ([], Nothing) +#if !MIN_VERSION_ghc (9,0,0) + notExported _ _ = True +#endif -mkExplicitEdit :: (ModuleName -> Bool) -> PositionMapping -> LImportDecl GhcRn -> T.Text -> Maybe TextEdit -mkExplicitEdit pred posMapping (L (locA -> src) imp) explicit - -- Explicit import list case +isExplicitImport :: ImportDecl GhcRn -> Bool #if MIN_VERSION_ghc (9,5,0) - | ImportDecl {ideclImportList = Just (Exactly, _)} <- imp = +isExplicitImport ImportDecl {ideclImportList = Just (Exactly, _)} = True #else - | ImportDecl {ideclHiding = Just (False, _)} <- imp = +isExplicitImport ImportDecl {ideclHiding = Just (False, _)} = True #endif - Nothing - | not (isQualifiedImport imp), - RealSrcSpan l _ <- src, - L _ mn <- ideclName imp, - pred mn, - Just rng <- toCurrentRange posMapping $ realSrcSpanToRange l = - Just $ TextEdit rng explicit - | otherwise = - Nothing +isExplicitImport _ = False -- This number is somewhat arbitrarily chosen. Ideally the protocol would tell us these things, -- but at the moment I don't believe we know it. @@ -292,23 +354,6 @@ mkExplicitEdit pred posMapping (L (locA -> src) imp) explicit maxColumns :: Int maxColumns = 120 --- | Given an import declaration, generate a code lens unless it has an --- explicit import list or it's qualified -generateLens :: PluginId -> Uri -> TextEdit -> IO (Maybe CodeLens) -generateLens pId uri importEdit@TextEdit {_range, _newText} = do - let - title = abbreviateImportTitle _newText - -- the code lens has no extra data - _data_ = Nothing - -- an edit that replaces the whole declaration with the explicit one - edit = WorkspaceEdit (Just editsMap) Nothing Nothing - editsMap = Map.fromList [(uri, [importEdit])] - -- the command argument is simply the edit - _arguments = Just [toJSON $ ImportCommandParams edit] - -- create the command - _command = Just $ mkLspCommand pId importCommandId title _arguments - -- create and return the code lens - return $ Just CodeLens {..} -- | The title of the command is ideally the minimal explicit import decl, but -- we don't want to create a really massive code lens (and the decl can be extremely large!). @@ -332,6 +377,7 @@ abbreviateImportTitle input = numAdditionalItems = T.count "," actualSuffix + 1 -- We want to make text like this: import Foo (AImport, BImport, ... (30 items)) -- We also want it to look sensible if we end up splitting in the module name itself, + summaryText :: Int -> T.Text summaryText n = " ... (" <> fromString (show n) <> " items)" -- so we only add a trailing paren if we've split in the export list suffixText = summaryText numAdditionalItems <> if T.count "(" prefix > 0 then ")" else "" @@ -344,10 +390,6 @@ abbreviateImportTitle input = -------------------------------------------------------------------------------- --- | A helper to run ide actions -runIde :: IdeState -> Action a -> IO a -runIde = runAction "importLens" - within :: Range -> SrcSpan -> Bool -within (Range start end) span = - isInsideSrcSpan start span || isInsideSrcSpan end span +within (Range start end) srcSpan = + isInsideSrcSpan start srcSpan || isInsideSrcSpan end srcSpan diff --git a/plugins/hls-explicit-imports-plugin/test/Main.hs b/plugins/hls-explicit-imports-plugin/test/Main.hs index 6a5303ecba..d787630b7f 100644 --- a/plugins/hls-explicit-imports-plugin/test/Main.hs +++ b/plugins/hls-explicit-imports-plugin/test/Main.hs @@ -1,33 +1,40 @@ {-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} - module Main ( main ) where -import Data.Foldable (find, forM_) +import Control.Lens ((^.)) +import Data.Either.Extra +import Data.Foldable (find) +import Data.Row ((.+), (.==)) import Data.Text (Text) import qualified Data.Text as T import qualified Ide.Plugin.ExplicitImports as ExplicitImports +import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message -import System.FilePath ((<.>), ()) +import System.FilePath (()) import Test.Hls explicitImportsPlugin :: PluginTestDescriptor ExplicitImports.Log explicitImportsPlugin = mkPluginTestDescriptor ExplicitImports.descriptor "explicitImports" -longModule :: T.Text -longModule = "F" <> T.replicate 80 "o" - main :: IO () main = defaultTestRunner $ testGroup "Make imports explicit" - [ codeActionGoldenTest "UsualCase" 3 0 + [ codeActionAllGoldenTest "UsualCase" 3 0 + , codeActionAllResolveGoldenTest "UsualCase" 3 0 + , codeActionOnlyGoldenTest "OnlyThis" 3 0 + , codeActionOnlyResolveGoldenTest "OnlyThis" 3 0 , codeLensGoldenTest "UsualCase" 0 + , codeActionBreakFile "BreakFile" 4 0 + , codeActionStaleAction "StaleAction" 4 0 , testCase "No CodeAction when exported" $ runSessionWithServer explicitImportsPlugin testDataDir $ do doc <- openDoc "Exported.hs" "haskell" @@ -65,12 +72,74 @@ main = defaultTestRunner $ -- code action tests -codeActionGoldenTest :: FilePath -> Int -> Int -> TestTree -codeActionGoldenTest fp l c = goldenWithExplicitImports fp $ \doc -> do +codeActionAllGoldenTest :: FilePath -> Int -> Int -> TestTree +codeActionAllGoldenTest fp l c = goldenWithExplicitImports " code action" fp codeActionNoResolveCaps $ \doc -> do + actions <- getCodeActions doc (pointRange l c) + case find ((== Just "Make all imports explicit") . caTitle) actions of + Just (InR x) -> executeCodeAction x + _ -> liftIO $ assertFailure "Unable to find CodeAction" + +codeActionBreakFile :: FilePath -> Int -> Int -> TestTree +codeActionBreakFile fp l c = goldenWithExplicitImports " code action" fp codeActionNoResolveCaps $ \doc -> do + _ <- waitForDiagnostics + changeDoc doc [edit] actions <- getCodeActions doc (pointRange l c) case find ((== Just "Make all imports explicit") . caTitle) actions of Just (InR x) -> executeCodeAction x _ -> liftIO $ assertFailure "Unable to find CodeAction" + where edit = TextDocumentContentChangeEvent $ InL $ #range .== pointRange 2 21 + .+ #rangeLength .== Nothing + .+ #text .== "x" + +codeActionStaleAction :: FilePath -> Int -> Int -> TestTree +codeActionStaleAction fp l c = goldenWithExplicitImports " code action" fp codeActionResolveCaps $ \doc -> do + _ <- waitForDiagnostics + actions <- getCodeActions doc (pointRange l c) + changeDoc doc [edit] + _ <- waitForDiagnostics + case find ((== Just "Make this import explicit") . caTitle) actions of + Just (InR x) -> + maybeResolveCodeAction x >>= + \case Just _ -> liftIO $ assertFailure "Code action still valid" + Nothing -> pure () + _ -> liftIO $ assertFailure "Unable to find CodeAction" + where edit = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 6 0) (Position 6 0) + .+ #rangeLength .== Nothing + .+ #text .== "\ntesting = undefined" + +codeActionAllResolveGoldenTest :: FilePath -> Int -> Int -> TestTree +codeActionAllResolveGoldenTest fp l c = goldenWithExplicitImports " code action resolve" fp codeActionResolveCaps $ \doc -> do + actions <- getCodeActions doc (pointRange l c) + Just (InR x) <- pure $ find ((== Just "Make all imports explicit") . caTitle) actions + resolved <- resolveCodeAction x + executeCodeAction resolved + +codeActionOnlyGoldenTest :: FilePath -> Int -> Int -> TestTree +codeActionOnlyGoldenTest fp l c = goldenWithExplicitImports " code action" fp codeActionNoResolveCaps $ \doc -> do + actions <- getCodeActions doc (pointRange l c) + case find ((== Just "Make this import explicit") . caTitle) actions of + Just (InR x) -> executeCodeAction x + _ -> liftIO $ assertFailure "Unable to find CodeAction" + +codeActionOnlyResolveGoldenTest :: FilePath -> Int -> Int -> TestTree +codeActionOnlyResolveGoldenTest fp l c = goldenWithExplicitImports " code action resolve" fp codeActionResolveCaps $ \doc -> do + actions <- getCodeActions doc (pointRange l c) + Just (InR x) <- pure $ find ((== Just "Make this import explicit") . caTitle) actions + resolved <- resolveCodeAction x + executeCodeAction resolved + +-- TODO: use the one from lsp-test once that's released +resolveCodeAction :: CodeAction -> Session CodeAction +resolveCodeAction ca = do + resolveResponse <- request SMethod_CodeActionResolve ca + Right resolved <- pure $ resolveResponse ^. L.result + pure resolved + +maybeResolveCodeAction :: CodeAction -> Session (Maybe CodeAction) +maybeResolveCodeAction ca = do + resolveResponse <- request SMethod_CodeActionResolve ca + let resolved = resolveResponse ^. L.result + pure $ eitherToMaybe resolved caTitle :: (Command |? CodeAction) -> Maybe Text caTitle (InR CodeAction {_title}) = Just _title @@ -79,18 +148,17 @@ caTitle _ = Nothing -- code lens tests codeLensGoldenTest :: FilePath -> Int -> TestTree -codeLensGoldenTest fp codeLensIdx = goldenWithExplicitImports fp $ \doc -> do - codeLens <- (!! codeLensIdx) <$> getCodeLensesBy isExplicitImports doc - mapM_ executeCmd - [c | CodeLens{_command = Just c} <- [codeLens]] - -getCodeLensesBy :: (CodeLens -> Bool) -> TextDocumentIdentifier -> Session [CodeLens] -getCodeLensesBy f doc = filter f <$> getCodeLenses doc - -isExplicitImports :: CodeLens -> Bool -isExplicitImports (CodeLens _ (Just (Command _ cmd _)) _) - | ":explicitImports:" `T.isInfixOf` cmd = True -isExplicitImports _ = False +codeLensGoldenTest fp _ = goldenWithExplicitImports " code lens" fp codeActionNoResolveCaps $ \doc -> do + (codeLens: _) <- getCodeLenses doc + CodeLens {_command = Just c} <- resolveCodeLens codeLens + executeCmd c + +-- TODO: use the one from lsp-test once that's released +resolveCodeLens :: CodeLens -> Session CodeLens +resolveCodeLens cl = do + resolveResponse <- request SMethod_CodeLensResolve cl + Right resolved <- pure $ resolveResponse ^. L.result + pure resolved -- Execute command and wait for result executeCmd :: Command -> Session () @@ -102,8 +170,8 @@ executeCmd cmd = do -- helpers -goldenWithExplicitImports :: FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree -goldenWithExplicitImports fp = goldenWithHaskellDoc explicitImportsPlugin (fp <> " (golden)") testDataDir fp "expected" "hs" +goldenWithExplicitImports :: String -> FilePath -> ClientCapabilities -> (TextDocumentIdentifier -> Session ()) -> TestTree +goldenWithExplicitImports title fp caps = goldenWithHaskellAndCaps caps explicitImportsPlugin (fp <> title <> " (golden)") testDataDir fp "expected" "hs" testDataDir :: String testDataDir = "test" "testdata" diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/B.hs b/plugins/hls-explicit-imports-plugin/test/testdata/B.hs new file mode 100644 index 0000000000..80159dc10b --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/B.hs @@ -0,0 +1,7 @@ +module B where + +b1 :: String +b1 = "b1" + +b2 :: String +b2 = "b2" diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/BreakFile.expected.hs b/plugins/hls-explicit-imports-plugin/test/testdata/BreakFile.expected.hs new file mode 100644 index 0000000000..6ef3eeec69 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/BreakFile.expected.hs @@ -0,0 +1,6 @@ +{-# OPTIONS_GHC -Wall #-} +module BreakFile whexe + +import A ( a1 ) + +main = putStrLn $ "hello " ++ a1 diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/BreakFile.hs b/plugins/hls-explicit-imports-plugin/test/testdata/BreakFile.hs new file mode 100644 index 0000000000..2a570ae2d8 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/BreakFile.hs @@ -0,0 +1,6 @@ +{-# OPTIONS_GHC -Wall #-} +module BreakFile where + +import A + +main = putStrLn $ "hello " ++ a1 diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/OnlyThis.expected.hs b/plugins/hls-explicit-imports-plugin/test/testdata/OnlyThis.expected.hs new file mode 100644 index 0000000000..5911ee5562 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/OnlyThis.expected.hs @@ -0,0 +1,7 @@ +module OnlyThis where + +import A ( a1 ) +import B + +main :: IO () +main = putStrLn $ "hello " ++ a1 ++ b1 diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/OnlyThis.hs b/plugins/hls-explicit-imports-plugin/test/testdata/OnlyThis.hs new file mode 100644 index 0000000000..9663d1b174 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/OnlyThis.hs @@ -0,0 +1,7 @@ +module OnlyThis where + +import A +import B + +main :: IO () +main = putStrLn $ "hello " ++ a1 ++ b1 diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/StaleAction.expected.hs b/plugins/hls-explicit-imports-plugin/test/testdata/StaleAction.expected.hs new file mode 100644 index 0000000000..a345a5c91e --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/StaleAction.expected.hs @@ -0,0 +1,8 @@ +{-# OPTIONS_GHC -Wall #-} +module StaleAction where + +import A + +main = putStrLn $ "hello " ++ a1 + +testing = undefined \ No newline at end of file diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/StaleAction.hs b/plugins/hls-explicit-imports-plugin/test/testdata/StaleAction.hs new file mode 100644 index 0000000000..6d38cc62c4 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/StaleAction.hs @@ -0,0 +1,6 @@ +{-# OPTIONS_GHC -Wall #-} +module StaleAction where + +import A + +main = putStrLn $ "hello " ++ a1 diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/UsualCase.expected.hs b/plugins/hls-explicit-imports-plugin/test/testdata/UsualCase.expected.hs index 8355eafde2..ec0b512b3b 100644 --- a/plugins/hls-explicit-imports-plugin/test/testdata/UsualCase.expected.hs +++ b/plugins/hls-explicit-imports-plugin/test/testdata/UsualCase.expected.hs @@ -1,4 +1,4 @@ -module Main where +module UsualCase where import A ( a1 ) diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/UsualCase.hs b/plugins/hls-explicit-imports-plugin/test/testdata/UsualCase.hs index b5c65ba8ea..4bf33dc094 100644 --- a/plugins/hls-explicit-imports-plugin/test/testdata/UsualCase.hs +++ b/plugins/hls-explicit-imports-plugin/test/testdata/UsualCase.hs @@ -1,4 +1,4 @@ -module Main where +module UsualCase where import A diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/hie.yaml b/plugins/hls-explicit-imports-plugin/test/testdata/hie.yaml index c1a3993dc4..8d08bfb527 100644 --- a/plugins/hls-explicit-imports-plugin/test/testdata/hie.yaml +++ b/plugins/hls-explicit-imports-plugin/test/testdata/hie.yaml @@ -1,6 +1,10 @@ + cradle: direct: arguments: + - OnlyThis.hs + - StaleAction.hs - UsualCase.hs - Exported.hs - A.hs + - B.hs diff --git a/plugins/hls-refine-imports-plugin/hls-refine-imports-plugin.cabal b/plugins/hls-refine-imports-plugin/hls-refine-imports-plugin.cabal index 2145fe6a2a..2011f74b37 100644 --- a/plugins/hls-refine-imports-plugin/hls-refine-imports-plugin.cabal +++ b/plugins/hls-refine-imports-plugin/hls-refine-imports-plugin.cabal @@ -35,6 +35,7 @@ library , hls-plugin-api == 2.1.0.0 , lsp , text + , transformers , unordered-containers default-language: Haskell2010 diff --git a/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs b/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs index 39616221bb..e7dc3e0142 100644 --- a/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs +++ b/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs @@ -15,6 +15,9 @@ import Control.Arrow (Arrow (second)) import Control.DeepSeq (rwhnf) import Control.Monad (join) import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT), + runMaybeT) import Data.Aeson.Types hiding (Null) import Data.IORef (readIORef) import Data.List (intercalate) @@ -184,28 +187,28 @@ instance Show RefineImportsResult where show _ = "" instance NFData RefineImportsResult where rnf = rwhnf refineImportsRule :: Recorder (WithPriority Log) -> Rules () -refineImportsRule recorder = define (cmapWithPrio LogShake recorder) $ \RefineImports nfp -> do +refineImportsRule recorder = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \RefineImports nfp -> runMaybeT $ do -- Get the typechecking artifacts from the module - tmr <- use TypeCheck nfp + tmr <- MaybeT $ use TypeCheck nfp -- We also need a GHC session with all the dependencies - hsc <- use GhcSessionDeps nfp + hsc <- MaybeT $ use GhcSessionDeps nfp -- 2 layer map ModuleName -> ModuleName -> [Avails] (exports) import2Map <- do -- first layer is from current(editing) module to its imports - ImportMap currIm <- use_ GetImportMap nfp + ImportMap currIm <- lift $ use_ GetImportMap nfp forM currIm $ \path -> do -- second layer is from the imports of first layer to their imports - ImportMap importIm <- use_ GetImportMap path + ImportMap importIm <- lift $ use_ GetImportMap path forM importIm $ \imp_path -> do - imp_hir <- use_ GetModIface imp_path + imp_hir <- lift $ use_ GetModIface imp_path return $ mi_exports $ hirModIface imp_hir -- Use the GHC api to extract the "minimal" imports -- We shouldn't blindly refine imports -- instead we should generate imports statements -- for modules/symbols actually got used - (imports, mbMinImports) <- liftIO $ extractMinimalImports hsc tmr + (imports, mbMinImports) <- MaybeT $ liftIO $ extractMinimalImports hsc tmr let filterByImport :: LImportDecl GhcRn @@ -259,7 +262,7 @@ refineImportsRule recorder = define (cmapWithPrio LogShake recorder) $ \RefineIm . Map.toList $ filteredInnerImports) -- for every minimal imports - | Just minImports <- [mbMinImports] + | minImports <- [mbMinImports] , i@(L _ ImportDecl{ideclName = L _ mn}) <- minImports -- we check for the inner imports , Just innerImports <- [Map.lookup mn import2Map] @@ -268,7 +271,7 @@ refineImportsRule recorder = define (cmapWithPrio LogShake recorder) $ \RefineIm -- if no symbols from this modules then don't need to generate new import , not $ null filteredInnerImports ] - return ([], RefineImportsResult res <$ mbMinImports) + pure $ RefineImportsResult res where -- Check if a name is exposed by AvailInfo (the available information of a module)