Skip to content

Commit b0390ac

Browse files
authored
Implement "use constructor" code action (#1461)
* Implement "use constructor" code action * Haddock * Make use ctor actions configurable * Undo more stupid formatting * Use loose parsing for config * Only show unifiable ctors * Don't use guard in IO Missing features were accidentally blocking all code actions * Push data con matching into tacticsGetDataCons
1 parent 43b33a5 commit b0390ac

15 files changed

+239
-83
lines changed

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

Lines changed: 15 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -13,30 +13,28 @@ module Ide.Plugin.Tactic
1313
, TacticCommand (..)
1414
) where
1515

16-
import Bag (bagToList,
17-
listToBag)
18-
import Control.Exception (evaluate)
16+
import Bag (bagToList, listToBag)
17+
import Control.Exception (evaluate)
1918
import Control.Monad
2019
import Control.Monad.Trans
2120
import Control.Monad.Trans.Maybe
2221
import Data.Aeson
23-
import Data.Bifunctor (Bifunctor (bimap))
24-
import Data.Bool (bool)
25-
import Data.Data (Data)
22+
import Data.Bifunctor (Bifunctor (bimap))
23+
import Data.Bool (bool)
24+
import Data.Data (Data)
2625
import Data.Foldable (for_)
27-
import Data.Generics.Aliases (mkQ)
28-
import Data.Generics.Schemes (everything)
26+
import Data.Generics.Aliases (mkQ)
27+
import Data.Generics.Schemes (everything)
2928
import Data.Maybe
3029
import Data.Monoid
31-
import qualified Data.Text as T
30+
import qualified Data.Text as T
3231
import Data.Traversable
33-
import Development.IDE.Core.Shake (IdeState (..))
32+
import Development.IDE.Core.Shake (IdeState (..))
3433
import Development.IDE.GHC.Compat
3534
import Development.IDE.GHC.ExactPrint
3635
import Development.Shake.Classes
3736
import Ide.Plugin.Tactic.CaseSplit
38-
import Ide.Plugin.Tactic.FeatureSet (Feature (..),
39-
hasFeature)
37+
import Ide.Plugin.Tactic.FeatureSet (Feature (..), hasFeature)
4038
import Ide.Plugin.Tactic.GHC
4139
import Ide.Plugin.Tactic.LanguageServer
4240
import Ide.Plugin.Tactic.LanguageServer.TacticProviders
@@ -49,7 +47,7 @@ import Language.LSP.Server
4947
import Language.LSP.Types
5048
import Language.LSP.Types.Capabilities
5149
import OccName
52-
import Prelude hiding (span)
50+
import Prelude hiding (span)
5351
import System.Timeout
5452

5553

