author | Walther Neuper <wneuper@ist.tugraz.at> |
Wed, 06 Apr 2016 16:56:47 +0200 | |
changeset 59216 | f4693c6f4bb2 |
permissions | -rw-r--r-- |
wneuper@59216 | 1 |
theory Protocol |
wneuper@59216 | 2 |
imports Codec_Class |
wneuper@59216 | 3 |
keywords "operation_setup" :: thy_decl % "ML" |
wneuper@59216 | 4 |
begin |
wneuper@59216 | 5 |
|
wneuper@59216 | 6 |
ML\<open> |
wneuper@59216 | 7 |
val _ = |
wneuper@59216 | 8 |
let |
wneuper@59216 | 9 |
open Protocol |
wneuper@59216 | 10 |
fun operation_setup_cmd name source (flags as {auto, ...}) ctxt = |
wneuper@59216 | 11 |
let |
wneuper@59216 | 12 |
fun eval enclose = |
wneuper@59216 | 13 |
ML_Context.eval_in (SOME ctxt) ML_Compiler.flags (Input.pos_of source) |
wneuper@59216 | 14 |
(ML_Lex.read ("Protocol.add_operation " ^ ML_Syntax.print_string name ^ "(") @ |
wneuper@59216 | 15 |
enclose (ML_Lex.read_source false source) @ |
wneuper@59216 | 16 |
ML_Lex.read ")" @ |
wneuper@59216 | 17 |
ML_Lex.read (print_flags flags)) |
wneuper@59216 | 18 |
in |
wneuper@59216 | 19 |
if auto then |
wneuper@59216 | 20 |
let |
wneuper@59216 | 21 |
val ML_Types.Fun (arg, res) = ML_Types.ml_type_of ctxt (Input.source_content source) |
wneuper@59216 | 22 |
val arg_codec = Classy.resolve @{ML.class codec} arg (Context.Proof ctxt) |
wneuper@59216 | 23 |
val res_codec = Classy.resolve @{ML.class codec} res (Context.Proof ctxt) |
wneuper@59216 | 24 |
fun enclose toks = |
wneuper@59216 | 25 |
ML_Lex.read "{from_lib=" @ ML_Lex.read arg_codec @ ML_Lex.read "," @ |
wneuper@59216 | 26 |
ML_Lex.read "to_lib=" @ ML_Lex.read res_codec @ ML_Lex.read "," @ |
wneuper@59216 | 27 |
ML_Lex.read "action=" @ toks @ ML_Lex.read "}" |
wneuper@59216 | 28 |
in |
wneuper@59216 | 29 |
eval enclose |
wneuper@59216 | 30 |
end |
wneuper@59216 | 31 |
else |
wneuper@59216 | 32 |
eval I |
wneuper@59216 | 33 |
end |
wneuper@59216 | 34 |
val parse_flag = |
wneuper@59216 | 35 |
(Parse.reserved "sequential" || Parse.reserved "bracket" || Parse.reserved "auto") >> |
wneuper@59216 | 36 |
(fn flag => join_flags |
wneuper@59216 | 37 |
{sequential = flag = "sequential", |
wneuper@59216 | 38 |
bracket = flag = "bracket", |
wneuper@59216 | 39 |
auto = flag = "auto"}) |
wneuper@59216 | 40 |
val parse_flags = |
wneuper@59216 | 41 |
Parse.list parse_flag >> (fn fs => fold (curry op o) fs I) |
wneuper@59216 | 42 |
val parse_cmd = |
wneuper@59216 | 43 |
Scan.optional (Args.parens parse_flags) I -- |
wneuper@59216 | 44 |
Parse.name -- |
wneuper@59216 | 45 |
Parse.!!! (@{keyword "="} |-- Parse.ML_source) |
wneuper@59216 | 46 |
in |
wneuper@59216 | 47 |
Outer_Syntax.command @{command_keyword "operation_setup"} "define protocol operation in ML" |
wneuper@59216 | 48 |
(parse_cmd >> (fn ((flags, name), txt) => |
wneuper@59216 | 49 |
Toplevel.keep (Toplevel.context_of #> operation_setup_cmd name txt (flags default_flags)))) |
wneuper@59216 | 50 |
end |
wneuper@59216 | 51 |
\<close> |
wneuper@59216 | 52 |
|
wneuper@59216 | 53 |
end |