git.iko.soy/ghcide
on master help sign in
Enhancements to top-level signatures (#232)

* Try adding a dependency on TypeCheck * Show warning regardless of the status of -Wall * Try diagnostics after type checking, again * Use `useE` instead of `use_` to not get a `BadDependency` error * Degrade information about signatures if not present in user options * Fix tests * Better suggested signatures for polymorphic bindings * Remove old comment

commit4440a263808e17ae4532f02a40b433b7af524403 authorAlejandro Serrano <trupill@gmail.com> dateMon 16 Dec 2019, 16:21 (7 years ago) parent8ea5d69
3 files changed+61−14
compare with master
unifiedsplit
src/Development/IDE/Core/Compile.hs+30−7 src/Development/IDE/LSP/CodeAction.hs+26−7 test/exe/Main.hs+5
src/Development/IDE/Core/Compile.hs+30−7
@@ -102,11 +102,20 @@ typecheckModule (IdeDefer defer) packageState deps pm =
102102 catchSrcErrors "typecheck" $ do
103103 setupEnv deps
104104 let modSummary = pm_mod_summary pm
105+ dflags = ms_hspp_opts modSummary
105106 modSummary' <- initPlugins modSummary
106107 (warnings, tcm) <- withWarnings "typecheck" $ \tweak ->
107− GHC.typecheckModule $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}
108+ GHC.typecheckModule $ enableTopLevelWarnings
109+ $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}
108110 tcm2 <- mkTcModuleResult tcm
109− return (map unDefer warnings, tcm2)
111+ let errorPipeline = unDefer
112+ . (if wopt Opt_WarnMissingSignatures dflags
113+ then id
114+ else degradeError Opt_WarnMissingSignatures)
115+ . (if wopt Opt_WarnMissingLocalSignatures dflags
116+ then id
117+ else degradeError Opt_WarnMissingLocalSignatures)
118+ return (map errorPipeline warnings, tcm2)
110119
111120initPlugins :: GhcMonad m => ModSummary -> m ModSummary
112121initPlugins modSummary = do
@@ -170,12 +179,17 @@ demoteTypeErrorsToWarnings =
170179 . (`gopt_set` Opt_DeferTypedHoles)
171180 . (`gopt_set` Opt_DeferOutOfScopeVariables)
172181
173− update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary
174− update_hspp_opts up ms = ms{ms_hspp_opts = up $ ms_hspp_opts ms}
182+enableTopLevelWarnings :: ParsedModule -> ParsedModule
183+enableTopLevelWarnings =
184+ (update_pm_mod_summary . update_hspp_opts)
185+ ((`wopt_set` Opt_WarnMissingSignatures) . (`wopt_set` Opt_WarnMissingLocalSignatures))
175186
176− update_pm_mod_summary :: (ModSummary -> ModSummary) -> ParsedModule -> ParsedModule
177− update_pm_mod_summary up pm =
178− pm{pm_mod_summary = up $ pm_mod_summary pm}
187+update_hspp_opts :: (DynFlags -> DynFlags) -> ModSummary -> ModSummary
188+update_hspp_opts up ms = ms{ms_hspp_opts = up $ ms_hspp_opts ms}
189+
190+update_pm_mod_summary :: (ModSummary -> ModSummary) -> ParsedModule -> ParsedModule
191+update_pm_mod_summary up pm =
192+ pm{pm_mod_summary = up $ pm_mod_summary pm}
179193
180194unDefer :: (WarnReason, FileDiagnostic) -> FileDiagnostic
181195unDefer (Reason Opt_WarnDeferredTypeErrors , fd) = upgradeWarningToError fd
@@ -183,12 +197,21 @@ unDefer (Reason Opt_WarnTypedHoles , fd) = upgradeWarningToError
183197unDefer (Reason Opt_WarnDeferredOutOfScopeVariables, fd) = upgradeWarningToError fd
184198unDefer ( _ , fd) = fd
185199
200+degradeError :: WarningFlag -> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)
201+degradeError f (Reason f', fd)
202+ | f == f' = (Reason f', degradeWarningToError fd)
203+degradeError _ wfd = wfd
204+
186205upgradeWarningToError :: FileDiagnostic -> FileDiagnostic
187206upgradeWarningToError (nfp, fd) =
188207 (nfp, fd{_severity = Just DsError, _message = warn2err $ _message fd}) where
189208 warn2err :: T.Text -> T.Text
190209 warn2err = T.intercalate ": error:" . T.splitOn ": warning:"
191210
211+degradeWarningToError :: FileDiagnostic -> FileDiagnostic
212+degradeWarningToError (nfp, fd) =
213+ (nfp, fd{_severity = Just DsInfo})
214+
192215addRelativeImport :: NormalizedFilePath -> ParsedModule -> DynFlags -> DynFlags
193216addRelativeImport fp modu dflags = dflags
194217 {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags}
src/Development/IDE/LSP/CodeAction.hs+26−7
@@ -14,6 +14,7 @@ module Development.IDE.LSP.CodeAction
1414import Language.Haskell.LSP.Types
1515import Development.IDE.GHC.Compat
1616import Development.IDE.Core.Rules
17+import Development.IDE.Core.RuleTypes
1718import Development.IDE.Core.Shake
1819import Development.IDE.LSP.Server
1920import Development.IDE.Types.Location
@@ -24,6 +25,7 @@ import Language.Haskell.LSP.VFS
2425import Language.Haskell.LSP.Messages
2526import qualified Data.Rope.UTF16 as Rope
2627import Data.Aeson.Types (toJSON, fromJSON, Value(..), Result(..))
28+import Control.Monad.Trans.Maybe
2729import Data.Char
2830import Data.Maybe
2931import Data.List.Extra
@@ -53,19 +55,20 @@ codeLens
5355 -> CodeLensParams
5456 -> IO (List CodeLens)
5557codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do
56− diag <- getDiagnostics ideState
5758 case uriToFilePath' uri of
5859 Just (toNormalizedFilePath -> filePath) -> do
60+ _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath
61+ diag <- getDiagnostics ideState
5962 pure $ List
6063 [ CodeLens _range (Just (Command title "typesignature.add" (Just $ List [toJSON edit]))) Nothing
6164 | (dFile, dDiag@Diagnostic{_range=_range@Range{..},..}) <- diag
6265 , dFile == filePath
63− , (title, tedit) <- suggestTopLevelBinding False dDiag
66+ , (title, tedit) <- suggestSignature False dDiag
6467 , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
6568 ]
6669 Nothing -> pure $ List []
6770
68−-- | Generate code lenses.
71+-- | Execute the "typesignature.add" command.
6972executeAddSignatureCommand
7073 :: LSP.LspFuncs ()
7174 -> IdeState
@@ -177,12 +180,12 @@ suggestAction contents diag@Diagnostic{_range=_range@Range{..},..}
177180 extractFitNames = map (T.strip . head . T.splitOn " :: ")
178181 in map proposeHoleFit $ nubOrd $ findSuggestedHoleFits _message
179182
180− | tlb@[_] <- suggestTopLevelBinding True diag = tlb
183+ | tlb@[_] <- suggestSignature True diag = tlb
181184
182185suggestAction _ _ = []
183186
184−suggestTopLevelBinding :: Bool -> Diagnostic -> [(T.Text, [TextEdit])]
185−suggestTopLevelBinding isQuickFix Diagnostic{_range=_range@Range{..},..}
187+suggestSignature :: Bool -> Diagnostic -> [(T.Text, [TextEdit])]
188+suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..}
186189 | "Top-level binding with no type signature" `T.isInfixOf` _message = let
187190 filterNewlines = T.concat . T.lines
188191 unifySpaces = T.unwords . T.words
@@ -192,7 +195,23 @@ suggestTopLevelBinding isQuickFix Diagnostic{_range=_range@Range{..},..}
192195 title = if isQuickFix then "add signature: " <> signature else signature
193196 action = TextEdit beforeLine $ signature <> "\n"
194197 in [(title, [action])]
195−suggestTopLevelBinding _ _ = []
198+suggestSignature isQuickFix Diagnostic{_range=_range@Range{..},..}
199+ | "Polymorphic local binding with no type signature" `T.isInfixOf` _message = let
200+ filterNewlines = T.concat . T.lines
201+ unifySpaces = T.unwords . T.words
202+ signature = removeInitialForAll
203+ $ T.takeWhile (\x -> x/='*' && x/='•')
204+ $ T.strip $ unifySpaces $ last $ T.splitOn "type signature: " $ filterNewlines _message
205+ startOfLine = Position (_line _start) (_character _start)
206+ beforeLine = Range startOfLine startOfLine
207+ title = if isQuickFix then "add signature: " <> signature else signature
208+ action = TextEdit beforeLine $ signature <> "\n" <> T.replicate (_character _start) " "
209+ in [(title, [action])]
210+ where removeInitialForAll :: T.Text -> T.Text
211+ removeInitialForAll (T.breakOnEnd " :: " -> (nm, ty))
212+ | "forall" `T.isPrefixOf` ty = nm <> T.drop 2 (snd (T.breakOn "." ty))
213+ | otherwise = nm <> ty
214+suggestSignature _ _ = []
196215
197216topOfHoleFitsMarker :: T.Text
198217topOfHoleFitsMarker =
test/exe/Main.hs+5
@@ -299,6 +299,7 @@ diagnosticTests = testGroup "diagnostics"
299299 , testSessionWait "package imports" $ do
300300 let thisDataListContent = T.unlines
301301 [ "module Data.List where"
302+ , "x :: Integer"
302303 , "x = 123"
303304 ]
304305 let mainContent = T.unlines
@@ -541,6 +542,7 @@ removeImportTests = testGroup "remove import actions"
541542 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
542543 , "module ModuleB where"
543544 , "import ModuleA"
545+ , "stuffB :: Integer"
544546 , "stuffB = 123"
545547 ]
546548 docB <- openDoc' "ModuleB.hs" "haskell" contentB
@@ -553,6 +555,7 @@ removeImportTests = testGroup "remove import actions"
553555 let expectedContentAfterAction = T.unlines
554556 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
555557 , "module ModuleB where"
558+ , "stuffB :: Integer"
556559 , "stuffB = 123"
557560 ]
558561 liftIO $ expectedContentAfterAction @=? contentAfterAction
@@ -565,6 +568,7 @@ removeImportTests = testGroup "remove import actions"
565568 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
566569 , "module ModuleB where"
567570 , "import qualified ModuleA"
571+ , "stuffB :: Integer"
568572 , "stuffB = 123"
569573 ]
570574 docB <- openDoc' "ModuleB.hs" "haskell" contentB
@@ -577,6 +581,7 @@ removeImportTests = testGroup "remove import actions"
577581 let expectedContentAfterAction = T.unlines
578582 [ "{-# OPTIONS_GHC -Wunused-imports #-}"
579583 , "module ModuleB where"
584+ , "stuffB :: Integer"
580585 , "stuffB = 123"
581586 ]
582587 liftIO $ expectedContentAfterAction @=? contentAfterAction