Clean up tacticCmd

Author: isovector

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

@@ -45,6 +45,8 @@ import           Language.LSP.Types.Capabilities
 import           OccName
 import           Prelude hiding (span)
 import           System.Timeout
+import Control.Exception (evaluate)
+import Data.Bifunctor (Bifunctor(bimap))
 
 
 descriptor :: PluginId -> PluginDescriptor IdeState
@@ -59,19 +61,18 @@ descriptor plId = (defaultPluginDescriptor plId)
     , pluginHandlers = mkPluginHandler STextDocumentCodeAction codeActionProvider
     }
 
+
 tacticDesc :: T.Text -> T.Text
 tacticDesc name = "fill the hole using the " <> name <> " tactic"
 
 
-
 ------------------------------------------------------------------------------
 -- | The name of the command for the LS.
 tcCommandName :: TacticCommand -> T.Text
 tcCommandName = T.pack . show
 
 
 
-
 codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction
 codeActionProvider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range _ctx)
   | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri =
@@ -98,24 +99,30 @@ tacticCmd tac state (TacticParams uri range var_name)
         let span = rangeToRealSrcSpan (fromNormalizedFilePath nfp) range'
         pm <- MaybeT $ useAnnotatedSource "tacticsCmd" state nfp
 
-        x <- lift $ timeout 2e8 $ pure $
-          case runTactic ctx jdg $ tac $ mkVarOcc $ T.unpack var_name of
-            Left err ->
-              Left $ mkErr InvalidRequest $ T.pack $ show err
-            Right rtr ->
-              mkWorkspaceEdits rtr span dflags clientCapabilities uri pm
-        pure $ joinNote (mkErr InvalidRequest "timed out") x
+        timingOut 2e8 $ join $
+          bimap (mkErr InvalidRequest . T.pack . show)
+                (mkWorkspaceEdits span dflags clientCapabilities uri pm)
+            $ runTactic ctx jdg $ tac $ mkVarOcc $ T.unpack var_name
 
       case res of
         Left err -> pure $ Left err
         Right medit -> do
           forM_ medit $ \edit ->
-            sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ())
+            sendRequest
+              SWorkspaceApplyEdit
+              (ApplyWorkspaceEditParams Nothing edit)
+              (const $ pure ())
           pure $ Right Null
 tacticCmd _ _ _ =
   pure $ Left $ mkErr InvalidRequest "Bad URI"
 
 
+timingOut :: Int -> (Either ResponseError a) -> MaybeT IO (Either ResponseError a)
+timingOut t m = do
+  x <- lift $ timeout t $ evaluate m
+  pure $ joinNote (mkErr InvalidRequest "timed out") x
+
+
 mkErr :: ErrorCode -> T.Text -> ResponseError
 mkErr code err = ResponseError code err Nothing
 
@@ -129,14 +136,14 @@ joinNote _ (Just a) = a
 -- | Turn a 'RunTacticResults' into concrete edits to make in the source
 -- document.
 mkWorkspaceEdits
-    :: RunTacticResults
-    -> RealSrcSpan
+    :: RealSrcSpan
     -> DynFlags
     -> ClientCapabilities
     -> Uri
     -> Annotated ParsedSource
+    -> RunTacticResults
     -> Either ResponseError (Maybe WorkspaceEdit)
-mkWorkspaceEdits rtr span dflags clientCapabilities uri pm = do
+mkWorkspaceEdits span dflags clientCapabilities uri pm rtr = do
   let g = graftHole (RealSrcSpan span) rtr
       response = transform dflags clientCapabilities uri g pm
    in case response of

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

@@ -132,7 +132,6 @@ getSpanAndTypeAtHole amapping range hf = do
         pure (nodeSpan ast', ty)
 
 
-
 liftMaybe :: Monad m => Maybe a -> MaybeT m a
 liftMaybe a = MaybeT $ pure a