src/Pure/ML/ml_thms.ML
changeset 56069 451d5b73f8cf
parent 55997 9dc5ce83202c
child 56072 31e427387ab5
equal deleted inserted replaced
56068:f74d0a4d8ae3 56069:451d5b73f8cf
    33 
    33 
    34 
    34 
    35 (* attribute source *)
    35 (* attribute source *)
    36 
    36 
    37 val _ = Theory.setup
    37 val _ = Theory.setup
    38   (ML_Context.add_antiq @{binding attributes}
    38   (ML_Context.antiquotation @{binding attributes} (Scan.lift Parse_Spec.attribs)
    39     (Scan.depend (fn context => Parse_Spec.attribs >> (fn raw_srcs =>
    39     (fn _ => fn raw_srcs => fn ctxt =>
    40       let
    40       let
    41         val ctxt = Context.the_proof context;
       
    42 
       
    43         val i = serial ();
    41         val i = serial ();
    44         val srcs = map (Attrib.check_src ctxt) raw_srcs;
    42         val srcs = map (Attrib.check_src ctxt) raw_srcs;
    45         val _ = map (Attrib.attribute ctxt) srcs;
    43         val _ = map (Attrib.attribute ctxt) srcs;
    46         val (a, ctxt') = ctxt
    44         val (a, ctxt') = ctxt
    47           |> ML_Antiquote.variant "attributes" ||> put_attributes (i, srcs);
    45           |> ML_Antiquote.variant "attributes" ||> put_attributes (i, srcs);
    48         val ml =
    46         val ml =
    49           ("val " ^ a ^ " = ML_Thms.the_attributes ML_context " ^
    47           ("val " ^ a ^ " = ML_Thms.the_attributes ML_context " ^
    50             string_of_int i ^ ";\n", "Isabelle." ^ a);
    48             string_of_int i ^ ";\n", "Isabelle." ^ a);
    51       in (Context.Proof ctxt', K ml) end))));
    49       in (K ml, ctxt') end));
    52 
    50 
    53 
    51 
    54 (* fact references *)
    52 (* fact references *)
    55 
    53 
    56 fun thm_binding kind is_single context thms =
    54 fun thm_binding kind is_single thms ctxt =
    57   let
    55   let
    58     val ctxt = Context.the_proof context;
       
    59 
       
    60     val initial = null (get_thmss ctxt);
    56     val initial = null (get_thmss ctxt);
    61     val (name, ctxt') = ML_Antiquote.variant kind ctxt;
    57     val (name, ctxt') = ML_Antiquote.variant kind ctxt;
    62     val ctxt'' = cons_thms ((name, is_single), thms) ctxt';
    58     val ctxt'' = cons_thms ((name, is_single), thms) ctxt';
    63 
    59 
    64     val ml_body = "Isabelle." ^ name;
    60     val ml_body = "Isabelle." ^ name;
    67         let
    63         let
    68           val binds = get_thmss final_ctxt |> map (fn ((a, b), _) => (b ? enclose "[" "]") a);
    64           val binds = get_thmss final_ctxt |> map (fn ((a, b), _) => (b ? enclose "[" "]") a);
    69           val ml_env = "val [" ^ commas binds ^ "] = ML_Thms.the_thmss ML_context;\n";
    65           val ml_env = "val [" ^ commas binds ^ "] = ML_Thms.the_thmss ML_context;\n";
    70         in (ml_env, ml_body) end
    66         in (ml_env, ml_body) end
    71       else ("", ml_body);
    67       else ("", ml_body);
    72   in (Context.Proof ctxt'', decl) end;
    68   in (decl, ctxt'') end;
    73 
    69 
    74 val _ = Theory.setup
    70 val _ = Theory.setup
    75   (ML_Context.add_antiq @{binding thm}
    71   (ML_Context.antiquotation @{binding thm} (Attrib.thm >> single) (K (thm_binding "thm" true)) #>
    76     (Scan.depend (fn context =>
    72    ML_Context.antiquotation @{binding thms} Attrib.thms (K (thm_binding "thms" false)));
    77       Scan.pass context Attrib.thm >> (thm_binding "thm" true context o single))) #>
       
    78    ML_Context.add_antiq @{binding thms}
       
    79     (Scan.depend (fn context =>
       
    80       Scan.pass context Attrib.thms >> thm_binding "thms" false context)));
       
    81 
    73 
    82 
    74 
    83 (* ad-hoc goals *)
    75 (* ad-hoc goals *)
    84 
    76 
    85 val and_ = Args.$$$ "and";
    77 val and_ = Args.$$$ "and";
    86 val by = Args.$$$ "by";
    78 val by = Args.$$$ "by";
    87 val goal = Scan.unless (by || and_) Args.name_inner_syntax;
    79 val goal = Scan.unless (by || and_) Args.name_inner_syntax;
    88 
    80 
    89 val _ = Theory.setup
    81 val _ = Theory.setup
    90   (ML_Context.add_antiq @{binding lemma}
    82   (ML_Context.antiquotation @{binding lemma}
    91     (Scan.depend (fn context =>
    83     (Scan.lift (Args.mode "open" -- Parse.enum1 "and" (Scan.repeat1 goal) --
    92       Args.mode "open" -- Parse.enum1 "and" (Scan.repeat1 goal) --
    84       (by |-- Method.parse -- Scan.option Method.parse)))
    93       (by |-- Method.parse -- Scan.option Method.parse)
    85     (fn _ => fn ((is_open, raw_propss), (m1, m2)) => fn ctxt =>
    94      >> (fn ((is_open, raw_propss), (m1, m2)) =>
    86       let
    95           let
    87         val _ = Context_Position.reports ctxt (maps Method.reports_of (m1 :: the_list m2));
    96             val ctxt = Context.proof_of context;
       
    97 
    88 
    98             val _ = Context_Position.reports ctxt (maps Method.reports_of (m1 :: the_list m2));
    89         val propss = burrow (map (rpair []) o Syntax.read_props ctxt) raw_propss;
       
    90         val prep_result = Goal.norm_result ctxt #> not is_open ? Thm.close_derivation;
       
    91         fun after_qed res goal_ctxt =
       
    92           Proof_Context.put_thms false (Auto_Bind.thisN,
       
    93             SOME (map prep_result (Proof_Context.export goal_ctxt ctxt (flat res)))) goal_ctxt;
    99 
    94 
   100             val propss = burrow (map (rpair []) o Syntax.read_props ctxt) raw_propss;
    95         val ctxt' = ctxt
   101             val prep_result = Goal.norm_result ctxt #> not is_open ? Thm.close_derivation;
    96           |> Proof.theorem NONE after_qed propss
   102             fun after_qed res goal_ctxt =
    97           |> Proof.global_terminal_proof (m1, m2);
   103               Proof_Context.put_thms false (Auto_Bind.thisN,
    98         val thms =
   104                 SOME (map prep_result (Proof_Context.export goal_ctxt ctxt (flat res)))) goal_ctxt;
    99           Proof_Context.get_fact ctxt'
   105 
   100             (Facts.named (Proof_Context.full_name ctxt' (Binding.name Auto_Bind.thisN)));
   106             val ctxt' = ctxt
   101       in thm_binding "lemma" (length (flat propss) = 1) thms ctxt end));
   107               |> Proof.theorem NONE after_qed propss
       
   108               |> Proof.global_terminal_proof (m1, m2);
       
   109             val thms =
       
   110               Proof_Context.get_fact ctxt'
       
   111                 (Facts.named (Proof_Context.full_name ctxt' (Binding.name Auto_Bind.thisN)));
       
   112           in thm_binding "lemma" (length (flat propss) = 1) context thms end))));
       
   113 
   102 
   114 end;
   103 end;
   115 
   104