44 val full_proofs: bool -> unit |
44 val full_proofs: bool -> unit |
45 val isarcmd: string -> unit |
45 val isarcmd: string -> unit |
46 val init: bool -> unit |
46 val init: bool -> unit |
47 val init_pgip: bool -> unit |
47 val init_pgip: bool -> unit |
48 val write_keywords: string -> unit |
48 val write_keywords: string -> unit |
|
49 val xmls_of_str : string -> string list (* temp for testing parser *) |
49 end; |
50 end; |
50 |
51 |
51 structure ProofGeneral : PROOF_GENERAL = |
52 structure ProofGeneral : PROOF_GENERAL = |
52 struct |
53 struct |
53 |
54 |
676 |
677 |
677 end |
678 end |
678 |
679 |
679 (** Parsing proof scripts without execution **) |
680 (** Parsing proof scripts without execution **) |
680 |
681 |
|
682 (* Notes. |
|
683 This is quite tricky, because 1) we need to put back whitespace which |
|
684 was removed during parsing so we can provide markup around commands; |
|
685 2) parsing is intertwined with execution in Isar so we have to repeat |
|
686 the parsing to extract interesting parts of commands. The trace of |
|
687 tokens parsed which is now recorded in each transition helps do this. |
|
688 |
|
689 If we had proper parse trees it would be easy, or if we could go |
|
690 beyond ML's type system to allow existential types to be part of |
|
691 parsers (the quantified type representing the result of the parse |
|
692 which is used to make the transition function) it might be possible. |
|
693 |
|
694 Probably the best solution is to produce the meta-information at |
|
695 the same time as the parse, for each command, e.g. by recording a |
|
696 list of (name,objtype) pairs which record the bindings created by |
|
697 a command. This would require changing the interfaces in |
|
698 outer_syntax.ML (or providing new ones), |
|
699 |
|
700 datatype metainfo = Binding of string * string (* name, objtype *) |
|
701 |
|
702 val command_withmetainfo: string -> string -> string -> |
|
703 (token list -> |
|
704 ((Toplevel.transition -> Toplevel.transition) * metainfo list) * |
|
705 token list) -> parser |
|
706 *) |
|
707 |
681 local |
708 local |
682 fun markup_text str elt = [XML.element elt [] [XML.text str]] |
709 fun markup_text str elt = [XML.element elt [] [XML.text str]] |
683 fun markup_text_attrs str elt attrs = [XML.element elt attrs [XML.text str]] |
710 fun markup_text_attrs str elt attrs = [XML.element elt attrs [XML.text str]] |
684 fun empty elt = [XML.element elt [] []] |
711 fun empty elt = [XML.element elt [] []] |
685 |
712 |
686 fun named_item_elt toks str elt nameP objtyp = |
713 (* an extra token is needed to terminate the command *) |
|
714 val sync = OuterSyntax.scan "\\<^sync>"; |
|
715 |
|
716 fun named_item_elt_with nameattr toks str elt nameP objtyp = |
687 let |
717 let |
688 val name = (fst (nameP toks)) |
718 val name = (fst (nameP (toks@sync))) |
689 handle _ => (error ("Error occurred in name parser for " ^ elt); |
719 handle _ => (error ("Error occurred in name parser for " ^ elt ^ |
|
720 "(objtype: " ^ objtyp ^ ")"); |
690 "") |
721 "") |
691 |
722 |
692 in |
723 in |
693 [XML.element elt |
724 [XML.element elt |
694 ((if name="" then [] else [("name", name)])@ |
725 ((if name="" then [] else [(nameattr, name)])@ |
695 (if objtyp="" then [] else [("objtype", objtyp)])) |
726 (if objtyp="" then [] else [("objtype", objtyp)])) |
696 ([XML.text str])] |
727 ([XML.text str])] |
697 end |
728 end |
698 |
729 |
|
730 val named_item_elt = named_item_elt_with "name" |
|
731 val thmnamed_item_elt = named_item_elt_with "thmname" |
|
732 |
699 fun parse_warning msg = warning ("script->PGIP markup parser: " ^ msg) |
733 fun parse_warning msg = warning ("script->PGIP markup parser: " ^ msg) |
700 |
734 |
701 (* FIXME: allow dynamic extensions to language here: we need a hook in |
735 (* FIXME: allow dynamic extensions to language here: we need a hook in |
702 outer_syntax.ML to reset this table. *) |
736 outer_syntax.ML to reset this table. *) |
703 |
737 |
713 |
747 |
714 |
748 |
715 |
749 |
716 fun xmls_of_thy_begin (name,toks,str) = (* see isar_syn.ML/theoryP *) |
750 fun xmls_of_thy_begin (name,toks,str) = (* see isar_syn.ML/theoryP *) |
717 let |
751 let |
718 val ((thyname,imports,files),_) = ThyHeader.args toks |
752 val ((thyname,imports,files),_) = ThyHeader.args (toks@sync) |
719 in |
753 in |
720 markup_text_attrs str "opentheory" [("thyname",thyname)] |
754 markup_text_attrs str "opentheory" [("thyname",thyname)] |
721 end |
755 end |
722 |
756 |
723 fun xmls_of_thy_decl (name,toks,str) = (* see isar_syn.ML/thy_decl cases *) |
757 fun xmls_of_thy_decl (name,toks,str) = (* see isar_syn.ML/thy_decl cases *) |
772 | _ => (parse_warning ("Unrecognized thy-decl command: " ^ name); plain_item) |
806 | _ => (parse_warning ("Unrecognized thy-decl command: " ^ name); plain_item) |
773 end |
807 end |
774 |
808 |
775 fun xmls_of_thy_goal (name,toks,str) = |
809 fun xmls_of_thy_goal (name,toks,str) = |
776 let |
810 let |
777 val nameP = P.locale_target |-- ((P.opt_thm_name ":") >> #1) |
811 (* see isar_syn.ML/gen_theorem *) |
|
812 val statement = P.and_list1 (P.opt_thm_name ":" -- Scan.repeat1 P.propp); |
|
813 val general_statement = |
|
814 statement >> pair [] || Scan.repeat P.locale_elem_or_expr -- (P.$$$ "shows" |-- statement); |
|
815 |
|
816 val gen_theoremP = |
|
817 P.locale_target -- Scan.optional (P.opt_thm_name ":" --| |
|
818 Scan.ahead (P.locale_keyword || P.$$$ "shows")) ("", []) -- |
|
819 general_statement >> (fn ((locale, a), (elems, concl)) => |
|
820 fst a) (* a : (bstring * Args.src list) *) |
|
821 |
|
822 val nameP = P.locale_target |-- (Scan.optional ((P.opt_thm_name ":") >> #1) "") |
778 (* TODO: add preference values for attributes |
823 (* TODO: add preference values for attributes |
779 val prefval = XML.element "prefval" [("name","thm-kind"),("value",name)] |
824 val prefval = XML.element "prefval" [("name","thm-kind"),("value",name)] |
780 *) |
825 *) |
781 in |
826 in |
782 named_item_elt toks str "opengoal" nameP "" |
827 thmnamed_item_elt toks str "opengoal" nameP "" |
783 end |
828 end |
784 |
829 |
785 fun xmls_of_qed (name,markup) = case name of |
830 fun xmls_of_qed (name,markup) = case name of |
786 "sorry" => markup "giveupgoal" |
831 "sorry" => markup "giveupgoal" |
787 | "oops" => markup "postponegoal" |
832 | "oops" => markup "postponegoal" |
801 (* theory/files *) |
846 (* theory/files *) |
802 | "theory-begin" => xmls_of_thy_begin (name,toks,str) |
847 | "theory-begin" => xmls_of_thy_begin (name,toks,str) |
803 | "theory-decl" => xmls_of_thy_decl (name,toks,str) |
848 | "theory-decl" => xmls_of_thy_decl (name,toks,str) |
804 | "theory-heading" => markup "litcomment" |
849 | "theory-heading" => markup "litcomment" |
805 | "theory-script" => markup "theorystep" |
850 | "theory-script" => markup "theorystep" |
|
851 | "theory-end" => markup "closetheory" |
806 (* proof control *) |
852 (* proof control *) |
807 | "theory-goal" => xmls_of_thy_goal (name,toks,str) |
853 | "theory-goal" => xmls_of_thy_goal (name,toks,str) |
808 | "proof-heading" => markup "litcomment" |
854 | "proof-heading" => markup "litcomment" |
809 | "proof-goal" => markup "opengoal" (* nested proof: have, show, ... *) |
855 | "proof-goal" => markup "opengoal" (* nested proof: have, show, ... *) |
810 | "proof-block" => markup "proofstep" (* context-shift: proof, next; really "newgoal" *) |
856 | "proof-block" => markup "proofstep" (* context-shift: proof, next; really "newgoal" *) |