Add subsequent tactic test

Author: isovector

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

@@ -30,7 +30,7 @@ import           Development.IDE.Core.PositionMapping (idDelta)
 import           Development.IDE.Core.RuleTypes
 import           Development.IDE.Core.Rules (usePropertyAction)
 import           Development.IDE.Core.Service (runAction)
-import           Development.IDE.Core.Shake (IdeState (..), uses, define, use, addPersistentRule)
+import           Development.IDE.Core.Shake (IdeState (..), uses, define, use, addPersistentRule, getShakeExtras, recordDirtyKeys)
 import qualified Development.IDE.Core.Shake as IDE
 import           Development.IDE.Core.UseStale
 import           Development.IDE.GHC.Compat hiding (empty)
@@ -63,6 +63,7 @@ import           Wingman.Judgements.Theta
 import           Wingman.Range
 import           Wingman.StaticPlugin (pattern WingmanMetaprogram, pattern MetaprogramSyntax)
 import           Wingman.Types
+import Control.Concurrent.STM.Stats (atomically)
 
 
 tacticDesc :: T.Text -> T.Text
@@ -594,6 +595,13 @@ wingmanRules plId = do
 
   action $ do
     files <- getFilesOfInterestUntracked
+    extras <- getShakeExtras
+    void
+      $ liftIO
+      $ join
+      $ atomically
+      $ recordDirtyKeys extras WriteDiagnostics
+      $ Map.keys files
     void $ uses WriteDiagnostics $ Map.keys files
 
 

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 = _
+