Skip to content

Commit a7510a9

Browse files
Catamorphism and collapse tactics (#1865)
* Perform lookups of terms in scope and context * Cata and collapse * Remove unused import * Fix bug in intros wrt forall * Assume a value for cata recursion if necessary * Add tests * Fix imports * Add tests * Cleanup and haddock * Null case for letForEach * mkFunTys' * Simplify away single-use let bindings * Use the applicative instance to implement letForEach Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com>
1 parent 13a2cc2 commit a7510a9

12 files changed

+146
-6
lines changed

plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs

Lines changed: 25 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -39,6 +39,7 @@ import Wingman.Judgements.Theta
3939
import Wingman.Machinery
4040
import Wingman.Naming
4141
import Wingman.Types
42+
import GHC.SourceGen (occNameToStr)
4243

4344

4445
destructMatches
@@ -274,3 +275,27 @@ mkApply occ (lhs : rhs : more)
274275
= noLoc $ foldl' (@@) (op lhs (coerceName occ) rhs) more
275276
mkApply occ args = noLoc $ foldl' (@@) (var' occ) args
276277

278+
279+
------------------------------------------------------------------------------
280+
-- | Run a tactic over each term in the given 'Hypothesis', binding the results
281+
-- of each in a let expression.
282+
letForEach
283+
:: (OccName -> OccName) -- ^ How to name bound variables
284+
-> (HyInfo CType -> TacticsM ()) -- ^ The tactic to run
285+
-> Hypothesis CType -- ^ Terms to generate bindings for
286+
-> Judgement -- ^ The goal of original hole
287+
-> RuleM (Synthesized (LHsExpr GhcPs))
288+
letForEach rename solve (unHypothesis -> hy) jdg = do
289+
case hy of
290+
[] -> newSubgoal jdg
291+
_ -> do
292+
let g = jGoal jdg
293+
terms <- fmap sequenceA $ for hy $ \hi -> do
294+
let name = rename $ hi_name hi
295+
res <- tacticToRule jdg $ solve hi
296+
pure $ fmap ((name,) . unLoc) res
297+
let hy' = fmap (g <$) $ syn_val terms
298+
matches = fmap (fmap (\(occ, expr) -> valBind (occNameToStr occ) expr)) terms
299+
g <- fmap (fmap unLoc) $ newSubgoal $ introduce (userHypothesis hy') jdg
300+
pure $ fmap noLoc $ let' <$> matches <*> g
301+

plugins/hls-tactics-plugin/src/Wingman/GHC.hs

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -3,6 +3,7 @@
33

44
module Wingman.GHC where
55

6+
import Bag (bagToList)
67
import ConLike
78
import Control.Applicative (empty)
89
import Control.Monad.State
@@ -196,6 +197,15 @@ pattern AMatch ctx pats body <-
196197
}
197198

198199

200+
pattern SingleLet :: IdP GhcPs -> [Pat GhcPs] -> HsExpr GhcPs -> HsExpr GhcPs -> HsExpr GhcPs
201+
pattern SingleLet bind pats val expr <-
202+
HsLet _
203+
(L _ (HsValBinds _
204+
(ValBinds _ (bagToList ->
205+
[(L _ (FunBind _ (L _ bind) (MG _ (L _ [L _ (AMatch _ pats val)]) _) _ _))]) _)))
206+
(L _ expr)
207+
208+
199209
------------------------------------------------------------------------------
200210
-- | A pattern over the otherwise (extremely) messy AST for lambdas.
201211
pattern Lambda :: [Pat GhcPs] -> HsExpr GhcPs -> HsExpr GhcPs

plugins/hls-tactics-plugin/src/Wingman/Judgements.hs

Lines changed: 12 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -107,6 +107,12 @@ recursiveHypothesis :: [(OccName, a)] -> Hypothesis a
107107
recursiveHypothesis = introduceHypothesis $ const $ const RecursivePrv
108108

109109

110+
------------------------------------------------------------------------------
111+
-- | Introduce a binding in a recursive context.
112+
userHypothesis :: [(OccName, a)] -> Hypothesis a
113+
userHypothesis = introduceHypothesis $ const $ const UserPrv
114+
115+
110116
------------------------------------------------------------------------------
111117
-- | Check whether any of the given occnames are an ancestor of the term.
112118
hasPositionalAncestry
@@ -302,6 +308,12 @@ jLocalHypothesis
302308
. jHypothesis
303309

