forked from haskell/haskell-language-server
/
Tactics.hs
305 lines (260 loc) · 10.5 KB
/
Tactics.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
module Ide.Plugin.Tactic.Tactics
( module Ide.Plugin.Tactic.Tactics
, runTactic
) where
import Control.Monad.Except (throwError)
import Control.Monad.Reader.Class (MonadReader (ask))
import Control.Monad.State.Class
import Control.Monad.State.Strict (StateT(..), runStateT)
import Data.Foldable
import Data.List
import qualified Data.Map as M
import Data.Maybe
import Data.Set (Set)
import qualified Data.Set as S
import DataCon
import Development.IDE.GHC.Compat
import GHC.Exts
import GHC.SourceGen.Expr
import GHC.SourceGen.Overloaded
import Ide.Plugin.Tactic.CodeGen
import Ide.Plugin.Tactic.Context
import Ide.Plugin.Tactic.GHC
import Ide.Plugin.Tactic.Judgements
import Ide.Plugin.Tactic.Machinery
import Ide.Plugin.Tactic.Naming
import Ide.Plugin.Tactic.Types
import Name (occNameString)
import Refinery.Tactic
import Refinery.Tactic.Internal
import TcType
import Type hiding (Var)
------------------------------------------------------------------------------
-- | Use something in the hypothesis to fill the hole.
assumption :: TacticsM ()
assumption = attemptOn (S.toList . allNames) assume
------------------------------------------------------------------------------
-- | Use something named in the hypothesis to fill the hole.
assume :: OccName -> TacticsM ()
assume name = rule $ \jdg -> do
case M.lookup name $ hyByName $ jHypothesis jdg of
Just (hi_type -> ty) -> do
unify ty $ jGoal jdg
for_ (M.lookup name $ jPatHypothesis jdg) markStructuralySmallerRecursion
pure $ Synthesized (tracePrim $ "assume " <> occNameString name)
mempty
(S.singleton name)
$ noLoc
$ var' name
Nothing -> throwError $ UndefinedHypothesis name
recursion :: TacticsM ()
recursion = requireConcreteHole $ tracing "recursion" $ do
defs <- getCurrentDefinitions
attemptOn (const defs) $ \(name, ty) -> do
-- TODO(sandy): When we can inspect the extract of a TacticsM bind
-- (requires refinery support), this recursion stack stuff is unnecessary.
-- We can just inspect the extract to see i we used any pattern vals, and
-- then be on our merry way.
modify $ pushRecursionStack . countRecursiveCall
ensure guardStructurallySmallerRecursion popRecursionStack $ do
let hy' = recursiveHypothesis defs
localTactic (apply $ HyInfo name RecursivePrv ty) (introduce hy')
<@> fmap (localTactic assumption . filterPosition name) [0..]
------------------------------------------------------------------------------
-- | Introduce a lambda binding every variable.
intros :: TacticsM ()
intros = rule $ \jdg -> do
let g = jGoal jdg
ctx <- ask
case tcSplitFunTys $ unCType g of
([], _) -> throwError $ GoalMismatch "intros" g
(as, b) -> do
vs <- mkManyGoodNames (hyNamesInScope $ jEntireHypothesis jdg) as
let top_hole = isTopHole ctx jdg
hy' = lambdaHypothesis top_hole $ zip vs $ coerce as
jdg' = introduce hy'
$ withNewGoal (CType b) jdg
Synthesized tr sc uv sg <- newSubgoal jdg'
pure
. Synthesized
(rose ("intros {" <> intercalate ", " (fmap show vs) <> "}") $ pure tr)
(sc <> hy')
uv
. noLoc
. lambda (fmap bvar' vs)
$ unLoc sg
------------------------------------------------------------------------------
-- | Case split, and leave holes in the matches.
destructAuto :: HyInfo CType -> TacticsM ()
destructAuto hi = requireConcreteHole $ tracing "destruct(auto)" $ do
jdg <- goal
let subtactic = rule $ destruct' (const subgoal) hi
case isPatternMatch $ hi_provenance hi of
True ->
pruning subtactic $ \jdgs ->
let getHyTypes = S.fromList . fmap hi_type . unHypothesis . jHypothesis
new_hy = foldMap getHyTypes jdgs
old_hy = getHyTypes jdg
in case S.null $ new_hy S.\\ old_hy of
True -> Just $ UnhelpfulDestruct $ hi_name hi
False -> Nothing
False -> subtactic
------------------------------------------------------------------------------
-- | Case split, and leave holes in the matches.
destruct :: HyInfo CType -> TacticsM ()
destruct hi = requireConcreteHole $ tracing "destruct(user)" $
rule $ destruct' (const subgoal) hi
------------------------------------------------------------------------------
-- | Case split, using the same data constructor in the matches.
homo :: HyInfo CType -> TacticsM ()
homo = requireConcreteHole . tracing "homo" . rule . destruct' (\dc jdg ->
buildDataCon jdg dc $ snd $ splitAppTys $ unCType $ jGoal jdg)
------------------------------------------------------------------------------
-- | LambdaCase split, and leave holes in the matches.
destructLambdaCase :: TacticsM ()
destructLambdaCase = tracing "destructLambdaCase" $ rule $ destructLambdaCase' (const subgoal)
------------------------------------------------------------------------------
-- | LambdaCase split, using the same data constructor in the matches.
homoLambdaCase :: TacticsM ()
homoLambdaCase =
tracing "homoLambdaCase" $
rule $ destructLambdaCase' $ \dc jdg ->
buildDataCon jdg dc
. snd
. splitAppTys
. unCType
$ jGoal jdg
apply :: HyInfo CType -> TacticsM ()
apply hi = requireConcreteHole $ tracing ("apply' " <> show (hi_name hi)) $ do
jdg <- goal
let g = jGoal jdg
ty = unCType $ hi_type hi
func = hi_name hi
ty' <- freshTyvars ty
let (_, _, args, ret) = tacticsSplitFunTy ty'
-- TODO(sandy): Bug here! Prevents us from doing mono-map like things
-- Don't require new holes for locally bound vars; only respect linearity
-- see https://github.com/haskell/haskell-language-server/issues/1447
requireNewHoles $ rule $ \jdg -> do
unify g (CType ret)
Synthesized tr sc uv sgs
<- fmap unzipTrace
$ traverse ( newSubgoal
. blacklistingDestruct
. flip withNewGoal jdg
. CType
) args
pure $ Synthesized tr sc (S.insert func uv)
$ noLoc . foldl' (@@) (var' func)
$ fmap unLoc sgs
------------------------------------------------------------------------------
-- | Choose between each of the goal's data constructors.
split :: TacticsM ()
split = tracing "split(user)" $ do
jdg <- goal
let g = jGoal jdg
case splitTyConApp_maybe $ unCType g of
Nothing -> throwError $ GoalMismatch "split" g
Just (tc, _) -> do
let dcs = tyConDataCons tc
choice $ fmap splitDataCon dcs
------------------------------------------------------------------------------
-- | Choose between each of the goal's data constructors. Different than
-- 'split' because it won't split a data con if it doesn't result in any new
-- goals.
splitAuto :: TacticsM ()
splitAuto = requireConcreteHole $ tracing "split(auto)" $ do
jdg <- goal
let g = jGoal jdg
case splitTyConApp_maybe $ unCType g of
Nothing -> throwError $ GoalMismatch "split" g
Just (tc, _) -> do
let dcs = tyConDataCons tc
case isSplitWhitelisted jdg of
True -> choice $ fmap splitDataCon dcs
False -> do
choice $ flip fmap dcs $ \dc -> requireNewHoles $
splitDataCon dc
------------------------------------------------------------------------------
-- | Allow the given tactic to proceed if and only if it introduces holes that
-- have a different goal than current goal.
requireNewHoles :: TacticsM () -> TacticsM ()
requireNewHoles m = do
jdg <- goal
pruning m $ \jdgs ->
case null jdgs || any (/= jGoal jdg) (fmap jGoal jdgs) of
True -> Nothing
False -> Just NoProgress
------------------------------------------------------------------------------
-- | Attempt to instantiate the given data constructor to solve the goal.
splitDataCon :: DataCon -> TacticsM ()
splitDataCon dc =
requireConcreteHole $ tracing ("splitDataCon:" <> show dc) $ rule $ \jdg -> do
let g = jGoal jdg
case splitTyConApp_maybe $ unCType g of
Just (tc, apps) -> do
case elem dc $ tyConDataCons tc of
True -> buildDataCon (unwhitelistingSplit jdg) dc apps
False -> throwError $ IncorrectDataCon dc
Nothing -> throwError $ GoalMismatch "splitDataCon" g
------------------------------------------------------------------------------
-- | 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
------------------------------------------------------------------------------
-- | @matching f@ takes a function from a judgement to a @Tactic@, and
-- then applies the resulting @Tactic@.
matching :: (Judgement -> TacticsM ()) -> TacticsM ()
matching f = TacticT $ StateT $ \s -> runStateT (unTacticT $ f s) s
attemptOn :: (Judgement -> [a]) -> (a -> TacticsM ()) -> TacticsM ()
attemptOn getNames tac = matching (choice . fmap (\s -> tac s) . getNames)
localTactic :: TacticsM a -> (Judgement -> Judgement) -> TacticsM a
localTactic t f = do
TacticT $ StateT $ \jdg ->
runStateT (unTacticT t) $ f jdg
auto' :: Int -> TacticsM ()
auto' 0 = throwError NoProgress
auto' n = do
let loop = auto' (n - 1)
try intros
choice
[ overFunctions $ \fname -> do
apply fname
loop
, overAlgebraicTerms $ \aname -> do
destructAuto aname
loop
, splitAuto >> loop
, assumption >> loop
, recursion
]
overFunctions :: (HyInfo CType -> TacticsM ()) -> TacticsM ()
overFunctions =
attemptOn $ filter (isFunction . unCType . hi_type)
. unHypothesis
. jHypothesis
overAlgebraicTerms :: (HyInfo CType -> TacticsM ()) -> TacticsM ()
overAlgebraicTerms =
attemptOn $ filter (isJust . algebraicTyCon . unCType . hi_type)
. unHypothesis
. jHypothesis
allNames :: Judgement -> Set OccName
allNames = hyNamesInScope . jHypothesis