src/Tools/Code/code_target.ML
changeset 39661 6381d18507ef
parent 39659 07549694e2f1
child 39679 d36864e3f06c
equal deleted inserted replaced
39660:6ab9781e6d11 39661:6381d18507ef
    71 (** abstract nonsense **)
    71 (** abstract nonsense **)
    72 
    72 
    73 datatype destination = Export of Path.T option | Produce | Present of string list;
    73 datatype destination = Export of Path.T option | Produce | Present of string list;
    74 type serialization = int -> destination -> (string * (string -> string option)) option;
    74 type serialization = int -> destination -> (string * (string -> string option)) option;
    75 
    75 
    76 fun using_plain_output f x = Print_Mode.setmp [] f x;
       
    77 
       
    78 fun serialization output _ content width (Export some_path) =
    76 fun serialization output _ content width (Export some_path) =
    79       (using_plain_output (output width some_path) content; NONE)
    77       (output width some_path content; NONE)
    80   | serialization _ string content width Produce = 
    78   | serialization _ string content width Produce =
    81       SOME (using_plain_output (string [] width) content)
    79       string [] width content |> SOME
    82   | serialization _ string content width (Present stmt_names) =
    80   | serialization _ string content width (Present stmt_names) =
    83       SOME (using_plain_output (string stmt_names width) content);
    81      string stmt_names width content
    84 
    82      |> apfst (Pretty.output (SOME width) o Pretty.str)
    85 fun export some_path serializer naming program names =
    83      |> SOME;
    86   (using_plain_output (serializer naming program) names (Export some_path); ());
    84 
    87 fun produce serializer naming program names =
    85 fun export some_path f = (f (Export some_path); ());
    88   the (using_plain_output (serializer naming program) names Produce);
    86 fun produce f = the (f Produce);
    89 fun present stmt_names serializer naming program names =
    87 fun present stmt_names f = fst (the (f (Present stmt_names)));
    90   fst (the (using_plain_output (serializer naming program) names (Present stmt_names)));
       
    91 
    88 
    92 
    89 
    93 (** theory data **)
    90 (** theory data **)
    94 
    91 
    95 datatype symbol_syntax_data = Symbol_Syntax_Data of {
    92 datatype symbol_syntax_data = Symbol_Syntax_Data of {
   357   | assert_module_name module_name = module_name;
   354   | assert_module_name module_name = module_name;
   358 
   355 
   359 in
   356 in
   360 
   357 
   361 fun export_code_for thy some_path target some_width module_name args =
   358 fun export_code_for thy some_path target some_width module_name args =
   362   export some_path (mount_serializer thy target some_width module_name args);
   359   export some_path ooo mount_serializer thy target some_width module_name args;
   363 
   360 
   364 fun produce_code_for thy target some_width module_name args =
   361 fun produce_code_for thy target some_width module_name args =
   365   let
   362   let
   366     val serializer = mount_serializer thy target some_width (assert_module_name module_name) args;
   363     val serializer = mount_serializer thy target some_width (assert_module_name module_name) args;
   367   in fn naming => fn program => fn names =>
   364   in fn naming => fn program => fn names =>
   368     produce serializer naming program names |> apsnd (fn deresolve => map deresolve names)
   365     produce (serializer naming program names) |> apsnd (fn deresolve => map deresolve names)
   369   end;
   366   end;
   370 
   367 
   371 fun present_code_for thy target some_width module_name args =
   368 fun present_code_for thy target some_width module_name args =
   372   let
   369   let
   373     val serializer = mount_serializer thy target some_width (assert_module_name module_name) args;
   370     val serializer = mount_serializer thy target some_width (assert_module_name module_name) args;
   374   in fn naming => fn program => fn (names, selects) =>
   371   in fn naming => fn program => fn (names, selects) =>
   375     present selects serializer naming program names
   372     present selects (serializer naming program names)
   376   end;
   373   end;
   377 
   374 
   378 fun check_code_for thy target strict args naming program names_cs =
   375 fun check_code_for thy target strict args naming program names_cs =
   379   let
   376   let
   380     val module_name = "Code";
   377     val module_name = "Code";
   383     val env_param = getenv env_var;
   380     val env_param = getenv env_var;
   384     fun ext_check env_param p =
   381     fun ext_check env_param p =
   385       let 
   382       let 
   386         val destination = make_destination p;
   383         val destination = make_destination p;
   387         val _ = export (SOME destination) (mount_serializer thy target (SOME 80)
   384         val _ = export (SOME destination) (mount_serializer thy target (SOME 80)
   388           module_name args) naming program names_cs;
   385           module_name args naming program names_cs);
   389         val cmd = make_command env_param module_name;
   386         val cmd = make_command env_param module_name;
   390       in if bash ("cd " ^ File.shell_path p ^ " && " ^ cmd ^ " 2>&1") <> 0
   387       in if bash ("cd " ^ File.shell_path p ^ " && " ^ cmd ^ " 2>&1") <> 0
   391         then error ("Code check failed for " ^ target ^ ": " ^ cmd)
   388         then error ("Code check failed for " ^ target ^ ": " ^ cmd)
   392         else ()
   389         else ()
   393       end;
   390       end;
   481   (fn {context = ctxt, ...} => fn ((mk_cs, mk_stmtss), (target, some_width)) =>
   478   (fn {context = ctxt, ...} => fn ((mk_cs, mk_stmtss), (target, some_width)) =>
   482     let val thy = ProofContext.theory_of ctxt in
   479     let val thy = ProofContext.theory_of ctxt in
   483       present_code thy (mk_cs thy)
   480       present_code thy (mk_cs thy)
   484         (fn naming => maps (fn f => f thy naming) mk_stmtss)
   481         (fn naming => maps (fn f => f thy naming) mk_stmtss)
   485         target some_width "Example" []
   482         target some_width "Example" []
   486       |> Latex.output_typewriter
   483       (*|> Latex.output_typewriter*)
   487     end);
   484     end);
   488 
   485 
   489 end;
   486 end;
   490 
   487 
   491 
   488