Skip to content

Commit 848067b

Browse files
isovectormergify[bot]
isovector
and
mergify[bot]
authored
Make Wingman produce user-facing error messages (#1502)
* Make Wingman produce user-facing error messages * Add a few tests to check the notifications come up Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com>
1 parent d517659 commit 848067b

File tree

7 files changed

+101
-29
lines changed

7 files changed

+101
-29
lines changed

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

Lines changed: 33 additions & 25 deletions
Original file line numberDiff line numberDiff line change
@@ -19,8 +19,7 @@ import Control.Monad
1919
import Control.Monad.Trans
2020
import Control.Monad.Trans.Maybe
2121
import Data.Aeson
22-
import Data.Bifunctor (Bifunctor (bimap))
23-
import Data.Bool (bool)
22+
import Data.Bifunctor (first)
2423
import Data.Data (Data)
2524
import Data.Foldable (for_)
2625
import Data.Generics.Aliases (mkQ)
@@ -32,9 +31,7 @@ import Data.Traversable
3231
import Development.IDE.Core.Shake (IdeState (..))
3332
import Development.IDE.GHC.Compat
3433
import Development.IDE.GHC.ExactPrint
35-
import Development.Shake.Classes
3634
import Ide.Plugin.Tactic.CaseSplit
37-
import Ide.Plugin.Tactic.FeatureSet (Feature (..), hasFeature)
3835
import Ide.Plugin.Tactic.GHC
3936
import Ide.Plugin.Tactic.LanguageServer
4037
import Ide.Plugin.Tactic.LanguageServer.TacticProviders
@@ -84,41 +81,54 @@ codeActionProvider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri)
8481
codeActionProvider _ _ _ = pure $ Right $ List []
8582

8683

