src/Pure/ML/ml_context.ML
author wenzelm
Tue Mar 18 11:07:47 2014 +0100 (2014-03-18)
changeset 56199 8e8d28ed7529
parent 56070 1bc0bea908c3
child 56201 dd2df97b379b
permissions -rw-r--r--
tuned signature -- rearranged modules;
     1 (*  Title:      Pure/ML/ml_context.ML
     2     Author:     Makarius
     3 
     4 ML context and antiquotations.
     5 *)
     6 
     7 signature ML_CONTEXT =
     8 sig
     9   val the_generic_context: unit -> Context.generic
    10   val the_global_context: unit -> theory
    11   val the_local_context: unit -> Proof.context
    12   val thm: xstring -> thm
    13   val thms: xstring -> thm list
    14   val exec: (unit -> unit) -> Context.generic -> Context.generic
    15   val check_antiquotation: Proof.context -> xstring * Position.T -> string
    16   val print_antiquotations: Proof.context -> unit
    17   type decl = Proof.context -> string * string
    18   val antiquotation: binding -> 'a context_parser ->
    19     (Args.src -> 'a -> Proof.context -> decl * Proof.context) -> theory -> theory
    20   val trace_raw: Config.raw
    21   val trace: bool Config.T
    22   val eval_antiquotes: ML_Lex.token Antiquote.antiquote list * Position.T ->
    23     Context.generic option -> (ML_Lex.token list * ML_Lex.token list) * Context.generic option
    24   val eval: bool -> Position.T -> ML_Lex.token Antiquote.antiquote list -> unit
    25   val eval_source: bool -> Symbol_Pos.source -> unit
    26   val eval_in: Proof.context option -> bool -> Position.T ->
    27     ML_Lex.token Antiquote.antiquote list -> unit
    28   val eval_source_in: Proof.context option -> bool -> Symbol_Pos.source -> unit
    29   val expression: Position.T -> string -> string -> ML_Lex.token Antiquote.antiquote list ->
    30     Context.generic -> Context.generic
    31 end
    32 
    33 structure ML_Context: ML_CONTEXT =
    34 struct
    35 
    36 (** implicit ML context **)
    37 
    38 val the_generic_context = Context.the_thread_data;
    39 val the_global_context = Context.theory_of o the_generic_context;
    40 val the_local_context = Context.proof_of o the_generic_context;
    41 
    42 fun thm name = Proof_Context.get_thm (the_local_context ()) name;
    43 fun thms name = Proof_Context.get_thms (the_local_context ()) name;
    44 
    45 fun exec (e: unit -> unit) context =
    46   (case Context.setmp_thread_data (SOME context) (fn () => (e (); Context.thread_data ())) () of
    47     SOME context' => context'
    48   | NONE => error "Missing context after execution");
    49 
    50 
    51 
    52 (** ML antiquotations **)
    53 
    54 (* theory data *)
    55 
    56 type decl = Proof.context -> string * string;  (*final context -> ML env, ML body*)
    57 structure Antiquotations = Theory_Data
    58 (
    59   type T = (Args.src -> Proof.context -> decl * Proof.context) Name_Space.table;
    60   val empty : T = Name_Space.empty_table Markup.ML_antiquotationN;
    61   val extend = I;
    62   fun merge data : T = Name_Space.merge_tables data;
    63 );
    64 
    65 val get_antiquotations = Antiquotations.get o Proof_Context.theory_of;
    66 
    67 fun check_antiquotation ctxt =
    68   #1 o Name_Space.check (Context.Proof ctxt) (get_antiquotations ctxt);
    69 
    70 fun add_antiquotation name f thy = thy
    71   |> Antiquotations.map (Name_Space.define (Context.Theory thy) true (name, f) #> snd);
    72 
    73 fun print_antiquotations ctxt =
    74   Pretty.big_list "ML antiquotations:"
    75     (map (Pretty.mark_str o #1) (Name_Space.markup_table ctxt (get_antiquotations ctxt)))
    76   |> Pretty.writeln;
    77 
    78 fun apply_antiquotation src ctxt =
    79   let val (src', f) = Args.check_src ctxt (get_antiquotations ctxt) src
    80   in f src' ctxt end;
    81 
    82 fun antiquotation name scan body =
    83   add_antiquotation name
    84     (fn src => fn orig_ctxt =>
    85       let val (x, _) = Args.syntax scan src orig_ctxt
    86       in body src x orig_ctxt end);
    87 
    88 
    89 (* parsing and evaluation *)
    90 
    91 local
    92 
    93 val antiq =
    94   Parse.!!! (Parse.position Parse.xname -- Args.parse --| Scan.ahead Parse.eof)
    95   >> uncurry Args.src;
    96 
    97 val begin_env0 = ML_Lex.tokenize "structure Isabelle =\nstruct\n";
    98 
    99 fun begin_env visible =
   100   ML_Lex.tokenize
   101     ("structure Isabelle =\nstruct\n\
   102      \val ML_context = Context_Position.set_visible " ^ Bool.toString visible ^
   103      " (ML_Context.the_local_context ());\n");
   104 
   105 val end_env = ML_Lex.tokenize "end;";
   106 val reset_env = ML_Lex.tokenize "structure Isabelle = struct end";
   107 
   108 in
   109 
   110 fun eval_antiquotes (ants, pos) opt_context =
   111   let
   112     val visible =
   113       (case opt_context of
   114         SOME (Context.Proof ctxt) => Context_Position.is_visible ctxt
   115       | _ => true);
   116     val opt_ctxt = Option.map (Context.Proof o Context.proof_of) opt_context;
   117 
   118     val ((ml_env, ml_body), opt_ctxt') =
   119       if forall Antiquote.is_text ants
   120       then ((begin_env0, map (fn Antiquote.Text tok => tok) ants), opt_ctxt)
   121       else
   122         let
   123           val lex = #1 (Keyword.get_lexicons ());
   124           fun no_decl _ = ([], []);
   125 
   126           fun expand (Antiquote.Text tok) ctxt = (K ([], [tok]), ctxt)
   127             | expand (Antiquote.Antiq (ss, {range, ...})) ctxt =
   128                 let
   129                   val (decl, ctxt') =
   130                     apply_antiquotation (Token.read_antiq lex antiq (ss, #1 range)) ctxt;
   131                   val decl' = decl #> pairself (ML_Lex.tokenize #> map (ML_Lex.set_range range));
   132                 in (decl', ctxt') end;
   133 
   134           val ctxt =
   135             (case opt_ctxt of
   136               NONE => error ("No context -- cannot expand ML antiquotations" ^ Position.here pos)
   137             | SOME ctxt => Context.proof_of ctxt);
   138 
   139           val (decls, ctxt') = fold_map expand ants ctxt;
   140           val (ml_env, ml_body) =
   141             decls |> map (fn decl => decl ctxt') |> split_list |> pairself flat;
   142         in ((begin_env visible @ ml_env, ml_body), SOME (Context.Proof ctxt')) end;
   143   in ((ml_env @ end_env, ml_body), opt_ctxt') end;
   144 
   145 val trace_raw = Config.declare "ML_trace" (fn _ => Config.Bool false);
   146 val trace = Config.bool trace_raw;
   147 
   148 fun eval verbose pos ants =
   149   let
   150     (*prepare source text*)
   151     val ((env, body), env_ctxt) = eval_antiquotes (ants, pos) (Context.thread_data ());
   152     val _ =
   153       (case Option.map Context.proof_of env_ctxt of
   154         SOME ctxt =>
   155           if Config.get ctxt trace then
   156             Context_Position.if_visible ctxt
   157               tracing (cat_lines [ML_Lex.flatten env, ML_Lex.flatten body])
   158           else ()
   159       | NONE => ());
   160 
   161     (*prepare static ML environment*)
   162     val _ =
   163       Context.setmp_thread_data
   164         (Option.map (Context.mapping I (Context_Position.set_visible false)) env_ctxt)
   165         (fn () => (ML_Compiler.eval false Position.none env; Context.thread_data ())) ()
   166       |> (fn NONE => () | SOME context' => Context.>> (ML_Env.inherit context'));
   167 
   168     val _ = ML_Compiler.eval verbose pos body;
   169     val _ = ML_Compiler.eval false Position.none reset_env;
   170   in () end;
   171 
   172 end;
   173 
   174 
   175 (* derived versions *)
   176 
   177 fun eval_source verbose source =
   178   eval verbose (#pos source) (ML_Lex.read_source source);
   179 
   180 fun eval_in ctxt verbose pos ants =
   181   Context.setmp_thread_data (Option.map Context.Proof ctxt)
   182     (fn () => eval verbose pos ants) ();
   183 
   184 fun eval_source_in ctxt verbose source =
   185   Context.setmp_thread_data (Option.map Context.Proof ctxt)
   186     (fn () => eval_source verbose source) ();
   187 
   188 fun expression pos bind body ants =
   189   exec (fn () => eval false pos
   190     (ML_Lex.read Position.none ("Context.set_thread_data (SOME (let " ^ bind ^ " = ") @ ants @
   191       ML_Lex.read Position.none (" in " ^ body ^ " end (ML_Context.the_generic_context ())));")));
   192 
   193 end;
   194