Make Wingman produce user-facing error messages

plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs

@@ -19,8 +19,7 @@ import           Control.Monad
 import           Control.Monad.Trans
 import           Control.Monad.Trans.Maybe
 import           Data.Aeson
-import           Data.Bifunctor (Bifunctor (bimap))
-import           Data.Bool (bool)
+import           Data.Bifunctor (first)
 import           Data.Data (Data)
 import           Data.Foldable (for_)
 import           Data.Generics.Aliases (mkQ)
@@ -32,9 +31,7 @@ import           Data.Traversable
 import           Development.IDE.Core.Shake (IdeState (..))
 import           Development.IDE.GHC.Compat
 import           Development.IDE.GHC.ExactPrint
-import           Development.Shake.Classes
 import           Ide.Plugin.Tactic.CaseSplit
-import           Ide.Plugin.Tactic.FeatureSet (Feature (..), hasFeature)
 import           Ide.Plugin.Tactic.GHC
 import           Ide.Plugin.Tactic.LanguageServer
 import           Ide.Plugin.Tactic.LanguageServer.TacticProviders
@@ -84,41 +81,54 @@ codeActionProvider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri)
 codeActionProvider _ _ _ = pure $ Right $ List []
 
 
+showUserFacingMessage
+    :: MonadLsp cfg m
+    => UserFacingMessage
+    -> m (Either ResponseError a)
+showUserFacingMessage ufm = do
+  showLspMessage $ mkShowMessageParams ufm
+  pure $ Left $ mkErr InternalError $ T.pack $ show ufm
+
+
 tacticCmd :: (OccName -> TacticsM ()) -> CommandFunction IdeState TacticParams
 tacticCmd tac state (TacticParams uri range var_name)
   | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do
       features <- getFeatureSet $ shakeExtras state
       ccs <- getClientCapabilities
-      res <- liftIO $ fromMaybeT (Right Nothing) $ do
+      res <- liftIO $ runMaybeT $ do
         (range', jdg, ctx, dflags) <- judgementForHole state nfp range features
         let span = rangeToRealSrcSpan (fromNormalizedFilePath nfp) range'
         pm <- MaybeT $ useAnnotatedSource "tacticsCmd" state nfp
 
         timingOut 2e8 $ join $
-          bimap (mkErr InvalidRequest . T.pack . show)
-                (mkWorkspaceEdits span dflags ccs uri pm)
-            $ runTactic ctx jdg $ tac $ mkVarOcc $ T.unpack var_name
+          case runTactic ctx jdg $ tac $ mkVarOcc $ T.unpack var_name of
+            Left _ -> Left TacticErrors
+            Right rtr ->
+              case rtr_extract rtr of
+                L _ (HsVar _ (L _ rdr)) | isHole (occName rdr) ->
+                  Left NothingToDo
+                _ -> pure $ mkWorkspaceEdits span dflags ccs uri pm rtr
 
       case res of
-        Left err -> pure $ Left err
-        Right medit -> do
-          forM_ medit $ \edit ->
-            sendRequest
-              SWorkspaceApplyEdit
-              (ApplyWorkspaceEditParams Nothing edit)
-              (const $ pure ())
+        Nothing -> do
+          showUserFacingMessage TimedOut
+        Just (Left ufm) -> do
+          showUserFacingMessage ufm
+        Just (Right edit) -> do
+          sendRequest
+            SWorkspaceApplyEdit
+            (ApplyWorkspaceEditParams Nothing edit)
+            (const $ pure ())
           pure $ Right Null
 tacticCmd _ _ _ =
   pure $ Left $ mkErr InvalidRequest "Bad URI"
 
 
 timingOut
-    :: Int                     -- ^ Time in microseconds
-    -> Either ResponseError a  -- ^ Computation to run
-    -> MaybeT IO (Either ResponseError a)
-timingOut t m = do
-  x <- lift $ timeout t $ evaluate m
-  pure $ joinNote (mkErr InvalidRequest "timed out") x
+    :: Int  -- ^ Time in microseconds
+    -> a    -- ^ Computation to run
+    -> MaybeT IO a
+timingOut t m = MaybeT $ timeout t $ evaluate m
 
 
 mkErr :: ErrorCode -> T.Text -> ResponseError
@@ -140,15 +150,13 @@ mkWorkspaceEdits
     -> Uri
     -> Annotated ParsedSource
     -> RunTacticResults
-    -> Either ResponseError (Maybe WorkspaceEdit)
+    -> Either UserFacingMessage WorkspaceEdit
 mkWorkspaceEdits span dflags ccs uri pm rtr = do
   for_ (rtr_other_solns rtr) $ traceMX "other solution"
   traceMX "solution" $ rtr_extract rtr
   let g = graftHole (RealSrcSpan span) rtr
       response = transform dflags ccs uri g pm
-   in case response of
-        Right res -> Right $ Just res
-        Left err  -> Left $ mkErr InternalError $ T.pack err
+   in first (InfrastructureError . T.pack) response
 
 
 ------------------------------------------------------------------------------

plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/LanguageServer.hs

@@ -46,7 +46,7 @@ import           Ide.Plugin.Tactic.GHC
 import           Ide.Plugin.Tactic.Judgements
 import           Ide.Plugin.Tactic.Range
 import           Ide.Plugin.Tactic.Types
-import           Language.LSP.Server (MonadLsp)
+import           Language.LSP.Server (MonadLsp, sendNotification)
 import           Language.LSP.Types
 import           OccName
 import           Prelude hiding (span)
@@ -345,3 +345,18 @@ isRhsHole rss tcs = everything (||) (mkQ False $ \case
   _                                        -> False
   ) tcs
 
+
+ufmSeverity :: UserFacingMessage -> MessageType
+ufmSeverity TacticErrors            = MtError
+ufmSeverity TimedOut                = MtInfo
+ufmSeverity NothingToDo             = MtInfo
+ufmSeverity (InfrastructureError _) = MtError
+
+
+mkShowMessageParams :: UserFacingMessage -> ShowMessageParams
+mkShowMessageParams ufm = ShowMessageParams (ufmSeverity ufm) $ T.pack $ show ufm
+
+
+showLspMessage :: MonadLsp cfg m => ShowMessageParams -> m ()
+showLspMessage = sendNotification SWindowShowMessage
+

plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Types.hs

@@ -35,7 +35,8 @@ import           Data.List.NonEmpty (NonEmpty (..))
 import           Data.Maybe (fromMaybe)
 import           Data.Semigroup
 import           Data.Set (Set)
-import qualified Data.Text                    as T
+import qualified Data.Text as T
+import           Data.Text (Text)
 import           Data.Tree
 import           Development.IDE.GHC.Compat hiding (Node)
 import           Development.IDE.GHC.Orphans ()
@@ -44,7 +45,6 @@ import           GHC.Generics
 import           GHC.SourceGen (var)
 import           Ide.Plugin.Tactic.Debug
 import           Ide.Plugin.Tactic.FeatureSet
-import           Ide.Plugin.Tactic.FeatureSet (FeatureSet)
 import           OccName
 import           Refinery.Tactic
 import           System.IO.Unsafe (unsafePerformIO)
@@ -452,3 +452,17 @@ data AgdaMatch = AgdaMatch
   }
   deriving (Show)
 
