-
Notifications
You must be signed in to change notification settings - Fork 350
/
BuiltinNotation.lean
359 lines (331 loc) · 16 KB
/
BuiltinNotation.lean
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
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
/-
Copyright (c) 2019 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Init.Data.ToString
import Lean.Compiler.BorrowedAnnotation
import Lean.Meta.KAbstract
import Lean.Meta.Transform
import Lean.Elab.App
import Lean.Elab.SyntheticMVars
namespace Lean.Elab.Term
open Meta
/--
The *anonymous constructor* `⟨e, ...⟩` is equivalent to `c e ...` if the
expected type is an inductive type with a single constructor `c`.
If more terms are given than `c` has parameters, the remaining arguments
are turned into a new anonymous constructor application. For example,
`⟨a, b, c⟩ : α × (β × γ)` is equivalent to `⟨a, ⟨b, c⟩⟩`. -/
@[builtinTermElab anonymousCtor] def elabAnonymousCtor : TermElab := fun stx expectedType? =>
match stx with
| `(⟨$args,*⟩) => do
tryPostponeIfNoneOrMVar expectedType?
match expectedType? with
| some expectedType =>
let expectedType ← whnf expectedType
matchConstInduct expectedType.getAppFn
(fun _ => throwError "invalid constructor ⟨...⟩, expected type must be an inductive type {indentExpr expectedType}")
(fun ival us => do
match ival.ctors with
| [ctor] =>
let cinfo ← getConstInfoCtor ctor
let numExplicitFields ← forallTelescopeReducing cinfo.type fun xs _ => do
let mut n := 0
for i in [cinfo.numParams:xs.size] do
if (← getFVarLocalDecl xs[i]).binderInfo.isExplicit then
n := n + 1
return n
let args := args.getElems
if args.size < numExplicitFields then
throwError "invalid constructor ⟨...⟩, insufficient number of arguments, constructs '{ctor}' has #{numExplicitFields} explicit fields, but only #{args.size} provided"
let newStx ←
if args.size == numExplicitFields then
`($(mkCIdentFrom stx ctor) $(args)*)
else if numExplicitFields == 0 then
throwError "invalid constructor ⟨...⟩, insufficient number of arguments, constructs '{ctor}' does not have explicit fields, but #{args.size} provided"
else
let extra := args[numExplicitFields-1:args.size]
let newLast ← `(⟨$[$extra],*⟩)
let newArgs := args[0:numExplicitFields-1].toArray.push newLast
`($(mkCIdentFrom stx ctor) $(newArgs)*)
withMacroExpansion stx newStx $ elabTerm newStx expectedType?
| _ => throwError "invalid constructor ⟨...⟩, expected type must be an inductive type with only one constructor {indentExpr expectedType}")
| none => throwError "invalid constructor ⟨...⟩, expected type must be known"
| _ => throwUnsupportedSyntax
@[builtinTermElab borrowed] def elabBorrowed : TermElab := fun stx expectedType? =>
match stx with
| `(@& $e) => return markBorrowed (← elabTerm e expectedType?)
| _ => throwUnsupportedSyntax
@[builtinMacro Lean.Parser.Term.show] def expandShow : Macro := fun stx =>
match stx with
| `(show $type from $val) => let thisId := mkIdentFrom stx `this; `(let_fun $thisId : $type := $val; $thisId)
| `(show $type by%$b $tac:tacticSeq) => `(show $type from by%$b $tac:tacticSeq)
| _ => Macro.throwUnsupported
@[builtinMacro Lean.Parser.Term.have] def expandHave : Macro := fun stx =>
let thisId := mkIdentFrom stx `this
match stx with
| `(have $x $bs* $[: $type]? := $val $[;]? $body) => `(let_fun $x $bs* $[: $type]? := $val; $body)
| `(have $[: $type]? := $val $[;]? $body) => `(have $thisId:ident $[: $type]? := $val; $body)
| `(have $x $bs* $[: $type]? $alts:matchAlts $[;]? $body) => `(let_fun $x $bs* $[: $type]? $alts:matchAlts; $body)
| `(have $[: $type]? $alts:matchAlts $[;]? $body) => `(have $thisId:ident $[: $type]? $alts:matchAlts; $body)
| `(have $pattern:term $[: $type]? := $val:term $[;]? $body) => `(let_fun $pattern:term $[: $type]? := $val:term ; $body)
| _ => Macro.throwUnsupported
@[builtinMacro Lean.Parser.Term.suffices] def expandSuffices : Macro
| `(suffices $[$x :]? $type from $val $[;]? $body) => `(have $[$x]? : $type := $body; $val)
| `(suffices $[$x :]? $type by%$b $tac:tacticSeq $[;]? $body) => `(have $[$x]? : $type := $body; by%$b $tac:tacticSeq)
| _ => Macro.throwUnsupported
open Lean.Parser in
private def elabParserMacroAux (prec : Syntax) (e : Syntax) : TermElabM Syntax := do
let (some declName) ← getDeclName?
| throwError "invalid `leading_parser` macro, it must be used in definitions"
match extractMacroScopes declName with
| { name := Name.str _ s _, scopes := scps, .. } =>
let kind := quote declName
let s := quote s
-- if the parser decl is hidden by hygiene, it doesn't make sense to provide an antiquotation kind
let antiquotKind ← if scps == [] then `(some $kind) else `(none)
``(withAntiquot (mkAntiquot $s $antiquotKind) (leadingNode $kind $prec $e))
| _ => throwError "invalid `leading_parser` macro, unexpected declaration name"
@[builtinTermElab «leading_parser»] def elabLeadingParserMacro : TermElab :=
adaptExpander fun stx => match stx with
| `(leading_parser $e) => elabParserMacroAux (quote Parser.maxPrec) e
| `(leading_parser : $prec $e) => elabParserMacroAux prec e
| _ => throwUnsupportedSyntax
private def elabTParserMacroAux (prec lhsPrec : Syntax) (e : Syntax) : TermElabM Syntax := do
let declName? ← getDeclName?
match declName? with
| some declName => let kind := quote declName; ``(Lean.Parser.trailingNode $kind $prec $lhsPrec $e)
| none => throwError "invalid `trailing_parser` macro, it must be used in definitions"
@[builtinTermElab «trailing_parser»] def elabTrailingParserMacro : TermElab :=
adaptExpander fun stx => match stx with
| `(trailing_parser$[:$prec?]?$[:$lhsPrec?]? $e) =>
elabTParserMacroAux (prec?.getD <| quote Parser.maxPrec) (lhsPrec?.getD <| quote 0) e
| _ => throwUnsupportedSyntax
/--
`panic! msg` formally evaluates to `@Inhabited.default α` if the expected type
`α` implements `Inhabited`.
At runtime, `msg` and the file position are printed to stderr unless the C
function `lean_set_panic_messages(false)` has been executed before. If the C
function `lean_set_exit_on_panic(true)` has been executed before, the process is
then aborted. -/
@[builtinTermElab panic] def elabPanic : TermElab := fun stx expectedType? => do
let arg := stx[1]
let pos ← getRefPosition
let env ← getEnv
let stxNew ← match (← getDeclName?) with
| some declName => `(panicWithPosWithDecl $(quote (toString env.mainModule)) $(quote (toString declName)) $(quote pos.line) $(quote pos.column) $arg)
| none => `(panicWithPos $(quote (toString env.mainModule)) $(quote pos.line) $(quote pos.column) $arg)
withMacroExpansion stx stxNew $ elabTerm stxNew expectedType?
/-- A shorthand for `panic! "unreachable code has been reached"`. -/
@[builtinMacro Lean.Parser.Term.unreachable] def expandUnreachable : Macro := fun stx =>
`(panic! "unreachable code has been reached")
/-- `assert! cond` panics if `cond` evaluates to `false`. -/
@[builtinMacro Lean.Parser.Term.assert] def expandAssert : Macro := fun stx =>
-- TODO: support for disabling runtime assertions
let cond := stx[1]
let body := stx[3]
match cond.reprint with
| some code => `(if $cond then $body else panic! ("assertion violation: " ++ $(quote code)))
| none => `(if $cond then $body else panic! ("assertion violation"))
/--
`dbg_trace e; body` evaluates to `body` and prints `e` (which can be an
interpolated string literal) to stderr. It should only be used for debugging. -/
@[builtinMacro Lean.Parser.Term.dbgTrace] def expandDbgTrace : Macro := fun stx =>
let arg := stx[1]
let body := stx[3]
if arg.getKind == interpolatedStrKind then
`(dbgTrace (s! $arg) fun _ => $body)
else
`(dbgTrace (toString $arg) fun _ => $body)
/-- A temporary placeholder for a missing proof or value. -/
@[builtinTermElab «sorry»] def elabSorry : TermElab := fun stx expectedType? => do
logWarning "declaration uses 'sorry'"
let stxNew ← `(sorryAx _ false)
withMacroExpansion stx stxNew <| elabTerm stxNew expectedType?
/-- Return syntax `Prod.mk elems[0] (Prod.mk elems[1] ... (Prod.mk elems[elems.size - 2] elems[elems.size - 1])))` -/
partial def mkPairs (elems : Array Syntax) : MacroM Syntax :=
let rec loop (i : Nat) (acc : Syntax) := do
if i > 0 then
let i := i - 1
let elem := elems[i]
let acc ← `(Prod.mk $elem $acc)
loop i acc
else
pure acc
loop (elems.size - 1) elems.back
private partial def hasCDot : Syntax → Bool
| Syntax.node _ k args =>
if k == ``Lean.Parser.Term.paren then false
else if k == ``Lean.Parser.Term.cdot then true
else args.any hasCDot
| _ => false
/--
Return `some` if succeeded expanding `·` notation occurring in
the given syntax. Otherwise, return `none`.
Examples:
- `· + 1` => `fun _a_1 => _a_1 + 1`
- `f · · b` => `fun _a_1 _a_2 => f _a_1 _a_2 b` -/
partial def expandCDot? (stx : Syntax) : MacroM (Option Syntax) := do
if hasCDot stx then
let (newStx, binders) ← (go stx).run #[];
`(fun $binders* => $newStx)
else
pure none
where
/--
Auxiliary function for expanding the `·` notation.
The extra state `Array Syntax` contains the new binder names.
If `stx` is a `·`, we create a fresh identifier, store in the
extra state, and return it. Otherwise, we just return `stx`. -/
go : Syntax → StateT (Array Syntax) MacroM Syntax
| stx@(Syntax.node i k args) =>
if k == ``Lean.Parser.Term.paren then pure stx
else if k == ``Lean.Parser.Term.cdot then withFreshMacroScope do
let id ← `(a)
modify fun s => s.push id;
pure id
else do
let args ← args.mapM go
pure $ Syntax.node i k args
| stx => pure stx
/--
Helper method for elaborating terms such as `(.+.)` where a constant name is expected.
This method is usually used to implement tactics that function names as arguments (e.g., `simp`).
-/
def elabCDotFunctionAlias? (stx : Syntax) : TermElabM (Option Expr) := do
let some stx ← liftMacroM <| expandCDotArg? stx | pure none
let stx ← liftMacroM <| expandMacros stx
match stx with
| `(fun $binders* => $f:ident $args*) =>
if binders == args then
try Term.resolveId? f catch _ => return none
else
return none
| `(fun $binders* => binop% $f:ident $a $b) =>
if binders == #[a, b] then
try Term.resolveId? f catch _ => return none
else
return none
| _ => return none
where
expandCDotArg? (stx : Syntax) : MacroM (Option Syntax) :=
match stx with
| `(($e)) => Term.expandCDot? e
| _ => Term.expandCDot? stx
/-
Try to expand `·` notation.
Recall that in Lean the `·` notation must be surrounded by parentheses.
We may change this is the future, but right now, here are valid examples
- `(· + 1)`
- `(f ⟨·, 1⟩ ·)`
- `(· + ·)`
- `(f · a b)` -/
@[builtinMacro Lean.Parser.Term.paren] def expandParen : Macro
| `(()) => `(Unit.unit)
| `(($e : $type)) => do
match (← expandCDot? e) with
| some e => `(($e : $type))
| none => Macro.throwUnsupported
| `(($e)) => return (← expandCDot? e).getD e
| `(($e, $es,*)) => do
let pairs ← mkPairs (#[e] ++ es)
(← expandCDot? pairs).getD pairs
| stx =>
if !stx[1][0].isMissing && stx[1][1].isMissing then
-- parsed `(` and `term`, assume it's a basic parenthesis to get any elaboration output at all
`(($(stx[1][0])))
else
throw <| Macro.Exception.error stx "unexpected parentheses notation"
@[builtinTermElab paren] def elabParen : TermElab := fun stx expectedType? => do
match stx with
| `(($e : $type)) =>
let type ← withSynthesize (mayPostpone := true) <| elabType type
let e ← elabTerm e type
ensureHasType type e
| _ => throwUnsupportedSyntax
/-- Return `true` if `lhs` is a free variable and `rhs` does not depend on it. -/
private def isSubstCandidate (lhs rhs : Expr) : MetaM Bool :=
if lhs.isFVar then
return !(← dependsOn rhs lhs.fvarId!)
else
return false
/--
Given an expression `e` that is the elaboration of `stx`, if `e` is a free variable, then return `k stx`.
Otherwise, return `(fun x => k x) e`
-/
private def withLocalIdentFor (stx : Syntax) (e : Expr) (k : Syntax → TermElabM Expr) : TermElabM Expr := do
if e.isFVar then
k stx
else
let id ← mkFreshUserName `h
let aux ← withLocalDeclD id (← inferType e) fun x => do mkLambdaFVars #[x] (← k (mkIdentFrom stx id))
return mkApp aux e
@[builtinTermElab subst] def elabSubst : TermElab := fun stx expectedType? => do
let expectedType ← tryPostponeIfHasMVars expectedType? "invalid `▸` notation"
match stx with
| `($heqStx ▸ $hStx) => do
let mut heq ← elabTerm heqStx none
let heqType ← inferType heq
let heqType ← instantiateMVars heqType
match (← Meta.matchEq? heqType) with
| none => throwError "invalid `▸` notation, argument{indentExpr heq}\nhas type{indentExpr heqType}\nequality expected"
| some (α, lhs, rhs) =>
let mut lhs := lhs
let mut rhs := rhs
let mkMotive (typeWithLooseBVar : Expr) := do
withLocalDeclD (← mkFreshUserName `x) α fun x => do
mkLambdaFVars #[x] $ typeWithLooseBVar.instantiate1 x
let mut expectedAbst ← kabstract expectedType rhs
unless expectedAbst.hasLooseBVars do
expectedAbst ← kabstract expectedType lhs
unless expectedAbst.hasLooseBVars do
throwError "invalid `▸` notation, expected type{indentExpr expectedType}\ndoes contain equation left-hand-side nor right-hand-side{indentExpr heqType}"
heq ← mkEqSymm heq
(lhs, rhs) := (rhs, lhs)
let hExpectedType := expectedAbst.instantiate1 lhs
let (h, badMotive?) ← withRef hStx do
let h ← elabTerm hStx hExpectedType
try
return (← ensureHasType hExpectedType h, none)
catch ex =>
-- if `rhs` occurs in `hType`, we try to apply `heq` to `h` too
let hType ← inferType h
let hTypeAbst ← kabstract hType rhs
unless hTypeAbst.hasLooseBVars do
throw ex
let hTypeNew := hTypeAbst.instantiate1 lhs
unless (← isDefEq hExpectedType hTypeNew) do
throw ex
let motive ← mkMotive hTypeAbst
if !(← isTypeCorrect motive) then
return (h, some motive)
else
return (← mkEqNDRec motive h (← mkEqSymm heq), none)
let motive ← mkMotive expectedAbst
if badMotive?.isSome || !(← isTypeCorrect motive) then
-- Before failing try tos use `subst`
if ← (isSubstCandidate lhs rhs <||> isSubstCandidate rhs lhs) then
withLocalIdentFor heqStx heq fun heqStx =>
withLocalIdentFor hStx h fun hStx => do
let stxNew ← `(by subst $heqStx; exact $hStx)
withMacroExpansion stx stxNew (elabTerm stxNew expectedType)
else
throwError "invalid `▸` notation, failed to compute motive for the substitution"
else
mkEqNDRec motive h heq
| _ => throwUnsupportedSyntax
@[builtinTermElab stateRefT] def elabStateRefT : TermElab := fun stx _ => do
let σ ← elabType stx[1]
let mut mStx := stx[2]
if mStx.getKind == ``Lean.Parser.Term.macroDollarArg then
mStx := mStx[1]
let m ← elabTerm mStx (← mkArrow (mkSort levelOne) (mkSort levelOne))
let ω ← mkFreshExprMVar (mkSort levelOne)
let stWorld ← mkAppM ``STWorld #[ω, m]
discard <| mkInstMVar stWorld
mkAppM ``StateRefT' #[ω, σ, m]
@[builtinTermElab noindex] def elabNoindex : TermElab := fun stx expectedType? => do
let e ← elabTerm stx[1] expectedType?
return DiscrTree.mkNoindexAnnotation e
end Lean.Elab.Term