84+
showUserFacingMessage
85+
:: MonadLsp cfg m
86+
=> UserFacingMessage
87+
-> m (Either ResponseError a)
88+
showUserFacingMessage ufm = do
89+
showLspMessage $ mkShowMessageParams ufm
90+
pure $ Left $ mkErr InternalError $ T.pack $ show ufm
91+
92+
8793
tacticCmd :: (OccName -> TacticsM ()) -> CommandFunction IdeState TacticParams
8894
tacticCmd tac state (TacticParams uri range var_name)
8995
| Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do
9096
features <- getFeatureSet $ shakeExtras state
9197
ccs <- getClientCapabilities
92-
res <- liftIO $ fromMaybeT (Right Nothing) $ do
98+
res <- liftIO $ runMaybeT $ do
9399
(range', jdg, ctx, dflags) <- judgementForHole state nfp range features
94100
let span = rangeToRealSrcSpan (fromNormalizedFilePath nfp) range'
95101
pm <- MaybeT $ useAnnotatedSource "tacticsCmd" state nfp
96102

97103
timingOut 2e8 $ join $
98-
bimap (mkErr InvalidRequest . T.pack . show)
99-
(mkWorkspaceEdits span dflags ccs uri pm)
100-
$ runTactic ctx jdg $ tac $ mkVarOcc $ T.unpack var_name
104+
case runTactic ctx jdg $ tac $ mkVarOcc $ T.unpack var_name of
105+
Left _ -> Left TacticErrors
106+
Right rtr ->
107+
case rtr_extract rtr of
108+
L _ (HsVar _ (L _ rdr)) | isHole (occName rdr) ->
109+
Left NothingToDo
110+
_ -> pure $ mkWorkspaceEdits span dflags ccs uri pm rtr
101111

102112
case res of
103-
Left err -> pure $ Left err
104-
Right medit -> do
105-
forM_ medit $ \edit ->
106-
sendRequest
107-
SWorkspaceApplyEdit
108-
(ApplyWorkspaceEditParams Nothing edit)
109-
(const $ pure ())
113+
Nothing -> do
114+
showUserFacingMessage TimedOut
115+
Just (Left ufm) -> do
116+
showUserFacingMessage ufm
117+
Just (Right edit) -> do
118+
sendRequest
119+
SWorkspaceApplyEdit
120+
(ApplyWorkspaceEditParams Nothing edit)
121+
(const $ pure ())
110122
pure $ Right Null
111123
tacticCmd _ _ _ =
112124
pure $ Left $ mkErr InvalidRequest "Bad URI"
113125

114126

115127
timingOut
116-
:: Int -- ^ Time in microseconds
117-
-> Either ResponseError a -- ^ Computation to run
118-
-> MaybeT IO (Either ResponseError a)
119-
timingOut t m = do
120-
x <- lift $ timeout t $ evaluate m
121-
pure $ joinNote (mkErr InvalidRequest "timed out") x
128+
:: Int -- ^ Time in microseconds
129+
-> a -- ^ Computation to run
130+
-> MaybeT IO a
131+
timingOut t m = MaybeT $ timeout t $ evaluate m
122132

123133

124134
mkErr :: ErrorCode -> T.Text -> ResponseError
@@ -140,15 +150,13 @@ mkWorkspaceEdits
140150
-> Uri
141151
-> Annotated ParsedSource
142152
-> RunTacticResults
143-
-> Either ResponseError (Maybe WorkspaceEdit)
153+
-> Either UserFacingMessage WorkspaceEdit
144154
mkWorkspaceEdits span dflags ccs uri pm rtr = do
145155
for_ (rtr_other_solns rtr) $ traceMX "other solution"
146156
traceMX "solution" $ rtr_extract rtr
147157
let g = graftHole (RealSrcSpan span) rtr
148158
response = transform dflags ccs uri g pm
149-
in case response of
150-
Right res -> Right $ Just res
151-
Left err -> Left $ mkErr InternalError $ T.pack err
159+
in first (InfrastructureError . T.pack) response
152160

153161

154162
------------------------------------------------------------------------------

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

Lines changed: 16 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -46,7 +46,7 @@ import Ide.Plugin.Tactic.GHC
4646
import Ide.Plugin.Tactic.Judgements
4747
import Ide.Plugin.Tactic.Range
4848
import Ide.Plugin.Tactic.Types
49-
import Language.LSP.Server (MonadLsp)
49+
import Language.LSP.Server (MonadLsp, sendNotification)
5050
import Language.LSP.Types
5151
import OccName
5252
import Prelude hiding (span)
@@ -345,3 +345,18 @@ isRhsHole rss tcs = everything (||) (mkQ False $ \case
345345
_ -> False
346346
) tcs
347347

348+
349+
ufmSeverity :: UserFacingMessage -> MessageType
350+
ufmSeverity TacticErrors = MtError
351+
ufmSeverity TimedOut = MtInfo
352+
ufmSeverity NothingToDo = MtInfo
353+
ufmSeverity (InfrastructureError _) = MtError
354+
355+
356+
mkShowMessageParams :: UserFacingMessage -> ShowMessageParams
357+
mkShowMessageParams ufm = ShowMessageParams (ufmSeverity ufm) $ T.pack $ show ufm
358+
359+
360+
showLspMessage :: MonadLsp cfg m => ShowMessageParams -> m ()
361+
showLspMessage = sendNotification SWindowShowMessage
362+

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

Lines changed: 16 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -35,7 +35,8 @@ import Data.List.NonEmpty (NonEmpty (..))
3535
import Data.Maybe (fromMaybe)
3636
import Data.Semigroup
3737
import Data.Set (Set)
38-
import qualified Data.Text as T
38+
import qualified Data.Text as T
39+
import Data.Text (Text)
3940
import Data.Tree
4041
import Development.IDE.GHC.Compat hiding (Node)
4142
import Development.IDE.GHC.Orphans ()
@@ -44,7 +45,6 @@ import GHC.Generics
4445
import GHC.SourceGen (var)
4546
import Ide.Plugin.Tactic.Debug
4647
import Ide.Plugin.Tactic.FeatureSet
47-
import Ide.Plugin.Tactic.FeatureSet (FeatureSet)
4848
import OccName
4949
import Refinery.Tactic
5050
import System.IO.Unsafe (unsafePerformIO)
@@ -452,3 +452,17 @@ data AgdaMatch = AgdaMatch
452452
}
453453
deriving (Show)
454454

