Implement "use constructor" code action

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

@@ -13,30 +13,28 @@ module Ide.Plugin.Tactic
   , TacticCommand (..)
   ) where
 
-import           Bag                                              (bagToList,
-                                                                   listToBag)
-import           Control.Exception                                (evaluate)
+import           Bag (bagToList, listToBag)
+import           Control.Exception (evaluate)
 import           Control.Monad
 import           Control.Monad.Trans
 import           Control.Monad.Trans.Maybe
 import           Data.Aeson
-import           Data.Bifunctor                                   (Bifunctor (bimap))
-import           Data.Bool                                        (bool)
-import           Data.Data                                        (Data)
+import           Data.Bifunctor (Bifunctor (bimap))
+import           Data.Bool (bool)
+import           Data.Data (Data)
 import           Data.Foldable (for_)
-import           Data.Generics.Aliases                            (mkQ)
-import           Data.Generics.Schemes                            (everything)
+import           Data.Generics.Aliases (mkQ)
+import           Data.Generics.Schemes (everything)
 import           Data.Maybe
 import           Data.Monoid
-import qualified Data.Text                                        as T
+import qualified Data.Text as T
 import           Data.Traversable
-import           Development.IDE.Core.Shake                       (IdeState (..))
+import           Development.IDE.Core.Shake (IdeState (..))
 import           Development.IDE.GHC.Compat
 import           Development.IDE.GHC.ExactPrint
 import           Development.Shake.Classes
 import           Ide.Plugin.Tactic.CaseSplit
-import           Ide.Plugin.Tactic.FeatureSet                     (Feature (..),
-                                                                   hasFeature)
+import           Ide.Plugin.Tactic.FeatureSet (Feature (..), hasFeature)
 import           Ide.Plugin.Tactic.GHC
 import           Ide.Plugin.Tactic.LanguageServer
 import           Ide.Plugin.Tactic.LanguageServer.TacticProviders
@@ -49,7 +47,7 @@ import           Language.LSP.Server
 import           Language.LSP.Types
 import           Language.LSP.Types.Capabilities
 import           OccName
-import           Prelude                                          hiding (span)
+import           Prelude hiding (span)
 import           System.Timeout
 
 
@@ -71,14 +69,14 @@ descriptor plId = (defaultPluginDescriptor plId)
 codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction
 codeActionProvider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range _ctx)
   | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do
-      features <- getFeatureSet (shakeExtras state)
+      cfg <- getTacticConfig $ shakeExtras state
       liftIO $ fromMaybeT (Right $ List []) $ do
-        (_, jdg, _, dflags) <- judgementForHole state nfp range features
+        (_, jdg, _, dflags) <- judgementForHole state nfp range $ cfg_feature_set cfg
         actions <- lift $
           -- This foldMap is over the function monoid.
           foldMap commandProvider [minBound .. maxBound]
             dflags
-            features
+            cfg
             plId
             uri
             range

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

@@ -44,7 +44,7 @@ import           Ide.Plugin.Tactic.GHC
 import           Ide.Plugin.Tactic.Judgements
 import           Ide.Plugin.Tactic.Range
 import           Ide.Plugin.Tactic.TestTypes          (TacticCommand,
-                                                       cfg_feature_set)
+                                                       cfg_feature_set, emptyConfig, Config)
 import           Ide.Plugin.Tactic.Types
 import           Language.LSP.Server                  (MonadLsp)
 import           Language.LSP.Types
@@ -82,13 +82,19 @@ runStaleIde state nfp a = MaybeT $ runIde state $ useWithStale a nfp
 
 
 ------------------------------------------------------------------------------
--- | Get the current feature set from the plugin config.
-getFeatureSet :: MonadLsp Plugin.Config m => ShakeExtras -> m FeatureSet
-getFeatureSet extras = do
+-- | Get the the plugin config
+getTacticConfig :: MonadLsp Plugin.Config m => ShakeExtras -> m Config
+getTacticConfig extras = do
   pcfg <- getPluginConfig extras "tactics"
   pure $ case fromJSON $ Object $ plcConfig pcfg of
-    Success cfg -> cfg_feature_set cfg
-    Error _     -> defaultFeatures
+    Success cfg -> cfg
+    Error _     -> emptyConfig
+
+
+------------------------------------------------------------------------------
+-- | Get the current feature set from the plugin config.
+getFeatureSet :: MonadLsp Plugin.Config m => ShakeExtras -> m FeatureSet
+getFeatureSet  = fmap cfg_feature_set . getTacticConfig
 
 
 getIdeDynflags

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

@@ -76,18 +76,19 @@ commandProvider HomomorphismLambdaCase =
     filterGoalType ((== Just True) . lambdaCaseable) $
       provide HomomorphismLambdaCase ""
 commandProvider UseDataCon =
