forked from LPCIC/coq-elpi
-
Notifications
You must be signed in to change notification settings - Fork 0
/
coq_elpi_builtins.ml
2069 lines (1880 loc) · 79.1 KB
/
coq_elpi_builtins.ml
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
(* coq-elpi: Coq terms as the object language of elpi *)
(* license: GNU Lesser General Public License Version 2.1 or later *)
(* ------------------------------------------------------------------------- *)
module API = Elpi.API
module E = API.RawData
module State = API.State
module P = API.RawPp
module Conv = API.Conversion
module CConv = API.ContextualConversion
module B = struct
include API.BuiltInData
include Elpi.Builtin
let ioarg = API.BuiltInPredicate.ioarg
let ioargC = API.BuiltInPredicate.ioargC
end
module Pred = API.BuiltInPredicate
module G = Globnames
module CNotation = Notation
open Names
open Coq_elpi_utils
open Coq_elpi_HOAS
let tactic_mode = ref false
let on_global_state api thunk = (); (fun state ->
if !tactic_mode then
Coq_elpi_utils.err Pp.(strbrk ("API " ^ api ^ " cannot be used in tactics"));
let state, result, gls = thunk state in
Coq_elpi_HOAS.grab_global_env state, result, gls)
(* This is for stuff that is not monotonic in the env, eg section closing *)
let on_global_state_does_rewind_env api thunk = (); (fun state ->
if !tactic_mode then
Coq_elpi_utils.err Pp.(strbrk ("API " ^ api ^ " cannot be used in tactics"));
let state, result, gls = thunk state in
Coq_elpi_HOAS.grab_global_env_drop_univs state, result, gls)
let warn_if_contains_univ_levels ~depth t =
let fold f acc ~depth t =
match t with
| E.Const _ | E.Nil | E.CData _ -> acc
| E.App(_,x,xs) -> List.fold_left (f ~depth) (f ~depth acc x) xs
| E.Cons(x,xs) -> f ~depth (f ~depth acc x) xs
| E.Builtin(_,xs) -> List.fold_left (f ~depth) acc xs
| E.Lam x -> f ~depth:(depth+1) acc x
| E.UnifVar(_,xs) -> List.fold_left (f ~depth) acc xs
in
let global_univs = UGraph.domain (Environ.universes (Global.env ())) in
let is_global u =
match Univ.Universe.level u with
| None -> true
| Some l -> Univ.LSet.mem l global_univs in
let rec aux ~depth acc t =
match E.look ~depth t with
| E.CData c when isuniv c -> let u = univout c in if is_global u then acc else u :: acc
| x -> fold aux acc ~depth x
in
let univs = aux ~depth [] t in
if univs <> [] then
err Pp.(strbrk "The hypothetical clause contains terms of type univ which are not global, you should abstract them out or replace them by global ones: " ++
prlist_with_sep spc Univ.Universe.pr univs)
;;
let bool = B.bool
let int = B.int
let list = B.list
let pair = B.pair
let option = B.option
let constraint_leq u1 u2 =
let open UnivProblem in
ULe (u1, u2)
let constraint_eq u1 u2 =
let open UnivProblem in
ULe (u1, u2)
let add_universe_constraint state c =
let open UnivProblem in
try add_constraints state (Set.singleton c)
with
| Univ.UniverseInconsistency p ->
Feedback.msg_debug
(Univ.explain_universe_inconsistency
UnivNames.pr_with_global_universes p);
raise Pred.No_clause
| Evd.UniversesDiffer | UState.UniversesDiffer ->
Feedback.msg_debug Pp.(str"UniversesDiffer");
raise Pred.No_clause
let mk_fresh_univ state = new_univ state
let mk_algebraic_super x = Univ.super x
let mk_algebraic_max x y = Univ.Universe.sup x y
(* I don't want the user to even know that algebraic universes exist *)
let purge_1_algebraic_universe state u =
if Univ.Universe.is_level u then state, u
else
let state, v = mk_fresh_univ state in
add_universe_constraint state (constraint_leq u v), v
let purge_algebraic_univs state t =
let sigma = get_sigma state in
(* no map_fold iterator :-/ *)
let state = ref state in
let rec aux t =
match EConstr.kind sigma t with
| Constr.Sort s -> begin
match EConstr.ESorts.kind sigma s with
| Sorts.Type u ->
let new_state, v = purge_1_algebraic_universe !state u in
state := new_state;
EConstr.mkType v
| _ -> EConstr.map sigma aux t
end
| _ -> EConstr.map sigma aux t in
let t = aux t in
!state, t
let univ_super state u v =
let state, u =
if Univ.Universe.is_level u then state, u
else
let state, w = mk_fresh_univ state in
add_universe_constraint state (constraint_leq u w), w in
add_universe_constraint state (constraint_leq (mk_algebraic_super u) v)
let univ_max state u1 u2 =
let state, v = mk_fresh_univ state in
let state =
add_universe_constraint state (constraint_leq (mk_algebraic_max u1 u2) v) in
state, v
let constr2lp ~depth hyps constraints state t =
let state, t = purge_algebraic_univs state t in
constr2lp ~depth hyps constraints state t
let constr2lp_closed ~depth hyps constraints state t =
let state, t = purge_algebraic_univs state t in
constr2lp_closed ~depth hyps constraints state t
let constr2lp_closed_ground ~depth state t =
let state, t = purge_algebraic_univs state t in
constr2lp_closed_ground ~depth state t
let clauses_for_later =
State.declare ~name:"coq-elpi:clauses_for_later"
~init:(fun () -> [])
~pp:(fun fmt l ->
List.iter (fun (dbname, code,local) ->
Format.fprintf fmt "db:%s code:%a local:%b\n"
(String.concat "." dbname)
Elpi.API.Pp.Ast.program code local) l)
;;
let univ = { univ with
Conv.readback = (fun ~depth state x ->
let state, u, gl = univ.Conv.readback ~depth state x in
let state, u = purge_1_algebraic_universe state u in
state, u, gl);
embed = (fun ~depth state x ->
let state, x = purge_1_algebraic_universe state x in
let state, u, gl = univ.Conv.embed ~depth state x in
state, u, gl);
}
let term = {
CConv.ty = Conv.TyName "term";
pp_doc = (fun fmt () -> Format.fprintf fmt "A Coq term containing evars");
pp = (fun fmt t -> Format.fprintf fmt "%s" (Pp.string_of_ppcmds (Printer.pr_econstr_env (Global.env()) Evd.empty t)));
readback = lp2constr;
embed = constr2lp;
}
let proof_context : (full coq_context, API.Data.constraints) CConv.ctx_readback =
fun ~depth hyps constraints state ->
let state, proof_context, _, gls = get_current_env_sigma ~depth hyps constraints state in
state, proof_context, constraints, gls
let closed_term = {
CConv.ty = Conv.TyName "term";
pp_doc = (fun fmt () -> Format.fprintf fmt "A closed Coq term");
pp = (fun fmt t -> Format.fprintf fmt "%s" (Pp.string_of_ppcmds (Printer.pr_econstr_env (Global.env()) Evd.empty t)));
readback = lp2constr_closed;
embed = constr2lp_closed
}
let global : (empty coq_context, API.Data.constraints) CConv.ctx_readback =
fun ~depth hyps constraints state ->
let state, proof_context, _, gls = get_global_env_current_sigma ~depth hyps constraints state in
state, proof_context, constraints, gls
let closed_ground_term = {
Conv.ty = Conv.TyName "term";
pp_doc = (fun fmt () -> Format.fprintf fmt "A ground, closed, Coq term");
pp = (fun fmt t -> Format.fprintf fmt "%s" (Pp.string_of_ppcmds (Printer.pr_econstr_env (Global.env()) Evd.empty t)));
readback = lp2constr_closed_ground;
embed = constr2lp_closed_ground
}
let term_skeleton = {
CConv.ty = Conv.TyName "term";
pp_doc = (fun fmt () -> Format.fprintf fmt "A Coq term containing holes");
pp = (fun fmt t -> Format.fprintf fmt "%s" (Pp.string_of_ppcmds (Printer.pr_glob_constr_env (Global.env()) t)));
readback = lp2skeleton;
embed = (fun ~depth _ _ _ _ -> assert false);
}
let prop = { B.any with Conv.ty = Conv.TyName "prop" }
let raw_goal = { B.any with Conv.ty = Conv.TyName "goal" }
let id = { B.string with
API.Conversion.ty = Conv.TyName "id";
pp_doc = (fun fmt () ->
Format.fprintf fmt "%% [id] is a name that matters, we piggy back on Elpi's strings.@\n";
Format.fprintf fmt "%% Note: [name] is a name that does not matter.@\n";
Format.fprintf fmt "typeabbrev id string.@\n@\n")
}
let flag name = { (unspec bool) with Conv.ty = Conv.TyName name }
(* Unfortunately the data tye is not symmeteric *)
let indt_decl_in = {
Conv.ty = Conv.TyName "indt-decl";
pp_doc = (fun fmt () -> Format.fprintf fmt "Declaration of an inductive type");
pp = (fun fmt _ -> Format.fprintf fmt "mutual_inductive_entry");
readback = (fun ~depth state t -> lp2inductive_entry ~depth (mk_coq_context state) E.no_constraints state t);
embed = (fun ~depth state t -> assert false);
}
let indt_decl_out = {
Conv.ty = Conv.TyName "indt-decl";
pp_doc = (fun fmt () -> Format.fprintf fmt "Declaration of an inductive type");
pp = (fun fmt _ -> Format.fprintf fmt "mutual_inductive_entry");
readback = (fun ~depth state t -> assert false);
embed = (fun ~depth state t -> inductive_decl2lp ~depth (mk_coq_context state) E.no_constraints state t);
}
let is_ground sigma t = Evar.Set.is_empty (Evd.evars_of_term sigma t)
let is_ground_one_inductive_entry sigma { Entries.mind_entry_arity; mind_entry_lc } =
is_ground sigma (EConstr.of_constr mind_entry_arity) &&
List.for_all (is_ground sigma) @@ List.map EConstr.of_constr mind_entry_lc
let is_ground_rel_ctx_entry sigma rc =
is_ground sigma @@ EConstr.of_constr @@ Context.Rel.Declaration.get_type rc &&
Option.cata (fun x -> is_ground sigma @@ EConstr.of_constr x) true @@ Context.Rel.Declaration.get_value rc
let is_mutual_inductive_entry_ground { Entries.mind_entry_params; mind_entry_inds } sigma =
List.for_all (is_ground_rel_ctx_entry sigma) mind_entry_params &&
List.for_all (is_ground_one_inductive_entry sigma) mind_entry_inds
type located =
| LocGref of Names.GlobRef.t
| LocModule of Names.ModPath.t
| LocModuleType of Names.ModPath.t
| LocAbbreviation of Globnames.syndef_name
let located = let open Conv in let open API.AlgebraicData in declare {
ty = TyName "located";
doc = "Result of coq.locate-all";
pp = (fun fmt _ -> Format.fprintf fmt "<todo>");
constructors = [
K("loc-gref","",A(gref,N),
B (fun x -> LocGref x),
M (fun ~ok ~ko -> function LocGref x -> ok x | _ -> ko ()));
K("loc-modpath","",A(modpath,N),
B (fun x -> LocModule x),
M (fun ~ok ~ko -> function LocModule x -> ok x | _ -> ko ()));
K("loc-modtypath","",A(modtypath,N),
B (fun x -> LocModuleType x),
M (fun ~ok ~ko -> function LocModuleType x -> ok x | _ -> ko ()));
K("loc-abbreviation","",A(abbreviation,N),
B (fun x -> LocAbbreviation x),
M (fun ~ok ~ko -> function LocAbbreviation x -> ok x | _ -> ko ()));
]
} |> CConv.(!<)
(* FIXME PARTIAL API
*
* Record foo A1..Am := K { f1; .. fn }. -- m params, n fields
* Canonical c (x1 : b1)..(xk : bk) := K p1..pm t1..tn.
*
* fi v1..vm ? rest1 == (ci w1..wr) rest2
*
* ?i : bi
* vi =?= pi[xi/?i]
* wi =?= ui[xi/?i]
* ? == c ?1 .. ?k
* rest1 == rest2
* ?j =<= (ci w1..wr) -- default proj, ti = xj
* ci == gr
*
* unif (const fi) [V1,..VM, C | R1] (const ci) [W1,..WR| R2] M U :-
* of (app[c, ?1,..?k]) _ CR, -- saturate
* hd-beta CR [] (indc _) [P1,..PM,T1,..TN],
* unify-list-U Vi Pi,
* Ti = app[const ci|U1,..,UN],
* unify-list-U Wi Ui,
* unify-eq C CR,
* unify-list-eq R1 R2.
*
*)
let cs_pattern =
let open Conv in let open API.AlgebraicData in let open Recordops in declare {
ty = TyName "cs-pattern";
doc = "Pattern for canonical values";
pp = (fun fmt -> function
| Const_cs x -> Format.fprintf fmt "Const_cs %s" "<todo>"
| Prod_cs -> Format.fprintf fmt "Prod_cs"
| Sort_cs _ -> Format.fprintf fmt "Sort_cs"
| Default_cs -> Format.fprintf fmt "Default_cs");
constructors = [
K("cs-gref","",A(gref,N),
B (fun x -> Const_cs x),
M (fun ~ok ~ko -> function Const_cs x -> ok x | _ -> ko ()));
K("cs-prod","",N,
B Prod_cs,
M (fun ~ok ~ko -> function Prod_cs -> ok | _ -> ko ()));
K("cs-default","",N,
B Default_cs,
M (fun ~ok ~ko -> function Default_cs -> ok | _ -> ko ()));
K("cs-sort","",A(universe,N),
B (fun s -> Sort_cs (Sorts.family s)),
MS (fun ~ok ~ko p state -> match p with
| Sort_cs Sorts.InSet -> ok Sorts.set state
| Sort_cs Sorts.InProp -> ok Sorts.prop state
| Sort_cs Sorts.InType ->
let state, u = mk_fresh_univ state in
ok (Sorts.sort_of_univ u) state
| _ -> ko state))
]
} |> CConv.(!<)
let cs_instance = let open Conv in let open API.AlgebraicData in let open Recordops in declare {
ty = TyName "cs-instance";
doc = "Canonical Structure instances: (cs-instance Proj ValPat Inst)";
pp = (fun fmt (_,{ o_DEF }) -> Format.fprintf fmt "%s" Pp.(string_of_ppcmds (Printer.pr_constr_env (Global.env()) Evd.empty o_DEF)));
constructors = [
K("cs-instance","",A(gref,A(cs_pattern,A(closed_ground_term,N))), (* XXX should be a gref *)
B (fun p v i -> assert false),
M (fun ~ok ~ko ((proj_gr,patt), {
o_DEF = solution; (* c *)
o_CTX = uctx_set;
o_INJ = def_val_pos; (* Some (j \in [0-n]) if ti = xj *)
o_TABS = types; (* b1 .. bk *)
o_TPARAMS = params; (* p1 .. pm *)
o_NPARAMS = nparams; (* m *)
o_TCOMPS = cval_args }) -> ok proj_gr patt (EConstr.of_constr solution)))
]
} |> CConv.(!<)
let tc_instance = let open Conv in let open API.AlgebraicData in let open Typeclasses in declare {
ty = TyName "tc-instance";
doc = "Type class instance with priority";
pp = (fun fmt _ -> Format.fprintf fmt "<todo>");
constructors = [
K("tc-instance","",A(gref,A(int,N)),
B (fun g p -> nYI "lp2instance"),
M (fun ~ok ~ko i ->
ok (instance_impl i) (Option.default 0 (hint_priority i))));
]} |> CConv.(!<)
type scope = ExecutionSite | CurrentModule
let scope = let open Conv in let open API.AlgebraicData in declare {
ty = TyName "scope";
doc = "Specify to which module the clause should be attached to";
pp = (fun fmt _ -> Format.fprintf fmt "<todo>");
constructors = [
K("execution-site","The module inside which the Elpi program is run",N,
B ExecutionSite,
M (fun ~ok ~ko -> function ExecutionSite -> ok | _ -> ko ()));
K("current","The module being defined (see begin/end-module)",N,
B CurrentModule,
M (fun ~ok ~ko -> function CurrentModule -> ok | _ -> ko ()))
]
} |> CConv.(!<)
let grafting = let open Conv in let open API.AlgebraicData in declare {
ty = TyName "grafting";
doc = "Specify if the clause has to be grafted before or after a named clause";
pp = (fun fmt _ -> Format.fprintf fmt "<todo>");
constructors = [
K("before","",A(id,N),
B (fun x -> (`Before,x)),
M (fun ~ok ~ko -> function (`Before,x) -> ok x | _ -> ko ()));
K("after","",A(id,N),
B (fun x -> (`After,x)),
M (fun ~ok ~ko -> function (`After,x) -> ok x | _ -> ko ()));
]
} |> CConv.(!<)
let clause = let open Conv in let open API.AlgebraicData in declare {
ty = TyName "clause";
doc = {|clauses
A clause like
:name "foo" :before "bar" foo X Y :- bar X Z, baz Z Y
is represented as
clause _ "foo" (before "bar") (pi x y z\ foo x y :- bar x z, baz z y)
that is exactly what one would load in the context using =>.
The name and the grafting specification can be left unspecified.|};
pp = (fun fmt _ -> Format.fprintf fmt "<todo>");
constructors = [
K("clause","",A(unspec id,A(unspec grafting,A(prop,N))),
B (fun id graft c -> unspec2opt id, unspec2opt graft, c),
M (fun ~ok ~ko (id,graft,c) -> ok (opt2unspec id) (opt2unspec graft) c));
]
} |> CConv.(!<)
let set_accumulate_to_db, get_accumulate_to_db =
let f = ref ((fun () -> assert false),(fun _ _ ~local:_ -> assert false)) in
(fun x -> f := x),
(fun () -> !f)
let class_ = let open Conv in let open API.AlgebraicData in let open Coercionops in declare {
ty = TyName "class";
doc = "Node of the coercion graph";
pp = (fun fmt _ -> Format.fprintf fmt "<todo>");
constructors = [
K("funclass","",N,
B CL_FUN,
M (fun ~ok ~ko -> function Coercionops.CL_FUN -> ok | _ -> ko ()));
K("sortclass","",N,
B CL_SORT,
M (fun ~ok ~ko -> function CL_SORT -> ok | _ -> ko ()));
K("grefclass","",A(gref,N),
B ComCoercion.class_of_global,
M (fun ~ok ~ko -> function
| CL_SECVAR v -> ok (GlobRef.VarRef v)
| CL_CONST c -> ok (GlobRef.ConstRef c)
| CL_IND i -> ok (GlobRef.IndRef i)
| CL_PROJ p -> ok (GlobRef.ConstRef (Projection.Repr.constant p))
| _ -> ko ()))
]
} |> CConv.(!<)
let src_class_of_class = function
| (Coercionops.CL_FUN | Coercionops.CL_SORT) -> CErrors.anomaly Pp.(str "src_class_of_class on a non source coercion class")
| Coercionops.CL_SECVAR v -> GlobRef.VarRef v
| Coercionops.CL_CONST c -> GlobRef.ConstRef c
| Coercionops.CL_IND i -> GlobRef.IndRef i
| Coercionops.CL_PROJ p -> GlobRef.ConstRef (Projection.Repr.constant p)
let coercion = let open Conv in let open API.AlgebraicData in declare {
ty = TyName "coercion";
doc = "Edge of the coercion graph";
pp = (fun fmt _ -> Format.fprintf fmt "<todo>");
constructors = [
K("coercion","ref, nparams, src, tgt", A(gref,A(unspec int,A(gref,A(class_,N)))),
B (fun t np src tgt -> t,np,src,tgt),
M (fun ~ok ~ko:_ -> function (t,np,src,tgt) -> ok t np src tgt))
]
} |> CConv.(!<)
let implicit_kind : Glob_term.binding_kind Conv.t = let open Conv in let open API.AlgebraicData in let open Glob_term in declare {
ty = TyName "implicit_kind";
doc = "Implicit status of an argument";
pp = (fun fmt -> function
| NonMaxImplicit -> Format.fprintf fmt "implicit"
| Explicit -> Format.fprintf fmt "explicit"
| MaxImplicit -> Format.fprintf fmt "maximal");
constructors = [
K("implicit","regular implicit argument, eg Arguments foo [x]",N,
B NonMaxImplicit,
M (fun ~ok ~ko -> function NonMaxImplicit -> ok | _ -> ko ()));
K("maximal","maximally inserted implicit argument, eg Arguments foo {x}",N,
B MaxImplicit,
M (fun ~ok ~ko -> function MaxImplicit -> ok | _ -> ko ()));
K("explicit","explicit argument, eg Arguments foo x",N,
B Explicit,
M (fun ~ok ~ko -> function Explicit -> ok | _ -> ko ()));
]
} |> CConv.(!<)
let implicit_kind_of_status = function
| None -> Glob_term.Explicit
| Some (_,_,(maximal,_)) ->
if maximal then Glob_term.MaxImplicit else Glob_term.NonMaxImplicit
let simplification_strategy = let open API.AlgebraicData in let open Reductionops.ReductionBehaviour in declare {
ty = Conv.TyName "simplification_strategy";
doc = "Strategy for simplification tactics";
pp = (fun fmt (x : t) -> Format.fprintf fmt "TODO");
constructors = [
K ("never", "Arguments foo : simpl never",N,
B NeverUnfold,
M (fun ~ok ~ko -> function NeverUnfold -> ok | _ -> ko ()));
K("when","Arguments foo .. / .. ! ..",A(B.list B.int, A(Elpi.Builtin.option B.int, N)),
B (fun recargs nargs -> UnfoldWhen { recargs; nargs }),
M (fun ~ok ~ko -> function UnfoldWhen { recargs; nargs } -> ok recargs nargs | _ -> ko ()));
K("when-nomatch","Arguments foo .. / .. ! .. : simpl moatch",A(B.list B.int, A(Elpi.Builtin.option B.int, N)),
B (fun recargs nargs -> UnfoldWhenNoMatch { recargs; nargs }),
M (fun ~ok ~ko -> function UnfoldWhenNoMatch { recargs; nargs } -> ok recargs nargs | _ -> ko ()));
]
} |> CConv.(!<)
let attribute a = let open API.AlgebraicData in declare {
ty = Conv.TyName "attribute";
doc = "Generic attribute";
pp = (fun fmt a -> Format.fprintf fmt "TODO");
constructors = [
K("attribute","",A(B.string,A(a,N)),
B (fun s a -> s,a),
M (fun ~ok ~ko -> function (s,a) -> ok s a));
]
} |> CConv.(!<)
let attribute_value = let open API.AlgebraicData in let open Attributes in let open CConv in declare {
ty = Conv.TyName "attribute-value";
doc = "Generic attribute value";
pp = (fun fmt a -> Format.fprintf fmt "TODO");
constructors = [
K("leaf","",A(B.string,N),
B (fun s -> if s = "" then VernacFlagEmpty else VernacFlagLeaf s),
M (fun ~ok ~ko -> function VernacFlagEmpty -> ok "" | VernacFlagLeaf x -> ok x | _ -> ko ()));
K("node","",C((fun self -> !> (B.list (attribute (!< self)))),N),
B (fun l -> VernacFlagList l),
M (fun ~ok ~ko -> function VernacFlagList l -> ok l | _ -> ko ())
)
]
} |> CConv.(!<)
let attribute = attribute attribute_value
let warning = CWarnings.create ~name:"lib" ~category:"elpi" Pp.str
let if_keep x f =
match x with
| Pred.Discard -> None
| Pred.Keep -> Some (f ())
let if_keep_acc x state f =
match x with
| Pred.Discard -> state, None
| Pred.Keep ->
let state, x = f state in
state, Some x
let detype env sigma t =
(* To avoid turning named universes into unnamed ones *)
Flags.with_option Constrextern.print_universes
(Detyping.detype Detyping.Now false Id.Set.empty env sigma) t
let version_parser version =
let (!!) x = try int_of_string x with Failure _ -> -100 in
match Str.split (Str.regexp_string ".") version with
| major :: minor :: patch :: _ -> !!major, !!minor, !!patch
| [ major ] -> !!major,0,0
| [] -> 0,0,0
| [ major; minor ] ->
match Str.split (Str.regexp_string "+") minor with
| [ minor ] -> !!major, !!minor, 0
| [ ] -> !!major, !!minor, 0
| minor :: prerelease :: _ ->
if Str.string_match (Str.regexp_string "beta") prerelease 0 then
!!major, !!minor, !!("-"^String.sub prerelease 4 (String.length prerelease - 4))
else if Str.string_match (Str.regexp_string "alpha") prerelease 0 then
!!major, !!minor, !!("-"^String.sub prerelease 5 (String.length prerelease - 5))
else !!major, !!minor, -100
let mp2path x =
let rec mp2sl = function
| MPfile dp -> CList.rev_map Id.to_string (DirPath.repr dp)
| MPbound id ->
let _,id,dp = MBId.repr id in
mp2sl (MPfile dp) @ [ Id.to_string id ]
| MPdot (mp,lbl) -> mp2sl mp @ [Label.to_string lbl] in
mp2sl x
let gr2path state gr =
match gr with
| Names.GlobRef.VarRef v -> [Id.to_string v]
| Names.GlobRef.ConstRef c -> (mp2path @@ Constant.modpath c)
| Names.GlobRef.IndRef (i,0) ->
let open Declarations in
let env = get_global_env state in
let { mind_packets } = Environ.lookup_mind i env in
((mp2path @@ MutInd.modpath i) @ [ Id.to_string (mind_packets.(0).mind_typename)])
| Names.GlobRef.ConstructRef ((i,0),j) ->
let env = get_global_env state in
let open Declarations in
let { mind_packets } = Environ.lookup_mind i env in
let klbl = Id.to_string (mind_packets.(0).mind_consnames.(j-1)) in
((mp2path @@ MutInd.modpath i) @ [klbl])
| Names.GlobRef.IndRef _ | Names.GlobRef.ConstructRef _ ->
nYI "mutual inductive (make-derived...)"
(* See https://github.com/coq/coq/pull/12759 , the system asserts no evars
and the allow_evars flag is gone! *)
let hack_prune_all_evars sigma =
Evd.from_ctx (Evd.evar_universe_context sigma)
let coq_builtins =
let open API.BuiltIn in
let open Pred in
let open Notation in
let open CConv in
let pp ~depth = P.term depth in
[LPCode
{|% Coq terms as the object language of elpi and basic API to access Coq
% license: GNU Lesser General Public License Version 2.1 or later
% -------------------------------------------------------------------------
% This file is automatically generated from
% - coq-HOAS.elpi
% - coq_elpi_builtin.ml
% and contains the descritpion of the data type of Coq terms and the
% API to access Coq.
|};
LPCode Coq_elpi_builtins_HOAS.code;
MLData Coq_elpi_HOAS.record_field_att;
LPCode {|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% builtins %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% This section contains the API to access Coq
% The marker *E* means *experimental*, i.e. use at your own risk, it may change
% substantially or even disappear in future versions.
|};
LPDoc "-- Misc ---------------------------------------------------------";
MLCode(Pred("coq.say",
VariadicIn(unit_ctx, !> B.any, "Prints an info message"),
(fun args ~depth _hyps _constraints state ->
let pp = pp ~depth in
Feedback.msg_notice Pp.(str (pp2string (P.list ~boxed:true pp " ") args));
state, ())),
DocAbove);
MLCode(Pred("coq.warn",
VariadicIn(unit_ctx, !> B.any, "Prints a warning message"),
(fun args ~depth _hyps _constraints state ->
let pp = pp ~depth in
let loc, args =
if args = [] then None, args
else
let x, args = List.hd args, List.tl args in
match E.look ~depth x with
| E.CData loc when API.RawOpaqueData.is_loc loc ->
Some (Coq_elpi_utils.to_coq_loc (API.RawOpaqueData.to_loc loc)), args
| _ -> None, x :: args
in
warning ?loc (pp2string (P.list ~boxed:true pp " ") args);
state, ())),
DocAbove);
MLCode(Pred("coq.error",
VariadicIn(unit_ctx, !> B.any, "Prints and *aborts* the program (it's a fatal error)"),
(fun args ~depth _hyps _constraints _state ->
let pp = pp ~depth in
err Pp.(str (pp2string (P.list ~boxed:true pp " ") args)))),
DocAbove);
MLCode(Pred("coq.version",
Out(B.string, "VersionString",
Out(int, "Major",
Out(int, "Minor",
Out(int, "Patch",
Easy "Fetches the version of Coq, as a string and as 3 numbers")))),
(fun _ _ _ _ ~depth:_ ->
let version = Coq_config.version in
let major, minor, patch = version_parser version in
!: version +! major +! minor +! patch)),
DocAbove);
LPCode {|
% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% API for objects belonging to the logic
% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%|};
LPDoc "-- Environment: names -----------------------------------------------";
LPDoc {|To make the API more precise we use different data types for the names of global objects.
Note: [ctype \"bla\"] is an opaque data type and by convention it is written [@bla].|};
MLData constant;
MLData inductive;
MLData constructor;
MLData gref;
MLData id;
MLData modpath;
MLData modtypath; ] @
[
LPDoc "-- Environment: read ------------------------------------------------";
LPDoc "Note: The type [term] is defined in coq-HOAS.elpi";
MLData located;
MLCode(Pred("coq.locate-all",
In(id, "Name",
Out(B.list located, "Located",
Easy {|finds all posible meanings of a string. Does not fail.|})),
(fun s _ ~depth ->
let qualid = Libnames.qualid_of_string s in
let l = ref [] in
let add x = l := !l @ [x] in
begin
match Nametab.locate_extended qualid with
| G.TrueGlobal gr -> add @@ LocGref gr
| G.SynDef sd ->
begin match Syntax_def.search_syntactic_definition sd with
| _, Notation_term.NRef gr -> add @@ LocGref gr
| _ -> add @@ LocAbbreviation sd
| exception Not_found -> () end
| exception Not_found -> ()
end;
begin
try add @@ LocModule (Nametab.locate_module qualid)
with Not_found -> ()
end;
begin
try add @@ LocModuleType (Nametab.locate_modtype qualid)
with Not_found -> ()
end;
!: !l)),
DocAbove);
MLCode(Pred("coq.locate",
In(id, "Name",
Out(gref, "GlobalReference",
Easy {|locates a global definition, inductive type or constructor via its name.
It unfolds syntactic notations, e.g. "Notation old_name := new_name."
It undestands qualified names, e.g. "Nat.t". It's a fatal error if Name cannot be located.|})),
(fun s _ ~depth ->
let qualid = Libnames.qualid_of_string s in
let gr =
try
match Nametab.locate_extended qualid with
| G.TrueGlobal gr -> gr
| G.SynDef sd ->
match Syntax_def.search_syntactic_definition sd with
| _, Notation_term.NRef gr -> gr
| _ -> nYI "complex call to Locate"
with Not_found ->
err Pp.(str "Global reference not found: " ++ Libnames.pr_qualid qualid) in
!: gr)),
DocAbove);
MLCode(Pred("coq.env.typeof",
In(gref, "GR",
Out(closed_ground_term, "Ty",
Full(unit_ctx, "reads the type Ty of a global reference."))),
(fun gr _ ~depth _ _ state ->
let state, ty = type_of_global state gr in
state, !:ty, [])),
DocAbove);
MLCode(Pred("coq.env.indt",
In(inductive, "reference to the inductive type",
Out(bool, "tt if the type is inductive (ff for co-inductive)",
Out(int, "number of parameters",
Out(int, "number of parameters that are uniform (<= parameters)",
Out(closed_ground_term, "type of the inductive type constructor including parameters",
Out(list constructor, "list of constructor names",
Out(list closed_ground_term, "list of the types of the constructors (type of KNames) including parameters",
Full(global, "reads the inductive type declaration for the environment")))))))),
(fun i _ _ _ arity knames ktypes ~depth { env } _ state ->
let open Declarations in
let mind, indbo as ind = lookup_inductive env i in
let co = mind.mind_finite <> Declarations.CoFinite in
let lno = mind.mind_nparams in
let luno = mind.mind_nparams_rec in
let arity = if_keep arity (fun () ->
Inductive.type_of_inductive (ind,Univ.Instance.empty)
|> EConstr.of_constr) in
let knames = if_keep knames (fun () ->
CList.(init Declarations.(indbo.mind_nb_constant + indbo.mind_nb_args)
(fun k -> i,k+1))) in
let ktypes = if_keep ktypes (fun () ->
Inductive.type_of_constructors (i,Univ.Instance.empty) ind
|> CArray.map_to_list EConstr.of_constr) in
state, !: co +! lno +! luno +? arity +? knames +? ktypes, [])),
DocNext);
MLCode(Pred("coq.env.indt-decl",
In(inductive, "reference to the inductive type",
Out(indt_decl_out,"HOAS description of the inductive type",
Full(global,"reads the inductive type declaration for the environment"))),
(fun i _ ~depth { env } _ state ->
let mind, indbo = lookup_inductive env i in
let knames = CList.(init Declarations.(indbo.mind_nb_constant + indbo.mind_nb_args) (fun k -> GlobRef.ConstructRef(i,k+1))) in
let k_impls = List.map (fun x -> Impargs.extract_impargs_data (Impargs.implicits_of_global x)) knames in
let hd x = match x with [] -> [] | (_,x) :: _ -> List.map implicit_kind_of_status x in
let k_impls = List.map hd k_impls in
let i_impls = Impargs.extract_impargs_data @@ Impargs.implicits_of_global (GlobRef.IndRef i) in
let i_impls = hd i_impls in
state, !: ((mind,indbo), (i_impls,k_impls)), [])),
DocNext);
MLCode(Pred("coq.env.indc",
In(constructor, "GR",
Out(int, "ParamNo",
Out(int, "UnifParamNo",
Out(int, "Kno",
Out(closed_ground_term,"Ty",
Full (global, "reads the type Ty of an inductive constructor GR, as well as "^
"the number of parameters ParamNo and uniform parameters "^
"UnifParamNo and the number of the constructor Kno (0 based)")))))),
(fun (i,k as kon) _ _ _ ty ~depth { env } _ state ->
let open Declarations in
let mind, indbo as ind = Inductive.lookup_mind_specif env i in
let lno = mind.mind_nparams in
let luno = mind.mind_nparams_rec in
let ty = if_keep ty (fun () ->
Inductive.type_of_constructor (kon,Univ.Instance.empty) ind
|> EConstr.of_constr) in
state, !: lno +! luno +! (k-1) +? ty, [])),
DocAbove);
MLCode(Pred("coq.env.const-opaque?",
In(constant, "GR",
Read(global, "checks if GR is an opaque constant")),
(fun c ~depth {env} _ state ->
match c with
| Constant c ->
let open Declareops in
let cb = Environ.lookup_constant c env in
if is_opaque cb || not(constant_has_body cb) then ()
else raise Pred.No_clause
| Variable v ->
match Environ.lookup_named v env with
| Context.Named.Declaration.LocalDef _ -> raise Pred.No_clause
| Context.Named.Declaration.LocalAssum _ -> ())),
DocAbove);
MLCode(Pred("coq.env.const",
In(constant, "GR",
Out(option closed_ground_term, "Bo",
Out(closed_ground_term, "Ty",
Full (global, "reads the type Ty and the body Bo of constant GR. "^
"Opaque constants have Bo = none.")))),
(fun c bo ty ~depth {env} _ state ->
match c with
| Constant c ->
let state, ty = if_keep_acc ty state (fun s -> type_of_global s (GlobRef.ConstRef c)) in
let state, bo = if_keep_acc bo state (fun state ->
if Declareops.is_opaque (Environ.lookup_constant c env)
then state, None
else
body_of_constant state c) in
state, ?: bo +? ty, []
| Variable v ->
let state, ty = if_keep_acc ty state (fun s -> type_of_global s (GlobRef.VarRef v)) in
let bo = if_keep bo (fun () ->
match Environ.lookup_named v env with
| Context.Named.Declaration.LocalDef(_,bo,_) -> Some (bo |> EConstr.of_constr)
| Context.Named.Declaration.LocalAssum _ -> None) in
state, ?: bo +? ty, [])),
DocAbove);
MLCode(Pred("coq.env.const-body",
In(constant, "GR",
Out(option closed_ground_term, "Bo",
Full (global, "reads the body of a constant, even if it is opaque. "^
"If such body is none, then the constant is a true axiom"))),
(fun c _ ~depth {env} _ state ->
match c with
| Constant c ->
let state, bo = body_of_constant state c in
state, !: bo, []
| Variable v ->
state, !: begin
match Environ.lookup_named v env with
| Context.Named.Declaration.LocalDef(_,bo,_) -> Some (bo |> EConstr.of_constr)
| Context.Named.Declaration.LocalAssum _ -> None
end, [])),
DocAbove);
MLCode(Pred("coq.env.const-primitive?",
In(constant, "GR",
Read (global,"tests if GR is a primitive constant (like uin63 addition)")),
(fun c ~depth {env} _ state ->
match c with
| Constant c ->
if Environ.is_primitive env c then ()
else raise No_clause
| Variable v -> raise No_clause)),
DocAbove);
MLCode(Pred("coq.locate-module",
In(id, "ModName",
Out(modpath, "ModPath",
Easy "locates a module. It's a fatal error if ModName cannot be located. *E*")),
(fun s _ ~depth ->
let qualid = Libnames.qualid_of_string s in
let mp =
try Nametab.locate_module qualid
with Not_found ->
err Pp.(str "Module not found: " ++ Libnames.pr_qualid qualid) in
!:mp)),
DocAbove);
MLCode(Pred("coq.locate-module-type",
In(id, "ModName",
Out(modtypath, "ModPath",
Easy "locates a module. It's a fatal error if ModName cannot be located. *E*")),
(fun s _ ~depth ->
let qualid = Libnames.qualid_of_string s in
let mp =
try Nametab.locate_modtype qualid
with Not_found ->
err Pp.(str "Module type not found: " ++ Libnames.pr_qualid qualid) in
!:mp)),
DocAbove);
MLCode(Pred("coq.env.module",
In(modpath, "MP",
Out(list gref, "Contents",
Read(global, "lists the contents of a module (recurses on submodules) *E*"))),
(fun mp _ ~depth {env} _ state ->
let t = in_elpi_module ~depth state (Environ.lookup_module mp env) in
!: t)),
DocAbove);
MLCode(Pred("coq.env.module-type",
In(modtypath, "MTP",
Out(list id, "Entries",
Read (global, "lists the items made visible by module type "^
"(does not recurse on submodules) *E*"))),
(fun mp _ ~depth {env} _ state ->
!: (in_elpi_module_type (Environ.lookup_modtype mp env)))),
DocAbove);
MLCode(Pred("coq.env.section",
Out(list constant, "GlobalObjects",
Read(unit_ctx, "lists the global objects that are marked as to be abstracted at the end of the enclosing sections")),
(fun _ ~depth _ _ state ->
let { section } = mk_coq_context state in
!: (section |> List.map (fun x -> Variable x)) )),
DocAbove);
MLCode(Pred("coq.env.current-path",
Out(list B.string, "Path",
Read(unit_ctx, "lists the current module path")),
(fun _ ~depth _ _ state -> !: (mp2path (Safe_typing.current_modpath (Global.safe_env ()))))),
DocAbove);
LPDoc "-- Environment: write -----------------------------------------------";
LPDoc ("Note: universe constraints are taken from ELPI's constraints "^
"store. Use coq.univ-* in order to add constraints (or any higher "^
"level facility as coq.typecheck)");
MLCode(Pred("coq.env.add-const",
In(id, "Name",
In(unspec closed_ground_term, "Bo",
In(unspec closed_ground_term, "Ty",
In(flag "opaque?", "Opaque",
Out(constant, "C",
Full (global, {|Declare a new constant: C gets a constant derived from Name
and the current module; Ty can be left unspecified and in that case the
inferred one is taken (as in writing Definition x := t); Bo can be left
unspecified and in that case an axiom is added (or a section variable,
if a section is open and @local! is used). Omitting the body and the type is
an error.
Supported attributes:
- @local! (default: false)|})))))),
(fun id body types opaque _ ~depth {options} _ -> on_global_state "coq.env.add-const" (fun state ->
let local = options.local = Some true in
let sigma = get_sigma state in
match body with
| Unspec -> (* axiom *)
begin match types with
| Unspec ->
err Pp.(str "coq.env.add-const: both Type and Body are unspecified")
| Given ty ->
let used = EConstr.universes_of_constr sigma ty in
let sigma = Evd.restrict_universe_context sigma used in
let ubinders = Evd.universe_binders sigma in
let uentry = Evd.univ_entry ~poly:false sigma in
let kind = Decls.Logical in
let impargs = [] in
let variable = CAst.(make @@ Id.of_string id) in
if not (is_ground sigma ty) then
err Pp.(str"coq.env.add-const: the type must be ground. Did you forge to call coq.typecheck-indt-decl?");
let gr, _ =
if local then begin
let uctx =
let context_set_of_entry = function
| Entries.Polymorphic_entry (_,uctx) -> Univ.ContextSet.of_context uctx
| Entries.Monomorphic_entry uctx -> uctx in
context_set_of_entry uentry in
DeclareUctx.declare_universe_context ~poly:false uctx;
ComAssumption.declare_variable false ~kind (EConstr.to_constr sigma ty) impargs Glob_term.Explicit variable;
GlobRef.VarRef(Id.of_string id), Univ.Instance.empty
end else
ComAssumption.declare_axiom false ~local:Declare.ImportDefaultBehavior ~poly:false ~kind (EConstr.to_constr sigma ty)
(uentry, ubinders) impargs Declaremods.NoInline
variable
in
state, !: (global_constant_of_globref gr), []
end