6 *) |
6 *) |
7 |
7 |
8 signature TOPLEVEL = |
8 signature TOPLEVEL = |
9 sig |
9 sig |
10 exception UNDEF |
10 exception UNDEF |
|
11 type generic_theory |
11 type node |
12 type node |
12 val theory_node: node -> theory option |
13 val theory_node: node -> generic_theory option |
13 val proof_node: node -> ProofHistory.T option |
14 val proof_node: node -> ProofHistory.T option |
14 val cases_node: (theory -> 'a) -> (Proof.state -> 'a) -> node -> 'a |
15 val cases_node: (generic_theory -> 'a) -> (Proof.state -> 'a) -> node -> 'a |
15 val body_context_node: node option -> xstring option -> Proof.context |
16 val presentation_context: node option -> xstring option -> Proof.context |
16 type state |
17 type state |
17 val toplevel: state |
18 val toplevel: state |
18 val is_toplevel: state -> bool |
19 val is_toplevel: state -> bool |
19 val is_theory: state -> bool |
20 val is_theory: state -> bool |
20 val is_proof: state -> bool |
21 val is_proof: state -> bool |
21 val level: state -> int |
22 val level: state -> int |
22 val assert: bool -> unit |
23 val assert: bool -> unit |
23 val node_history_of: state -> node History.T |
24 val node_history_of: state -> node History.T |
24 val node_of: state -> node |
25 val node_of: state -> node |
25 val node_case: (theory -> 'a) -> (Proof.state -> 'a) -> state -> 'a |
26 val node_case: (generic_theory -> 'a) -> (Proof.state -> 'a) -> state -> 'a |
26 val context_of: state -> Context.generic |
27 val context_of: state -> Context.generic |
27 val theory_of: state -> theory |
28 val theory_of: state -> theory |
28 val proof_of: state -> Proof.state |
29 val proof_of: state -> Proof.state |
29 val proof_position_of: state -> int |
30 val proof_position_of: state -> int |
30 val enter_forward_proof: state -> Proof.state |
31 val enter_forward_proof: state -> Proof.state |
72 val imperative: (unit -> unit) -> transition -> transition |
72 val imperative: (unit -> unit) -> transition -> transition |
73 val init_theory: (bool -> theory) -> (theory -> unit) -> (theory -> unit) |
73 val init_theory: (bool -> theory) -> (theory -> unit) -> (theory -> unit) |
74 -> transition -> transition |
74 -> transition -> transition |
75 val theory: (theory -> theory) -> transition -> transition |
75 val theory: (theory -> theory) -> transition -> transition |
76 val theory': (bool -> theory -> theory) -> transition -> transition |
76 val theory': (bool -> theory -> theory) -> transition -> transition |
77 val theory_context: (theory -> Proof.context * theory) -> transition -> transition |
77 val exit_local_theory: transition -> transition |
78 val local_theory: xstring option -> (local_theory -> local_theory) -> |
78 val begin_local_theory: bool -> (theory -> string * local_theory) -> transition -> transition |
79 transition -> transition |
79 val local_theory: xstring option -> (local_theory -> local_theory) -> transition -> transition |
|
80 val present_local_theory: xstring option -> (bool -> node -> unit) -> transition -> transition |
80 val theory_to_proof: (theory -> Proof.state) -> transition -> transition |
81 val theory_to_proof: (theory -> Proof.state) -> transition -> transition |
81 val proof: (Proof.state -> Proof.state) -> transition -> transition |
82 val proof: (Proof.state -> Proof.state) -> transition -> transition |
82 val proofs: (Proof.state -> Proof.state Seq.seq) -> transition -> transition |
83 val proofs: (Proof.state -> Proof.state Seq.seq) -> transition -> transition |
83 val proof': (bool -> Proof.state -> Proof.state) -> transition -> transition |
84 val proof': (bool -> Proof.state -> Proof.state) -> transition -> transition |
84 val proofs': (bool -> Proof.state -> Proof.state Seq.seq) -> transition -> transition |
85 val proofs': (bool -> Proof.state -> Proof.state Seq.seq) -> transition -> transition |
85 val actual_proof: (ProofHistory.T -> ProofHistory.T) -> transition -> transition |
86 val actual_proof: (ProofHistory.T -> ProofHistory.T) -> transition -> transition |
86 val skip_proof: (int History.T -> int History.T) -> transition -> transition |
87 val skip_proof: (int History.T -> int History.T) -> transition -> transition |
87 val proof_to_theory: (Proof.state -> theory) -> transition -> transition |
|
88 val proof_to_theory': (bool -> Proof.state -> theory) -> transition -> transition |
|
89 val proof_to_theory_context: (bool -> Proof.state -> Proof.context * theory) |
|
90 -> transition -> transition |
|
91 val skip_proof_to_theory: (int -> bool) -> transition -> transition |
88 val skip_proof_to_theory: (int -> bool) -> transition -> transition |
92 val forget_proof: transition -> transition |
89 val forget_proof: transition -> transition |
93 val present_local_theory: xstring option -> (bool -> node -> unit) -> transition -> transition |
90 val end_proof: (bool -> Proof.state -> Proof.context) -> transition -> transition |
94 val present_proof: (bool -> node -> unit) -> transition -> transition |
91 val present_proof: (bool -> node -> unit) -> transition -> transition |
95 val unknown_theory: transition -> transition |
92 val unknown_theory: transition -> transition |
96 val unknown_proof: transition -> transition |
93 val unknown_proof: transition -> transition |
97 val unknown_context: transition -> transition |
94 val unknown_context: transition -> transition |
98 val apply: bool -> transition -> state -> (state * (exn * string) option) option |
95 val apply: bool -> transition -> state -> (state * (exn * string) option) option |
108 end; |
105 end; |
109 |
106 |
110 structure Toplevel: TOPLEVEL = |
107 structure Toplevel: TOPLEVEL = |
111 struct |
108 struct |
112 |
109 |
113 |
|
114 (** toplevel state **) |
110 (** toplevel state **) |
115 |
111 |
116 exception UNDEF; |
112 exception UNDEF; |
117 |
113 |
118 |
114 |
119 (* datatype state *) |
115 (* datatype state *) |
120 |
116 |
|
117 type generic_theory = Context.generic; (*theory or local_theory*) |
|
118 |
121 datatype node = |
119 datatype node = |
122 Theory of theory * Proof.context option | (*theory with optional body context*) |
120 Theory of generic_theory * Proof.context option | (*theory with presentation context*) |
123 Proof of ProofHistory.T * theory | (*history of proof states, original theory*) |
121 Proof of ProofHistory.T * generic_theory | (*history of proof states, original theory*) |
124 SkipProof of (int History.T * theory) * theory; |
122 SkipProof of (int History.T * generic_theory) * generic_theory; |
125 (*history of proof depths, resulting theory, original theory*) |
123 (*history of proof depths, resulting theory, original theory*) |
126 |
124 |
127 val theory_node = fn Theory (thy, _) => SOME thy | _ => NONE; |
125 val theory_node = fn Theory (gthy, _) => SOME gthy | _ => NONE; |
128 val proof_node = fn Proof (prf, _) => SOME prf | _ => NONE; |
126 val proof_node = fn Proof (prf, _) => SOME prf | _ => NONE; |
129 |
127 |
130 fun cases_node f _ (Theory (thy, _)) = f thy |
128 fun cases_node f _ (Theory (gthy, _)) = f gthy |
131 | cases_node _ g (Proof (prf, _)) = g (ProofHistory.current prf) |
129 | cases_node _ g (Proof (prf, _)) = g (ProofHistory.current prf) |
132 | cases_node f _ (SkipProof ((_, thy), _)) = f thy; |
130 | cases_node f _ (SkipProof ((_, gthy), _)) = f gthy; |
133 |
131 |
134 fun body_context_node (SOME (Theory (_, SOME ctxt))) NONE = ctxt |
132 fun presentation_context (SOME (Theory (_, SOME ctxt))) NONE = ctxt |
135 | body_context_node (SOME node) loc = |
133 | presentation_context (SOME node) NONE = cases_node Context.proof_of Proof.context_of node |
136 node |> cases_node (TheoryTarget.init loc) |
134 | presentation_context (SOME node) (SOME loc) = |
137 (if is_some loc then TheoryTarget.init loc o Proof.theory_of |
135 TheoryTarget.init (SOME loc) (cases_node Context.theory_of Proof.theory_of node) |
138 else Proof.context_of) |
136 | presentation_context NONE _ = raise UNDEF; |
139 | body_context_node NONE _ = raise UNDEF; |
|
140 |
137 |
141 datatype state = State of (node History.T * ((node -> unit) * (node -> unit))) option; |
138 datatype state = State of (node History.T * ((node -> unit) * (node -> unit))) option; |
142 |
139 |
143 val toplevel = State NONE; |
140 val toplevel = State NONE; |
144 |
141 |
341 |
338 |
342 fun is_stale state = Context.is_stale (theory_of state) handle UNDEF => false; |
339 fun is_stale state = Context.is_stale (theory_of state) handle UNDEF => false; |
343 |
340 |
344 val stale_theory = ERROR "Stale theory encountered after succesful execution!"; |
341 val stale_theory = ERROR "Stale theory encountered after succesful execution!"; |
345 |
342 |
346 fun checkpoint_node (Theory (thy, _)) = Theory (Theory.checkpoint thy, NONE) |
343 fun checkpoint_node (Theory (gthy, _)) = Theory |
|
344 (Context.mapping Theory.checkpoint (LocalTheory.raw_theory Theory.checkpoint) gthy, NONE) |
347 | checkpoint_node node = node; |
345 | checkpoint_node node = node; |
348 |
|
349 fun copy_node (Theory (thy, _)) = Theory (Theory.copy thy, NONE) |
|
350 | copy_node node = node; |
|
351 |
346 |
352 fun return (result, NONE) = result |
347 fun return (result, NONE) = result |
353 | return (result, SOME exn) = raise FAILURE (result, exn); |
348 | return (result, SOME exn) = raise FAILURE (result, exn); |
354 |
349 |
355 in |
350 in |
356 |
351 |
357 fun transaction hist f (node, term) = |
352 fun transaction hist f (node, term) = |
358 let |
353 let |
359 val cont_node = History.map checkpoint_node node; |
354 val cont_node = History.map checkpoint_node node; |
360 val back_node = History.map copy_node cont_node; |
355 val back_node = History.map checkpoint_node cont_node; |
361 fun state nd = State (SOME (nd, term)); |
356 fun state nd = State (SOME (nd, term)); |
362 fun normal_state nd = (state nd, NONE); |
357 fun normal_state nd = (state nd, NONE); |
363 fun error_state nd exn = (state nd, SOME exn); |
358 fun error_state nd exn = (state nd, SOME exn); |
364 |
359 |
365 val (result, err) = |
360 val (result, err) = |
366 cont_node |
361 cont_node |
367 |> (f |
362 |> (f |
368 |> (if hist then History.apply_copy copy_node else History.map) |
363 |> (if hist then History.apply_copy checkpoint_node else History.map) |
369 |> controlled_execution) |
364 |> controlled_execution) |
370 |> normal_state |
365 |> normal_state |
371 handle exn => error_state cont_node exn; |
366 handle exn => error_state cont_node exn; |
372 in |
367 in |
373 if is_stale result |
368 if is_stale result |
516 |
510 |
517 fun keep f = add_trans (Keep (fn _ => f)); |
511 fun keep f = add_trans (Keep (fn _ => f)); |
518 fun imperative f = keep (fn _ => f ()); |
512 fun imperative f = keep (fn _ => f ()); |
519 |
513 |
520 fun init_theory f exit kill = |
514 fun init_theory f exit kill = |
521 init (fn int => Theory (f int, NONE)) |
515 init (fn int => Theory (Context.Theory (f int), NONE)) |
522 (fn Theory (thy, _) => exit thy | _ => raise UNDEF) |
516 (fn Theory (Context.Theory thy, _) => exit thy | _ => raise UNDEF) |
523 (fn Theory (thy, _) => kill thy | _ => raise UNDEF); |
517 (fn Theory (Context.Theory thy, _) => kill thy | _ => raise UNDEF); |
524 |
518 |
525 |
519 |
526 (* typed transitions *) |
520 (* typed transitions *) |
527 |
521 |
528 fun theory f = app_current |
|
529 (K (fn Theory (thy, _) => Theory (f thy, NONE) | _ => raise UNDEF)); |
|
530 |
|
531 fun theory' f = app_current (fn int => |
522 fun theory' f = app_current (fn int => |
532 (fn Theory (thy, _) => Theory (f int thy, NONE) | _ => raise UNDEF)); |
523 (fn Theory (Context.Theory thy, _) => Theory (Context.Theory (f int thy), NONE) |
533 |
524 | _ => raise UNDEF)); |
534 fun theory_context f = app_current |
525 |
535 (K (fn Theory (thy, _) => Theory (swap (apfst SOME (f thy))) | _ => raise UNDEF)); |
526 fun theory f = theory' (K f); |
536 |
527 |
537 fun local_theory loc f = theory_context (TheoryTarget.mapping loc f); |
528 val exit_local_theory = app_current (fn _ => |
|
529 (fn Theory (Context.Proof lthy, _) => |
|
530 let val (ctxt', thy') = TheoryTarget.exit lthy |
|
531 in Theory (Context.Theory thy', SOME ctxt') end |
|
532 | _ => raise UNDEF)); |
|
533 |
|
534 fun begin_local_theory begin f = app_current (fn _ => |
|
535 (fn Theory (Context.Theory thy, _) => |
|
536 let |
|
537 val lthy = thy |> f |-> TheoryTarget.begin; |
|
538 val (ctxt, gthy) = |
|
539 if begin then (lthy, Context.Proof lthy) |
|
540 else lthy |> TheoryTarget.exit ||> Context.Theory; |
|
541 in Theory (gthy, SOME ctxt) end |
|
542 | _ => raise UNDEF)); |
|
543 |
|
544 fun local_theory_presentation loc f g = app_current (fn int => |
|
545 (fn Theory (Context.Theory thy, _) => |
|
546 let val (ctxt', thy') = TheoryTarget.mapping loc f thy |
|
547 in Theory (Context.Theory thy', SOME ctxt') end |
|
548 | Theory (Context.Proof lthy, _) => |
|
549 let val (ctxt', lthy') = |
|
550 if is_none loc then f lthy |> (fn lthy' => (lthy', LocalTheory.reinit lthy')) |
|
551 else lthy |> LocalTheory.raw_theory_result (TheoryTarget.mapping loc f) |
|
552 in Theory (Context.Proof lthy', SOME ctxt') end |
|
553 | _ => raise UNDEF) #> tap (g int)); |
|
554 |
|
555 fun local_theory loc f = local_theory_presentation loc f (K I); |
|
556 fun present_local_theory loc g = local_theory_presentation loc I g; |
538 |
557 |
539 fun theory_to_proof f = app_current (fn int => |
558 fun theory_to_proof f = app_current (fn int => |
540 (fn Theory (thy, _) => |
559 (fn Theory (gthy as Context.Theory thy, _) => |
541 let |
560 let |
542 val prf = f thy; |
561 val prf = f thy; |
543 val schematic = Proof.schematic_goal prf; |
562 val schematic = Proof.schematic_goal prf; |
544 in |
563 in |
545 if ! skip_proofs andalso schematic then |
564 if ! skip_proofs andalso schematic then |
546 warning "Cannot skip proof of schematic goal statement" |
565 warning "Cannot skip proof of schematic goal statement" |
547 else (); |
566 else (); |
548 if ! skip_proofs andalso not schematic then |
567 if ! skip_proofs andalso not schematic then |
549 SkipProof ((History.init (undo_limit int) 0, |
568 SkipProof ((History.init (undo_limit int) 0, |
550 ProofContext.theory_of (Proof.global_skip_proof int prf)), thy) |
569 Context.Theory (ProofContext.theory_of (Proof.global_skip_proof int prf))), gthy) |
551 else Proof (ProofHistory.init (undo_limit int) prf, thy) |
570 else Proof (ProofHistory.init (undo_limit int) prf, gthy) |
552 end |
571 end |
553 | _ => raise UNDEF)); |
572 | _ => raise UNDEF)); |
554 |
573 |
555 fun proofs' f = map_current (fn int => |
574 fun proofs' f = map_current (fn int => |
556 (fn Proof (prf, orig_thy) => Proof (ProofHistory.applys (f int) prf, orig_thy) |
575 (fn Proof (prf, orig_gthy) => Proof (ProofHistory.applys (f int) prf, orig_gthy) |
557 | SkipProof ((h, thy), orig_thy) => SkipProof ((History.apply I h, thy), orig_thy) |
576 | SkipProof ((h, gthy), orig_gthy) => SkipProof ((History.apply I h, gthy), orig_gthy) |
558 | _ => raise UNDEF)); |
577 | _ => raise UNDEF)); |
559 |
578 |
560 fun proof' f = proofs' (Seq.single oo f); |
579 fun proof' f = proofs' (Seq.single oo f); |
561 val proofs = proofs' o K; |
580 val proofs = proofs' o K; |
562 val proof = proof' o K; |
581 val proof = proof' o K; |
563 |
582 |
564 fun actual_proof f = map_current (fn _ => |
583 fun actual_proof f = map_current (fn _ => |
565 (fn Proof (prf, orig_thy) => Proof (f prf, orig_thy) | _ => raise UNDEF)); |
584 (fn Proof (prf, orig_gthy) => Proof (f prf, orig_gthy) |
|
585 | _ => raise UNDEF)); |
566 |
586 |
567 fun skip_proof f = map_current (fn _ => |
587 fun skip_proof f = map_current (fn _ => |
568 (fn SkipProof ((h, thy), orig_thy) => SkipProof ((f h, thy), orig_thy) | _ => raise UNDEF)); |
588 (fn SkipProof ((h, gthy), orig_gthy) => SkipProof ((f h, gthy), orig_gthy) |
569 |
|
570 fun end_proof f = map_current (fn int => |
|
571 (fn Proof (prf, _) => Theory (f int (ProofHistory.current prf)) |
|
572 | SkipProof ((h, thy), _) => if History.current h = 0 then Theory (thy, NONE) else raise UNDEF |
|
573 | _ => raise UNDEF)); |
589 | _ => raise UNDEF)); |
574 |
|
575 val forget_proof = map_current (fn _ => |
|
576 (fn Proof (_, orig_thy) => Theory (orig_thy, NONE) |
|
577 | SkipProof (_, orig_thy) => Theory (orig_thy, NONE) |
|
578 | _ => raise UNDEF)); |
|
579 |
|
580 fun proof_to_theory' f = end_proof (rpair NONE oo f); |
|
581 fun proof_to_theory f = proof_to_theory' (K f); |
|
582 fun proof_to_theory_context f = end_proof ((swap o apfst SOME) oo f); |
|
583 |
590 |
584 fun skip_proof_to_theory p = map_current (fn _ => |
591 fun skip_proof_to_theory p = map_current (fn _ => |
585 (fn SkipProof ((h, thy), _) => |
592 (fn SkipProof ((h, thy), _) => |
586 if p (History.current h) then Theory (thy, NONE) |
593 if p (History.current h) then Theory (thy, NONE) |
587 else raise UNDEF |
594 else raise UNDEF |
588 | _ => raise UNDEF)); |
595 | _ => raise UNDEF)); |
589 |
596 |
590 fun present_local_theory loc f = app_current (fn int => |
597 val forget_proof = map_current (fn _ => |
591 (fn Theory (thy, _) => Theory (swap (apfst SOME (TheoryTarget.mapping loc I thy))) |
598 (fn Proof (_, orig_gthy) => Theory (orig_gthy, NONE) |
592 | _ => raise UNDEF) #> tap (f int)); |
599 | SkipProof (_, orig_gthy) => Theory (orig_gthy, NONE) |
|
600 | _ => raise UNDEF)); |
|
601 |
|
602 fun end_proof f = map_current (fn int => |
|
603 (fn Proof (prf, orig_gthy) => |
|
604 let val state = ProofHistory.current prf in |
|
605 if can (Proof.assert_bottom true) state then |
|
606 let |
|
607 val ctxt' = f int state; |
|
608 val gthy' = |
|
609 if can Context.the_theory orig_gthy |
|
610 then Context.Theory (ProofContext.theory_of ctxt') |
|
611 else Context.Proof (LocalTheory.reinit ctxt'); |
|
612 in Theory (gthy', SOME ctxt') end |
|
613 else raise UNDEF |
|
614 end |
|
615 | SkipProof ((h, gthy), _) => |
|
616 if History.current h = 0 then Theory (gthy, NONE) else raise UNDEF |
|
617 | _ => raise UNDEF)); |
593 |
618 |
594 fun present_proof f = map_current (fn int => |
619 fun present_proof f = map_current (fn int => |
595 (fn node as Proof _ => node | _ => raise UNDEF) #> tap (f int)); |
620 (fn node as Proof _ => node | _ => raise UNDEF) #> tap (f int)); |
596 |
621 |
597 val unknown_theory = imperative (fn () => warning "Unknown theory context"); |
622 val unknown_theory = imperative (fn () => warning "Unknown theory context"); |