diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/FeatureSet.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/FeatureSet.hs index ce2901b7a6..426d7949bf 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/FeatureSet.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/FeatureSet.hs @@ -22,7 +22,8 @@ import qualified Data.Text as T -- | All the available features. A 'FeatureSet' describes the ones currently -- available to the user. data Feature - = FeatureUseDataCon + = FeatureDestructAll + | FeatureUseDataCon | FeatureRefineHole deriving (Eq, Ord, Show, Read, Enum, Bounded) diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Judgements.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Judgements.hs index c865f53650..a691441d86 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Judgements.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Judgements.hs @@ -295,6 +295,17 @@ hyNamesInScope :: Hypothesis a -> Set OccName hyNamesInScope = M.keysSet . hyByName +------------------------------------------------------------------------------ +-- | Are there any top-level function argument bindings in this judgement? +jHasBoundArgs :: Judgement' a -> Bool +jHasBoundArgs + = not + . null + . filter (isTopLevel . hi_provenance) + . unHypothesis + . jLocalHypothesis + + ------------------------------------------------------------------------------ -- | Fold a hypothesis into a single mapping from name to info. This -- unavoidably will cause duplicate names (things like methods) to shadow one 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 3ebf91de23..a1a530d55b 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 @@ -50,6 +50,7 @@ commandTactic Destruct = useNameFromHypothesis destruct commandTactic Homomorphism = useNameFromHypothesis homo commandTactic DestructLambdaCase = const destructLambdaCase commandTactic HomomorphismLambdaCase = const homoLambdaCase +commandTactic DestructAll = const destructAll commandTactic UseDataCon = userSplit commandTactic Refine = const refine @@ -76,6 +77,12 @@ commandProvider HomomorphismLambdaCase = requireExtension LambdaCase $ filterGoalType ((== Just True) . lambdaCaseable) $ provide HomomorphismLambdaCase "" +commandProvider DestructAll = + requireFeature FeatureDestructAll $ + withJudgement $ \jdg -> + case _jIsTopHole jdg && jHasBoundArgs jdg of + True -> provide DestructAll "" + False -> mempty commandProvider UseDataCon = withConfig $ \cfg -> requireFeature FeatureUseDataCon $ @@ -153,6 +160,14 @@ filterGoalType p 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. +withJudgement :: (Judgement -> TacticProvider) -> TacticProvider +withJudgement tp dflags fs plId uri range jdg = + tp jdg dflags fs plId uri range jdg + + ------------------------------------------------------------------------------ -- | Multiply a 'TacticProvider' for each binding, making sure it appears only -- when the given predicate holds over the goal and binding types. diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Tactics.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Tactics.hs index 476a6c3232..da8f9f86e2 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Tactics.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/Tactics.hs @@ -256,6 +256,24 @@ splitDataCon dc = ------------------------------------------------------------------------------ +-- | Perform a case split on each top-level argument. Used to implement the +-- "Destruct all function arguments" action. +destructAll :: TacticsM () +destructAll = do + jdg <- goal + let args = fmap fst + $ sortOn (Down . snd) + $ mapMaybe (\(hi, prov) -> + case prov of + TopLevelArgPrv _ idx _ -> pure (hi, idx) + _ -> Nothing + ) + $ fmap (\hi -> (hi, hi_provenance hi)) + $ unHypothesis + $ jHypothesis jdg + for_ args destruct + +-------------------------------------------------------------------------------- -- | User-facing tactic to implement "Use constructor " userSplit :: OccName -> TacticsM () userSplit occ = do diff --git a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/TestTypes.hs b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/TestTypes.hs index 638fda6311..1f151e96c4 100644 --- a/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/TestTypes.hs +++ b/plugins/hls-tactics-plugin/src/Ide/Plugin/Tactic/TestTypes.hs @@ -19,6 +19,7 @@ data TacticCommand | Homomorphism | DestructLambdaCase | HomomorphismLambdaCase + | DestructAll | UseDataCon | Refine deriving (Eq, Ord, Show, Enum, Bounded) @@ -31,6 +32,7 @@ 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" diff --git a/plugins/hls-tactics-plugin/test/GoldenSpec.hs b/plugins/hls-tactics-plugin/test/GoldenSpec.hs index 80e4f26228..add283d012 100644 --- a/plugins/hls-tactics-plugin/test/GoldenSpec.hs +++ b/plugins/hls-tactics-plugin/test/GoldenSpec.hs @@ -73,6 +73,34 @@ spec = do let goldenTest = mkGoldenTest allFeatures + -- 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 + + -- test via: -- stack test hls-tactics-plugin --test-arguments '--match "Golden/use constructor/"' describe "use constructor" $ do @@ -115,7 +143,6 @@ spec = do refineTest "RefineReader.hs" 4 8 refineTest "RefineGADT.hs" 8 8 - describe "golden tests" $ do let autoTest = mkGoldenTest allFeatures Auto "" diff --git a/plugins/hls-tactics-plugin/test/golden/DestructAllAnd.hs b/plugins/hls-tactics-plugin/test/golden/DestructAllAnd.hs new file mode 100644 index 0000000000..892eab679c --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/DestructAllAnd.hs @@ -0,0 +1,2 @@ +and :: Bool -> Bool -> Bool +and x y = _ diff --git a/plugins/hls-tactics-plugin/test/golden/DestructAllAnd.hs.expected b/plugins/hls-tactics-plugin/test/golden/DestructAllAnd.hs.expected new file mode 100644 index 0000000000..0559503178 --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/DestructAllAnd.hs.expected @@ -0,0 +1,5 @@ +and :: Bool -> Bool -> Bool +and False False = _ +and True False = _ +and False True = _ +and True True = _ diff --git a/plugins/hls-tactics-plugin/test/golden/DestructAllMany.hs b/plugins/hls-tactics-plugin/test/golden/DestructAllMany.hs new file mode 100644 index 0000000000..ab0a4dccb9 --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/DestructAllMany.hs @@ -0,0 +1,4 @@ +data ABC = A | B | C + +many :: () -> Either a b -> Bool -> Maybe ABC -> ABC -> () +many u e b mabc abc = _ diff --git a/plugins/hls-tactics-plugin/test/golden/DestructAllMany.hs.expected b/plugins/hls-tactics-plugin/test/golden/DestructAllMany.hs.expected new file mode 100644 index 0000000000..95dd543773 --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/DestructAllMany.hs.expected @@ -0,0 +1,27 @@ +data ABC = A | B | C + +many :: () -> Either a b -> Bool -> Maybe ABC -> ABC -> () +many () (Left a) False Nothing A = _ +many () (Right b5) False Nothing A = _ +many () (Left a) True Nothing A = _ +many () (Right b5) True Nothing A = _ +many () (Left a6) False (Just a) A = _ +many () (Right b6) False (Just a) A = _ +many () (Left a6) True (Just a) A = _ +many () (Right b6) True (Just a) A = _ +many () (Left a) False Nothing B = _ +many () (Right b5) False Nothing B = _ +many () (Left a) True Nothing B = _ +many () (Right b5) True Nothing B = _ +many () (Left a6) False (Just a) B = _ +many () (Right b6) False (Just a) B = _ +many () (Left a6) True (Just a) B = _ +many () (Right b6) True (Just a) B = _ +many () (Left a) False Nothing C = _ +many () (Right b5) False Nothing C = _ +many () (Left a) True Nothing C = _ +many () (Right b5) True Nothing C = _ +many () (Left a6) False (Just a) C = _ +many () (Right b6) False (Just a) C = _ +many () (Left a6) True (Just a) C = _ +many () (Right b6) True (Just a) C = _ diff --git a/plugins/hls-tactics-plugin/test/golden/DestructAllProvider.hs b/plugins/hls-tactics-plugin/test/golden/DestructAllProvider.hs new file mode 100644 index 0000000000..8d115e828d --- /dev/null +++ b/plugins/hls-tactics-plugin/test/golden/DestructAllProvider.hs @@ -0,0 +1,12 @@ +-- we need to name the args ourselves first +nothingToDestruct :: [a] -> [a] -> [a] +nothingToDestruct = _ + + +-- can't destruct all for non-top-level holes +notTop :: Bool -> Bool -> Bool +notTop a b = a && _ + +-- destruct all is ok +canDestructAll :: Bool -> Bool -> Bool +canDestructAll a b = _