diff --git a/plugins/hls-tactics-plugin/src/Wingman/AbstractLSP.hs b/plugins/hls-tactics-plugin/src/Wingman/AbstractLSP.hs index 4e8200042a..dde391ee82 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/AbstractLSP.hs +++ b/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 [] ------------------------------------------------------------------------------ diff --git a/plugins/hls-tactics-plugin/src/Wingman/AbstractLSP/TacticActions.hs b/plugins/hls-tactics-plugin/src/Wingman/AbstractLSP/TacticActions.hs index 181a42cae6..3693d7c1d3 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/AbstractLSP/TacticActions.hs +++ b/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} <- diff --git a/plugins/hls-tactics-plugin/src/Wingman/AbstractLSP/Types.hs b/plugins/hls-tactics-plugin/src/Wingman/AbstractLSP/Types.hs index 8555b880d2..18d38c6eca 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/AbstractLSP/Types.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/AbstractLSP/Types.hs @@ -121,7 +121,6 @@ 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. @@ -129,11 +128,6 @@ data FileContext = FileContext 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 diff --git a/plugins/hls-tactics-plugin/src/Wingman/EmptyCase.hs b/plugins/hls-tactics-plugin/src/Wingman/EmptyCase.hs index 442ac0cb99..6b0523be2f 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/EmptyCase.hs +++ b/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 diff --git a/plugins/hls-tactics-plugin/test/ProviderSpec.hs b/plugins/hls-tactics-plugin/test/ProviderSpec.hs index 7d6d0fcfe6..4eea30f5b3 100644 --- a/plugins/hls-tactics-plugin/test/ProviderSpec.hs +++ b/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 + ] diff --git a/plugins/hls-tactics-plugin/test/Utils.hs b/plugins/hls-tactics-plugin/test/Utils.hs index fa516193da..82ab426b4f 100644 --- a/plugins/hls-tactics-plugin/test/Utils.hs +++ b/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 diff --git a/plugins/hls-tactics-plugin/test/golden/SubsequentTactics.expected.hs b/plugins/hls-tactics-plugin/test/golden/SubsequentTactics.expected.hs new file mode 100644 index 0000000000..e638fa311c --- /dev/null +++ b/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 + diff --git a/plugins/hls-tactics-plugin/test/golden/SubsequentTactics.hs b/plugins/hls-tactics-plugin/test/golden/SubsequentTactics.hs new file mode 100644 index 0000000000..7487adf038 --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/SubsequentTactics.hs @@ -0,0 +1,5 @@ +data Dummy a = Dummy a + +f :: Dummy Int -> Int +f = _ +