@@ -71,14 +69,14 @@ descriptor plId = (defaultPluginDescriptor plId)
7169
codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction
7270
codeActionProvider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range _ctx)
7371
| Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do
74-
features <- getFeatureSet (shakeExtras state)
72+
cfg <- getTacticConfig $ shakeExtras state
7573
liftIO $ fromMaybeT (Right $ List []) $ do
76-
(_, jdg, _, dflags) <- judgementForHole state nfp range features
74+
(_, jdg, _, dflags) <- judgementForHole state nfp range $ cfg_feature_set cfg
7775
actions <- lift $
7876
-- This foldMap is over the function monoid.
7977
foldMap commandProvider [minBound .. maxBound]
8078
dflags
81-
features
79+
cfg
8280
plId
8381
uri
8482
range
@@ -90,7 +88,7 @@ codeActionProvider _ _ _ = pure $ Right $ List []
9088
tacticCmd :: (OccName -> TacticsM ()) -> CommandFunction IdeState TacticParams
9189
tacticCmd tac state (TacticParams uri range var_name)
9290
| Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do
93-
features <- getFeatureSet (shakeExtras state)
91+
features <- getFeatureSet $ shakeExtras state
9492
ccs <- getClientCapabilities
9593
res <- liftIO $ fromMaybeT (Right Nothing) $ do
9694
(range', jdg, ctx, dflags) <- judgementForHole state nfp range features

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -21,7 +21,7 @@ import qualified Data.Text as T
2121
------------------------------------------------------------------------------
2222
-- | All the available features. A 'FeatureSet' describes the ones currently
2323
-- available to the user.
24-
data Feature = CantHaveAnEmptyDataType
24+
data Feature = FeatureUseDataCon
2525
deriving (Eq, Ord, Show, Read, Enum, Bounded)
2626

2727

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

Lines changed: 28 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -9,28 +9,28 @@
99

1010
module Ide.Plugin.Tactic.GHC where
1111

12+
import Control.Arrow
1213
import Control.Monad.State
13-
import Data.Function (on)
14-
import Data.List (isPrefixOf)
15-
import qualified Data.Map as M
16-
import Data.Maybe (isJust)
17-
import Data.Set (Set)
18-
import qualified Data.Set as S
14+
import Data.Function (on)
15+
import Data.List (isPrefixOf)
16+
import qualified Data.Map as M
17+
import Data.Maybe (isJust)
18+
import Data.Set (Set)
19+
import qualified Data.Set as S
1920
import Data.Traversable
2021
import DataCon
2122
import Development.IDE.GHC.Compat
22-
import GHC.SourceGen (case', lambda, match)
23-
import Generics.SYB (Data, everything, everywhere,
24-
listify, mkQ, mkT)
23+
import GHC.SourceGen (case', lambda, match)
24+
import Generics.SYB (Data, everything, everywhere, listify, mkQ, mkT)
2525
import Ide.Plugin.Tactic.Types
2626
import OccName
2727
import TcType
2828
import TyCoRep
2929
import Type
30-
import TysWiredIn (charTyCon, doubleTyCon, floatTyCon,
31-
intTyCon)
30+
import TysWiredIn (charTyCon, doubleTyCon, floatTyCon, intTyCon)
3231
import Unique
3332
import Var
33+
import Data.Functor ((<&>))
3434

3535

3636
tcTyVar_maybe :: Type -> Maybe Var
@@ -81,6 +81,15 @@ tacticsThetaTy :: Type -> ThetaType
8181
tacticsThetaTy (tcSplitSigmaTy -> (_, theta, _)) = theta
8282

8383

84+
------------------------------------------------------------------------------
85+
-- | Get the data cons of a type, if it has any.
86+
tacticsGetDataCons :: Type -> Maybe ([DataCon], [Type])
87+
tacticsGetDataCons ty =
88+
splitTyConApp_maybe ty <&> \(tc, apps) ->
89+
( filter (not . dataConCannotMatch apps) $ tyConDataCons tc
90+
, apps
91+
)
92+
8493
------------------------------------------------------------------------------
8594
-- | Instantiate all of the quantified type variables in a type with fresh
8695
-- skolems.
@@ -126,12 +135,18 @@ algebraicTyCon _ = Nothing
126135

127136

128137
------------------------------------------------------------------------------
129-
-- | We can't compare 'RdrName' for equality directly. Instead, compare them by
130-
-- their 'OccName's.
138+
-- | We can't compare 'RdrName' for equality directly. Instead, sloppily
139+
-- compare them by their 'OccName's.
131140
eqRdrName :: RdrName -> RdrName -> Bool
132141
eqRdrName = (==) `on` occNameString . occName
133142

134143

144+
------------------------------------------------------------------------------
145+
-- | Compare two 'OccName's for unqualified equality.
146+
sloppyEqOccName :: OccName -> OccName -> Bool
147+
sloppyEqOccName = (==) `on` occNameString
148+
149+
135150
------------------------------------------------------------------------------
136151
-- | Does this thing contain any references to 'HsVar's with the given
137152
-- 'RdrName'?

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

Lines changed: 12 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -44,7 +44,7 @@ import Ide.Plugin.Tactic.GHC
4444
import Ide.Plugin.Tactic.Judgements
4545
import Ide.Plugin.Tactic.Range
4646
import Ide.Plugin.Tactic.TestTypes (TacticCommand,
47-
cfg_feature_set)
47+
cfg_feature_set, emptyConfig, Config)
4848
import Ide.Plugin.Tactic.Types
4949
import Language.LSP.Server (MonadLsp)
5050
import Language.LSP.Types
@@ -82,13 +82,19 @@ runStaleIde state nfp a = MaybeT $ runIde state $ useWithStale a nfp
8282

8383

8484
------------------------------------------------------------------------------
85-
-- | Get the current feature set from the plugin config.
86-
getFeatureSet :: MonadLsp Plugin.Config m => ShakeExtras -> m FeatureSet
87-
getFeatureSet extras = do
85+
-- | Get the the plugin config
86+
getTacticConfig :: MonadLsp Plugin.Config m => ShakeExtras -> m Config
87+
getTacticConfig extras = do
8888
pcfg <- getPluginConfig extras "tactics"
8989
pure $ case fromJSON $ Object $ plcConfig pcfg of
90-
Success cfg -> cfg_feature_set cfg
91-
Error _ -> defaultFeatures
90+
Success cfg -> cfg
91+
Error _ -> emptyConfig
92+
93+
94+
------------------------------------------------------------------------------
95+
-- | Get the current feature set from the plugin config.
96+
getFeatureSet :: MonadLsp Plugin.Config m => ShakeExtras -> m FeatureSet
97+
getFeatureSet = fmap cfg_feature_set . getTacticConfig
9298

9399

94100
getIdeDynflags

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

Lines changed: 59 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -3,6 +3,7 @@
33
{-# LANGUAGE DerivingStrategies #-}
44
{-# LANGUAGE OverloadedStrings #-}
55
{-# LANGUAGE ViewPatterns #-}
6+
{-# OPTIONS_GHC -Wall #-}
67

78
module Ide.Plugin.Tactic.LanguageServer.TacticProviders
89
( commandProvider
@@ -12,17 +13,19 @@ module Ide.Plugin.Tactic.LanguageServer.TacticProviders
1213
) where
1314

1415
import Control.Monad
15-
import Control.Monad.Error.Class (MonadError (throwError))
16+
import Control.Monad.Error.Class (MonadError (throwError))
1617
import Data.Aeson
18+
import Data.Bool (bool)
1719
import Data.Coerce
18-
import qualified Data.Map as M
20+
import qualified Data.Map as M
1921
import Data.Maybe
2022
import Data.Monoid
21-
import qualified Data.Text as T
23+
import qualified Data.Text as T
2224
import Data.Traversable
25+
import DataCon (dataConName)
2326
import Development.IDE.GHC.Compat
2427
import GHC.Generics
25-
import GHC.LanguageExtensions.Type (Extension (LambdaCase))
28+
import GHC.LanguageExtensions.Type (Extension (LambdaCase))
2629
import Ide.Plugin.Tactic.Auto
2730
import Ide.Plugin.Tactic.FeatureSet
2831
import Ide.Plugin.Tactic.GHC
@@ -34,8 +37,8 @@ import Ide.PluginUtils
3437
import Ide.Types
3538
import Language.LSP.Types
3639
import OccName
37-
import Prelude hiding (span)
38-
import Refinery.Tactic (goal)
40+
import Prelude hiding (span)
41+
import Refinery.Tactic (goal)
3942

4043

4144
------------------------------------------------------------------------------
@@ -47,6 +50,7 @@ commandTactic Destruct = useNameFromHypothesis destruct
4750
commandTactic Homomorphism = useNameFromHypothesis homo
4851
commandTactic DestructLambdaCase = const destructLambdaCase
4952
commandTactic HomomorphismLambdaCase = const homoLambdaCase
53+
commandTactic UseDataCon = userSplit
5054

5155

5256
------------------------------------------------------------------------------
@@ -71,14 +75,34 @@ commandProvider HomomorphismLambdaCase =
7175
requireExtension LambdaCase $
7276
filterGoalType ((== Just True) . lambdaCaseable) $
7377
provide HomomorphismLambdaCase ""
78+
commandProvider UseDataCon =
79+
withConfig $ \cfg ->
80+
requireFeature FeatureUseDataCon $
81+
filterTypeProjection
82+
( guardLength (<= cfg_max_use_ctor_actions cfg)
83+
. fromMaybe []
84+
. fmap fst
85+
. tacticsGetDataCons
86+
) $ \dcon ->
87+
provide UseDataCon
88+
. T.pack
89+
. occNameString
90+
. occName
91+
$ dataConName dcon
92+
93+
94+
------------------------------------------------------------------------------
95+
-- | Return an empty list if the given predicate doesn't hold over the length
96+
guardLength :: (Int -> Bool) -> [a] -> [a]
97+
guardLength f as = bool [] as $ f $ length as
7498

7599

76100
------------------------------------------------------------------------------
77101
-- | A 'TacticProvider' is a way of giving context-sensitive actions to the LS
78102
-- UI.
79103
type TacticProvider
80104
= DynFlags
81-
-> FeatureSet
105+
-> Config
82106
-> PluginId
83107
-> Uri
84108
-> Range
@@ -99,28 +123,29 @@ data TacticParams = TacticParams
99123
-- | Restrict a 'TacticProvider', making sure it appears only when the given
100124
-- 'Feature' is in the feature set.
101125
requireFeature :: Feature -> TacticProvider -> TacticProvider
102-
requireFeature f tp dflags fs plId uri range jdg = do
103-
guard $ hasFeature f fs
104-
tp dflags fs plId uri range jdg
126+
requireFeature f tp dflags cfg plId uri range jdg = do
127+
case hasFeature f $ cfg_feature_set cfg of
128+
True -> tp dflags cfg plId uri range jdg
129+
False -> pure []
105130

106131

107132
------------------------------------------------------------------------------
108133
-- | Restrict a 'TacticProvider', making sure it appears only when the given
109134
-- predicate holds for the goal.
110135
requireExtension :: Extension -> TacticProvider -> TacticProvider
111-
requireExtension ext tp dflags fs plId uri range jdg =
136+
requireExtension ext tp dflags cfg plId uri range jdg =
112137
case xopt ext dflags of
113-
True -> tp dflags fs plId uri range jdg
138+
True -> tp dflags cfg plId uri range jdg
114139
False -> pure []
115140

116141

117142
------------------------------------------------------------------------------
118143
-- | Restrict a 'TacticProvider', making sure it appears only when the given
119144
-- predicate holds for the goal.
120145
filterGoalType :: (Type -> Bool) -> TacticProvider -> TacticProvider
121-
filterGoalType p tp dflags fs plId uri range jdg =
146+
filterGoalType p tp dflags cfg plId uri range jdg =
122147
case p $ unCType $ jGoal jdg of
123-
True -> tp dflags fs plId uri range jdg
148+
True -> tp dflags cfg plId uri range jdg
124149
False -> pure []
125150

126151

@@ -131,16 +156,34 @@ filterBindingType
131156
:: (Type -> Type -> Bool) -- ^ Goal and then binding types.
132157
-> (OccName -> Type -> TacticProvider)
133158
-> TacticProvider
134-
filterBindingType p tp dflags fs plId uri range jdg =
159+
filterBindingType p tp dflags cfg plId uri range jdg =
135160
let hy = jHypothesis jdg
136161
g = jGoal jdg
137162
in fmap join $ for (unHypothesis hy) $ \hi ->
138163
let ty = unCType $ hi_type hi
139164
in case p (unCType g) ty of
140-
True -> tp (hi_name hi) ty dflags fs plId uri range jdg
165+
True -> tp (hi_name hi) ty dflags cfg plId uri range jdg
141166
False -> pure []
142167

143168

169+
------------------------------------------------------------------------------
170+
-- | Multiply a 'TacticProvider' by some feature projection out of the goal
171+
-- type. Used e.g. to crete a code action for every data constructor.
172+
filterTypeProjection
173+
:: (Type -> [a]) -- ^ Features of the goal to look into further
174+
-> (a -> TacticProvider)
175+
-> TacticProvider
176+
filterTypeProjection p tp dflags cfg plId uri range jdg =
177+
fmap join $ for (p $ unCType $ jGoal jdg) $ \a ->
178+
tp a dflags cfg plId uri range jdg
179+
180+
181+
------------------------------------------------------------------------------
182+
-- | Get access to the 'Config' when building a 'TacticProvider'.
183+
withConfig :: (Config -> TacticProvider) -> TacticProvider
184+
withConfig tp dflags cfg plId uri range jdg = tp cfg dflags cfg plId uri range jdg
185+
186+
144187

145188
------------------------------------------------------------------------------
146189
-- | Lift a function over 'HyInfo's to one that takes an 'OccName' and tries to
@@ -174,7 +217,6 @@ tcCommandId :: TacticCommand -> CommandId
174217
tcCommandId c = coerce $ T.pack $ "tactics" <> show c <> "Command"
175218

176219

177-
178220
------------------------------------------------------------------------------
179221
-- | We should show homos only when the goal type is the same as the binding
180222
-- type, and that both are usual algebraic types.

0 commit comments

Comments
 (0)