Make Tactics tests run with a full feature set

Author: isovector

haskell-language-server.cabal

@@ -462,6 +462,7 @@ test-suite func-test
     Splice
     HaddockComments
     Ide.Plugin.Splice.Types
+    Ide.Plugin.Tactic.FeatureSet
     Ide.Plugin.Tactic.TestTypes
     Ide.Plugin.Eval.Types
 

plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/FeatureSet.hs

@@ -7,6 +7,7 @@ module Ide.Plugin.Tactic.FeatureSet
   , FeatureSet
   , hasFeature
   , defaultFeatures
+  , allFeatures
   , parseFeatureSet
   , prettyFeatureSet
   ) where

plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/LanguageServer.hs

@@ -9,6 +9,8 @@ module Ide.Plugin.Tactic.LanguageServer where
 import           Control.Arrow
 import           Control.Monad
 import           Control.Monad.Trans.Maybe
+import           Data.Aeson (Value(Object), fromJSON)
+import           Data.Aeson.Types (Result(Success, Error))
 import           Data.Coerce
 import           Data.Functor ((<&>))
 import           Data.Generics.Aliases (mkQ)
@@ -30,24 +32,22 @@ import           Development.IDE.Spans.LocalBindings (Bindings, getDefiningBindi
 import           Development.Shake (RuleResult, Action)
 import           Development.Shake.Classes
 import qualified FastString
+import           Ide.Plugin.Config (PluginConfig(plcConfig))
+import qualified Ide.Plugin.Config as Plugin
 import           Ide.Plugin.Tactic.Context
 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)
+import           Ide.Plugin.Tactic.TestTypes (cfg_feature_set, TacticCommand)
 import           Ide.Plugin.Tactic.Types
 import           Ide.PluginUtils (getPluginConfig)
+import           Language.LSP.Server (MonadLsp)
 import           Language.LSP.Types
 import           OccName
 import           Prelude hiding (span)
 import           SrcLoc (containsSpan)
 import           TcRnTypes (tcg_binds)
-import Ide.Plugin.Config (PluginConfig(plcConfig))
-import qualified Ide.Plugin.Config as Plugin
-import Data.Aeson (Value(Object), fromJSON)
-import Data.Aeson.Types (Result(Success, Error))
-import Language.LSP.Server (MonadLsp)
 
 
 tacticDesc :: T.Text -> T.Text

plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/TestTypes.hs

@@ -3,6 +3,8 @@
 module Ide.Plugin.Tactic.TestTypes where
 
 import qualified Data.Text as T
+import Data.Aeson
+import Ide.Plugin.Tactic.FeatureSet
 
 ------------------------------------------------------------------------------
 -- | The list of tactics exposed to the outside world. These are attached to
@@ -25,3 +27,24 @@ 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"
+
+
+------------------------------------------------------------------------------
+-- | Plugin configuration for tactics
+newtype Config = Config
+  { cfg_feature_set :: FeatureSet
+  }
+
+emptyConfig :: Config
+emptyConfig = Config defaultFeatures
+
+instance ToJSON Config where
+  toJSON (Config features) = object
+    [ "features" .= prettyFeatureSet features
+    ]
+
+instance FromJSON Config where
+  parseJSON = withObject "Config" $ \obj -> do
+    features <- parseFeatureSet <$> obj .: "features"
+    pure $ Config features
+

plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Types.hs

@@ -388,23 +388,3 @@ data AgdaMatch = AgdaMatch
   }
   deriving (Show)
 
-
-------------------------------------------------------------------------------
--- | Plugin configuration for tactics
-newtype Config = Config
-  { cfg_feature_set :: FeatureSet
-  }
-
-emptyConfig :: Config
-emptyConfig = Config defaultFeatures
-
-instance ToJSON Config where
-  toJSON (Config features) = object
-    [ "features" .= prettyFeatureSet features
-    ]
-
-instance FromJSON Config where
-  parseJSON = withObject "Config" $ \obj -> do
-    features <- parseFeatureSet <$> obj .: "features"
-    pure $ Config features
-

test/functional/Tactic.hs

@@ -15,12 +15,16 @@ import           Control.Lens hiding ((<.>))
 import           Control.Monad (unless)
 import           Control.Monad.IO.Class
 import           Data.Aeson
+import           Data.Default (Default(def))
 import           Data.Either (isLeft)
 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
@@ -154,10 +158,30 @@ mkTest name fp line col ts =
           @? ("Expected a code action with title " <> T.unpack title)
 
 
+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
+
 goldenTest :: FilePath -> Int -> Int -> TacticCommand -> Text -> TestTree
-goldenTest input line col tc occ =
+goldenTest = goldenTest' allFeatures
+
+goldenTest' :: FeatureSet -> FilePath -> Int -> Int -> TacticCommand -> Text -> TestTree
+goldenTest' features input line col tc occ =
   testCase (input <> " (golden)") $ do
     runSession hlsCommand fullCaps tacticPath $ do
+      setFeatureSet features
       doc <- openDoc input "haskell"
       _ <- waitForDiagnostics
       actions <- getCodeActions doc $ pointRange line col