-
Notifications
You must be signed in to change notification settings - Fork 822
Expand file tree
/
Copy pathStructure.lean
More file actions
1603 lines (1482 loc) · 78.5 KB
/
Structure.lean
File metadata and controls
1603 lines (1482 loc) · 78.5 KB
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
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
/-
Copyright (c) 2020 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
module
prelude
public import Lean.Meta.Structure
public import Lean.Elab.MutualInductive
import Init.Omega
public section
namespace Lean.Elab.Command
builtin_initialize
registerTraceClass `Elab.structure
registerTraceClass `Elab.structure.resolutionOrder
register_builtin_option structureDiamondWarning : Bool := {
defValue := false
descr := "if true, enable warnings when a structure has diamond inheritance"
}
register_builtin_option structure.strictResolutionOrder : Bool := {
defValue := false
descr := "if true, require a strict resolution order for structures"
}
open Meta
open TSyntax.Compat
namespace Structure
/-! Recall that the `structure command syntax is
```
leading_parser (structureTk <|> classTk) >> declId >> optDeclSig >> optional «extends» >> optional (" := " >> optional structCtor >> structFields)
```
-/
/--
Represents the data of the syntax of a structure parent.
-/
structure StructParentView where
ref : Syntax
/-- Ref to use for the parent projection. -/
projRef : Syntax
/-- The name of the parent projection (without macro scopes). -/
name? : Option Name
/-- The name of the parent projection (with macro scopes). Used for local name during elaboration. -/
rawName? : Option Name
type : Syntax
inductive StructFieldViewDefault where
| optParam (value : Syntax)
| autoParam (tactic : Syntax)
/--
Represents the data of the syntax of a structure field declaration.
-/
structure StructFieldView where
ref : Syntax
modifiers : Modifiers
binderInfo : BinderInfo
declName : Name
/-- Ref for the field name -/
nameId : Syntax
/-- The name of the field (without macro scopes). -/
name : Name
/-- The name of the field (with macro scopes).
Used when adding the field to the local context, for field elaboration. -/
rawName : Name
binders : Syntax
type? : Option Syntax
default? : Option StructFieldViewDefault
structure StructView extends InductiveView where
parents : Array StructParentView
fields : Array StructFieldView
deriving Inhabited
/--
Gets the single constructor view from the underlying `InductiveView`.
Recall that `structure`s have exactly one constructor.
-/
def StructView.ctor (view : StructView) : CtorView :=
view.ctors[0]!
/--
Elaborated parent info.
-/
structure StructParentInfo where
ref : Syntax
/-- Whether to add term info to the ref. False if there's no user-provided parent projection. -/
addTermInfo : Bool
/-- A let variable that represents this structure parent. -/
fvar : Expr
structName : Name
/-- Field name for parent. -/
name : Name
/-- Name of the projection function. -/
declName : Name
/-- Whether this parent corresponds to a `subobject` field. -/
subobject : Bool
deriving Inhabited
/--
Records the way in which a field is represented in a structure.
Standard fields are one of `.newField`, `.copiedField`, or `.fromSubobject`.
Parent fields are one of `.subobject` or `.otherParent`.
-/
inductive StructFieldKind where
/-- New field defined by the `structure`.
Represented as a constructor argument. Will have a projection function. -/
| newField
/-- Field that comes from a parent but will be represented as a new field.
Represented as a constructor argument. Will have a projection function.
Its inherited default value may be overridden. -/
| copiedField
/-- Field that comes from a embedded parent field, and is represented within a `subobject` field.
Not represented as a constructor argument. Will not have a projection function.
Its inherited default value may be overridden. -/
| fromSubobject
/-- The field is an embedded parent structure.
Represented as a constructor argument. Will have a projection function.
Default values are not allowed. -/
| subobject (structName : Name)
/-- The field represents a parent projection for a parent that is not itself embedded as a subobject.
(Note: parents of `subobject` fields are `otherParent` fields.)
Not represented as a constructor argument. Will only have a projection function if it is a direct parent.
Default values are not allowed. -/
| otherParent (structName : Name)
deriving Inhabited, DecidableEq, Repr
def StructFieldKind.isFromSubobject (kind : StructFieldKind) : Bool :=
kind matches StructFieldKind.fromSubobject
def StructFieldKind.isSubobject (kind : StructFieldKind) : Bool :=
kind matches StructFieldKind.subobject ..
/-- Returns `true` if the field represents a parent projection. -/
def StructFieldKind.isParent (kind : StructFieldKind) : Bool :=
kind matches StructFieldKind.subobject .. | StructFieldKind.otherParent ..
/-- Returns `true` if the field is represented as a field in the constructor. -/
def StructFieldKind.isInCtor (kind : StructFieldKind) : Bool :=
kind matches .newField | .copiedField | .subobject ..
inductive StructFieldDefault where
| optParam (value : Expr)
| autoParam (tactic : Expr)
deriving Repr
/--
Elaborated field info.
-/
structure StructFieldInfo where
ref : Syntax
name : Name
kind : StructFieldKind
/-- Name of projection function.
Remark: for fields that don't get projection functions (like `fromSubobject` fields), only relevant for the auxiliary "default value" functions. -/
declName : Name
/-- Binder info to use when making the constructor. Only applies to those fields that will appear in the constructor. -/
binfo : BinderInfo
/-- Overrides for the parameters' binder infos when making the projections. The first component is a ref for the binder. -/
paramInfoOverrides : ExprMap (Syntax × BinderInfo) := {}
/-- Number of binders for the field's type, used for elaborating the default value for the field (if present). -/
numBinders : Nat := 0
/--
Structure names that are responsible for this field being here.
- Empty if the field is a `newField`.
- Otherwise, it is a stack with the last element being a parent in the `extends` clause.
The first element is the (indirect) parent that is responsible for this field.
-/
sourceStructNames : List Name
/-- Local variable for the field.
All fields (both real fields and parent projection fields) get a local variable.
Parent fields are ldecls constructed from non-parent fields. -/
fvar : Expr
/-- An expression representing a `.fromSubobject` field as a projection of a `.subobject` field.
Used when making the constructor.
Note: `.otherParent` fields are let decls, there is no need for `projExpr?`. -/
projExpr? : Option Expr := none
/-- The default value, as explicitly given in this `structure`. -/
default? : Option StructFieldDefault := none
/-- If this is an inherited field, the name of the projection function.
Used for adding terminfo for fields with overridden default values. -/
projFn? : Option Name := none
/-- The inherited default values, as parent structure / value pairs. -/
inheritedDefaults : Array (Name × StructFieldDefault) := #[]
/-- The default that will be used for this structure. -/
resolvedDefault? : Option StructFieldDefault := none
deriving Inhabited
/-!
### View construction
-/
private def defaultCtorName := `mk
/--
Drops the docstring from structure constructor or binder syntax (i.e., syntax with leading
`declModifiers`), preserving source information. Used for generating error message hint spans.
-/
private def dropLeadingDeclModifiersDocstring (stx : Syntax) : Syntax :=
stx.modifyArgs (·.modify 0 (·.setArg 0 mkNullNode))
/--
Creates a hint to delete a `private` modifier from the decl modifiers `stx` of either a field or a
constructor (indicated by the value of `fieldKindDescr`) if such a modifier exists. `fullSpan`
should be the full field or constructor syntax, whose first argument is a doc comment.
-/
private def mkDeletePrivateFieldHint (stx : TSyntax ``Parser.Command.declModifiers) (fullSpan : Syntax) (fieldKindDescr : String) := do
let previewSpan? := dropLeadingDeclModifiersDocstring fullSpan
let .original .. := stx.raw.getHeadInfo | pure .nil
let some range := stx.raw[2].getRangeWithTrailing? | pure .nil
MessageData.hint m!"Remove `private` modifier from {fieldKindDescr}" #[{
suggestion := ""
span? := Syntax.ofRange range
toCodeActionTitle? := some fun _ => "Delete `private` modifier"
previewSpan?
}]
/-
The structure constructor syntax is
```
def structCtor := leading_parser
declModifiers true >> ident >> many Term.bracketedBinder >> " :: "
```
and `structStx[4]` is `optional (" where " >> optional structCtor >> structFields)`.
-/
private def expandCtor (structStx : Syntax) (structModifiers : Modifiers) (structDeclName : Name)
(forcePrivate : Bool) : TermElabM CtorView := do
let useDefault := do
let visibility := if forcePrivate then .private else .regular
let modifiers := { (default : Modifiers) with visibility }
let declName := structDeclName ++ defaultCtorName
let declName ← applyVisibility modifiers declName
let ref := structStx[1].mkSynthetic
addDeclarationRangesFromSyntax declName ref
if structModifiers.isMeta then
modifyEnv (markMeta · declName)
pure { ref, declId := ref, modifiers, declName }
if structStx[4].isNone then
useDefault
else
let optCtor := structStx[4][1]
if optCtor.isNone then
useDefault
else
let ctor := optCtor[0]
withRef ctor do
let modifiersStx := ctor[0]
let ctorModifiers ← elabModifiers modifiersStx
checkValidCtorModifier ctorModifiers
if ctorModifiers.isPrivate && structModifiers.isPrivate then
let hint ← mkDeletePrivateFieldHint modifiersStx ctor "constructor"
throwError m!"Constructor cannot be marked `private` because it is already in a `private` structure" ++ hint
if ctorModifiers.isProtected && structModifiers.isPrivate then
throwError "Constructor cannot be `protected` because this structure is `private`"
if !ctorModifiers.isPrivate && forcePrivate then
let hint ← do
let .original .. := ctor.getHeadInfo | pure .nil
let spanSuggestion? :=
if modifiersStx[2].getRange?.isSome then
some (modifiersStx[2], "private")
-- Place `private` after the doc comment, or else before other modifiers, or else before the identifier
else if let some pos := modifiersStx[0].getTrailingTailPos? <|> modifiersStx.getPos? <|> ctor[1].getPos? then
some (Syntax.ofRange ⟨pos, pos⟩, "private ")
else none
let some (span?, suggestion) := spanSuggestion? | pure .nil
let previewSpan? := dropLeadingDeclModifiersDocstring ctor
MessageData.hint m!"Mark constructor as `private`" #[{
suggestion, span?, previewSpan?, toCodeActionTitle? := some fun _ => "Mark constructor private"
}]
throwError m!"Constructor must be `private` because one or more of this structure's fields are `private`" ++ hint
let name := ctor[1].getId
let declName := structDeclName ++ name
let declName ← applyVisibility ctorModifiers declName
-- `binders` is type parameter binder overrides; this will be validated when the constructor is created in `Structure.mkCtor`.
let binders := ctor[2]
addDeclarationRangesFromSyntax declName ctor[1]
if structModifiers.isMeta then
modifyEnv (markMeta · declName)
pure { ref := ctor[1], declId := ctor[1], modifiers := ctorModifiers, declName, binders }
/--
```
def structParent := leading_parser optional (atomic (ident >> " : ")) >> termParser
def «extends» := leading_parser " extends " >> sepBy1 structParent ", "
```
-/
private def expandParents (optExtendsStx : Syntax) : TermElabM (Array StructParentView) := do
let parentDecls := if optExtendsStx.isNone then #[] else optExtendsStx[0][1].getSepArgs
parentDecls.mapM fun parentDecl => withRef parentDecl do
let mut projRef := parentDecl
let mut rawName? := none
let mut name? := none
unless parentDecl[0].isNone do
let ident := parentDecl[0][0]
let rawName := ident.getId
let name := rawName.eraseMacroScopes
unless name.isAtomic do
throwErrorAt ident "Invalid parent projection name `{name}`: Name must be atomic"
projRef := ident
rawName? := rawName
name? := name
let type := parentDecl[1]
return {
ref := parentDecl
projRef
name?
rawName?
type
}
def checkValidFieldModifier (modifiers : Modifiers) : TermElabM Unit := do
if modifiers.isNoncomputable then
throwError "Invalid modifier: Fields cannot be marked as `noncomputable`"
if modifiers.isPartial then
throwError "Invalid modifier: Fields cannot be marked as `partial`"
if modifiers.isUnsafe then
throwError "Invalid modifier: Fields cannot be marked as `unsafe`"
/-
```
def structExplicitBinder := leading_parser atomic (declModifiers true >> "(") >> many1 ident >> optDeclSig >> optional (Term.binderTactic <|> Term.binderDefault) >> ")"
def structImplicitBinder := leading_parser atomic (declModifiers true >> "{") >> many1 ident >> declSig >> "}"
def structInstBinder := leading_parser atomic (declModifiers true >> "[") >> many1 ident >> declSig >> "]"
def structSimpleBinder := leading_parser atomic (declModifiers true >> ident) >> optDeclSig >> optional (Term.binderTactic <|> Term.binderDefault)
def structFields := leading_parser many (structExplicitBinder <|> structImplicitBinder <|> structInstBinder)
```
-/
private def expandFields (structStx : Syntax) (structModifiers : Modifiers) (structDeclName : Name) : TermElabM (Array StructFieldView) := do
if structStx[4][0].isToken ":=" then
-- https://github.com/leanprover/lean4/issues/5236
let cmd := if structStx[0].getKind == ``Parser.Command.classTk then "class" else "structure"
withRef structStx[0] <| Linter.logLintIf Linter.linter.deprecated structStx[4][0]
s!"`{cmd} ... :=` has been deprecated in favor of `{cmd} ... where`."
let fieldBinders := if structStx[4].isNone then #[] else structStx[4][2][0].getArgs
fieldBinders.foldlM (init := #[]) fun (views : Array StructFieldView) fieldBinder => withRef fieldBinder do
let mut fieldBinder := fieldBinder
if fieldBinder.getKind == ``Parser.Command.structSimpleBinder then
fieldBinder := mkNode ``Parser.Command.structExplicitBinder
#[ fieldBinder[0], mkAtomFrom fieldBinder "(", mkNullNode #[ fieldBinder[1] ], fieldBinder[2], fieldBinder[3], fieldBinder[4], mkAtomFrom fieldBinder ")" ]
let k := fieldBinder.getKind
let binfo ←
if k == ``Parser.Command.structExplicitBinder then pure BinderInfo.default
else if k == ``Parser.Command.structImplicitBinder then pure BinderInfo.implicit
else if k == ``Parser.Command.structInstBinder then pure BinderInfo.instImplicit
else throwError "Found an unexpected binder type for field{indentD fieldBinder}"
let fieldModifiers ← elabModifiers fieldBinder[0]
checkValidFieldModifier fieldModifiers
if fieldModifiers.isPrivate && structModifiers.isPrivate then
let hint ← mkDeletePrivateFieldHint fieldBinder[0] fieldBinder "field"
throwError m!"Field cannot be marked `private` because it is already in a `private` structure" ++ hint
if fieldModifiers.isProtected && structModifiers.isPrivate then
throwError "Field cannot be marked `protected` because this structure is `private`"
let (binders, type?, default?) ←
if binfo == BinderInfo.default then
let (binders, type?) := expandOptDeclSig fieldBinder[3]
let optBinderTacticDefault := fieldBinder[4]
if optBinderTacticDefault.isNone then
pure (binders, type?, none)
else if optBinderTacticDefault[0].getKind != ``Parser.Term.binderTactic then
-- binderDefault := leading_parser " := " >> termParser
let value := optBinderTacticDefault[0][1]
pure (binders, type?, some <| StructFieldViewDefault.optParam value)
else
let binderTactic := optBinderTacticDefault[0]
let tac := binderTactic[2]
-- Auto-param applies to `forall $binders*, $type`, which will be handled in `elabFieldTypeValue`
pure (binders, type?, some <| StructFieldViewDefault.autoParam tac)
else
let (binders, type) := expandDeclSig fieldBinder[3]
pure (binders, some type, none)
let idents := fieldBinder[2].getArgs
idents.foldlM (init := views) fun (views : Array StructFieldView) ident => withRef ident do
let rawName := ident.getId
let name := rawName.eraseMacroScopes
unless name.isAtomic do
throwErrorAt ident "Invalid field name `{name.eraseMacroScopes}`: Field names must be atomic"
let declName := structDeclName ++ name
let declName ← applyVisibility fieldModifiers declName
return views.push {
ref := ident
modifiers := fieldModifiers
binderInfo := binfo
declName
name
nameId := ident
rawName
binders
type?
default?
}
/-
leading_parser (structureTk <|> classTk) >> declId >> optDeclSig >> optional «extends» >>
optional (("where" <|> ":=") >> optional structCtor >> structFields) >> optDeriving
where
def structParent := leading_parser optional (atomic (ident >> " : ")) >> termParser
def «extends» := leading_parser " extends " >> sepBy1 structParent ", " >> optType
def structFields := leading_parser many (structExplicitBinder <|> structImplicitBinder <|> structInstBinder)
def structCtor := leading_parser try (declModifiers >> ident >> " :: ")
-/
def structureSyntaxToView (modifiers : Modifiers) (stx : Syntax) : TermElabM StructView := do
checkValidInductiveModifier modifiers
let isClass := stx[0].getKind == ``Parser.Command.classTk
-- **Note**: We use `addFirstAttr` to make sure the `[class]` attribute is processed **before** `[univ_out_params]`
let modifiers := if isClass then modifiers.addFirstAttr { name := `class } else modifiers
let declId := stx[1]
let ⟨name, declName, levelNames, docString?⟩ ← Term.expandDeclId (← getCurrNamespace) (← Term.getLevelNames) declId modifiers
-- In the case of mutual inductives, this is the earliests point where we can establish the
-- correct scope for each individual inductive declaration (used e.g. to infer ctor visibility
-- below), so let's do that now.
withExporting (isExporting := !isPrivateName declName) do
if modifiers.isMeta then
modifyEnv (markMeta · declName)
addDeclarationRangesForBuiltin declName modifiers.stx stx
let (binders, type?) := expandOptDeclSig stx[2]
let exts := stx[3]
let type? ←
-- Compatibility mode for `structure S extends P : Type` syntax
if type?.isNone && !exts.isNone && !exts[0][2].isNone then
logWarningAt exts[0][2][0] <| "\
The syntax is now `structure S : Type extends P` rather than `structure S extends P : Type`"
++ .note "The purpose of this change is to accommodate `structure S extends toP : P` syntax for naming parent projections."
pure (some exts[0][2][0][1])
else
if !exts.isNone && !exts[0][2].isNone then
logErrorAt exts[0][2][0] <| "\
Unexpected additional resulting type. \
The syntax is now `structure S : Type extends P` rather than `structure S extends P : Type`."
++ .note "The purpose of this change is to accommodate `structure S extends toP : P` syntax for naming parent projections."
pure type?
let parents ← expandParents exts
let derivingClasses ← getOptDerivingClasses stx[5]
let fields ← expandFields stx modifiers declName
-- Private fields imply a private constructor (in the module system only, for back-compat)
let ctor ← expandCtor
(forcePrivate := (← getEnv).header.isModule && fields.any (·.modifiers.isPrivate))
stx modifiers declName
fields.forM fun field => do
if field.declName == ctor.declName then
throwErrorAt field.ref "Invalid field name `{field.name}`: This is the name of the structure constructor"
addDeclarationRangesFromSyntax field.declName field.ref
return {
ref := stx
declId
modifiers
isClass
shortDeclName := name
declName
levelNames
binders
type?
allowIndices := false
allowSortPolymorphism := false
ctors := #[ctor]
parents
fields
computedFields := #[]
derivingClasses
docString?
}
/-!
### Elaboration
-/
private structure State where
/-- Immediate parents. -/
parents : Array StructParentInfo := #[]
/-- All fields, both newly defined and inherited. Every parent has a `StructFieldInfo` too. -/
fields : Array StructFieldInfo := #[]
/-- Map from field name to its index in `fields`. -/
fieldIdx : NameMap Nat := {}
/-- Map from structure name to `field` index. -/
ancestorFieldIdx : NameMap Nat := {}
/-- Map from fvar ids to its index in `fields`. -/
fvarIdFieldIdx : FVarIdMap Nat := {}
deriving Inhabited
/--
Monad for elaborating parents and fields of a `structure`.
-/
private abbrev StructElabM := StateT State TermElabM
private instance : Inhabited (StructElabM α) where
default := throw default
private def runStructElabM (k : StructElabM α) (init : State := {}) : TermElabM α := k.run' init
private def addParentInfo (parent : StructParentInfo) : StructElabM Unit := do
modify fun s => { s with parents := s.parents.push parent }
private def findFieldInfo? (fieldName : Name) : StructElabM (Option StructFieldInfo) := do
let s ← get
return s.fieldIdx.find? fieldName |>.map fun idx => s.fields[idx]!
private def hasFieldName (fieldName : Name) : StructElabM Bool :=
return (← get).fieldIdx.contains fieldName
private def findFieldInfoByFVarId? (fvarId : FVarId) : StructElabM (Option StructFieldInfo) := do
let s ← get
return s.fvarIdFieldIdx.get? fvarId |>.map fun idx => s.fields[idx]!
/--
Inserts a field info into the current state.
Throws an error if there is already a field with that name.
-/
private def addFieldInfo (info : StructFieldInfo) : StructElabM Unit := do
if ← hasFieldName info.name then
throwError "Internal error in addFieldInfo: Structure field `{info.name}` already exists"
else
modify fun s =>
let idx := s.fields.size
{ s with
fields := s.fields.push info
fieldIdx := s.fieldIdx.insert info.name idx
fvarIdFieldIdx := s.fvarIdFieldIdx.insert info.fvar.fvarId! idx
ancestorFieldIdx :=
match info.kind with
| .subobject structName | .otherParent structName =>
s.ancestorFieldIdx.insert structName idx
| _ =>
s.ancestorFieldIdx
}
private def findParentFieldInfo? (structName : Name) : StructElabM (Option StructFieldInfo) := do
let s ← get
return s.ancestorFieldIdx.find? structName |>.map fun idx => s.fields[idx]!
/--
Replaces the field info for a given field.
Throws an error if there is not already a field with that name.
-/
private def replaceFieldInfo (info : StructFieldInfo) : StructElabM Unit := do
if let some idx := (← get).fieldIdx.find? info.name then
modify fun s => { s with fields := s.fields.set! idx info }
else
throwError "Internal error in replaceFieldInfo: Structure field `{info.name}` does not already exist"
private def addFieldInheritedDefault (fieldName : Name) (structName : Name) (d : StructFieldDefault) : StructElabM Unit := do
let some info ← findFieldInfo? fieldName
| throwError "Internal error in addFieldInheritedDefault: Structure field `{fieldName}` does not already exist"
replaceFieldInfo { info with inheritedDefaults := info.inheritedDefaults.push (structName, d) }
/--
Reduces projections applied to constructors or parent fvars, for structure types that have appeared as parents.
If `zetaDelta` is true (default), then zeta reduces parent fvars as needed to do the reductions.
-/
private def reduceFieldProjs (e : Expr) (zetaDelta := true) : StructElabM Expr := do
let e ← instantiateMVars e
let postVisit (e : Expr) : StructElabM TransformStep := do
if let Expr.const projName .. := e.getAppFn then
if let some projInfo ← getProjectionFnInfo? projName then
let ConstantInfo.ctorInfo cval := (← getEnv).find? projInfo.ctorName | unreachable!
if let some info ← findParentFieldInfo? cval.induct then
let args := e.getAppArgs
if let some major := args[projInfo.numParams]? then
let major ←
if zetaDelta && major == info.fvar then
pure <| (← major.fvarId!.getValue?).getD major
else
pure major
if major.isAppOfArity projInfo.ctorName (cval.numParams + cval.numFields) then
if let some arg := major.getAppArgs[projInfo.numParams + projInfo.i]? then
return TransformStep.visit <| mkAppN arg args[(projInfo.numParams+1)...*]
return TransformStep.continue
Meta.transform e (post := postVisit)
/--
Puts an expression into "field normal form".
- All projections of constructors for parent structures are reduced.
- If `zetaDelta` is true (default) then all parent fvars are zeta reduced.
- Constructors of parent structures are eta reduced.
-/
private def fieldNormalizeExpr (e : Expr) (zetaDelta : Bool := true) : StructElabM Expr := do
let ancestors := (← get).ancestorFieldIdx
etaStructReduce (p := ancestors.contains) <| ← reduceFieldProjs e (zetaDelta := zetaDelta)
private def fieldFromMsg (info : StructFieldInfo) : MessageData :=
if let some sourceStructName := info.sourceStructNames.head? then
m!"field `{info.name}` from `{.ofConstName sourceStructName}`"
else
m!"field `{info.name}`"
/--
Instantiates default value for field `fieldName` set at structure `structName`, using the field fvars in the `StructFieldInfo`s.
After default values are resolved, then the one that is added to the environment
as an `_inherited_default` auxiliary function is normalized;
we don't do those normalizations here, since that could be wasted effort if this default isn't chosen.
-/
private partial def getFieldDefaultValue? (structName : Name) (params : Array Expr) (fieldName : Name) : StructElabM (Option Expr) := do
let some defFn := getDefaultFnForField? (← getEnv) structName fieldName
| return none
let fieldVal? (n : Name) : StructElabM (Option Expr) := do
let some info ← findFieldInfo? n | return none
return info.fvar
let some (_, val) ← instantiateStructDefaultValueFn? defFn none params fieldVal?
| logWarning m!"Default value for field `{fieldName}` of structure `{.ofConstName structName}` could not be instantiated; ignoring"
return none
return val
private def getFieldDefault? (structName : Name) (params : Array Expr) (fieldName : Name) :
StructElabM (Option StructFieldDefault) := do
if let some val ← getFieldDefaultValue? structName params fieldName then
-- Important: we use `getFieldDefaultValue?` because we want default value definitions, not *inherited* ones, to properly handle diamonds
trace[Elab.structure] "found default value for '{fieldName}' from '{.ofConstName structName}'{indentExpr val}"
return StructFieldDefault.optParam val
else if let some fn := getAutoParamFnForField? (← getEnv) structName fieldName then
trace[Elab.structure] "found autoparam for '{fieldName}' from '{.ofConstName structName}'"
return StructFieldDefault.autoParam (Expr.const fn [])
else
return none
private def toModifiers (fieldInfo : StructureFieldInfo) : CoreM Modifiers := do
return {
isProtected := isProtected (← getEnv) fieldInfo.projFn
visibility := if isPrivateName fieldInfo.projFn then .private else .regular
}
mutual
/--
Adds `fieldName` of type `fieldType` from structure `structName`.
See `withStructFields` for meanings of other arguments.
-/
private partial def withStructField (view : StructView) (sourceStructNames : List Name) (inSubobject? : Option Expr)
(structName : Name) (params : Array Expr) (fieldName : Name) (fieldType : Expr)
(k : Expr → StructElabM α) : StructElabM α := do
trace[Elab.structure] "withStructField '{.ofConstName structName}', field '{fieldName}'"
let fieldType ← instantiateMVars fieldType
let fieldType := fieldType.consumeTypeAnnotations -- remove autoParam from constructor field
let env ← getEnv
let some fieldInfo := getFieldInfo? env structName fieldName
| throwError "Internal error in withStructField: No such field `{fieldName}` of `{.ofConstName structName}`"
if let some _ := fieldInfo.subobject? then
-- It's a subobject field, add it and its fields
withStruct view (structName :: sourceStructNames) (binfo := fieldInfo.binderInfo)
fieldName fieldType inSubobject? fun info => k info.fvar
else if let some existingField ← findFieldInfo? fieldName then
-- It's a pre-existing field, make sure it is compatible (unless diamonds are not allowed)
if structureDiamondWarning.get (← getOptions) then
logWarning m!"Field `{fieldName}` from `{.ofConstName structName}` has already been declared"
let existingFieldType ← inferType existingField.fvar
unless (← isDefEq fieldType existingFieldType) do
throwError "Field type mismatch: Field `{fieldName}` from parent `{.ofConstName structName}` {← mkHasTypeButIsExpectedMsg fieldType existingFieldType}"
if let some d ← getFieldDefault? structName params fieldName then
addFieldInheritedDefault fieldName structName d
k existingField.fvar
else
-- It's a not-yet-seen field
/- For `.fromSubobject`: the following `declName` is only used for creating the `_default`/`_inherited_default` auxiliary declaration name when
its default value is overridden, otherwise the `declName` is irrelevant, except to ensure a declaration is not already declared. -/
let mut declName := view.declName ++ fieldName
if inSubobject?.isNone then
declName ← applyVisibility (← toModifiers fieldInfo) declName
-- Create a link to the parent field's docstring
addInheritedDocString declName fieldInfo.projFn
addDeclarationRangesFromSyntax declName (← getRef)
checkNotAlreadyDeclared declName
withLocalDecl fieldName fieldInfo.binderInfo (← reduceFieldProjs fieldType) fun fieldFVar => do
let projExpr? ← inSubobject?.mapM fun subobject => mkProjection subobject fieldName
addFieldInfo {
ref := (← getRef)
sourceStructNames := structName :: sourceStructNames
name := fieldName
declName
kind := if inSubobject?.isSome then .fromSubobject else .copiedField
fvar := fieldFVar
projExpr?
binfo := fieldInfo.binderInfo
projFn? := fieldInfo.projFn
}
if let some d ← getFieldDefault? structName params fieldName then
addFieldInheritedDefault fieldName structName d
k fieldFVar
/--
Adds all the fields from `structType` along with its parent projection fields.
Does not add a parent field for the structure itself; that is done by `withStruct`.
- if `inSubobject?` is `some e`, then `e` must be an expression representing the `.subobject` parent being constructed (a metavariable),
and the added fields are marked `.fromSubobject` and are set to have `e` projections
- `sourceStructNames` is a stack of the structures visited, used for error reporting
- the continuation `k` is run with a constructor expression for this structure
-/
private partial def withStructFields (view : StructView) (sourceStructNames : List Name)
(structType : Expr) (inSubobject? : Option Expr)
(k : Expr → StructElabM α) : StructElabM α := do
let structName ← getStructureName structType
let .const _ us := structType.getAppFn | unreachable!
let params := structType.getAppArgs
trace[Elab.structure] "withStructFields '{.ofConstName structName}'"
let env ← getEnv
let fields := getStructureFields env structName
let parentInfos := getStructureParentInfo env structName
let ctorVal := getStructureCtor env structName
let ctor := mkAppN (mkConst ctorVal.name us) params
let (fieldMVars, _, _) ← forallMetaTelescope (← inferType ctor)
assert! fieldMVars.size == fields.size
-- Go through all parents to make sure parent projections are consistent.
let rec goParents (s : Expr) (i : Nat) : StructElabM α := do
if h : i < parentInfos.size then
let parentInfo := parentInfos[i]
if parentInfo.subobject then
goParents s (i + 1)
else
let fieldName := Name.mkSimple parentInfo.projFn.getString!
let fieldType ← inferType <| mkApp (mkAppN (.const parentInfo.projFn us) params) s
withStruct view (structName :: sourceStructNames) (binfo := .default)
fieldName fieldType inSubobject? fun _ => goParents s (i + 1)
else
k s
let rec goFields (i : Nat) : StructElabM α := do
if h : i < fields.size then
let fieldName := fields[i]
let fieldMVar := fieldMVars[i]!
let fieldType ← inferType fieldMVar
withStructField view sourceStructNames inSubobject? structName params fieldName fieldType fun fieldFVar => do
fieldMVar.mvarId!.assign fieldFVar
goFields (i + 1)
else
let s ← instantiateMVars <| mkAppN ctor fieldMVars
goParents s 0
goFields 0
/--
Adds a parent structure and all its fields.
- `structFieldName` is the name to use for the parent field.
- `rawStructFieldName` is name to use in local context, for hygiene. By default it is `structFieldName`.
See `withStructFields` for meanings of other arguments.
-/
private partial def withStruct (view : StructView) (sourceStructNames : List Name) (binfo : BinderInfo)
(structFieldName : Name)
(structType : Expr) (inSubobject? : Option Expr)
(k : StructFieldInfo → StructElabM α)
(rawStructFieldName := structFieldName) (projRef := Syntax.missing) :
StructElabM α := do
let env ← getEnv
let structType ← reduceFieldProjs (← whnf structType)
let structName ← getStructureName structType
let params := structType.getAppArgs
trace[Elab.structure] "withStructField '{.ofConstName structName}', using parent field '{structFieldName}'"
if let some info ← findFieldInfo? structFieldName then
-- Exact field name match. If it's a parent, then check defeq, otherwise it's a name conflict.
if info.kind.isParent then
let infoType ← inferType info.fvar
if ← isDefEq infoType structType then
k info
else
throwError "Parent type mismatch: {← mkHasTypeButIsExpectedMsg structType infoType}"
else
throwErrorAt projRef m!"{fieldFromMsg info} has a name conflict with parent projection for `{.ofConstName structName}`"
++ .hint' "The `toParent : P` syntax can be used to adjust the name for the parent projection"
else if let some info ← findParentFieldInfo? structName then
-- The field name is different. Error.
assert! structFieldName != info.name
throwErrorAt projRef m!"Expected `{structFieldName}` to match {fieldFromMsg info} for parent `{.ofConstName structName}`"
++ .hint' "The `toParent : P` syntax can be used to adjust the name for the parent projection"
else
-- Main case: there is no field named `structFieldName` and there is no field for the structure `structName` yet.
let projDeclName := view.declName ++ structFieldName
withRef projRef do checkNotAlreadyDeclared projDeclName
let allFields := getStructureFieldsFlattened env structName (includeSubobjectFields := false)
let withStructFields' (kind : StructFieldKind) (inSubobject? : Option Expr) (k : StructFieldInfo → StructElabM α) : StructElabM α := do
withStructFields view sourceStructNames structType inSubobject? fun structVal => do
if let some _ ← findFieldInfo? structFieldName then
throwErrorAt projRef m!"Field `{structFieldName}` has already been declared"
++ .hint' "The `toParent : P` syntax can be used to adjust the name for the parent projection"
-- Add default values.
-- We've added some default values so far, but we want all overridden default values,
-- which for inherited fields might not have been seen yet.
-- Note: duplication is ok for now. We use a stable sort later.
for fieldName in allFields do
if let some d ← getFieldDefault? structName params fieldName then
addFieldInheritedDefault fieldName structName d
withLetDecl rawStructFieldName structType structVal fun structFVar => do
let info : StructFieldInfo := {
ref := (← getRef)
sourceStructNames := sourceStructNames
name := structFieldName
declName := projDeclName
fvar := structFVar
binfo := binfo
kind
}
addFieldInfo info
k info
if inSubobject?.isSome then
-- If we are currently in a subobject, then we can't use a subobject to represent this parent.
withStructFields' (.otherParent structName) inSubobject? k
else
/-
If there are no fields, we can avoid representing this structure in the constructor.
This is mainly to support test files that define structures with no fields.
TODO(kmill): remove check that there are any fields so far.
This is to get around some oddities when parent projections are all no-ops (tests fail when it is removed).
TODO(kmill): allow overlapping proof fields between subobjects! This does not harm defeq, and it should be more efficient.
-/
let elideParent := allFields.isEmpty && (← get).fields.any (·.kind.isInCtor)
if elideParent || (← allFields.anyM hasFieldName) then
-- Or, if there is an overlapping field, we need to copy/reuse fields rather than embed the parent as a subobject.
withStructFields' (.otherParent structName) none k
else
-- Use a subobject for this parent.
-- We create a metavariable to represent the subobject, so that `withStructField` can create projections
let inSubobject ← mkFreshExprMVar structType
withStructFields' (.subobject structName) inSubobject fun info => do
inSubobject.mvarId!.assign info.fvar
k info
end
/--
- `view` is the view of the structure being elaborated
- `projRef` is the ref to use for errors about the projection, set to the current ref when recursing
- `rawStructFieldName` is the name to use for the local declaration for this parent
- `structFieldName` is the field name to use for this parent
- `structType` is the parent's type
- `k` is a continuation that is run with a local context containing the fields and the ancestor fields,
and it's provided the field info for the parent
-/
private partial def withParent (view : StructView) (projRef : Syntax)
(rawStructFieldName structFieldName : Name)
(structType : Expr)
(k : StructFieldInfo → StructElabM α) :
StructElabM α := do
let env ← getEnv
let structType ← whnf structType
let structName ← getStructureName structType
let binfo := if view.isClass && isClass env structName then BinderInfo.instImplicit else BinderInfo.default
trace[Elab.structure] "binfo for {structFieldName} is {repr binfo}"
withStruct view [] (projRef := projRef) (rawStructFieldName := rawStructFieldName)
(binfo := binfo) (inSubobject? := none) structFieldName structType k
private def mkToParentName (parentStructName : Name) : Name :=
Name.mkSimple <| "to" ++ parentStructName.eraseMacroScopes.getString!
private def StructParentView.mkToParentNames (parentView : StructParentView) (parentStructName : Name) : Name × Name :=
match parentView.rawName?, parentView.name? with
| some rawName, some name => (rawName, name)
| _, _ =>
let toParentName := mkToParentName parentStructName
(toParentName, toParentName)
private def withParents (view : StructView) (rs : Array ElabHeaderResult) (indFVar : Expr) (k : StructElabM α) : StructElabM α := do
go 0
where
go (i : Nat) : StructElabM α := do
if h : i < view.parents.size then
let parentView := view.parents[i]
withRef parentView.ref do
-- The only use case for autobound implicits for parents might be outParams, but outParam is not propagated.
let parentType ← Term.withoutAutoBoundImplicit <| Term.elabType parentView.type
Term.synthesizeSyntheticMVarsNoPostponing
let parentType ← whnf parentType
if parentType.getAppFn == indFVar then
logWarning "Structure extends itself; skipping"
return ← go (i + 1)
if rs.any (fun r => r.indFVar == parentType.getAppFn) then
throwError "Structure cannot extend types defined in the same mutual block"
let parentStructName ← try
getStructureName parentType
catch ex =>
throwErrorAt parentView.type ex.toMessageData
++ .hint' "This error is possibly due to a change in the `structure` syntax. \
Now the syntax is `structure S : Type extends P` rather than `structure S extends P : Type`.\n\n\
The purpose of the change is to accommodate `structure S extends toP : P` syntax for naming parent projections."
let (rawToParentName, toParentName) := parentView.mkToParentNames parentStructName
if (← get).parents.any (·.structName == parentStructName) then
logWarning m!"Duplicate parent structure `{.ofConstName parentStructName}`; skipping"
go (i + 1)
else if (← get).parents.any (·.name == toParentName) then
throwError m!"Field `{toParentName}` has already been declared"
++ .hint' "The `toParent : P` syntax can be used to adjust the name for the parent projection"
else
withParent view parentView.projRef rawToParentName toParentName parentType fun parentFieldInfo => do
addParentInfo {
ref := parentView.projRef
addTermInfo := parentView.name?.isSome
fvar := parentFieldInfo.fvar
subobject := parentFieldInfo.kind.isSubobject
structName := parentStructName
name := toParentName
declName := parentFieldInfo.declName
}
go (i + 1)
else
k
private def registerFailedToInferFieldType (fieldName : Name) (e : Expr) (ref : Syntax) : TermElabM Unit := do
Term.registerCustomErrorIfMVar (← instantiateMVars e) ref m!"Failed to infer type of field `{.ofConstName fieldName}`"
Term.registerLevelMVarErrorExprInfo e ref m!"Failed to infer universe levels in type of field `{.ofConstName fieldName}`"
private def registerFailedToInferDefaultValue (fieldName : Name) (e : Expr) (ref : Syntax) : TermElabM Unit := do
Term.registerCustomErrorIfMVar (← instantiateMVars e) ref m!"Failed to infer default value for field `{.ofConstName fieldName}`"
Term.registerLevelMVarErrorExprInfo e ref m!"Failed to infer universe levels in default value for field `{.ofConstName fieldName}`"
/--
Goes through all the natural mvars appearing in `e`, assigning any whose type is one of the inherited parents.
Rationale 1: Structures can only extend a parent once.
There should be no other occurrences of a parent except for the parent itself.
Rationale 2: Consider the following code in the test `lean/run/balg.lean`:
```lean
structure Magma where
α : Type u
mul : α → α → α
instance : CoeSort Magma (Type u) where
coe s := s.α
abbrev mul {M : Magma} (a b : M) : M :=
M.mul a b
infixl:70 (priority := high) "*" => mul
structure Semigroup extends Magma where
mul_assoc (a b c : α) : a * b * c = a * (b * c)
```
When elaborating `*` in `mul_assoc`'s type, the `M` parameter of `mul` cannot be synthesized by unification.
Now `α` and `mul` are cdecls and `toMagma` is an ldecl,
but it used to be that `toMagma` was the cdecl and `α` and `mul` were projections of it,
which made it possible for unification to infer `toMagma` from `α`.
However, now `α` does not know its relationship to `toMagma`.
This was not robust, since in diamond inheritance `α` only remembered *one* of its parents in this indirect way.
-/
private def solveParentMVars (e : Expr) : StructElabM Unit := do
let mvars ← getMVarsNoDelayed e
unless mvars.isEmpty do
Term.synthesizeSyntheticMVars (postpone := .yes)
for mvar in mvars do
unless ← mvar.isAssigned do
let decl ← mvar.getDecl
if decl.kind.isNatural then
withLCtx decl.lctx decl.localInstances do
if let .const name .. := (← whnf decl.type).getAppFn then
if let some parentInfo ← findParentFieldInfo? name then
if ← isDefEq (← mvar.getType) (← inferType parentInfo.fvar) then
discard <| MVarId.checkedAssign mvar parentInfo.fvar
private def elabParamInfoUpdatesForField (structParams : Array Expr) (binders : Array Syntax) : StructElabM (Array Syntax × ExprMap (Syntax × BinderInfo)) := do
elabParamInfoUpdates structParams binders
-- Filter out all fields. We assume the remaining fvars are the possible parameters.
(fun fvarId => return (← findFieldInfoByFVarId? fvarId).isNone)
/--
Elaborates the field's type, returning
1. the type
2. the parameter binder info overrides
3. the number of binders for the type
-/
private def elabFieldType (structParams : Array Expr) (view : StructFieldView) :
StructElabM (Expr × ExprMap (Syntax × BinderInfo) × Nat) := do
withoutExporting (when := view.modifiers.isPrivate) do
let state ← get
let binders := view.binders.getArgs
let (binders, paramInfoOverrides) ← elabParamInfoUpdatesForField structParams binders
Term.withAutoBoundImplicit <| Term.withAutoBoundImplicitForbiddenPred (fun n => view.name == n) <|
Term.elabBinders binders fun params => do
let type ←
match view.type? with
| some typeStx =>
let type ← Term.elabType typeStx
runStructElabM (init := state) <| solveParentMVars type
registerFailedToInferFieldType view.name type typeStx
pure type
| none =>
let type ← mkFreshTypeMVar
registerFailedToInferFieldType view.name type view.nameId
pure type
Term.synthesizeSyntheticMVarsNoPostponing
let params ← Term.addAutoBoundImplicits params (view.nameId.getTailPos? (canonicalOnly := true))
let type ← mkForallFVars params type
return (type, paramInfoOverrides, params.size)
private def throwExistingDefaultValue (name : Name) : StructElabM α :=
throwError "A default value for field `{name}` has already been set for this structure"