Wingman: Fix TODO(sandy) when performing subsequent actions

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

@@ -93,7 +93,8 @@ runContinuation plId cont state (fc, b) = do
               , _xdata =  Nothing
               } ) $ do
       env@LspEnv{..} <- buildEnv state plId fc
-      let stale a = runStaleIde "runContinuation" state (fc_nfp le_fileContext) a
+      nfp <- getNfp $ fc_uri le_fileContext
+      let stale a = runStaleIde "runContinuation" state nfp a
       args <- fetchTargetArgs @a env
       res <- c_runCommand cont env args fc b
 
@@ -151,7 +152,8 @@ buildEnv
     -> MaybeT (LspM Plugin.Config) LspEnv
 buildEnv state plId fc = do
   cfg <- lift $ getTacticConfig plId
-  dflags <- mapMaybeT liftIO $ getIdeDynflags state $ fc_nfp fc
+  nfp <- getNfp $ fc_uri fc
+  dflags <- mapMaybeT liftIO $ getIdeDynflags state nfp
   pure $ LspEnv
     { le_ideState = state
     , le_pluginId = plId
@@ -173,22 +175,19 @@ codeActionProvider
        )
     -> PluginMethodHandler IdeState TextDocumentCodeAction
 codeActionProvider sort k state plId
-                   (CodeActionParams _ _ (TextDocumentIdentifier uri) range _)
-  | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do
-      fromMaybeT (Right $ List []) $ do
-        let fc = FileContext
-                   { fc_uri   = uri
-                   , fc_nfp   = nfp
-                   , fc_range = Just $ unsafeMkCurrent range
-                   }
-        env <- buildEnv state plId fc
-        args <- fetchTargetArgs @target env
-        actions <- k env args
-        pure
-          $ Right
-          $ List
-          $ fmap (InR . uncurry (makeCodeAction plId fc sort)) actions
-codeActionProvider _ _ _ _ _ = pure $ Right $ List []
+                   (CodeActionParams _ _ (TextDocumentIdentifier uri) range _) = do
+  fromMaybeT (Right $ List []) $ do
+    let fc = FileContext
+                { fc_uri   = uri
+                , fc_range = Just $ unsafeMkCurrent range
+                }
+    env <- buildEnv state plId fc
+    args <- fetchTargetArgs @target env
+    actions <- k env args
+    pure
+      $ Right
+      $ List
+      $ fmap (InR . uncurry (makeCodeAction plId fc sort)) actions
 
 
 ------------------------------------------------------------------------------
@@ -203,12 +202,10 @@ codeLensProvider
       )
     -> PluginMethodHandler IdeState TextDocumentCodeLens
 codeLensProvider sort k state plId
-                 (CodeLensParams _ _ (TextDocumentIdentifier uri))
-  | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do
+                 (CodeLensParams _ _ (TextDocumentIdentifier uri)) = do
       fromMaybeT (Right $ List []) $ do
         let fc = FileContext
                    { fc_uri   = uri
-                   , fc_nfp   = nfp
                    , fc_range = Nothing
                    }
         env <- buildEnv state plId fc
@@ -218,7 +215,6 @@ codeLensProvider sort k state plId
           $ Right
           $ List
           $ fmap (uncurry3 $ makeCodeLens plId sort fc) actions
-codeLensProvider _ _ _ _ _ = pure $ Right $ List []
 
 
 ------------------------------------------------------------------------------

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

@@ -45,9 +45,10 @@ makeTacticInteraction cmd =
               }
     )
     $ \LspEnv{..} HoleJudgment{..} FileContext{..} var_name -> do
-        let stale a = runStaleIde "tacticCmd" le_ideState fc_nfp a
+        nfp <- getNfp fc_uri
+        let stale a = runStaleIde "tacticCmd" le_ideState nfp a
 
-        let span = fmap (rangeToRealSrcSpan (fromNormalizedFilePath fc_nfp)) hj_range
+        let span = fmap (rangeToRealSrcSpan (fromNormalizedFilePath nfp)) hj_range
         TrackedStale _ pmmap <- mapMaybeT liftIO $ stale GetAnnotatedParsedSource
         pm_span <- liftMaybe $ mapAgeFrom pmmap span
         IdeOptions{optTesting = IdeTesting isTesting} <-

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