304310

311+
------------------------------------------------------------------------------
312+
-- | Filter elements from the hypothesis
313+
hyFilter :: (HyInfo a -> Bool) -> Hypothesis a -> Hypothesis a
314+
hyFilter f = Hypothesis . filter f . unHypothesis
315+
316+
305317
------------------------------------------------------------------------------
306318
-- | Given a judgment, return the hypotheses that are acceptable to destruct.
307319
--

plugins/hls-tactics-plugin/src/Wingman/Machinery.hs

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -8,7 +8,7 @@ import Control.Lens ((<>~))
88
import Control.Monad.Error.Class
99
import Control.Monad.Reader
1010
import Control.Monad.State.Class (gets, modify)
11-
import Control.Monad.State.Strict (StateT (..))
11+
import Control.Monad.State.Strict (StateT (..), execStateT)
1212
import Data.Bool (bool)
1313
import Data.Coerce
1414
import Data.Either
@@ -55,6 +55,10 @@ newSubgoal j = do
5555
$ unsetIsTopHole j
5656

5757

58+
tacticToRule :: Judgement -> TacticsM () -> Rule
59+
tacticToRule jdg (TacticT tt) = RuleT $ flip execStateT jdg tt >>= flip Subgoal Axiom
60+
61+
5862
------------------------------------------------------------------------------
5963
-- | Attempt to generate a term of the right type using in-scope bindings, and
6064
-- a given tactic.

plugins/hls-tactics-plugin/src/Wingman/Metaprogramming/Parser.hs

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -68,6 +68,8 @@ oneTactic =
6868
, nullary "sorry" sorry
6969
, nullary "unary" $ nary 1
7070
, nullary "binary" $ nary 2
71+
, unary_occ "cata" $ useNameFromHypothesis cata
72+
, nullary "collapse" collapse
7173
, nullary "recursion" $
7274
fmap listToMaybe getCurrentDefinitions >>= \case
7375
Just (self, _) -> useNameFromContext apply self

plugins/hls-tactics-plugin/src/Wingman/Simplify.hs

Lines changed: 10 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -11,7 +11,7 @@ import Development.IDE.GHC.Compat
1111
import GHC.SourceGen (var)
1212
import GHC.SourceGen.Expr (lambda)
1313
import Wingman.CodeGen.Utils
14-
import Wingman.GHC (containsHsVar, fromPatCompat)
14+
import Wingman.GHC (containsHsVar, fromPatCompat, pattern SingleLet)
1515

1616

1717
------------------------------------------------------------------------------
@@ -30,6 +30,7 @@ pattern Lambda pats body <-
3030
Lambda pats body = lambda pats body
3131

3232

33+
3334
------------------------------------------------------------------------------
3435
-- | Simlify an expression.
3536
simplify :: LHsExpr GhcPs -> LHsExpr GhcPs
@@ -41,6 +42,7 @@ simplify
4142
[ simplifyEtaReduce
4243
, simplifyRemoveParens
4344
, simplifyCompose
45+
, simplifySingleLet
4446
])
4547

4648

@@ -68,6 +70,13 @@ simplifyEtaReduce = mkT $ \case
6870
Lambda pats f
6971
x -> x
7072

73+
------------------------------------------------------------------------------
74+
-- | Eliminates the unnecessary binding in @let a = b in a@
75+
simplifySingleLet :: GenericT
76+
simplifySingleLet = mkT $ \case
77+
SingleLet bind [] val (HsVar _ (L _ a)) | a == bind -> val
78+
x -> x
79+
7180

7281
------------------------------------------------------------------------------
7382
-- | Perform an eta-reducing function composition. For example, transforms

plugins/hls-tactics-plugin/src/Wingman/Tactics.hs