-  requireFeature FeatureUseDataCon $
-    filterTypeProjection
-        ( guardLength (<= 5)
-        . fromMaybe []
-        . fmap fst
-        . tacticsGetDataCons
-        ) $ \dcon ->
-      provide UseDataCon
-        . T.pack
-        . occNameString
-        . occName
-        $ dataConName dcon
+  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
 
 
 ------------------------------------------------------------------------------
@@ -101,7 +102,7 @@ guardLength f as = bool [] as $ f $ length as
 -- UI.
 type TacticProvider
      = DynFlags
-    -> FeatureSet
+    -> Config
     -> PluginId
     -> Uri
     -> Range
@@ -122,28 +123,28 @@ data TacticParams = TacticParams
 -- | Restrict a 'TacticProvider', making sure it appears only when the given
 -- 'Feature' is in the feature set.
 requireFeature :: Feature -> TacticProvider -> TacticProvider
-requireFeature f tp dflags fs plId uri range jdg = do
-  guard $ hasFeature f fs
-  tp dflags fs plId uri range jdg
+requireFeature f tp dflags cfg plId uri range jdg = do
+  guard $ hasFeature f $ cfg_feature_set cfg
+  tp dflags cfg plId uri range jdg
 
 
 ------------------------------------------------------------------------------
 -- | Restrict a 'TacticProvider', making sure it appears only when the given
 -- predicate holds for the goal.
 requireExtension :: Extension -> TacticProvider -> TacticProvider
-requireExtension ext tp dflags fs plId uri range jdg =
+requireExtension ext tp dflags cfg plId uri range jdg =
   case xopt ext dflags of
-    True  -> tp dflags fs plId uri range jdg
+    True  -> tp dflags cfg plId uri range jdg
     False -> pure []
 
 
 ------------------------------------------------------------------------------
 -- | Restrict a 'TacticProvider', making sure it appears only when the given
 -- predicate holds for the goal.
 filterGoalType :: (Type -> Bool) -> TacticProvider -> TacticProvider
-filterGoalType p tp dflags fs plId uri range jdg =
+filterGoalType p tp dflags cfg plId uri range jdg =
   case p $ unCType $ jGoal jdg of
-    True  -> tp dflags fs plId uri range jdg
+    True  -> tp dflags cfg plId uri range jdg
     False -> pure []
 
 
@@ -154,13 +155,13 @@ filterBindingType
     :: (Type -> Type -> Bool)  -- ^ Goal and then binding types.
     -> (OccName -> Type -> TacticProvider)
     -> TacticProvider
-filterBindingType p tp dflags fs plId uri range jdg =
+filterBindingType p tp dflags cfg plId uri range jdg =
   let hy = jHypothesis jdg
       g  = jGoal jdg
    in fmap join $ for (unHypothesis hy) $ \hi ->
         let ty = unCType $ hi_type hi
          in case p (unCType g) ty of
-              True  -> tp (hi_name hi) ty dflags fs plId uri range jdg
+              True  -> tp (hi_name hi) ty dflags cfg plId uri range jdg
               False -> pure []
 
 
@@ -171,9 +172,16 @@ filterTypeProjection
     :: (Type -> [a])  -- ^ Features of the goal to look into further
     -> (a -> TacticProvider)
     -> TacticProvider
-filterTypeProjection p tp dflags fs plId uri range jdg =
+filterTypeProjection p tp dflags cfg plId uri range jdg =
   fmap join $ for (p $ unCType $ jGoal jdg) $ \a ->
-      tp a dflags fs plId uri range jdg
+      tp a dflags cfg plId uri range jdg
+
+
+------------------------------------------------------------------------------
+-- | Get access to the 'Config' when building a 'TacticProvider'.
+withConfig :: (Config -> TacticProvider) -> TacticProvider
+withConfig tp dflags cfg plId uri range jdg = tp cfg dflags cfg plId uri range jdg
+
 
 
 ------------------------------------------------------------------------------

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

@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
 
 module Ide.Plugin.Tactic.TestTypes where
 
@@ -33,20 +34,23 @@ tacticTitle UseDataCon dcon          = "Use constructor " <> dcon
 
 ------------------------------------------------------------------------------
 -- | Plugin configuration for tactics
-newtype Config = Config
-  { cfg_feature_set :: FeatureSet
+data Config = Config
+  { cfg_feature_set          :: FeatureSet
+  , cfg_max_use_ctor_actions :: Int
   }
 
 emptyConfig :: Config
-emptyConfig = Config defaultFeatures
+emptyConfig = Config defaultFeatures 5
 
 instance ToJSON Config where
-  toJSON (Config features) = object
-    [ "features" .= prettyFeatureSet features
+  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
-    features <- parseFeatureSet <$> obj .: "features"
-    pure $ Config features
+    cfg_feature_set          <- parseFeatureSet <$> obj .: "features"
+    cfg_max_use_ctor_actions <- obj .: "max_use_ctor_actions"
+    pure $ Config{..}