@@ -121,19 +121,13 @@ data Continuation sort target payload = Continuation
 -- | What file are we looking at, and what bit of it?
 data FileContext = FileContext
   { fc_uri      :: Uri
-  , fc_nfp      :: NormalizedFilePath
   , fc_range    :: Maybe (Tracked 'Current Range)
     -- ^ For code actions, this is 'Just'. For code lenses, you'll get
     -- a 'Nothing' in the request, and a 'Just' in the response.
   }
   deriving stock (Eq, Ord, Show, Generic)
   deriving anyclass (A.ToJSON, A.FromJSON)
 
-deriving anyclass instance A.ToJSON NormalizedFilePath
-deriving anyclass instance A.ToJSON NormalizedUri
-deriving anyclass instance A.FromJSON NormalizedFilePath
-deriving anyclass instance A.FromJSON NormalizedUri
-
 
 ------------------------------------------------------------------------------
 -- | Everything we need to resolve continuations.
@@ -162,10 +156,14 @@ class IsTarget t where
 data HoleTarget = HoleTarget
   deriving stock (Eq, Ord, Show, Enum, Bounded)
 
+getNfp :: Applicative m => Uri -> MaybeT m NormalizedFilePath
+getNfp = MaybeT . pure . uriToNormalizedFilePath . toNormalizedUri
+
 instance IsTarget HoleTarget where
   type TargetArgs HoleTarget = HoleJudgment
   fetchTargetArgs LspEnv{..} = do
     let FileContext{..} = le_fileContext
     range <- MaybeT $ pure fc_range
-    mapMaybeT liftIO $ judgementForHole le_ideState fc_nfp range le_config
+    nfp <- getNfp fc_uri
+    mapMaybeT liftIO $ judgementForHole le_ideState nfp range le_config
 

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

@@ -50,13 +50,14 @@ emptyCaseInteraction = Interaction $
   Continuation @EmptyCaseT @EmptyCaseT @WorkspaceEdit EmptyCaseT
     (SynthesizeCodeLens $ \LspEnv{..} _ -> do
       let FileContext{..} = le_fileContext
+      nfp <- getNfp fc_uri
 
-      let stale a = runStaleIde "codeLensProvider" le_ideState fc_nfp a
+      let stale a = runStaleIde "codeLensProvider" le_ideState nfp a
 
       ccs <- lift getClientCapabilities
       TrackedStale pm _ <- mapMaybeT liftIO $ stale GetAnnotatedParsedSource
       TrackedStale binds bind_map <- mapMaybeT liftIO $ stale GetBindings
-      holes <- mapMaybeT liftIO $ emptyCaseScrutinees le_ideState fc_nfp
+      holes <- mapMaybeT liftIO $ emptyCaseScrutinees le_ideState nfp
 
       for holes $ \(ss, ty) -> do
         binds_ss <- liftMaybe $ mapAgeFrom bind_map ss

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

@@ -20,3 +20,9 @@ spec = do
     "T2" 8 8
     [ (not, Intros, "")
     ]
+
+  goldenTestMany "SubsequentTactics"
+    [ InvokeTactic Intros   ""   4  5
+    , InvokeTactic Destruct "du" 4  8
+    , InvokeTactic Auto     ""   4 15
+    ]

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

@@ -4,6 +4,7 @@
 {-# LANGUAGE ScopedTypeVariables   #-}
 {-# LANGUAGE TypeOperators         #-}
 {-# LANGUAGE ViewPatterns          #-}
+{-# LANGUAGE RecordWildCards #-}
 
 module Utils where
 
@@ -96,39 +97,45 @@ mkTest name fp line col ts = it name $ do
       liftIO $
         (title `elem` titles) `shouldSatisfy` f
 
+data InvokeTactic = InvokeTactic
+  { it_command :: TacticCommand
+  , it_argument :: Text
+  , it_line :: Int
+  , it_col :: Int
+  }
+
+invokeTactic :: TextDocumentIdentifier -> InvokeTactic -> Session ()
+invokeTactic doc InvokeTactic{..} = do
+    -- wait for the entire build to finish, so that Tactics code actions that
+    -- use stale data will get uptodate stuff
+    void waitForDiagnostics
+    void $ waitForTypecheck doc
+    actions <- getCodeActions doc $ pointRange it_line it_col
+    case find ((== Just (tacticTitle it_command it_argument)) . codeActionTitle) actions of
+      Just (InR CodeAction {_command = Just c}) -> do
+          executeCommand c
+          void $ skipManyTill anyMessage $ message SWorkspaceApplyEdit
+      _ -> error $ show actions
 
 
 mkGoldenTest
     :: (Text -> Text -> Assertion)
-    -> TacticCommand
-    -> Text
-    -> Int
-    -> Int
+    -> [InvokeTactic]
     -> FilePath
     -> SpecWith ()
-mkGoldenTest eq tc occ line col input =
+mkGoldenTest eq invocations input =
   it (input <> " (golden)") $ do
     resetGlobalHoleRef
     runSessionForTactics $ do
       doc <- openDoc (input <.> "hs") "haskell"
-      -- wait for diagnostics to start coming
-      void waitForDiagnostics
-      -- wait for the entire build to finish, so that Tactics code actions that
-      -- use stale data will get uptodate stuff
-      void $ waitForTypecheck doc
-      actions <- getCodeActions doc $ pointRange line col
-      case find ((== Just (tacticTitle tc occ)) . codeActionTitle) actions of
-        Just (InR CodeAction {_command = Just c}) -> do
-            executeCommand c
-            _resp <- skipManyTill anyMessage (message SWorkspaceApplyEdit)
-            edited <- documentContents doc
-            let expected_name = input <.> "expected" <.> "hs"
-            -- Write golden tests if they don't already exist
-            liftIO $ (doesFileExist expected_name >>=) $ flip unless $ do
-                T.writeFile expected_name edited
-            expected <- liftIO $ T.readFile expected_name
-            liftIO $ edited `eq` expected
-        _ -> error $ show actions
+      traverse_ (invokeTactic doc) invocations
+      edited <- documentContents doc
+      let expected_name = input <.> "expected" <.> "hs"
+      -- Write golden tests if they don't already exist
+      liftIO $ (doesFileExist expected_name >>=) $ flip unless $ do
+          T.writeFile expected_name edited
+      expected <- liftIO $ T.readFile expected_name
+      liftIO $ edited `eq` expected
 
 mkCodeLensTest
     :: FilePath
@@ -197,10 +204,13 @@ mkShowMessageTest tc occ line col input ufm =
 
 
 goldenTest :: TacticCommand -> Text -> Int -> Int -> FilePath -> SpecWith ()
-goldenTest = mkGoldenTest shouldBe
+goldenTest tc occ line col = mkGoldenTest shouldBe [InvokeTactic tc occ line col]
+
+goldenTestMany :: FilePath -> [InvokeTactic] -> SpecWith ()
+goldenTestMany = flip $ mkGoldenTest shouldBe
 
 goldenTestNoWhitespace :: TacticCommand -> Text -> Int -> Int -> FilePath -> SpecWith ()
-goldenTestNoWhitespace = mkGoldenTest shouldBeIgnoringSpaces
+goldenTestNoWhitespace tc occ line col = mkGoldenTest shouldBeIgnoringSpaces [InvokeTactic tc occ line col]
 
 
 shouldBeIgnoringSpaces :: Text -> Text -> Assertion

plugins/hls-tactics-plugin/test/golden/SubsequentTactics.expected.hs

@@ -0,0 +1,5 @@
+data Dummy a = Dummy a
+
+f :: Dummy Int -> Int
+f (Dummy n) = n
+

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

@@ -0,0 +1,5 @@
+data Dummy a = Dummy a
+
+f :: Dummy Int -> Int
+f = _
+