455+
456+
data UserFacingMessage
457+
= TacticErrors
458+
| TimedOut
459+
| NothingToDo
460+
| InfrastructureError Text
461+
deriving Eq
462+
463+
instance Show UserFacingMessage where
464+
show TacticErrors = "Wingman couldn't find a solution"
465+
show TimedOut = "Wingman timed out while trying to find a solution"
466+
show NothingToDo = "Nothing to do"
467+
show (InfrastructureError t) = "Internal error: " <> T.unpack t
468+

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

Lines changed: 6 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -10,13 +10,14 @@ module CodeAction.AutoSpec where
1010
import Ide.Plugin.Tactic.Types
1111
import Test.Hspec
1212
import Utils
13+
import Ide.Plugin.Tactic.FeatureSet (allFeatures)
1314

1415

1516
spec :: Spec
1617
spec = do
1718
let autoTest = goldenTest Auto ""
1819

19-
describe "golden tests" $ do
20+
describe "golden" $ do
2021
autoTest 11 8 "AutoSplitGADT.hs"
2122
autoTest 2 11 "GoldenEitherAuto.hs"
2223
autoTest 4 12 "GoldenJoinCont.hs"
@@ -53,3 +54,7 @@ spec = do
5354
failing "not enough auto gas" $
5455
autoTest 5 18 "GoldenFish.hs"
5556

57+
58+
describe "messages" $ do
59+
mkShowMessageTest allFeatures Auto "" 2 8 "MessageForallA.hs" TacticErrors
60+

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

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -10,6 +10,7 @@ module CodeAction.RefineSpec where
1010
import Ide.Plugin.Tactic.Types
1111
import Test.Hspec
1212
import Utils
13+
import Ide.Plugin.Tactic.FeatureSet (allFeatures)
1314

1415

1516
spec :: Spec
@@ -22,3 +23,6 @@ spec = do
2223
refineTest 4 8 "RefineReader.hs"
2324
refineTest 8 8 "RefineGADT.hs"
2425

26+
describe "messages" $ do
27+
mkShowMessageTest allFeatures Refine "" 2 8 "MessageForallA.hs" NothingToDo
28+

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

Lines changed: 24 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -20,6 +20,7 @@ import Data.Text (Text)
2020
import qualified Data.Text.IO as T
2121
import qualified Ide.Plugin.Config as Plugin
2222
import Ide.Plugin.Tactic.FeatureSet (FeatureSet, allFeatures)
23+
import Ide.Plugin.Tactic.LanguageServer (mkShowMessageParams)
2324
import Ide.Plugin.Tactic.Types
2425
import Language.LSP.Test
2526
import Language.LSP.Types
@@ -118,6 +119,29 @@ mkGoldenTest features tc occ line col input =
118119
expected <- liftIO $ T.readFile expected_name
119120
liftIO $ edited `shouldBe` expected
120121

122+
mkShowMessageTest
123+
:: FeatureSet
124+
-> TacticCommand
125+
-> Text
126+
-> Int
127+
-> Int
128+
-> FilePath
129+
-> UserFacingMessage
130+
-> SpecWith ()
131+
mkShowMessageTest features tc occ line col input ufm =
132+
it (input <> " (golden)") $ do
133+
runSession testCommand fullCaps tacticPath $ do
134+
setFeatureSet features
135+
doc <- openDoc input "haskell"
136+
_ <- waitForDiagnostics
137+
actions <- getCodeActions doc $ pointRange line col
138+
Just (InR CodeAction {_command = Just c})
139+
<- pure $ find ((== Just (tacticTitle tc occ)) . codeActionTitle) actions
140+
executeCommand c
141+
NotificationMessage _ _ err <- skipManyTill anyMessage (message SWindowShowMessage)
142+
liftIO $ err `shouldBe` mkShowMessageParams ufm
143+
144+
121145
goldenTest :: TacticCommand -> Text -> Int -> Int -> FilePath -> SpecWith ()
122146
goldenTest = mkGoldenTest allFeatures
123147

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

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,2 @@
1+
test :: a
2+
test = _

0 commit comments

Comments
 (0)