src/Pure/ML/ml_context.ML
author wenzelm
Thu Aug 02 12:36:54 2012 +0200 (2012-08-02)
changeset 48646 91281e9472d8
parent 47005 421760a1efe7
child 48776 37cd53e69840
permissions -rw-r--r--
more official command specifications, including source position;
     1 (*  Title:      Pure/ML/ml_context.ML
     2     Author:     Makarius
     3 
     4 ML context and antiquotations.
     5 *)
     6 
     7 signature BASIC_ML_CONTEXT =
     8 sig
     9   val bind_thm: string * thm -> unit
    10   val bind_thms: string * thm list -> unit
    11 end
    12 
    13 signature ML_CONTEXT =
    14 sig
    15   include BASIC_ML_CONTEXT
    16   val the_generic_context: unit -> Context.generic
    17   val the_global_context: unit -> theory
    18   val the_local_context: unit -> Proof.context
    19   val thm: xstring -> thm
    20   val thms: xstring -> thm list
    21   val exec: (unit -> unit) -> Context.generic -> Context.generic
    22   val get_stored_thms: unit -> thm list
    23   val get_stored_thm: unit -> thm
    24   val ml_store_thms: string * thm list -> unit
    25   val ml_store_thm: string * thm -> unit
    26   type antiq = Proof.context -> (Proof.context -> string * string) * Proof.context
    27   val add_antiq: binding -> (Position.T -> antiq context_parser) -> theory -> theory
    28   val intern_antiq: theory -> xstring -> string
    29   val defined_antiq: theory -> string -> bool
    30   val trace_raw: Config.raw
    31   val trace: bool Config.T
    32   val eval_antiquotes: ML_Lex.token Antiquote.antiquote list * Position.T ->
    33     Context.generic option -> (ML_Lex.token list * ML_Lex.token list) * Context.generic option
    34   val eval: bool -> Position.T -> ML_Lex.token Antiquote.antiquote list -> unit
    35   val eval_text: bool -> Position.T -> Symbol_Pos.text -> unit
    36   val eval_in: Proof.context option -> bool -> Position.T ->
    37     ML_Lex.token Antiquote.antiquote list -> unit
    38   val eval_text_in: Proof.context option -> bool -> Position.T -> Symbol_Pos.text -> unit
    39   val expression: Position.T -> string -> string -> ML_Lex.token Antiquote.antiquote list ->
    40     Context.generic -> Context.generic
    41 end
    42 
    43 structure ML_Context: ML_CONTEXT =
    44 struct
    45 
    46 (** implicit ML context **)
    47 
    48 val the_generic_context = Context.the_thread_data;
    49 val the_global_context = Context.theory_of o the_generic_context;
    50 val the_local_context = Context.proof_of o the_generic_context;
    51 
    52 fun thm name = Proof_Context.get_thm (the_local_context ()) name;
    53 fun thms name = Proof_Context.get_thms (the_local_context ()) name;
    54 
    55 fun exec (e: unit -> unit) context =
    56   (case Context.setmp_thread_data (SOME context) (fn () => (e (); Context.thread_data ())) () of
    57     SOME context' => context'
    58   | NONE => error "Missing context after execution");
    59 
    60 
    61 (* theorem bindings *)
    62 
    63 structure Stored_Thms = Theory_Data
    64 (
    65   type T = thm list;
    66   val empty = [];
    67   fun extend _ = [];
    68   fun merge _ = [];
    69 );
    70 
    71 fun get_stored_thms () = Stored_Thms.get (the_global_context ());
    72 val get_stored_thm = hd o get_stored_thms;
    73 
    74 fun ml_store get (name, ths) =
    75   let
    76     val ths' = Context.>>> (Context.map_theory_result
    77       (Global_Theory.store_thms (Binding.name name, ths)));
    78     val _ = Context.>> (Context.map_theory (Stored_Thms.put ths'));
    79     val _ =
    80       if name = "" then ()
    81       else if not (ML_Syntax.is_identifier name) then
    82         error ("Cannot bind theorem(s) " ^ quote name ^ " as ML value")
    83       else
    84         ML_Compiler.eval true Position.none
    85           (ML_Lex.tokenize ("val " ^ name ^ " = " ^ get ^ " ();"));
    86     val _ = Context.>> (Context.map_theory (Stored_Thms.put []));
    87   in () end;
    88 
    89 val ml_store_thms = ml_store "ML_Context.get_stored_thms";
    90 fun ml_store_thm (name, th) = ml_store "ML_Context.get_stored_thm" (name, [th]);
    91 
    92 fun bind_thm (name, thm) = ml_store_thm (name, Drule.export_without_context thm);
    93 fun bind_thms (name, thms) = ml_store_thms (name, map Drule.export_without_context thms);
    94 
    95 
    96 
    97 (** ML antiquotations **)
    98 
    99 (* antiquotation commands *)
   100 
   101 type antiq = Proof.context -> (Proof.context -> string * string) * Proof.context;
   102 
   103 structure Antiq_Parsers = Theory_Data
   104 (
   105   type T = (Position.T -> antiq context_parser) Name_Space.table;
   106   val empty : T = Name_Space.empty_table Isabelle_Markup.ML_antiquotationN;
   107   val extend = I;
   108   fun merge data : T = Name_Space.merge_tables data;
   109 );
   110 
   111 fun add_antiq name scan thy = thy
   112   |> Antiq_Parsers.map (Name_Space.define (Context.Theory thy) true (name, scan) #> snd);
   113 
   114 val intern_antiq = Name_Space.intern o #1 o Antiq_Parsers.get;
   115 val defined_antiq = Symtab.defined o #2 o Antiq_Parsers.get;
   116 
   117 fun antiquotation src ctxt =
   118   let
   119     val thy = Proof_Context.theory_of ctxt;
   120     val ((xname, _), pos) = Args.dest_src src;
   121     val (_, scan) = Name_Space.check (Context.Proof ctxt) (Antiq_Parsers.get thy) (xname, pos);
   122   in Args.context_syntax Isabelle_Markup.ML_antiquotationN (scan pos) src ctxt end;
   123 
   124 
   125 (* parsing and evaluation *)
   126 
   127 local
   128 
   129 val antiq =
   130   Parse.!!! (Parse.position Parse.xname -- Args.parse --| Scan.ahead Parse.eof)
   131   >> (fn ((x, pos), y) => Args.src ((x, y), pos));
   132 
   133 val begin_env = ML_Lex.tokenize "structure Isabelle =\nstruct\n";
   134 val end_env = ML_Lex.tokenize "end;";
   135 val reset_env = ML_Lex.tokenize "structure Isabelle = struct end";
   136 
   137 in
   138 
   139 fun eval_antiquotes (ants, pos) opt_context =
   140   let
   141     val opt_ctxt = Option.map (Context.Proof o Context.proof_of) opt_context;
   142     val ((ml_env, ml_body), opt_ctxt') =
   143       if forall Antiquote.is_text ants
   144       then (([], map (fn Antiquote.Text tok => tok) ants), opt_ctxt)
   145       else
   146         let
   147           val ctxt =
   148             (case opt_ctxt of
   149               NONE => error ("No context -- cannot expand ML antiquotations" ^ Position.str_of pos)
   150             | SOME ctxt => Context.proof_of ctxt);
   151 
   152           val lex = #1 (Keyword.get_lexicons ());
   153           fun no_decl _ = ([], []);
   154 
   155           fun expand (Antiquote.Text tok) state = (K ([], [tok]), state)
   156             | expand (Antiquote.Antiq (ss, range)) (scope, background) =
   157                 let
   158                   val context = Stack.top scope;
   159                   val (f, context') =
   160                     antiquotation (Token.read_antiq lex antiq (ss, #1 range)) context;
   161                   val (decl, background') = f background;
   162                   val decl' = decl #> pairself (ML_Lex.tokenize #> map (ML_Lex.set_range range));
   163                 in (decl', (Stack.map_top (K context') scope, background')) end
   164             | expand (Antiquote.Open _) (scope, background) =
   165                 (no_decl, (Stack.push scope, background))
   166             | expand (Antiquote.Close _) (scope, background) =
   167                 (no_decl, (Stack.pop scope, background));
   168 
   169           val (decls, (_, ctxt')) = fold_map expand ants (Stack.init ctxt, ctxt);
   170           val ml = decls |> map (fn decl => decl ctxt') |> split_list |> pairself flat;
   171         in (ml, SOME (Context.Proof ctxt')) end;
   172   in ((begin_env @ ml_env @ end_env, ml_body), opt_ctxt') end;
   173 
   174 val trace_raw = Config.declare "ML_trace" (fn _ => Config.Bool false);
   175 val trace = Config.bool trace_raw;
   176 
   177 fun eval verbose pos ants =
   178   let
   179     (*prepare source text*)
   180     val ((env, body), env_ctxt) = eval_antiquotes (ants, pos) (Context.thread_data ());
   181     val _ =
   182       (case Option.map Context.proof_of env_ctxt of
   183         SOME ctxt =>
   184           if Config.get ctxt trace then
   185             Context_Position.if_visible ctxt
   186               tracing (cat_lines [ML_Lex.flatten env, ML_Lex.flatten body])
   187           else ()
   188       | NONE => ());
   189 
   190     (*prepare static ML environment*)
   191     val _ =
   192       Context.setmp_thread_data
   193         (Option.map (Context.mapping I (Context_Position.set_visible false)) env_ctxt)
   194         (fn () => (ML_Compiler.eval false Position.none env; Context.thread_data ())) ()
   195       |> (fn NONE => () | SOME context' => Context.>> (ML_Env.inherit context'));
   196 
   197     val _ = ML_Compiler.eval verbose pos body;
   198     val _ = ML_Compiler.eval false Position.none reset_env;
   199   in () end;
   200 
   201 end;
   202 
   203 
   204 (* derived versions *)
   205 
   206 fun eval_text verbose pos txt = eval verbose pos (ML_Lex.read pos txt);
   207 
   208 fun eval_in ctxt verbose pos ants =
   209   Context.setmp_thread_data (Option.map Context.Proof ctxt) (fn () => eval verbose pos ants) ();
   210 
   211 fun eval_text_in ctxt verbose pos txt =
   212   Context.setmp_thread_data (Option.map Context.Proof ctxt) (fn () => eval_text verbose pos txt) ();
   213 
   214 fun expression pos bind body ants =
   215   exec (fn () => eval false pos
   216     (ML_Lex.read Position.none ("Context.set_thread_data (SOME (let " ^ bind ^ " = ") @ ants @
   217       ML_Lex.read Position.none (" in " ^ body ^ " end (ML_Context.the_generic_context ())));")));
   218 
   219 end;
   220 
   221 structure Basic_ML_Context: BASIC_ML_CONTEXT = ML_Context;
   222 open Basic_ML_Context;