47 val checkpoint_thy: theory -> theory |
46 val checkpoint_thy: theory -> theory |
48 val finish_thy: theory -> theory |
47 val finish_thy: theory -> theory |
49 val theory_data_of: theory -> string list |
48 val theory_data_of: theory -> string list |
50 val pre_pure_thy: theory |
49 val pre_pure_thy: theory |
51 val begin_thy: (theory -> Pretty.pp) -> string -> theory list -> theory |
50 val begin_thy: (theory -> Pretty.pp) -> string -> theory list -> theory |
52 (*ML theory context*) |
|
53 val get_context: unit -> theory option |
|
54 val set_context: theory option -> unit |
|
55 val reset_context: unit -> unit |
|
56 val setmp: theory option -> ('a -> 'b) -> 'a -> 'b |
|
57 val pass: theory option -> ('a -> 'b) -> 'a -> 'b * theory option |
|
58 val pass_theory: theory -> ('a -> 'b) -> 'a -> 'b * theory |
|
59 val save: ('a -> 'b) -> 'a -> 'b |
|
60 val >> : (theory -> theory) -> unit |
|
61 val use_mltext: string -> bool -> theory option -> unit |
|
62 val use_mltext_theory: string -> bool -> theory -> theory |
|
63 val use_let: string -> string -> string -> theory -> theory |
|
64 val add_setup: (theory -> theory) -> unit |
|
65 val setup: unit -> theory -> theory |
|
66 (*proof context*) |
51 (*proof context*) |
67 type proof |
52 type proof |
68 val theory_of_proof: proof -> theory |
53 val theory_of_proof: proof -> theory |
69 val transfer_proof: theory -> proof -> proof |
54 val transfer_proof: theory -> proof -> proof |
70 val init_proof: theory -> proof |
55 val init_proof: theory -> proof |
80 val map_proof: (proof -> proof) -> generic -> generic |
65 val map_proof: (proof -> proof) -> generic -> generic |
81 val theory_map: (generic -> generic) -> theory -> theory |
66 val theory_map: (generic -> generic) -> theory -> theory |
82 val proof_map: (generic -> generic) -> proof -> proof |
67 val proof_map: (generic -> generic) -> proof -> proof |
83 val theory_of: generic -> theory (*total*) |
68 val theory_of: generic -> theory (*total*) |
84 val proof_of: generic -> proof (*total*) |
69 val proof_of: generic -> proof (*total*) |
|
70 (*ML context*) |
|
71 val get_context: unit -> generic option |
|
72 val set_context: generic option -> unit |
|
73 val setmp: generic option -> ('a -> 'b) -> 'a -> 'b |
|
74 val the_generic_context: unit -> generic |
|
75 val the_local_context: unit -> proof |
|
76 val pass: generic option -> ('a -> 'b) -> 'a -> 'b * generic option |
|
77 val pass_context: generic -> ('a -> 'b) -> 'a -> 'b * generic |
|
78 val save: ('a -> 'b) -> 'a -> 'b |
|
79 val >> : (theory -> theory) -> unit |
|
80 val use_mltext: string -> bool -> generic option -> unit |
|
81 val use_mltext_update: string -> bool -> generic -> generic |
|
82 val use_let: string -> string -> string -> generic -> generic |
|
83 val add_setup: (theory -> theory) -> unit |
|
84 val setup: unit -> theory -> theory |
85 end; |
85 end; |
86 |
86 |
87 signature PRIVATE_CONTEXT = |
87 signature PRIVATE_CONTEXT = |
88 sig |
88 sig |
89 include CONTEXT |
89 include CONTEXT |
445 |
445 |
446 end; |
446 end; |
447 |
447 |
448 |
448 |
449 |
449 |
450 (*** ML theory context ***) |
|
451 |
|
452 local |
|
453 val current_theory = ref (NONE: theory option); |
|
454 in |
|
455 fun get_context () = ! current_theory; |
|
456 fun set_context opt_thy = current_theory := opt_thy; |
|
457 fun setmp opt_thy f x = Library.setmp current_theory opt_thy f x; |
|
458 end; |
|
459 |
|
460 fun the_context () = |
|
461 (case get_context () of |
|
462 SOME thy => thy |
|
463 | _ => error "Unknown theory context"); |
|
464 |
|
465 fun context thy = set_context (SOME thy); |
|
466 fun reset_context () = set_context NONE; |
|
467 |
|
468 fun pass opt_thy f x = |
|
469 setmp opt_thy (fn x => let val y = f x in (y, get_context ()) end) x; |
|
470 |
|
471 fun pass_theory thy f x = |
|
472 (case pass (SOME thy) f x of |
|
473 (y, SOME thy') => (y, thy') |
|
474 | (_, NONE) => error "Lost theory context in ML"); |
|
475 |
|
476 fun save f x = setmp (get_context ()) f x; |
|
477 |
|
478 |
|
479 (* map context *) |
|
480 |
|
481 nonfix >>; |
|
482 fun >> f = set_context (SOME (f (the_context ()))); |
|
483 |
|
484 |
|
485 (* use ML text *) |
|
486 |
|
487 fun use_output verbose txt = |
|
488 Output.ML_errors (use_text Output.ml_output verbose) (Symbol.escape txt); |
|
489 |
|
490 fun use_mltext txt verbose opt_thy = setmp opt_thy (fn () => use_output verbose txt) (); |
|
491 fun use_mltext_theory txt verbose thy = #2 (pass_theory thy (use_output verbose) txt); |
|
492 |
|
493 fun use_context txt = use_mltext_theory ("Context.>> (" ^ txt ^ ");") false; |
|
494 |
|
495 fun use_let bind body txt = |
|
496 use_context ("let " ^ bind ^ " = " ^ txt ^ " in\n" ^ body ^ " end"); |
|
497 |
|
498 |
|
499 (* delayed theory setup *) |
|
500 |
|
501 local |
|
502 val setup_fn = ref (I: theory -> theory); |
|
503 in |
|
504 fun add_setup f = setup_fn := (! setup_fn #> f); |
|
505 fun setup () = let val f = ! setup_fn in setup_fn := I; f end; |
|
506 end; |
|
507 |
|
508 |
|
509 |
|
510 (*** proof context ***) |
450 (*** proof context ***) |
511 |
451 |
512 (* datatype proof *) |
452 (* datatype proof *) |
513 |
453 |
514 datatype proof = Proof of theory_ref * Object.T Datatab.table; |
454 datatype proof = Proof of theory_ref * Object.T Datatab.table; |
599 fun proof_map f = the_proof o f o Proof; |
539 fun proof_map f = the_proof o f o Proof; |
600 |
540 |
601 val theory_of = cases I theory_of_proof; |
541 val theory_of = cases I theory_of_proof; |
602 val proof_of = cases init_proof I; |
542 val proof_of = cases init_proof I; |
603 |
543 |
|
544 |
|
545 |
|
546 (*** ML context ***) |
|
547 |
|
548 local |
|
549 val current_context = ref (NONE: generic option); |
|
550 in |
|
551 fun get_context () = ! current_context; |
|
552 fun set_context opt_context = current_context := opt_context; |
|
553 fun setmp opt_context f x = Library.setmp current_context opt_context f x; |
|
554 end; |
|
555 |
|
556 fun the_generic_context () = |
|
557 (case get_context () of |
|
558 SOME context => context |
|
559 | _ => error "Unknown context"); |
|
560 |
|
561 val the_context = theory_of o the_generic_context; |
|
562 val the_local_context = the_proof o the_generic_context; |
|
563 |
|
564 fun pass opt_context f x = |
|
565 setmp opt_context (fn x => let val y = f x in (y, get_context ()) end) x; |
|
566 |
|
567 fun pass_context context f x = |
|
568 (case pass (SOME context) f x of |
|
569 (y, SOME context') => (y, context') |
|
570 | (_, NONE) => error "Lost context in ML"); |
|
571 |
|
572 fun save f x = setmp (get_context ()) f x; |
|
573 |
|
574 |
|
575 (* map context *) |
|
576 |
|
577 nonfix >>; |
|
578 fun >> f = set_context (SOME (map_theory f (the_generic_context ()))); |
|
579 |
|
580 |
|
581 (* use ML text *) |
|
582 |
|
583 fun use_output verbose txt = |
|
584 Output.ML_errors (use_text Output.ml_output verbose) (Symbol.escape txt); |
|
585 |
|
586 fun use_mltext txt verbose opt_context = setmp opt_context (fn () => use_output verbose txt) (); |
|
587 fun use_mltext_update txt verbose context = #2 (pass_context context (use_output verbose) txt); |
|
588 |
|
589 fun use_context txt = use_mltext_update |
|
590 ("Context.set_context (SOME ((" ^ txt ^ ") (Context.the_generic_context ())));") false; |
|
591 |
|
592 fun use_let bind body txt = |
|
593 use_context ("let " ^ bind ^ " = " ^ txt ^ " in\n" ^ body ^ " end"); |
|
594 |
|
595 |
|
596 (* delayed theory setup *) |
|
597 |
|
598 local |
|
599 val setup_fn = ref (I: theory -> theory); |
|
600 in |
|
601 fun add_setup f = setup_fn := (! setup_fn #> f); |
|
602 fun setup () = let val f = ! setup_fn in setup_fn := I; f end; |
|
603 end; |
|
604 |
604 end; |
605 end; |
605 |
606 |
606 structure BasicContext: BASIC_CONTEXT = Context; |
607 structure BasicContext: BASIC_CONTEXT = Context; |
607 open BasicContext; |
608 open BasicContext; |
608 |
609 |