diff --git a/src/Development/IDE/Core/Compile.hs b/src/Development/IDE/Core/Compile.hs index dbe4e82bd8..7cf5a82d05 100644 --- a/src/Development/IDE/Core/Compile.hs +++ b/src/Development/IDE/Core/Compile.hs @@ -102,11 +102,20 @@ typecheckModule (IdeDefer defer) packageState deps pm = catchSrcErrors "typecheck" $ do setupEnv deps let modSummary = pm_mod_summary pm + dflags = ms_hspp_opts modSummary modSummary' <- initPlugins modSummary (warnings, tcm) <- withWarnings "typecheck" $ \tweak -> - GHC.typecheckModule $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'} + GHC.typecheckModule $ enableTopLevelWarnings + $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'} tcm2 <- mkTcModuleResult tcm - return (map unDefer warnings, tcm2) + let errorPipeline = unDefer + . (if wopt Opt_WarnMissingSignatures dflags + then id + else degradeError Opt_WarnMissingSignatures) + . (if wopt Opt_WarnMissingLocalSignatures dflags + then id + else degradeError Opt_WarnMissingLocalSignatures) + return (map errorPipeline warnings, tcm2) initPlugins :: GhcMonad m => ModSummary -> m ModSummary initPlugins modSummary = do @@ -170,12 +179,17 @@ demoteTypeErrorsToWarnings = . (`gopt_set` Opt_DeferTypedHoles) . (`gopt_set` Opt_DeferOutOfScopeVariables) - update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary - update_hspp_opts up ms = ms{ms_hspp_opts = up $ ms_hspp_opts ms} +enableTopLevelWarnings :: ParsedModule -> ParsedModule +enableTopLevelWarnings = + (update_pm_mod_summary . update_hspp_opts) + ((`wopt_set` Opt_WarnMissingSignatures) . (`wopt_set` Opt_WarnMissingLocalSignatures)) - update_pm_mod_summary :: (ModSummary -> ModSummary) -> ParsedModule -> ParsedModule - update_pm_mod_summary up pm = - pm{pm_mod_summary = up $ pm_mod_summary pm} +update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary +update_hspp_opts up ms = ms{ms_hspp_opts = up $ ms_hspp_opts ms} + +update_pm_mod_summary :: (ModSummary -> ModSummary) -> ParsedModule -> ParsedModule +update_pm_mod_summary up pm = + pm{pm_mod_summary = up $ pm_mod_summary pm} unDefer :: (WarnReason, FileDiagnostic) -> FileDiagnostic unDefer (Reason Opt_WarnDeferredTypeErrors , fd) = upgradeWarningToError fd @@ -183,12 +197,21 @@ unDefer (Reason Opt_WarnTypedHoles , fd) = upgradeWarningToError unDefer (Reason Opt_WarnDeferredOutOfScopeVariables, fd) = upgradeWarningToError fd unDefer ( _ , fd) = fd +degradeError :: WarningFlag -> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic) +degradeError f (Reason f', fd) + | f == f' = (Reason f', degradeWarningToError fd) +degradeError _ wfd = wfd + upgradeWarningToError :: FileDiagnostic -> FileDiagnostic upgradeWarningToError (nfp, fd) = (nfp, fd{_severity = Just DsError, _message = warn2err $ _message fd}) where warn2err :: T.Text -> T.Text warn2err = T.intercalate ": error:" . T.splitOn ": warning:" +degradeWarningToError :: FileDiagnostic -> FileDiagnostic +degradeWarningToError (nfp, fd) = + (nfp, fd{_severity = Just DsInfo}) + addRelativeImport :: NormalizedFilePath -> ParsedModule -> DynFlags -> DynFlags addRelativeImport fp modu dflags = dflags {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags} diff --git a/src/Development/IDE/LSP/CodeAction.hs b/src/Development/IDE/LSP/CodeAction.hs index 0ffed42a58..07afa539ab 100644 --- a/src/Development/IDE/LSP/CodeAction.hs +++ b/src/Development/IDE/LSP/CodeAction.hs @@ -14,6 +14,7 @@ module Development.IDE.LSP.CodeAction import Language.Haskell.LSP.Types import Development.IDE.GHC.Compat import Development.IDE.Core.Rules +import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake import Development.IDE.LSP.Server import Development.IDE.Types.Location @@ -24,6 +25,7 @@ import Language.Haskell.LSP.VFS import Language.Haskell.LSP.Messages import qualified Data.Rope.UTF16 as Rope import Data.Aeson.Types (toJSON, fromJSON, Value(..), Result(..)) +import Control.Monad.Trans.Maybe import Data.Char import Data.Maybe import Data.List.Extra @@ -53,19 +55,20 @@ codeLens -> CodeLensParams -> IO (List CodeLens) codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do - diag <- getDiagnostics ideState case uriToFilePath' uri of Just (toNormalizedFilePath -> filePath) -> do + _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath + diag <- getDiagnostics ideState pure $ List [ CodeLens _range (Just (Command title "typesignature.add" (Just $ List [toJSON edit]))) Nothing | (dFile, dDiag@Diagnostic{_range=_range@Range{..},..}) <- diag , dFile == filePath - , (title, tedit) <- suggestTopLevelBinding False dDiag + , (title, tedit) <- suggestSignature False dDiag , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing ] Nothing -> pure $ List [] --- | Generate code lenses. +-- | Execute the "typesignature.add" command. executeAddSignatureCommand :: LSP.LspFuncs () -> IdeState @@ -177,12 +180,12 @@ suggestAction contents diag@Diagnostic{_range=_range@Range{..},..} extractFitNames = map (T.strip . head . T.splitOn " :: ") in map proposeHoleFit $ nubOrd $ findSuggestedHoleFits _message - | tlb@[_] <- suggestTopLevelBinding True diag = tlb + | tlb@[_] <- suggestSignature True diag = tlb suggestAction _ _ = [] -suggestTopLevelBinding :: Bool -> Diagnostic -> [(T.Text, [TextEdit])] -suggestTopLevelBinding isQuickFix Diagnostic{_range=_range@Range{..},..} +suggestSignature :: Bool -> Diagnostic -> [(T.Text, [TextEdit])] +suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..} | "Top-level binding with no type signature" `T.isInfixOf` _message = let filterNewlines = T.concat . T.lines unifySpaces = T.unwords . T.words @@ -192,7 +195,23 @@ suggestTopLevelBinding isQuickFix Diagnostic{_range=_range@Range{..},..} title = if isQuickFix then "add signature: " <> signature else signature action = TextEdit beforeLine $ signature <> "\n" in [(title, [action])] -suggestTopLevelBinding _ _ = [] +suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..} + | "Polymorphic local binding with no type signature" `T.isInfixOf` _message = let + filterNewlines = T.concat . T.lines + unifySpaces = T.unwords . T.words + signature = removeInitialForAll + $ T.takeWhile (\x -> x/='*' && x/='•') + $ T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message + startOfLine = Position (_line _start) (_character _start) + beforeLine = Range startOfLine startOfLine + title = if isQuickFix then "add signature: " <> signature else signature + action = TextEdit beforeLine $ signature <> "\n" <> T.replicate (_character _start) " " + in [(title, [action])] + where removeInitialForAll :: T.Text -> T.Text + removeInitialForAll (T.breakOnEnd " :: " -> (nm, ty)) + | "forall" `T.isPrefixOf` ty = nm <> T.drop 2 (snd (T.breakOn "." ty)) + | otherwise = nm <> ty +suggestSignature _ _ = [] topOfHoleFitsMarker :: T.Text topOfHoleFitsMarker = diff --git a/test/exe/Main.hs b/test/exe/Main.hs index 9729b819dd..fd52cfe4b7 100644 --- a/test/exe/Main.hs +++ b/test/exe/Main.hs @@ -299,6 +299,7 @@ diagnosticTests = testGroup "diagnostics" , testSessionWait "package imports" $ do let thisDataListContent = T.unlines [ "module Data.List where" + , "x :: Integer" , "x = 123" ] let mainContent = T.unlines @@ -541,6 +542,7 @@ removeImportTests = testGroup "remove import actions" [ "{-# OPTIONS_GHC -Wunused-imports #-}" , "module ModuleB where" , "import ModuleA" + , "stuffB :: Integer" , "stuffB = 123" ] docB <- openDoc' "ModuleB.hs" "haskell" contentB @@ -553,6 +555,7 @@ removeImportTests = testGroup "remove import actions" let expectedContentAfterAction = T.unlines [ "{-# OPTIONS_GHC -Wunused-imports #-}" , "module ModuleB where" + , "stuffB :: Integer" , "stuffB = 123" ] liftIO $ expectedContentAfterAction @=? contentAfterAction @@ -565,6 +568,7 @@ removeImportTests = testGroup "remove import actions" [ "{-# OPTIONS_GHC -Wunused-imports #-}" , "module ModuleB where" , "import qualified ModuleA" + , "stuffB :: Integer" , "stuffB = 123" ] docB <- openDoc' "ModuleB.hs" "haskell" contentB @@ -577,6 +581,7 @@ removeImportTests = testGroup "remove import actions" let expectedContentAfterAction = T.unlines [ "{-# OPTIONS_GHC -Wunused-imports #-}" , "module ModuleB where" + , "stuffB :: Integer" , "stuffB = 123" ] liftIO $ expectedContentAfterAction @=? contentAfterAction