From 3ea0290df8b92b0f490e23770499f76e798c4e8e Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 4 Mar 2021 21:59:30 -0800 Subject: [PATCH 1/3] Split GoldenSpec into more manageable chunks --- .../hls-tactics-plugin.cabal | 9 +- .../test/CodeAction/AutoSpec.hs | 53 +++ .../test/CodeAction/DestructAllSpec.hs | 41 +++ .../test/CodeAction/DestructSpec.hs | 30 ++ .../test/CodeAction/IntrosSpec.hs | 19 ++ .../test/CodeAction/RefineSpec.hs | 23 ++ .../test/CodeAction/UseDataConSpec.hs | 46 +++ plugins/hls-tactics-plugin/test/GoldenSpec.hs | 311 ------------------ .../hls-tactics-plugin/test/ProviderSpec.hs | 54 +++ plugins/hls-tactics-plugin/test/Utils.hs | 144 ++++++++ 10 files changed, 418 insertions(+), 312 deletions(-) create mode 100644 plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs create mode 100644 plugins/hls-tactics-plugin/test/CodeAction/DestructAllSpec.hs create mode 100644 plugins/hls-tactics-plugin/test/CodeAction/DestructSpec.hs create mode 100644 plugins/hls-tactics-plugin/test/CodeAction/IntrosSpec.hs create mode 100644 plugins/hls-tactics-plugin/test/CodeAction/RefineSpec.hs create mode 100644 plugins/hls-tactics-plugin/test/CodeAction/UseDataConSpec.hs delete mode 100644 plugins/hls-tactics-plugin/test/GoldenSpec.hs create mode 100644 plugins/hls-tactics-plugin/test/ProviderSpec.hs create mode 100644 plugins/hls-tactics-plugin/test/Utils.hs diff --git a/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal b/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal index 54b7d43e8a..75f871ecc5 100644 --- a/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal +++ b/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal @@ -101,8 +101,15 @@ test-suite tests main-is: Main.hs other-modules: AutoTupleSpec - GoldenSpec + CodeAction.AutoSpec + CodeAction.DestructAllSpec + CodeAction.RefineSpec + CodeAction.DestructSpec + CodeAction.IntrosSpec + CodeAction.UseDataConSpec + ProviderSpec UnificationSpec + Utils hs-source-dirs: test ghc-options: -Wall -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N diff --git a/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs b/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs new file mode 100644 index 0000000000..21e76277f0 --- /dev/null +++ b/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +module CodeAction.AutoSpec where + +import Ide.Plugin.Tactic.TestTypes +import Test.Hspec +import Utils + + +spec :: Spec +spec = do + let autoTest line col fp = goldenTest Auto "" fp line col + + describe "golden tests" $ do + autoTest 11 8 "AutoSplitGADT.hs" + autoTest 2 11 "GoldenEitherAuto.hs" + autoTest 4 12 "GoldenJoinCont.hs" + autoTest 3 11 "GoldenIdentityFunctor.hs" + autoTest 7 11 "GoldenIdTypeFam.hs" + autoTest 2 15 "GoldenEitherHomomorphic.hs" + autoTest 2 8 "GoldenNote.hs" + autoTest 2 12 "GoldenPureList.hs" + autoTest 2 12 "GoldenListFmap.hs" + autoTest 2 13 "GoldenFromMaybe.hs" + autoTest 2 10 "GoldenFoldr.hs" + autoTest 2 8 "GoldenSwap.hs" + autoTest 4 11 "GoldenFmapTree.hs" + autoTest 7 13 "GoldenGADTAuto.hs" + autoTest 2 12 "GoldenSwapMany.hs" + autoTest 4 12 "GoldenBigTuple.hs" + autoTest 2 10 "GoldenShow.hs" + autoTest 2 15 "GoldenShowCompose.hs" + autoTest 2 8 "GoldenShowMapChar.hs" + autoTest 7 8 "GoldenSuperclass.hs" + autoTest 2 12 "GoldenSafeHead.hs" + autoTest 25 13 "GoldenArbitrary.hs" + autoTest 2 12 "FmapBoth.hs" + autoTest 7 8 "RecordCon.hs" + autoTest 6 8 "NewtypeRecord.hs" + autoTest 2 14 "FmapJoin.hs" + autoTest 2 9 "Fgmap.hs" + autoTest 4 19 "FmapJoinInLet.hs" + + failing "flaky in CI" $ + autoTest 2 11 "GoldenApplicativeThen.hs" + failing "not enough auto gas" $ + autoTest 5 18 "GoldenFish.hs" + diff --git a/plugins/hls-tactics-plugin/test/CodeAction/DestructAllSpec.hs b/plugins/hls-tactics-plugin/test/CodeAction/DestructAllSpec.hs new file mode 100644 index 0000000000..56f3ca0daa --- /dev/null +++ b/plugins/hls-tactics-plugin/test/CodeAction/DestructAllSpec.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +module CodeAction.DestructAllSpec where + +import Ide.Plugin.Tactic.TestTypes +import Test.Hspec +import Utils + + +spec :: Spec +spec = do + let destructAllTest = goldenTest DestructAll "" + describe "provider" $ do + mkTest + "Requires args on lhs of =" + "DestructAllProvider.hs" 3 21 + [ (not, DestructAll, "") + ] + mkTest + "Can't be a non-top-hole" + "DestructAllProvider.hs" 8 19 + [ (not, DestructAll, "") + , (id, Destruct, "a") + , (id, Destruct, "b") + ] + mkTest + "Provides a destruct all otherwise" + "DestructAllProvider.hs" 12 22 + [ (id, DestructAll, "") + ] + + describe "golden" $ do + destructAllTest "DestructAllAnd.hs" 2 11 + destructAllTest "DestructAllMany.hs" 4 23 + destructAllTest "DestructAllNonVarTopMatch.hs" 2 18 + diff --git a/plugins/hls-tactics-plugin/test/CodeAction/DestructSpec.hs b/plugins/hls-tactics-plugin/test/CodeAction/DestructSpec.hs new file mode 100644 index 0000000000..6db23f0826 --- /dev/null +++ b/plugins/hls-tactics-plugin/test/CodeAction/DestructSpec.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +module CodeAction.DestructSpec where + +import Ide.Plugin.Tactic.TestTypes +import Test.Hspec +import Utils + + +spec :: Spec +spec = do + describe "golden" $ do + goldenTest Destruct "gadt" + "GoldenGADTDestruct.hs" 7 17 + goldenTest Destruct "gadt" + "GoldenGADTDestructCoercion.hs" 8 17 + goldenTest Destruct "a" + "SplitPattern.hs" 7 25 + + describe "layout" $ do + goldenTest Destruct "b" "LayoutBind.hs" 4 3 + goldenTest Destruct "b" "LayoutDollarApp.hs" 2 15 + goldenTest Destruct "b" "LayoutOpApp.hs" 2 18 + goldenTest Destruct "b" "LayoutLam.hs" 2 14 + diff --git a/plugins/hls-tactics-plugin/test/CodeAction/IntrosSpec.hs b/plugins/hls-tactics-plugin/test/CodeAction/IntrosSpec.hs new file mode 100644 index 0000000000..b46ffd8760 --- /dev/null +++ b/plugins/hls-tactics-plugin/test/CodeAction/IntrosSpec.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +module CodeAction.IntrosSpec where + +import Ide.Plugin.Tactic.TestTypes +import Test.Hspec +import Utils + + +spec :: Spec +spec = do + describe "golden" $ do + goldenTest Intros "" "GoldenIntros.hs" 2 8 + diff --git a/plugins/hls-tactics-plugin/test/CodeAction/RefineSpec.hs b/plugins/hls-tactics-plugin/test/CodeAction/RefineSpec.hs new file mode 100644 index 0000000000..cb2ce4e31e --- /dev/null +++ b/plugins/hls-tactics-plugin/test/CodeAction/RefineSpec.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +module CodeAction.RefineSpec where + +import Ide.Plugin.Tactic.TestTypes +import Test.Hspec +import Utils + + +spec :: Spec +spec = do + let refineTest = goldenTest Refine "" + describe "golden" $ do + refineTest "RefineIntro.hs" 2 8 + refineTest "RefineCon.hs" 2 8 + refineTest "RefineReader.hs" 4 8 + refineTest "RefineGADT.hs" 8 8 + diff --git a/plugins/hls-tactics-plugin/test/CodeAction/UseDataConSpec.hs b/plugins/hls-tactics-plugin/test/CodeAction/UseDataConSpec.hs new file mode 100644 index 0000000000..550b243c74 --- /dev/null +++ b/plugins/hls-tactics-plugin/test/CodeAction/UseDataConSpec.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +module CodeAction.UseDataConSpec where + +import qualified Data.Text as T +import Ide.Plugin.Tactic.TestTypes +import Test.Hspec +import Utils + + +spec :: Spec +spec = do + let useTest = goldenTest UseDataCon + describe "provider" $ do + mkTest + "Suggests all data cons for Either" + "ConProviders.hs" 5 6 + [ (id, UseDataCon, "Left") + , (id, UseDataCon, "Right") + , (not, UseDataCon, ":") + , (not, UseDataCon, "[]") + , (not, UseDataCon, "C1") + ] + mkTest + "Suggests no data cons for big types" + "ConProviders.hs" 11 17 $ do + c <- [1 :: Int .. 10] + pure $ (not, UseDataCon, T.pack $ show c) + mkTest + "Suggests only matching data cons for GADT" + "ConProviders.hs" 20 12 + [ (id, UseDataCon, "IntGADT") + , (id, UseDataCon, "VarGADT") + , (not, UseDataCon, "BoolGADT") + ] + + describe "golden" $ do + useTest "(,)" "UseConPair.hs" 2 8 + useTest "Left" "UseConLeft.hs" 2 8 + useTest "Right" "UseConRight.hs" 2 8 + diff --git a/plugins/hls-tactics-plugin/test/GoldenSpec.hs b/plugins/hls-tactics-plugin/test/GoldenSpec.hs deleted file mode 100644 index 550c65ee65..0000000000 --- a/plugins/hls-tactics-plugin/test/GoldenSpec.hs +++ /dev/null @@ -1,311 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} - -module GoldenSpec where - -import Control.Applicative.Combinators (skipManyTill) -import Control.Lens hiding (failing, (<.>)) -import Control.Monad (unless) -import Control.Monad.IO.Class -import Data.Aeson -import Data.Default (Default (def)) -import Data.Foldable -import qualified Data.Map as M -import Data.Maybe -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as T -import qualified Ide.Plugin.Config as Plugin -import Ide.Plugin.Tactic.FeatureSet (FeatureSet, allFeatures) -import Ide.Plugin.Tactic.TestTypes -import Language.LSP.Test -import Language.LSP.Types -import Language.LSP.Types.Lens hiding (actions, applyEdit, capabilities, executeCommand, id, line, message, name, rename, title) -import System.Directory (doesFileExist) -import System.FilePath -import Test.Hspec - - -spec :: Spec -spec = do - describe "code action availability" $ do - mkTest - "Produces intros code action" - "T1.hs" 2 14 - [ (id, Intros, "") - ] - mkTest - "Produces destruct and homomorphism code actions" - "T2.hs" 2 21 - [ (id, Destruct, "eab") - , (id, Homomorphism, "eab") - ] - mkTest - "Won't suggest homomorphism on the wrong type" - "T2.hs" 8 8 - [ (not, Homomorphism, "global") - ] - mkTest - "Won't suggest intros on the wrong type" - "T2.hs" 8 8 - [ (not, Intros, "") - ] - mkTest - "Produces (homomorphic) lambdacase code actions" - "T3.hs" 4 24 - [ (id, HomomorphismLambdaCase, "") - , (id, DestructLambdaCase, "") - ] - mkTest - "Produces lambdacase code actions" - "T3.hs" 7 13 - [ (id, DestructLambdaCase, "") - ] - mkTest - "Doesn't suggest lambdacase without -XLambdaCase" - "T2.hs" 11 25 - [ (not, DestructLambdaCase, "") - ] - - let goldenTest = mkGoldenTest allFeatures - - -- test via: - -- stack test hls-tactics-plugin --test-arguments '--match "Golden/layout/"' - describe "layout" $ do - let test = mkGoldenTest allFeatures - test Destruct "b" "LayoutBind.hs" 4 3 - test Destruct "b" "LayoutDollarApp.hs" 2 15 - test Destruct "b" "LayoutOpApp.hs" 2 18 - test Destruct "b" "LayoutLam.hs" 2 14 - - -- test via: - -- stack test hls-tactics-plugin --test-arguments '--match "Golden/destruct all/"' - describe "destruct all" $ do - let destructAllTest = mkGoldenTest allFeatures DestructAll "" - describe "provider" $ do - mkTest - "Requires args on lhs of =" - "DestructAllProvider.hs" 3 21 - [ (not, DestructAll, "") - ] - mkTest - "Can't be a non-top-hole" - "DestructAllProvider.hs" 8 19 - [ (not, DestructAll, "") - , (id, Destruct, "a") - , (id, Destruct, "b") - ] - mkTest - "Provides a destruct all otherwise" - "DestructAllProvider.hs" 12 22 - [ (id, DestructAll, "") - ] - - describe "golden" $ do - destructAllTest "DestructAllAnd.hs" 2 11 - destructAllTest "DestructAllMany.hs" 4 23 - destructAllTest "DestructAllNonVarTopMatch.hs" 2 18 - - - -- test via: - -- stack test hls-tactics-plugin --test-arguments '--match "Golden/use constructor/"' - describe "use constructor" $ do - let useTest = mkGoldenTest allFeatures UseDataCon - describe "provider" $ do - mkTest - "Suggests all data cons for Either" - "ConProviders.hs" 5 6 - [ (id, UseDataCon, "Left") - , (id, UseDataCon, "Right") - , (not, UseDataCon, ":") - , (not, UseDataCon, "[]") - , (not, UseDataCon, "C1") - ] - mkTest - "Suggests no data cons for big types" - "ConProviders.hs" 11 17 $ do - c <- [1 :: Int .. 10] - pure $ (not, UseDataCon, T.pack $ show c) - mkTest - "Suggests only matching data cons for GADT" - "ConProviders.hs" 20 12 - [ (id, UseDataCon, "IntGADT") - , (id, UseDataCon, "VarGADT") - , (not, UseDataCon, "BoolGADT") - ] - - describe "golden" $ do - useTest "(,)" "UseConPair.hs" 2 8 - useTest "Left" "UseConLeft.hs" 2 8 - useTest "Right" "UseConRight.hs" 2 8 - - -- test via: - -- stack test hls-tactics-plugin --test-arguments '--match "Golden/refine/"' - describe "refine" $ do - let refineTest = mkGoldenTest allFeatures Refine "" - describe "golden" $ do - refineTest "RefineIntro.hs" 2 8 - refineTest "RefineCon.hs" 2 8 - refineTest "RefineReader.hs" 4 8 - refineTest "RefineGADT.hs" 8 8 - - -- test via: - -- stack test hls-tactics-plugin --test-arguments '--match "Golden/golden tests/"' - describe "golden tests" $ do - let autoTest = mkGoldenTest allFeatures Auto "" - - autoTest "AutoSplitGADT.hs" 11 8 - goldenTest Intros "" "GoldenIntros.hs" 2 8 - autoTest "GoldenEitherAuto.hs" 2 11 - autoTest "GoldenJoinCont.hs" 4 12 - autoTest "GoldenIdentityFunctor.hs" 3 11 - autoTest "GoldenIdTypeFam.hs" 7 11 - autoTest "GoldenEitherHomomorphic.hs" 2 15 - autoTest "GoldenNote.hs" 2 8 - autoTest "GoldenPureList.hs" 2 12 - autoTest "GoldenListFmap.hs" 2 12 - autoTest "GoldenFromMaybe.hs" 2 13 - autoTest "GoldenFoldr.hs" 2 10 - autoTest "GoldenSwap.hs" 2 8 - autoTest "GoldenFmapTree.hs" 4 11 - goldenTest Destruct "gadt" - "GoldenGADTDestruct.hs" 7 17 - goldenTest Destruct "gadt" - "GoldenGADTDestructCoercion.hs" 8 17 - autoTest "GoldenGADTAuto.hs" 7 13 - autoTest "GoldenSwapMany.hs" 2 12 - autoTest "GoldenBigTuple.hs" 4 12 - autoTest "GoldenShow.hs" 2 10 - autoTest "GoldenShowCompose.hs" 2 15 - autoTest "GoldenShowMapChar.hs" 2 8 - autoTest "GoldenSuperclass.hs" 7 8 - failing "flaky in CI" $ - autoTest "GoldenApplicativeThen.hs" 2 11 - autoTest "GoldenSafeHead.hs" 2 12 - failing "not enough auto gas" $ - autoTest "GoldenFish.hs" 5 18 - autoTest "GoldenArbitrary.hs" 25 13 - autoTest "FmapBoth.hs" 2 12 - autoTest "RecordCon.hs" 7 8 - autoTest "NewtypeRecord.hs" 6 8 - autoTest "FmapJoin.hs" 2 14 - autoTest "Fgmap.hs" 2 9 - autoTest "FmapJoinInLet.hs" 4 19 - goldenTest Destruct "a" - "SplitPattern.hs" 7 25 - - ------------------------------------------------------------------------------- --- | Get a range at the given line and column corresponding to having nothing --- selected. --- --- NB: These coordinates are in "file space", ie, 1-indexed. -pointRange :: Int -> Int -> Range -pointRange - (subtract 1 -> line) - (subtract 1 -> col) = - Range (Position line col) (Position line $ col + 1) - - ------------------------------------------------------------------------------- --- | Get the title of a code action. -codeActionTitle :: (Command |? CodeAction) -> Maybe Text -codeActionTitle InL{} = Nothing -codeActionTitle (InR(CodeAction title _ _ _ _ _ _)) = Just title - - ------------------------------------------------------------------------------- --- | Make a tactic unit test. -mkTest - :: Foldable t - => String -- ^ The test name - -> FilePath -- ^ The file to load - -> Int -- ^ Cursor line - -> Int -- ^ Cursor columnn - -> t ( Bool -> Bool -- Use 'not' for actions that shouldnt be present - , TacticCommand -- An expected command ... - , Text -- ... for this variable - ) -- ^ A collection of (un)expected code actions. - -> SpecWith (Arg Bool) -mkTest name fp line col ts = it name $ do - runSession testCommand fullCaps tacticPath $ do - setFeatureSet allFeatures - doc <- openDoc fp "haskell" - _ <- waitForDiagnostics - actions <- getCodeActions doc $ pointRange line col - let titles = mapMaybe codeActionTitle actions - for_ ts $ \(f, tc, var) -> do - let title = tacticTitle tc var - liftIO $ - (title `elem` titles) `shouldSatisfy` f - - -setFeatureSet :: FeatureSet -> Session () -setFeatureSet features = do - let unObject (Object obj) = obj - unObject _ = undefined - def_config = def :: Plugin.Config - config = - def_config - { Plugin.plugins = M.fromList [("tactics", - def { Plugin.plcConfig = unObject $ toJSON $ - emptyConfig { cfg_feature_set = features }} - )] <> Plugin.plugins def_config } - - sendNotification SWorkspaceDidChangeConfiguration $ - DidChangeConfigurationParams $ - toJSON config - - -mkGoldenTest - :: FeatureSet - -> TacticCommand - -> Text - -> FilePath - -> Int - -> Int - -> SpecWith () -mkGoldenTest features tc occ input line col = - it (input <> " (golden)") $ do - runSession testCommand fullCaps tacticPath $ do - setFeatureSet features - doc <- openDoc input "haskell" - _ <- waitForDiagnostics - actions <- getCodeActions doc $ pointRange line col - Just (InR CodeAction {_command = Just c}) - <- pure $ find ((== Just (tacticTitle tc occ)) . codeActionTitle) actions - executeCommand c - _resp <- skipManyTill anyMessage (message SWorkspaceApplyEdit) - edited <- documentContents doc - let expected_name = tacticPath input <.> "expected" - -- 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 `shouldBe` expected - - ------------------------------------------------------------------------------- --- | Don't run a test. -failing :: Applicative m => String -> b -> m () -failing _ _ = pure () - - -tacticPath :: FilePath -tacticPath = "test/golden" - - -testCommand :: String -testCommand = "test-server" - - -executeCommandWithResp :: Command -> Session (ResponseMessage 'WorkspaceExecuteCommand) -executeCommandWithResp cmd = do - let args = decode $ encode $ fromJust $ cmd ^. arguments - execParams = ExecuteCommandParams Nothing (cmd ^. command) args - request SWorkspaceExecuteCommand execParams - diff --git a/plugins/hls-tactics-plugin/test/ProviderSpec.hs b/plugins/hls-tactics-plugin/test/ProviderSpec.hs new file mode 100644 index 0000000000..ceeffff401 --- /dev/null +++ b/plugins/hls-tactics-plugin/test/ProviderSpec.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +module ProviderSpec where + +import Ide.Plugin.Tactic.TestTypes +import Test.Hspec +import Utils + + +spec :: Spec +spec = do + mkTest + "Produces intros code action" + "T1.hs" 2 14 + [ (id, Intros, "") + ] + mkTest + "Produces destruct and homomorphism code actions" + "T2.hs" 2 21 + [ (id, Destruct, "eab") + , (id, Homomorphism, "eab") + ] + mkTest + "Won't suggest homomorphism on the wrong type" + "T2.hs" 8 8 + [ (not, Homomorphism, "global") + ] + mkTest + "Won't suggest intros on the wrong type" + "T2.hs" 8 8 + [ (not, Intros, "") + ] + mkTest + "Produces (homomorphic) lambdacase code actions" + "T3.hs" 4 24 + [ (id, HomomorphismLambdaCase, "") + , (id, DestructLambdaCase, "") + ] + mkTest + "Produces lambdacase code actions" + "T3.hs" 7 13 + [ (id, DestructLambdaCase, "") + ] + mkTest + "Doesn't suggest lambdacase without -XLambdaCase" + "T2.hs" 11 25 + [ (not, DestructLambdaCase, "") + ] + diff --git a/plugins/hls-tactics-plugin/test/Utils.hs b/plugins/hls-tactics-plugin/test/Utils.hs new file mode 100644 index 0000000000..16a50c5041 --- /dev/null +++ b/plugins/hls-tactics-plugin/test/Utils.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +module Utils where + +import Control.Applicative.Combinators (skipManyTill) +import Control.Lens hiding (failing, (<.>)) +import Control.Monad (unless) +import Control.Monad.IO.Class +import Data.Aeson +import Data.Default (Default (def)) +import Data.Foldable +import qualified Data.Map as M +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text.IO as T +import qualified Ide.Plugin.Config as Plugin +import Ide.Plugin.Tactic.FeatureSet (FeatureSet, allFeatures) +import Ide.Plugin.Tactic.TestTypes +import Language.LSP.Test +import Language.LSP.Types +import Language.LSP.Types.Lens hiding (actions, applyEdit, capabilities, executeCommand, id, line, message, name, rename, title) +import System.Directory (doesFileExist) +import System.FilePath +import Test.Hspec + + +------------------------------------------------------------------------------ +-- | Get a range at the given line and column corresponding to having nothing +-- selected. +-- +-- NB: These coordinates are in "file space", ie, 1-indexed. +pointRange :: Int -> Int -> Range +pointRange + (subtract 1 -> line) + (subtract 1 -> col) = + Range (Position line col) (Position line $ col + 1) + + +------------------------------------------------------------------------------ +-- | Get the title of a code action. +codeActionTitle :: (Command |? CodeAction) -> Maybe Text +codeActionTitle InL{} = Nothing +codeActionTitle (InR(CodeAction title _ _ _ _ _ _)) = Just title + + +------------------------------------------------------------------------------ +-- | Make a tactic unit test. +mkTest + :: Foldable t + => String -- ^ The test name + -> FilePath -- ^ The file to load + -> Int -- ^ Cursor line + -> Int -- ^ Cursor columnn + -> t ( Bool -> Bool -- Use 'not' for actions that shouldnt be present + , TacticCommand -- An expected command ... + , Text -- ... for this variable + ) -- ^ A collection of (un)expected code actions. + -> SpecWith (Arg Bool) +mkTest name fp line col ts = it name $ do + runSession testCommand fullCaps tacticPath $ do + setFeatureSet allFeatures + doc <- openDoc fp "haskell" + _ <- waitForDiagnostics + actions <- getCodeActions doc $ pointRange line col + let titles = mapMaybe codeActionTitle actions + for_ ts $ \(f, tc, var) -> do + let title = tacticTitle tc var + liftIO $ + (title `elem` titles) `shouldSatisfy` f + + +setFeatureSet :: FeatureSet -> Session () +setFeatureSet features = do + let unObject (Object obj) = obj + unObject _ = undefined + def_config = def :: Plugin.Config + config = + def_config + { Plugin.plugins = M.fromList [("tactics", + def { Plugin.plcConfig = unObject $ toJSON $ + emptyConfig { cfg_feature_set = features }} + )] <> Plugin.plugins def_config } + + sendNotification SWorkspaceDidChangeConfiguration $ + DidChangeConfigurationParams $ + toJSON config + + +mkGoldenTest + :: FeatureSet + -> TacticCommand + -> Text + -> FilePath + -> Int + -> Int + -> SpecWith () +mkGoldenTest features tc occ input line col = + it (input <> " (golden)") $ do + runSession testCommand fullCaps tacticPath $ do + setFeatureSet features + doc <- openDoc input "haskell" + _ <- waitForDiagnostics + actions <- getCodeActions doc $ pointRange line col + Just (InR CodeAction {_command = Just c}) + <- pure $ find ((== Just (tacticTitle tc occ)) . codeActionTitle) actions + executeCommand c + _resp <- skipManyTill anyMessage (message SWorkspaceApplyEdit) + edited <- documentContents doc + let expected_name = tacticPath input <.> "expected" + -- 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 `shouldBe` expected + +goldenTest :: TacticCommand -> Text -> FilePath -> Int -> Int -> SpecWith () +goldenTest = mkGoldenTest allFeatures + + +------------------------------------------------------------------------------ +-- | Don't run a test. +failing :: Applicative m => String -> b -> m () +failing _ _ = pure () + + +tacticPath :: FilePath +tacticPath = "test/golden" + + +testCommand :: String +testCommand = "test-server" + + +executeCommandWithResp :: Command -> Session (ResponseMessage 'WorkspaceExecuteCommand) +executeCommandWithResp cmd = do + let args = decode $ encode $ fromJust $ cmd ^. arguments + execParams = ExecuteCommandParams Nothing (cmd ^. command) args + request SWorkspaceExecuteCommand execParams + From 0dffecd1026734119fbbda3e049ecff935b96512 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 4 Mar 2021 22:04:55 -0800 Subject: [PATCH 2/3] Move line/col arguments before file path for better alignment --- .../test/CodeAction/AutoSpec.hs | 3 ++- .../test/CodeAction/DestructAllSpec.hs | 6 +++--- .../test/CodeAction/DestructSpec.hs | 19 +++++++++---------- .../test/CodeAction/IntrosSpec.hs | 4 +++- .../test/CodeAction/RefineSpec.hs | 9 +++++---- .../test/CodeAction/UseDataConSpec.hs | 7 ++++--- plugins/hls-tactics-plugin/test/Utils.hs | 6 +++--- 7 files changed, 29 insertions(+), 25 deletions(-) diff --git a/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs b/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs index 21e76277f0..3a6cb93636 100644 --- a/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs +++ b/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs @@ -14,7 +14,7 @@ import Utils spec :: Spec spec = do - let autoTest line col fp = goldenTest Auto "" fp line col + let autoTest = goldenTest Auto "" describe "golden tests" $ do autoTest 11 8 "AutoSplitGADT.hs" @@ -48,6 +48,7 @@ spec = do failing "flaky in CI" $ autoTest 2 11 "GoldenApplicativeThen.hs" + failing "not enough auto gas" $ autoTest 5 18 "GoldenFish.hs" diff --git a/plugins/hls-tactics-plugin/test/CodeAction/DestructAllSpec.hs b/plugins/hls-tactics-plugin/test/CodeAction/DestructAllSpec.hs index 56f3ca0daa..4d8c60528b 100644 --- a/plugins/hls-tactics-plugin/test/CodeAction/DestructAllSpec.hs +++ b/plugins/hls-tactics-plugin/test/CodeAction/DestructAllSpec.hs @@ -35,7 +35,7 @@ spec = do ] describe "golden" $ do - destructAllTest "DestructAllAnd.hs" 2 11 - destructAllTest "DestructAllMany.hs" 4 23 - destructAllTest "DestructAllNonVarTopMatch.hs" 2 18 + destructAllTest 2 11 "DestructAllAnd.hs" + destructAllTest 4 23 "DestructAllMany.hs" + destructAllTest 2 18 "DestructAllNonVarTopMatch.hs" diff --git a/plugins/hls-tactics-plugin/test/CodeAction/DestructSpec.hs b/plugins/hls-tactics-plugin/test/CodeAction/DestructSpec.hs index 6db23f0826..653f6ab5ba 100644 --- a/plugins/hls-tactics-plugin/test/CodeAction/DestructSpec.hs +++ b/plugins/hls-tactics-plugin/test/CodeAction/DestructSpec.hs @@ -14,17 +14,16 @@ import Utils spec :: Spec spec = do + let destructTest = goldenTest Destruct + describe "golden" $ do - goldenTest Destruct "gadt" - "GoldenGADTDestruct.hs" 7 17 - goldenTest Destruct "gadt" - "GoldenGADTDestructCoercion.hs" 8 17 - goldenTest Destruct "a" - "SplitPattern.hs" 7 25 + destructTest "gadt" 7 17 "GoldenGADTDestruct.hs" + destructTest "gadt" 8 17 "GoldenGADTDestructCoercion.hs" + destructTest "a" 7 25 "SplitPattern.hs" describe "layout" $ do - goldenTest Destruct "b" "LayoutBind.hs" 4 3 - goldenTest Destruct "b" "LayoutDollarApp.hs" 2 15 - goldenTest Destruct "b" "LayoutOpApp.hs" 2 18 - goldenTest Destruct "b" "LayoutLam.hs" 2 14 + destructTest "b" 4 3 "LayoutBind.hs" + destructTest "b" 2 15 "LayoutDollarApp.hs" + destructTest "b" 2 18 "LayoutOpApp.hs" + destructTest "b" 2 14 "LayoutLam.hs" diff --git a/plugins/hls-tactics-plugin/test/CodeAction/IntrosSpec.hs b/plugins/hls-tactics-plugin/test/CodeAction/IntrosSpec.hs index b46ffd8760..13af14b9ad 100644 --- a/plugins/hls-tactics-plugin/test/CodeAction/IntrosSpec.hs +++ b/plugins/hls-tactics-plugin/test/CodeAction/IntrosSpec.hs @@ -14,6 +14,8 @@ import Utils spec :: Spec spec = do + let introsTest = goldenTest Intros "" + describe "golden" $ do - goldenTest Intros "" "GoldenIntros.hs" 2 8 + introsTest 2 8 "GoldenIntros.hs" diff --git a/plugins/hls-tactics-plugin/test/CodeAction/RefineSpec.hs b/plugins/hls-tactics-plugin/test/CodeAction/RefineSpec.hs index cb2ce4e31e..f798315ce1 100644 --- a/plugins/hls-tactics-plugin/test/CodeAction/RefineSpec.hs +++ b/plugins/hls-tactics-plugin/test/CodeAction/RefineSpec.hs @@ -15,9 +15,10 @@ import Utils spec :: Spec spec = do let refineTest = goldenTest Refine "" + describe "golden" $ do - refineTest "RefineIntro.hs" 2 8 - refineTest "RefineCon.hs" 2 8 - refineTest "RefineReader.hs" 4 8 - refineTest "RefineGADT.hs" 8 8 + refineTest 2 8 "RefineIntro.hs" + refineTest 2 8 "RefineCon.hs" + refineTest 4 8 "RefineReader.hs" + refineTest 8 8 "RefineGADT.hs" diff --git a/plugins/hls-tactics-plugin/test/CodeAction/UseDataConSpec.hs b/plugins/hls-tactics-plugin/test/CodeAction/UseDataConSpec.hs index 550b243c74..6e5bbea70c 100644 --- a/plugins/hls-tactics-plugin/test/CodeAction/UseDataConSpec.hs +++ b/plugins/hls-tactics-plugin/test/CodeAction/UseDataConSpec.hs @@ -16,6 +16,7 @@ import Utils spec :: Spec spec = do let useTest = goldenTest UseDataCon + describe "provider" $ do mkTest "Suggests all data cons for Either" @@ -40,7 +41,7 @@ spec = do ] describe "golden" $ do - useTest "(,)" "UseConPair.hs" 2 8 - useTest "Left" "UseConLeft.hs" 2 8 - useTest "Right" "UseConRight.hs" 2 8 + useTest "(,)" 2 8 "UseConPair.hs" + useTest "Left" 2 8 "UseConLeft.hs" + useTest "Right" 2 8 "UseConRight.hs" diff --git a/plugins/hls-tactics-plugin/test/Utils.hs b/plugins/hls-tactics-plugin/test/Utils.hs index 16a50c5041..20dc0e3437 100644 --- a/plugins/hls-tactics-plugin/test/Utils.hs +++ b/plugins/hls-tactics-plugin/test/Utils.hs @@ -95,11 +95,11 @@ mkGoldenTest :: FeatureSet -> TacticCommand -> Text - -> FilePath -> Int -> Int + -> FilePath -> SpecWith () -mkGoldenTest features tc occ input line col = +mkGoldenTest features tc occ line col input = it (input <> " (golden)") $ do runSession testCommand fullCaps tacticPath $ do setFeatureSet features @@ -118,7 +118,7 @@ mkGoldenTest features tc occ input line col = expected <- liftIO $ T.readFile expected_name liftIO $ edited `shouldBe` expected -goldenTest :: TacticCommand -> Text -> FilePath -> Int -> Int -> SpecWith () +goldenTest :: TacticCommand -> Text -> Int -> Int -> FilePath -> SpecWith () goldenTest = mkGoldenTest allFeatures From 0346f92a9ed4869bf07c7ac8ea489c81e91a9b51 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Thu, 4 Mar 2021 22:11:53 -0800 Subject: [PATCH 3/3] Merge TestTypes into Types --- .../hls-tactics-plugin.cabal | 1 - .../src/Ide/Plugin/Tactic.hs | 1 - .../src/Ide/Plugin/Tactic/LanguageServer.hs | 1 - .../Tactic/LanguageServer/TacticProviders.hs | 1 - .../src/Ide/Plugin/Tactic/TestTypes.hs | 63 ----------- .../src/Ide/Plugin/Tactic/Types.hs | 107 ++++++++++++++---- .../test/CodeAction/AutoSpec.hs | 2 +- .../test/CodeAction/DestructAllSpec.hs | 2 +- .../test/CodeAction/DestructSpec.hs | 2 +- .../test/CodeAction/IntrosSpec.hs | 2 +- .../test/CodeAction/RefineSpec.hs | 2 +- .../test/CodeAction/UseDataConSpec.hs | 2 +- .../hls-tactics-plugin/test/ProviderSpec.hs | 2 +- plugins/hls-tactics-plugin/test/Utils.hs | 2 +- 14 files changed, 92 insertions(+), 98 deletions(-) delete mode 100644 plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/TestTypes.hs diff --git a/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal b/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal index 75f871ecc5..a507a5e657 100644 --- a/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal +++ b/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal @@ -44,7 +44,6 @@ library Ide.Plugin.Tactic.Simplify Ide.Plugin.Tactic.Tactics Ide.Plugin.Tactic.Types - Ide.Plugin.Tactic.TestTypes ghc-options: -Wno-name-shadowing -Wredundant-constraints -Wno-unticked-promoted-constructors diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs index 69c28c7109..3a6219d7fb 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic.hs @@ -40,7 +40,6 @@ import Ide.Plugin.Tactic.LanguageServer import Ide.Plugin.Tactic.LanguageServer.TacticProviders import Ide.Plugin.Tactic.Range import Ide.Plugin.Tactic.Tactics -import Ide.Plugin.Tactic.TestTypes import Ide.Plugin.Tactic.Types import Ide.Types import Language.LSP.Server diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/LanguageServer.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/LanguageServer.hs index 916aebed53..80b12e7ed5 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/LanguageServer.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/LanguageServer.hs @@ -45,7 +45,6 @@ import Ide.Plugin.Tactic.FeatureSet import Ide.Plugin.Tactic.GHC import Ide.Plugin.Tactic.Judgements import Ide.Plugin.Tactic.Range -import Ide.Plugin.Tactic.TestTypes (TacticCommand, cfg_feature_set, emptyConfig, Config) import Ide.Plugin.Tactic.Types import Language.LSP.Server (MonadLsp) import Language.LSP.Types diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/LanguageServer/TacticProviders.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/LanguageServer/TacticProviders.hs index a1a530d55b..de4e3c66ee 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/LanguageServer/TacticProviders.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/LanguageServer/TacticProviders.hs @@ -31,7 +31,6 @@ import Ide.Plugin.Tactic.FeatureSet import Ide.Plugin.Tactic.GHC import Ide.Plugin.Tactic.Judgements import Ide.Plugin.Tactic.Tactics -import Ide.Plugin.Tactic.TestTypes import Ide.Plugin.Tactic.Types import Ide.PluginUtils import Ide.Types diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/TestTypes.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/TestTypes.hs deleted file mode 100644 index 1f151e96c4..0000000000 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/TestTypes.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -module Ide.Plugin.Tactic.TestTypes where - -import Data.Aeson -import Data.Maybe (fromMaybe) -import qualified Data.Text as T -import Ide.Plugin.Tactic.FeatureSet - ------------------------------------------------------------------------------- --- | The list of tactics exposed to the outside world. These are attached to --- actual tactics via 'commandTactic' and are contextually provided to the --- editor via 'commandProvider'. -data TacticCommand - = Auto - | Intros - | Destruct - | Homomorphism - | DestructLambdaCase - | HomomorphismLambdaCase - | DestructAll - | UseDataCon - | Refine - deriving (Eq, Ord, Show, Enum, Bounded) - --- | Generate a title for the command. -tacticTitle :: TacticCommand -> T.Text -> T.Text -tacticTitle Auto _ = "Attempt to fill hole" -tacticTitle Intros _ = "Introduce lambda" -tacticTitle Destruct var = "Case split on " <> var -tacticTitle Homomorphism var = "Homomorphic case split on " <> var -tacticTitle DestructLambdaCase _ = "Lambda case split" -tacticTitle HomomorphismLambdaCase _ = "Homomorphic lambda case split" -tacticTitle DestructAll _ = "Split all function arguments" -tacticTitle UseDataCon dcon = "Use constructor " <> dcon -tacticTitle Refine _ = "Refine hole" - - ------------------------------------------------------------------------------- --- | Plugin configuration for tactics -data Config = Config - { cfg_feature_set :: FeatureSet - , cfg_max_use_ctor_actions :: Int - } - -emptyConfig :: Config -emptyConfig = Config defaultFeatures 5 - -instance ToJSON Config where - toJSON Config{..} = object - [ "features" .= prettyFeatureSet cfg_feature_set - , "max_use_ctor_actions" .= cfg_max_use_ctor_actions - ] - -instance FromJSON Config where - parseJSON = withObject "Config" $ \obj -> do - cfg_feature_set <- - parseFeatureSet . fromMaybe "" <$> obj .:? "features" - cfg_max_use_ctor_actions <- - fromMaybe 5 <$> obj .:? "max_use_ctor_actions" - pure $ Config{..} - diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Types.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Types.hs index 92a1f66c88..1dead7f8e4 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Types.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Types.hs @@ -8,7 +8,9 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} + {-# OPTIONS_GHC -fno-warn-orphans #-} module Ide.Plugin.Tactic.Types @@ -22,29 +24,88 @@ module Ide.Plugin.Tactic.Types , Range ) where -import Control.Lens hiding (Context, (.=)) -import Control.Monad.Reader -import Control.Monad.State -import Data.Coerce -import Data.Function -import Data.Generics.Product (field) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Semigroup -import Data.Set (Set) -import Data.Tree -import Development.IDE.GHC.Compat hiding (Node) -import Development.IDE.GHC.Orphans () -import Development.IDE.Types.Location -import GHC.Generics -import GHC.SourceGen (var) -import Ide.Plugin.Tactic.Debug -import Ide.Plugin.Tactic.FeatureSet (FeatureSet) -import OccName -import Refinery.Tactic -import System.IO.Unsafe (unsafePerformIO) -import Type (TCvSubst, Var, eqType, nonDetCmpType, emptyTCvSubst) -import UniqSupply (takeUniqFromSupply, mkSplitUniqSupply, UniqSupply) -import Unique (nonDetCmpUnique, Uniquable, getUnique, Unique) +import Control.Lens hiding (Context, (.=)) +import Control.Monad.Reader +import Control.Monad.State +import Data.Aeson +import Data.Coerce +import Data.Function +import Data.Generics.Product (field) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe (fromMaybe) +import Data.Semigroup +import Data.Set (Set) +import qualified Data.Text as T +import Data.Tree +import Development.IDE.GHC.Compat hiding (Node) +import Development.IDE.GHC.Orphans () +import Development.IDE.Types.Location +import GHC.Generics +import GHC.SourceGen (var) +import Ide.Plugin.Tactic.Debug +import Ide.Plugin.Tactic.FeatureSet +import Ide.Plugin.Tactic.FeatureSet (FeatureSet) +import OccName +import Refinery.Tactic +import System.IO.Unsafe (unsafePerformIO) +import Type (TCvSubst, Var, eqType, nonDetCmpType, emptyTCvSubst) +import UniqSupply (takeUniqFromSupply, mkSplitUniqSupply, UniqSupply) +import Unique (nonDetCmpUnique, Uniquable, getUnique, Unique) + + +------------------------------------------------------------------------------ +-- | The list of tactics exposed to the outside world. These are attached to +-- actual tactics via 'commandTactic' and are contextually provided to the +-- editor via 'commandProvider'. +data TacticCommand + = Auto + | Intros + | Destruct + | Homomorphism + | DestructLambdaCase + | HomomorphismLambdaCase + | DestructAll + | UseDataCon + | Refine + deriving (Eq, Ord, Show, Enum, Bounded) + +-- | Generate a title for the command. +tacticTitle :: TacticCommand -> T.Text -> T.Text +tacticTitle Auto _ = "Attempt to fill hole" +tacticTitle Intros _ = "Introduce lambda" +tacticTitle Destruct var = "Case split on " <> var +tacticTitle Homomorphism var = "Homomorphic case split on " <> var +tacticTitle DestructLambdaCase _ = "Lambda case split" +tacticTitle HomomorphismLambdaCase _ = "Homomorphic lambda case split" +tacticTitle DestructAll _ = "Split all function arguments" +tacticTitle UseDataCon dcon = "Use constructor " <> dcon +tacticTitle Refine _ = "Refine hole" + + +------------------------------------------------------------------------------ +-- | Plugin configuration for tactics +data Config = Config + { cfg_feature_set :: FeatureSet + , cfg_max_use_ctor_actions :: Int + } + +emptyConfig :: Config +emptyConfig = Config defaultFeatures 5 + + +instance ToJSON Config where + toJSON Config{..} = object + [ "features" .= prettyFeatureSet cfg_feature_set + , "max_use_ctor_actions" .= cfg_max_use_ctor_actions + ] + +instance FromJSON Config where + parseJSON = withObject "Config" $ \obj -> do + cfg_feature_set <- + parseFeatureSet . fromMaybe "" <$> obj .:? "features" + cfg_max_use_ctor_actions <- + fromMaybe 5 <$> obj .:? "max_use_ctor_actions" + pure $ Config{..} ------------------------------------------------------------------------------ diff --git a/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs b/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs index 3a6cb93636..7e01a0a2eb 100644 --- a/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs +++ b/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs @@ -7,7 +7,7 @@ module CodeAction.AutoSpec where -import Ide.Plugin.Tactic.TestTypes +import Ide.Plugin.Tactic.Types import Test.Hspec import Utils diff --git a/plugins/hls-tactics-plugin/test/CodeAction/DestructAllSpec.hs b/plugins/hls-tactics-plugin/test/CodeAction/DestructAllSpec.hs index 4d8c60528b..77db7fa335 100644 --- a/plugins/hls-tactics-plugin/test/CodeAction/DestructAllSpec.hs +++ b/plugins/hls-tactics-plugin/test/CodeAction/DestructAllSpec.hs @@ -7,7 +7,7 @@ module CodeAction.DestructAllSpec where -import Ide.Plugin.Tactic.TestTypes +import Ide.Plugin.Tactic.Types import Test.Hspec import Utils diff --git a/plugins/hls-tactics-plugin/test/CodeAction/DestructSpec.hs b/plugins/hls-tactics-plugin/test/CodeAction/DestructSpec.hs index 653f6ab5ba..f330f1288a 100644 --- a/plugins/hls-tactics-plugin/test/CodeAction/DestructSpec.hs +++ b/plugins/hls-tactics-plugin/test/CodeAction/DestructSpec.hs @@ -7,7 +7,7 @@ module CodeAction.DestructSpec where -import Ide.Plugin.Tactic.TestTypes +import Ide.Plugin.Tactic.Types import Test.Hspec import Utils diff --git a/plugins/hls-tactics-plugin/test/CodeAction/IntrosSpec.hs b/plugins/hls-tactics-plugin/test/CodeAction/IntrosSpec.hs index 13af14b9ad..d209df207c 100644 --- a/plugins/hls-tactics-plugin/test/CodeAction/IntrosSpec.hs +++ b/plugins/hls-tactics-plugin/test/CodeAction/IntrosSpec.hs @@ -7,7 +7,7 @@ module CodeAction.IntrosSpec where -import Ide.Plugin.Tactic.TestTypes +import Ide.Plugin.Tactic.Types import Test.Hspec import Utils diff --git a/plugins/hls-tactics-plugin/test/CodeAction/RefineSpec.hs b/plugins/hls-tactics-plugin/test/CodeAction/RefineSpec.hs index f798315ce1..f779a21947 100644 --- a/plugins/hls-tactics-plugin/test/CodeAction/RefineSpec.hs +++ b/plugins/hls-tactics-plugin/test/CodeAction/RefineSpec.hs @@ -7,7 +7,7 @@ module CodeAction.RefineSpec where -import Ide.Plugin.Tactic.TestTypes +import Ide.Plugin.Tactic.Types import Test.Hspec import Utils diff --git a/plugins/hls-tactics-plugin/test/CodeAction/UseDataConSpec.hs b/plugins/hls-tactics-plugin/test/CodeAction/UseDataConSpec.hs index 6e5bbea70c..d3f9b110b7 100644 --- a/plugins/hls-tactics-plugin/test/CodeAction/UseDataConSpec.hs +++ b/plugins/hls-tactics-plugin/test/CodeAction/UseDataConSpec.hs @@ -8,7 +8,7 @@ module CodeAction.UseDataConSpec where import qualified Data.Text as T -import Ide.Plugin.Tactic.TestTypes +import Ide.Plugin.Tactic.Types import Test.Hspec import Utils diff --git a/plugins/hls-tactics-plugin/test/ProviderSpec.hs b/plugins/hls-tactics-plugin/test/ProviderSpec.hs index ceeffff401..3db52ebd6f 100644 --- a/plugins/hls-tactics-plugin/test/ProviderSpec.hs +++ b/plugins/hls-tactics-plugin/test/ProviderSpec.hs @@ -7,7 +7,7 @@ module ProviderSpec where -import Ide.Plugin.Tactic.TestTypes +import Ide.Plugin.Tactic.Types import Test.Hspec import Utils diff --git a/plugins/hls-tactics-plugin/test/Utils.hs b/plugins/hls-tactics-plugin/test/Utils.hs index 20dc0e3437..f11ecb34c6 100644 --- a/plugins/hls-tactics-plugin/test/Utils.hs +++ b/plugins/hls-tactics-plugin/test/Utils.hs @@ -20,7 +20,7 @@ import Data.Text (Text) import qualified Data.Text.IO as T import qualified Ide.Plugin.Config as Plugin import Ide.Plugin.Tactic.FeatureSet (FeatureSet, allFeatures) -import Ide.Plugin.Tactic.TestTypes +import Ide.Plugin.Tactic.Types import Language.LSP.Test import Language.LSP.Types import Language.LSP.Types.Lens hiding (actions, applyEdit, capabilities, executeCommand, id, line, message, name, rename, title)