+
+data UserFacingMessage
+  = TacticErrors
+  | TimedOut
+  | NothingToDo
+  | InfrastructureError Text
+  deriving Eq
+
+instance Show UserFacingMessage where
+  show TacticErrors            = "Wingman couldn't find a solution"
+  show TimedOut                = "Wingman timed out while trying to find a solution"
+  show NothingToDo             = "Nothing to do"
+  show (InfrastructureError t) = "Internal error: " <> T.unpack t
+

plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs

@@ -10,13 +10,14 @@ module CodeAction.AutoSpec where
 import Ide.Plugin.Tactic.Types
 import Test.Hspec
 import Utils
+import Ide.Plugin.Tactic.FeatureSet (allFeatures)
 
 
 spec :: Spec
 spec = do
   let autoTest = goldenTest Auto ""
 
-  describe "golden tests" $ do
+  describe "golden" $ do
     autoTest 11  8 "AutoSplitGADT.hs"
     autoTest  2 11 "GoldenEitherAuto.hs"
     autoTest  4 12 "GoldenJoinCont.hs"
@@ -53,3 +54,7 @@ spec = do
     failing "not enough auto gas" $
       autoTest 5 18 "GoldenFish.hs"
 
+
+  describe "messages" $ do
+    mkShowMessageTest allFeatures Auto "" 2 8 "MessageForallA.hs" TacticErrors
+

plugins/hls-tactics-plugin/test/CodeAction/RefineSpec.hs

@@ -10,6 +10,7 @@ module CodeAction.RefineSpec where
 import Ide.Plugin.Tactic.Types
 import Test.Hspec
 import Utils
+import Ide.Plugin.Tactic.FeatureSet (allFeatures)
 
 
 spec :: Spec
@@ -22,3 +23,6 @@ spec = do
     refineTest 4 8 "RefineReader.hs"
     refineTest 8 8 "RefineGADT.hs"
 
+  describe "messages" $ do
+    mkShowMessageTest allFeatures Refine "" 2 8 "MessageForallA.hs" NothingToDo
+

plugins/hls-tactics-plugin/test/Utils.hs

@@ -20,6 +20,7 @@ import           Data.Text (Text)
 import qualified Data.Text.IO as T
 import qualified Ide.Plugin.Config as Plugin
 import           Ide.Plugin.Tactic.FeatureSet (FeatureSet, allFeatures)
+import           Ide.Plugin.Tactic.LanguageServer (mkShowMessageParams)
 import           Ide.Plugin.Tactic.Types
 import           Language.LSP.Test
 import           Language.LSP.Types
@@ -118,6 +119,29 @@ mkGoldenTest features tc occ line col input =
       expected <- liftIO $ T.readFile expected_name
       liftIO $ edited `shouldBe` expected
 
+mkShowMessageTest
+    :: FeatureSet
+    -> TacticCommand
+    -> Text
+    -> Int
+    -> Int
+    -> FilePath
+    -> UserFacingMessage
+    -> SpecWith ()
+mkShowMessageTest features tc occ line col input ufm =
+  it (input <> " (golden)") $ do
+    runSession testCommand fullCaps tacticPath $ do
+      setFeatureSet features
+      doc <- openDoc input "haskell"
+      _ <- waitForDiagnostics
+      actions <- getCodeActions doc $ pointRange line col
+      Just (InR CodeAction {_command = Just c})
+        <- pure $ find ((== Just (tacticTitle tc occ)) . codeActionTitle) actions
+      executeCommand c
+      NotificationMessage _ _ err <- skipManyTill anyMessage (message SWindowShowMessage)
+      liftIO $ err `shouldBe` mkShowMessageParams ufm
+
+
 goldenTest :: TacticCommand -> Text -> Int -> Int -> FilePath -> SpecWith ()
 goldenTest = mkGoldenTest allFeatures
 

plugins/hls-tactics-plugin/test/golden/MessageForallA.hs

@@ -0,0 +1,2 @@
+test :: a
+test = _