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