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