diff --git a/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal b/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal index 54b7d43e8a..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 @@ -101,8 +100,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/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 new file mode 100644 index 0000000000..7e01a0a2eb --- /dev/null +++ b/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +module CodeAction.AutoSpec where + +import Ide.Plugin.Tactic.Types +import Test.Hspec +import Utils + + +spec :: Spec +spec = do + let autoTest = goldenTest Auto "" + + 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..77db7fa335 --- /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.Types +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 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 new file mode 100644 index 0000000000..f330f1288a --- /dev/null +++ b/plugins/hls-tactics-plugin/test/CodeAction/DestructSpec.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +module CodeAction.DestructSpec where + +import Ide.Plugin.Tactic.Types +import Test.Hspec +import Utils + + +spec :: Spec +spec = do + let destructTest = goldenTest Destruct + + describe "golden" $ do + destructTest "gadt" 7 17 "GoldenGADTDestruct.hs" + destructTest "gadt" 8 17 "GoldenGADTDestructCoercion.hs" + destructTest "a" 7 25 "SplitPattern.hs" + + describe "layout" $ do + 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 new file mode 100644 index 0000000000..d209df207c --- /dev/null +++ b/plugins/hls-tactics-plugin/test/CodeAction/IntrosSpec.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +module CodeAction.IntrosSpec where + +import Ide.Plugin.Tactic.Types +import Test.Hspec +import Utils + + +spec :: Spec +spec = do + let introsTest = goldenTest Intros "" + + describe "golden" $ do + 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 new file mode 100644 index 0000000000..f779a21947 --- /dev/null +++ b/plugins/hls-tactics-plugin/test/CodeAction/RefineSpec.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +module CodeAction.RefineSpec where + +import Ide.Plugin.Tactic.Types +import Test.Hspec +import Utils + + +spec :: Spec +spec = do + let refineTest = goldenTest Refine "" + + describe "golden" $ do + 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 new file mode 100644 index 0000000000..d3f9b110b7 --- /dev/null +++ b/plugins/hls-tactics-plugin/test/CodeAction/UseDataConSpec.hs @@ -0,0 +1,47 @@ +{-# 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.Types +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 "(,)" 2 8 "UseConPair.hs" + useTest "Left" 2 8 "UseConLeft.hs" + useTest "Right" 2 8 "UseConRight.hs" + 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..3db52ebd6f --- /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.Types +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..f11ecb34c6 --- /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.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) +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 + -> Int + -> Int + -> FilePath + -> SpecWith () +mkGoldenTest features tc occ line col input = + 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 -> Int -> Int -> FilePath -> 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 +