From fd43c6373af2be5f4d9186405193ffbf3f4a9468 Mon Sep 17 00:00:00 2001 From: Sandy Maguire Date: Tue, 8 Jun 2021 16:37:29 -0700 Subject: [PATCH] Remove FeatureSet It's what Hamming would have wanted --- .../hls-tactics-plugin.cabal | 1 - .../src/Wingman/EmptyCase.hs | 3 - .../src/Wingman/FeatureSet.hs | 99 ------------------- .../src/Wingman/KnownStrategies.hs | 23 ++--- .../src/Wingman/LanguageServer.hs | 12 +-- .../src/Wingman/LanguageServer/Metaprogram.hs | 2 - .../Wingman/LanguageServer/TacticProviders.hs | 41 +++----- .../hls-tactics-plugin/src/Wingman/Types.hs | 11 +-- .../test/CodeAction/AutoSpec.hs | 3 +- .../test/CodeAction/RefineSpec.hs | 3 +- .../test/CodeLens/EmptyCaseSpec.hs | 3 +- plugins/hls-tactics-plugin/test/Utils.hs | 37 ++----- 12 files changed, 33 insertions(+), 205 deletions(-) delete mode 100644 plugins/hls-tactics-plugin/src/Wingman/FeatureSet.hs diff --git a/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal b/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal index ee9bb2be28..6e12994da1 100644 --- a/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal +++ b/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal @@ -34,7 +34,6 @@ library Wingman.Context Wingman.Debug Wingman.EmptyCase - Wingman.FeatureSet Wingman.GHC Wingman.Judgements Wingman.Judgements.SYB diff --git a/plugins/hls-tactics-plugin/src/Wingman/EmptyCase.hs b/plugins/hls-tactics-plugin/src/Wingman/EmptyCase.hs index fdfdcc4c65..4ffc0e6c7a 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/EmptyCase.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/EmptyCase.hs @@ -32,7 +32,6 @@ import Prelude hiding (span) import Prelude hiding (span) import TcRnTypes (tcg_binds) import Wingman.CodeGen (destructionFor) -import Wingman.FeatureSet import Wingman.GHC import Wingman.Judgements import Wingman.LanguageServer @@ -63,8 +62,6 @@ codeLensProvider state plId (CodeLensParams _ _ (TextDocumentIdentifier uri)) cfg <- getTacticConfig plId ccs <- getClientCapabilities liftIO $ fromMaybeT (Right $ List []) $ do - guard $ hasFeature FeatureEmptyCase $ cfg_feature_set cfg - dflags <- getIdeDynflags state nfp TrackedStale pm _ <- stale GetAnnotatedParsedSource TrackedStale binds bind_map <- stale GetBindings diff --git a/plugins/hls-tactics-plugin/src/Wingman/FeatureSet.hs b/plugins/hls-tactics-plugin/src/Wingman/FeatureSet.hs deleted file mode 100644 index 1bde1a06ca..0000000000 --- a/plugins/hls-tactics-plugin/src/Wingman/FeatureSet.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Wingman.FeatureSet - ( Feature (..) - , FeatureSet - , hasFeature - , defaultFeatures - , allFeatures - , parseFeatureSet - , prettyFeatureSet - ) where - -import Data.List (intercalate) -import Data.Maybe (listToMaybe, mapMaybe) -import Data.Set (Set) -import qualified Data.Set as S -import qualified Data.Text as T - - ------------------------------------------------------------------------------- --- | All the available features. A 'FeatureSet' describes the ones currently --- available to the user. -data Feature - = FeatureDestructAll - | FeatureUseDataCon - | FeatureRefineHole - | FeatureKnownMonoid - | FeatureEmptyCase - | FeatureDestructPun - | FeatureMetaprogram - deriving (Eq, Ord, Show, Read, Enum, Bounded) - - ------------------------------------------------------------------------------- --- | A collection of enabled features. -type FeatureSet = Set Feature - - ------------------------------------------------------------------------------- --- | Parse a feature set. -parseFeatureSet :: T.Text -> FeatureSet -parseFeatureSet - = mappend defaultFeatures - . S.fromList - . mapMaybe (readMaybe . mappend featurePrefix . rot13 . T.unpack) - . T.split (== '/') - - ------------------------------------------------------------------------------- --- | Features that are globally enabled for all users. -defaultFeatures :: FeatureSet -defaultFeatures = S.fromList - [ FeatureDestructAll - , FeatureUseDataCon - , FeatureRefineHole - ] - - ------------------------------------------------------------------------------- --- | All available features. -allFeatures :: FeatureSet -allFeatures = S.fromList $ enumFromTo minBound maxBound - - ------------------------------------------------------------------------------- --- | Pretty print a feature set. -prettyFeatureSet :: FeatureSet -> String -prettyFeatureSet - = intercalate "/" - . fmap (rot13 . drop (length featurePrefix) . show) - . S.toList - - ------------------------------------------------------------------------------- --- | Is a given 'Feature' currently enabled? -hasFeature :: Feature -> FeatureSet -> Bool -hasFeature = S.member - - ------------------------------------------------------------------------------- --- | Like 'read', but not partial. -readMaybe :: Read a => String -> Maybe a -readMaybe = fmap fst . listToMaybe . reads - - -featurePrefix :: String -featurePrefix = "Feature" - - -rot13 :: String -> String -rot13 = fmap (toEnum . rot13int . fromEnum) - - -rot13int :: Integral a => a -> a -rot13int x - | (fromIntegral x :: Word) - 97 < 26 = 97 + rem (x - 84) 26 - | (fromIntegral x :: Word) - 65 < 26 = 65 + rem (x - 52) 26 - | otherwise = x - diff --git a/plugins/hls-tactics-plugin/src/Wingman/KnownStrategies.hs b/plugins/hls-tactics-plugin/src/Wingman/KnownStrategies.hs index 780b58c891..2ad926ce74 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/KnownStrategies.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/KnownStrategies.hs @@ -1,18 +1,17 @@ module Wingman.KnownStrategies where +import Control.Applicative (empty) import Control.Monad.Error.Class +import Control.Monad.Reader.Class (asks) +import Data.Foldable (for_) import OccName (mkVarOcc) import Refinery.Tactic import Wingman.Context (getCurrentDefinitions, getKnownInstance) +import Wingman.Judgements (jGoal) import Wingman.KnownStrategies.QuickCheck (deriveArbitrary) import Wingman.Machinery (tracing) import Wingman.Tactics import Wingman.Types -import Wingman.Judgements (jGoal) -import Data.Foldable (for_) -import Wingman.FeatureSet -import Control.Applicative (empty) -import Control.Monad.Reader.Class (asks) knownStrategies :: TacticsM () @@ -20,21 +19,11 @@ knownStrategies = choice [ known "fmap" deriveFmap , known "mempty" deriveMempty , known "arbitrary" deriveArbitrary - , featureGuard FeatureKnownMonoid $ known "<>" deriveMappend - , featureGuard FeatureKnownMonoid $ known "mappend" deriveMappend + , known "<>" deriveMappend + , known "mappend" deriveMappend ] ------------------------------------------------------------------------------- --- | Guard a tactic behind a feature. -featureGuard :: Feature -> TacticsM a -> TacticsM a -featureGuard feat t = do - fs <- asks $ cfg_feature_set . ctxConfig - case hasFeature feat fs of - True -> t - False -> empty - - known :: String -> TacticsM () -> TacticsM () known name t = do getCurrentDefinitions >>= \case diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs index c7052a7070..cef799857e 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs @@ -61,7 +61,6 @@ import Retrie (transformA) import SrcLoc (containsSpan) import TcRnTypes (tcg_binds, TcGblEnv (tcg_rdr_env)) import Wingman.Context -import Wingman.FeatureSet import Wingman.GHC import Wingman.Judgements import Wingman.Judgements.SYB (everythingContaining, metaprogramQ) @@ -137,7 +136,6 @@ unsafeRunStaleIde herald state nfp a = do properties :: Properties '[ 'PropertyKey "hole_severity" ('TEnum (Maybe DiagnosticSeverity)) , 'PropertyKey "max_use_ctor_actions" 'TInteger - , 'PropertyKey "features" 'TString , 'PropertyKey "timeout_duration" 'TInteger , 'PropertyKey "auto_gas" 'TInteger ] @@ -146,8 +144,6 @@ properties = emptyProperties "The depth of the search tree when performing \"Attempt to fill hole\". Bigger values will be able to derive more solutions, but will take exponentially more time." 4 & defineIntegerProperty #timeout_duration "The timeout for Wingman actions, in seconds" 2 - & defineStringProperty #features - "Feature set used by Wingman" "" & defineIntegerProperty #max_use_ctor_actions "Maximum number of `Use constructor ` code actions that can appear" 5 & defineEnumProperty #hole_severity @@ -165,16 +161,10 @@ properties = emptyProperties getTacticConfig :: MonadLsp Plugin.Config m => PluginId -> m Config getTacticConfig pId = Config - <$> (parseFeatureSet <$> usePropertyLsp #features pId properties) - <*> usePropertyLsp #max_use_ctor_actions pId properties + <$> usePropertyLsp #max_use_ctor_actions pId properties <*> usePropertyLsp #timeout_duration pId properties <*> usePropertyLsp #auto_gas pId properties ------------------------------------------------------------------------------- --- | Get the current feature set from the plugin config. -getFeatureSet :: MonadLsp Plugin.Config m => PluginId -> m FeatureSet -getFeatureSet = fmap cfg_feature_set . getTacticConfig - getIdeDynflags :: IdeState diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/Metaprogram.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/Metaprogram.hs index c54d82973f..a84d274e24 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/Metaprogram.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/Metaprogram.hs @@ -45,8 +45,6 @@ hoverProvider state plId (HoverParams (TextDocumentIdentifier uri) (unsafeMkCurr cfg <- getTacticConfig plId liftIO $ fromMaybeT (Right Nothing) $ do - -- guard $ hasFeature FeatureEmptyCase $ cfg_feature_set cfg - holes <- getMetaprogramsAtSpan state nfp $ RealSrcSpan $ unTrack loc fmap (Right . Just) $ diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/TacticProviders.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/TacticProviders.hs index cad31a0107..a3bcad4c58 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/TacticProviders.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/TacticProviders.hs @@ -12,6 +12,7 @@ module Wingman.LanguageServer.TacticProviders ) where import Control.Monad +import Control.Monad.Reader (runReaderT) import Data.Aeson import Data.Bool (bool) import Data.Coerce @@ -30,7 +31,6 @@ import Language.LSP.Types import OccName import Prelude hiding (span) import Wingman.Auto -import Wingman.FeatureSet import Wingman.GHC import Wingman.Judgements import Wingman.Machinery (useNameFromHypothesis) @@ -38,7 +38,6 @@ import Wingman.Metaprogramming.Lexer (ParserContext) import Wingman.Metaprogramming.Parser (parseMetaprogram) import Wingman.Tactics import Wingman.Types -import Control.Monad.Reader (runReaderT) ------------------------------------------------------------------------------ @@ -115,7 +114,6 @@ commandProvider Destruct = provide Destruct $ T.pack $ occNameString occ commandProvider DestructPun = requireHoleSort (== Hole) $ - requireFeature FeatureDestructPun $ filterBindingType destructPunFilter $ \occ _ -> provide DestructPun $ T.pack $ occNameString occ commandProvider Homomorphism = @@ -134,7 +132,6 @@ commandProvider HomomorphismLambdaCase = provide HomomorphismLambdaCase "" commandProvider DestructAll = requireHoleSort (== Hole) $ - requireFeature FeatureDestructAll $ withJudgement $ \jdg -> case _jIsTopHole jdg && jHasBoundArgs jdg of True -> provide DestructAll "" @@ -142,30 +139,26 @@ commandProvider DestructAll = commandProvider UseDataCon = requireHoleSort (== Hole) $ withConfig $ \cfg -> - requireFeature FeatureUseDataCon $ - filterTypeProjection - ( guardLength (<= cfg_max_use_ctor_actions cfg) - . fromMaybe [] - . fmap fst - . tacticsGetDataCons - ) $ \dcon -> - provide UseDataCon - . T.pack - . occNameString - . occName - $ dataConName dcon + filterTypeProjection + ( guardLength (<= cfg_max_use_ctor_actions cfg) + . fromMaybe [] + . fmap fst + . tacticsGetDataCons + ) $ \dcon -> + provide UseDataCon + . T.pack + . occNameString + . occName + $ dataConName dcon commandProvider Refine = requireHoleSort (== Hole) $ - requireFeature FeatureRefineHole $ provide Refine "" commandProvider BeginMetaprogram = requireGHC88OrHigher $ - requireFeature FeatureMetaprogram $ requireHoleSort (== Hole) $ provide BeginMetaprogram "" commandProvider RunMetaprogram = requireGHC88OrHigher $ - requireFeature FeatureMetaprogram $ withMetaprogram $ \mp -> provide RunMetaprogram mp @@ -213,16 +206,6 @@ data TacticParams = TacticParams deriving anyclass (ToJSON, FromJSON) ------------------------------------------------------------------------------- --- | Restrict a 'TacticProvider', making sure it appears only when the given --- 'Feature' is in the feature set. -requireFeature :: Feature -> TacticProvider -> TacticProvider -requireFeature f tp tpd = - case hasFeature f $ cfg_feature_set $ tpd_config tpd of - True -> tp tpd - False -> pure [] - - requireHoleSort :: (HoleSort -> Bool) -> TacticProvider -> TacticProvider requireHoleSort p tp tpd = case p $ tpd_hole_sort tpd of diff --git a/plugins/hls-tactics-plugin/src/Wingman/Types.hs b/plugins/hls-tactics-plugin/src/Wingman/Types.hs index bfea1afe4c..e1fbc9807b 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Types.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Types.hs @@ -26,6 +26,8 @@ import Data.Set (Set) import Data.Text (Text) import qualified Data.Text as T import Data.Tree +import Development.IDE (Range) +import Development.IDE.Core.UseStale import Development.IDE.GHC.Compat hiding (Node) import Development.IDE.GHC.Orphans () import GHC.Generics @@ -38,9 +40,6 @@ import Type (TCvSubst, Var, eqType, nonDetCmpType, emptyTCvSubst) import UniqSupply (takeUniqFromSupply, mkSplitUniqSupply, UniqSupply) import Unique (nonDetCmpUnique, Uniquable, getUnique, Unique) import Wingman.Debug -import Wingman.FeatureSet -import Development.IDE.Core.UseStale -import Development.IDE (Range) ------------------------------------------------------------------------------ @@ -83,8 +82,7 @@ tacticTitle = (mappend "Wingman: " .) . go ------------------------------------------------------------------------------ -- | Plugin configuration for tactics data Config = Config - { cfg_feature_set :: FeatureSet - , cfg_max_use_ctor_actions :: Int + { cfg_max_use_ctor_actions :: Int , cfg_timeout_seconds :: Int , cfg_auto_gas :: Int } @@ -92,8 +90,7 @@ data Config = Config emptyConfig :: Config emptyConfig = Config - { cfg_feature_set = mempty - , cfg_max_use_ctor_actions = 5 + { cfg_max_use_ctor_actions = 5 , cfg_timeout_seconds = 2 , cfg_auto_gas = 4 } diff --git a/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs b/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs index 5c6b6efff5..b7be9f1fee 100644 --- a/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs +++ b/plugins/hls-tactics-plugin/test/CodeAction/AutoSpec.hs @@ -5,7 +5,6 @@ module CodeAction.AutoSpec where import Wingman.Types import Test.Hspec import Utils -import Wingman.FeatureSet (allFeatures) spec :: Spec @@ -81,5 +80,5 @@ spec = do describe "messages" $ do - mkShowMessageTest allFeatures Auto "" 2 8 "MessageForallA" TacticErrors + mkShowMessageTest Auto "" 2 8 "MessageForallA" TacticErrors diff --git a/plugins/hls-tactics-plugin/test/CodeAction/RefineSpec.hs b/plugins/hls-tactics-plugin/test/CodeAction/RefineSpec.hs index e0f69a5780..32e5620b56 100644 --- a/plugins/hls-tactics-plugin/test/CodeAction/RefineSpec.hs +++ b/plugins/hls-tactics-plugin/test/CodeAction/RefineSpec.hs @@ -5,7 +5,6 @@ module CodeAction.RefineSpec where import Wingman.Types import Test.Hspec import Utils -import Wingman.FeatureSet (allFeatures) spec :: Spec @@ -19,5 +18,5 @@ spec = do refineTest 8 10 "RefineGADT" describe "messages" $ do - mkShowMessageTest allFeatures Refine "" 2 8 "MessageForallA" TacticErrors + mkShowMessageTest Refine "" 2 8 "MessageForallA" TacticErrors diff --git a/plugins/hls-tactics-plugin/test/CodeLens/EmptyCaseSpec.hs b/plugins/hls-tactics-plugin/test/CodeLens/EmptyCaseSpec.hs index 66901defcd..cda80ab5d7 100644 --- a/plugins/hls-tactics-plugin/test/CodeLens/EmptyCaseSpec.hs +++ b/plugins/hls-tactics-plugin/test/CodeLens/EmptyCaseSpec.hs @@ -4,12 +4,11 @@ module CodeLens.EmptyCaseSpec where import Test.Hspec import Utils -import Wingman.FeatureSet (allFeatures) spec :: Spec spec = do - let test = mkCodeLensTest allFeatures + let test = mkCodeLensTest describe "golden" $ do test "EmptyCaseADT" diff --git a/plugins/hls-tactics-plugin/test/Utils.hs b/plugins/hls-tactics-plugin/test/Utils.hs index d2f7356563..c1832503a6 100644 --- a/plugins/hls-tactics-plugin/test/Utils.hs +++ b/plugins/hls-tactics-plugin/test/Utils.hs @@ -29,7 +29,6 @@ import System.FilePath import Test.Hls import Test.Hspec import Test.Hspec.Formatters (FailureReason(ExpectedButGot)) -import Wingman.FeatureSet (FeatureSet, allFeatures, prettyFeatureSet) import Wingman.LanguageServer (mkShowMessageParams) import Wingman.Types @@ -71,7 +70,6 @@ mkTest -> SpecWith (Arg Bool) mkTest name fp line col ts = it name $ do runSessionWithServer plugin tacticPath $ do - setFeatureSet allFeatures doc <- openDoc (fp <.> "hs") "haskell" _ <- waitForDiagnostics actions <- getCodeActions doc $ pointRange line col @@ -82,35 +80,18 @@ mkTest name fp line col ts = it name $ do (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 $ object ["features" .= prettyFeatureSet features] } - )] <> Plugin.plugins def_config } - - sendNotification SWorkspaceDidChangeConfiguration $ - DidChangeConfigurationParams $ - toJSON config - mkGoldenTest :: (Text -> Text -> Assertion) - -> FeatureSet -> TacticCommand -> Text -> Int -> Int -> FilePath -> SpecWith () -mkGoldenTest eq features tc occ line col input = +mkGoldenTest eq tc occ line col input = it (input <> " (golden)") $ do runSessionWithServer plugin tacticPath $ do - setFeatureSet features doc <- openDoc (input <.> "hs") "haskell" _ <- waitForDiagnostics actions <- getCodeActions doc $ pointRange line col @@ -128,13 +109,11 @@ mkGoldenTest eq features tc occ line col input = mkCodeLensTest - :: FeatureSet - -> FilePath + :: FilePath -> SpecWith () -mkCodeLensTest features input = +mkCodeLensTest input = it (input <> " (golden)") $ do runSessionWithServer plugin tacticPath $ do - setFeatureSet features doc <- openDoc (input <.> "hs") "haskell" _ <- waitForDiagnostics lenses <- fmap (reverse . filter isWingmanLens) $ getCodeLenses doc @@ -158,18 +137,16 @@ isWingmanLens _ = False mkShowMessageTest - :: FeatureSet - -> TacticCommand + :: TacticCommand -> Text -> Int -> Int -> FilePath -> UserFacingMessage -> SpecWith () -mkShowMessageTest features tc occ line col input ufm = +mkShowMessageTest tc occ line col input ufm = it (input <> " (golden)") $ do runSessionWithServer plugin tacticPath $ do - setFeatureSet features doc <- openDoc (input <.> "hs") "haskell" _ <- waitForDiagnostics actions <- getCodeActions doc $ pointRange line col @@ -181,10 +158,10 @@ mkShowMessageTest features tc occ line col input ufm = goldenTest :: TacticCommand -> Text -> Int -> Int -> FilePath -> SpecWith () -goldenTest = mkGoldenTest shouldBe allFeatures +goldenTest = mkGoldenTest shouldBe goldenTestNoWhitespace :: TacticCommand -> Text -> Int -> Int -> FilePath -> SpecWith () -goldenTestNoWhitespace = mkGoldenTest shouldBeIgnoringSpaces allFeatures +goldenTestNoWhitespace = mkGoldenTest shouldBeIgnoringSpaces shouldBeIgnoringSpaces :: Text -> Text -> Assertion