Let interactions return multiple results --- aka also info messages

Author: isovector

plugins/hls-tactics-plugin/src/Wingman/AbstractLSP.hs

@@ -13,8 +13,11 @@ import           Control.Monad.IO.Class
 import           Control.Monad.Trans (lift)
 import           Control.Monad.Trans.Maybe (MaybeT, mapMaybeT)
 import qualified Data.Aeson as A
+import           Data.Coerce
 import           Data.Foldable (traverse_)
+import           Data.Monoid (Last (..))
 import qualified Data.Text as T
+import           Data.Traversable (for)
 import           Data.Tuple.Extra (uncurry3)
 import           Development.IDE (IdeState)
 import           Development.IDE.Core.UseStale
@@ -93,26 +96,30 @@ runContinuation plId cont state (fc, b) = do
       env@LspEnv{..} <- buildEnv state plId fc
       let stale a = runStaleIde "runContinuation" state (fc_nfp le_fileContext) a
       args <- fetchTargetArgs @a env
-      c_runCommand cont env args fc b >>= \case
-        ErrorMessages errs -> do
-          traverse_ showUserFacingMessage errs
-          pure $ Right A.Null
-        RawEdit edits -> do
-          sendEdits edits
-          pure $ Right A.Null
-        GraftEdit gr -> do
-          ccs <- lift getClientCapabilities
-          TrackedStale pm _ <- mapMaybeT liftIO $ stale GetAnnotatedParsedSource
-          case mkWorkspaceEdits le_dflags ccs (fc_uri le_fileContext) (unTrack pm) gr of
-            Left errs ->
-              pure $ Left $ ResponseError
-                { _code    = InternalError
-                , _message = T.pack $ show errs
-                , _xdata   = Nothing
-                }
-            Right edits -> do
-              sendEdits edits
-              pure $ Right A.Null
+      res <- c_runCommand cont env args fc b
+
+      -- This block returns a maybe error.
+      fmap (maybe (Right $ A.Null) Left . coerce . foldMap Last) $
+        for res $ \case
+          ErrorMessages errs -> do
+            traverse_ showUserFacingMessage errs
+            pure Nothing
+          RawEdit edits -> do
+            sendEdits edits
+            pure Nothing
+          GraftEdit gr -> do
+            ccs <- lift getClientCapabilities
+            TrackedStale pm _ <- mapMaybeT liftIO $ stale GetAnnotatedParsedSource
+            case mkWorkspaceEdits le_dflags ccs (fc_uri le_fileContext) (unTrack pm) gr of
+              Left errs ->
+                pure $ Just $ ResponseError
+                  { _code    = InternalError
+                  , _message = T.pack $ show errs
+                  , _xdata   = Nothing
+                  }
+              Right edits -> do
+                sendEdits edits
+                pure $ Nothing
 
 
 ------------------------------------------------------------------------------

plugins/hls-tactics-plugin/src/Wingman/AbstractLSP/TacticActions.hs

@@ -51,24 +51,33 @@ makeTacticInteraction cmd =
         pm_span <- liftMaybe $ mapAgeFrom pmmap span
         let t = commandTactic cmd var_name
 
-        res <-
-          liftIO $ runTactic (cfg_timeout_seconds le_config * seconds) hj_ctx hj_jdg t >>= \case
-            Left err -> pure $ ErrorMessages $ pure $ mkUserFacingMessage err
-            Right rtr ->
-              case rtr_extract rtr of
-                L _ (HsVar _ (L _ rdr)) | isHole (occName rdr) ->
-                  pure $ ErrorMessages [NothingToDo]
-                _ -> do
-                  for_ (rtr_other_solns rtr) $ \soln -> do
-                    traceMX "other solution" $ syn_val soln
-                    traceMX "with score" $ scoreSolution soln (rtr_jdg rtr) []
-                  traceMX "solution" $ rtr_extract rtr
-                  pure $ GraftEdit $ graftHole (RealSrcSpan $ unTrack pm_span) rtr
-
-        pure res
---         pure $ case res of
---           Nothing -> ErrorMessages $ pure TimedOut
---           Just c  -> c
+        liftIO $ runTactic (cfg_timeout_seconds le_config * seconds) hj_ctx hj_jdg t >>= \case
+          Left err -> pure $ pure $ ErrorMessages $ pure $ mkUserFacingMessage err
+          Right rtr ->
+            case rtr_extract rtr of
+              L _ (HsVar _ (L _ rdr)) | isHole (occName rdr) ->
+                pure
+                  $ addTimeoutMessage rtr
+                  $ pure
+                  $ ErrorMessages
+                  $ pure NothingToDo
+              _ -> do
+                for_ (rtr_other_solns rtr) $ \soln -> do
+                  traceMX "other solution" $ syn_val soln
+                  traceMX "with score" $ scoreSolution soln (rtr_jdg rtr) []
+                traceMX "solution" $ rtr_extract rtr
+                pure
+                  $ addTimeoutMessage rtr
+                  $ pure
+                  $ GraftEdit
+                  $ graftHole (RealSrcSpan $ unTrack pm_span) rtr
+
+
+addTimeoutMessage :: RunTacticResults -> [ContinuationResult] -> [ContinuationResult]
+addTimeoutMessage rtr = mappend
+  [ ErrorMessages $ pure TimedOut
+  | rtr_timed_out rtr
+  ]
 
 
 ------------------------------------------------------------------------------

plugins/hls-tactics-plugin/src/Wingman/AbstractLSP/Types.hs

@@ -113,7 +113,7 @@ data Continuation sort target payload = Continuation
         -> TargetArgs target
         -> FileContext
         -> payload
-        -> MaybeT (LspM Plugin.Config) ContinuationResult
+        -> MaybeT (LspM Plugin.Config) [ContinuationResult]
   }
 
 

plugins/hls-tactics-plugin/src/Wingman/EmptyCase.hs

@@ -84,7 +84,7 @@ emptyCaseInteraction = Interaction $
           , edits
           )
     )
-  $ (\ _ _ _ we -> pure $ RawEdit we)
+  $ (\ _ _ _ we -> pure $ pure $ RawEdit we)
 
 
 scrutinzedType :: EmptyCaseSort Type -> Maybe Type

plugins/hls-tactics-plugin/src/Wingman/Machinery.hs

@@ -123,7 +123,7 @@ runTactic duration ctx jdg t = do
                $ runStreamingTacticT t jdg tacticState
     (in_chan, out_chan) <- newChan
     timed_out <-
-      fmap isJust $ timeout duration $ consume stream $ \case
+      fmap (not. isJust) $ timeout duration $ consume stream $ \case
         Left _ -> pure ()
         Right proof -> writeChan in_chan $ Just proof
     writeChan in_chan Nothing

plugins/hls-tactics-plugin/src/Wingman/Types.hs

@@ -552,7 +552,7 @@ data UserFacingMessage
 instance Show UserFacingMessage where
   show NotEnoughGas = "Wingman ran out of gas when trying to find a solution.  \nTry increasing the `auto_gas` setting."
   show TacticErrors = "Wingman couldn't find a solution"
-  show TimedOut     = "Wingman timed out while trying to find a solution"
+  show TimedOut     = "Wingman timed out while finding a solution.  \nYou might get a better result if you increase the timeout duration."
   show NothingToDo  = "Nothing to do"
   show (InfrastructureError t) = "Internal error: " <> T.unpack t