Lines changed: 40 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -111,9 +111,9 @@ intros'
111111
intros' names = rule $ \jdg -> do
112112
let g = jGoal jdg
113113
ctx <- ask
114-
case tcSplitFunTys $ unCType g of
115-
([], _) -> throwError $ GoalMismatch "intros" g
116-
(as, b) -> do
114+
case tacticsSplitFunTy $ unCType g of
115+
(_, _, [], _) -> throwError $ GoalMismatch "intros" g
116+
(_, _, as, b) -> do
117117
let vs = fromMaybe (mkManyGoodNames (hyNamesInScope $ jEntireHypothesis jdg) as) names
118118
num_args = length vs
119119
top_hole = isTopHole ctx jdg
@@ -448,14 +448,14 @@ applyByType ty = tracing ("applyByType " <> show ty) $ do
448448
let (_, _, args, ret) = tacticsSplitFunTy ty'
449449
rule $ \jdg -> do
450450
unify g (CType ret)
451-
app <- newSubgoal . blacklistingDestruct $ withNewGoal (CType ty) jdg
452451
ext
453452
<- fmap unzipTrace
454453
$ traverse ( newSubgoal
455454
. blacklistingDestruct
456455
. flip withNewGoal jdg
457456
. CType
458457
) args
458+
app <- newSubgoal . blacklistingDestruct $ withNewGoal (CType ty) jdg
459459
pure $
460460
fmap noLoc $
461461
foldl' (@@)
@@ -472,3 +472,39 @@ nary n =
472472
mkInvForAllTys [alphaTyVar, betaTyVar] $
473473
mkFunTys' (replicate n alphaTy) betaTy
474474

475+
self :: TacticsM ()
476+
self =
477+
fmap listToMaybe getCurrentDefinitions >>= \case
478+
Just (self, _) -> useNameFromContext apply self
479+
Nothing -> throwError $ TacticPanic "no defining function"
480+
481+
482+
cata :: HyInfo CType -> TacticsM ()
483+
cata hi = do
484+
diff <- hyDiff $ destruct hi
485+
rule $
486+
letForEach
487+
(mkVarOcc . flip mappend "_c" . occNameString)
488+
(\hi -> self >> commit (apply hi) assumption)
489+
diff
490+
491+
collapse :: TacticsM ()
492+
collapse = do
493+
g <- goal
494+
let terms = unHypothesis $ hyFilter ((jGoal g ==) . hi_type) $ jLocalHypothesis g
495+
case terms of
496+
[hi] -> assume $ hi_name hi
497+
_ -> nary (length terms) <@> fmap (assume . hi_name) terms
498+
499+
500+
------------------------------------------------------------------------------
501+
-- | Determine the difference in hypothesis due to running a tactic. Also, it
502+
-- runs the tactic.
503+
hyDiff :: TacticsM () -> TacticsM (Hypothesis CType)
504+
hyDiff m = do
505+
g <- unHypothesis . jEntireHypothesis <$> goal
506+
let g_len = length g
507+
m
508+
g' <- unHypothesis . jEntireHypothesis <$> goal
509+
pure $ Hypothesis $ take (length g' - g_len) g'
510+

plugins/hls-tactics-plugin/test/CodeAction/RunMetaprogramSpec.hs

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -31,4 +31,6 @@ spec = do
3131
metaTest 5 40 "MetaUseImport"
3232
metaTest 6 31 "MetaUseLocal"
3333
metaTest 11 11 "MetaUseMethod"
34+
metaTest 9 38 "MetaCataCollapse"
35+
metaTest 7 16 "MetaCataCollapseUnary"
3436

Lines changed: 14 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,14 @@
1+
{-# LANGUAGE TypeOperators #-}
2+
3+
import GHC.Generics
4+
5+
class Yo f where
6+
yo :: f x -> Int
7+
8+
instance (Yo f, Yo g) => Yo (f :*: g) where
9+
yo (fx :*: gx)
10+
= let
11+
fx_c = yo fx
12+
gx_c = yo gx
13+
in _ fx_c gx_c
14+
Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,10 @@
1+
{-# LANGUAGE TypeOperators #-}
2+
3+
import GHC.Generics
4+
5+
class Yo f where
6+
yo :: f x -> Int
7+
8+
instance (Yo f, Yo g) => Yo (f :*: g) where
9+
yo = [wingman| intros x, cata x, collapse |]
10+
Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,8 @@
1+
import GHC.Generics
2+
3+
class Yo f where
4+
yo :: f x -> Int
5+
6+
instance (Yo f) => Yo (M1 _1 _2 f) where
7+
yo (M1 fx) = yo fx
8+
Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,8 @@
1+
import GHC.Generics
2+
3+
class Yo f where
4+
yo :: f x -> Int
5+
6+
instance (Yo f) => Yo (M1 _1 _2 f) where
7+
yo = [wingman| intros x, cata x, collapse |]
8+

0 commit comments

Comments
 (0)