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

Author: serras

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,25 +179,39 @@ 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
 unDefer (Reason Opt_WarnTypedHoles                 , fd) = upgradeWarningToError fd
 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}

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 =

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