--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/ProgTutorial/antiquote_setup.ML	Thu Mar 19 13:28:16 2009 +0100
@@ -0,0 +1,128 @@
+(* Auxiliary antiquotations for the tutorial. *)
+
+structure AntiquoteSetup: sig end =
+struct
+
+(* functions for generating appropriate expressions *)
+fun ml_val_open (ys, xs) txt = 
+  let fun ml_val_open_aux ys txt = 
+          "fn " ^ (case ys of [] => "_" | _ => enclose "(" ")" (commas ys)) ^ " => (" ^ txt ^ ")";
+  in
+    (case xs of
+       [] => ml_val_open_aux ys txt
+     | _  => ml_val_open_aux ys ("let open " ^ (space_implode " " xs) ^ " in " ^ txt ^ " end"))
+  end;
+
+fun ml_val txt = ml_val_open ([],[]) txt;
+
+fun ml_pat (lhs, pat) =
+  let 
+     val pat' = implode (map (fn "\\<dots>" => "_" | s => s) (Symbol.explode pat))
+  in "val " ^ pat' ^ " = " ^ lhs end;
+
+fun ml_struct txt = "functor DUMMY_FUNCTOR() = struct structure DUMMY = " ^ txt ^ " end";
+fun ml_type txt = "val _ = NONE : (" ^ txt ^ ") option";
+
+(* eval function *)
+fun eval_fn ctxt exp =
+  ML_Context.eval_in (SOME ctxt) false Position.none exp
+
+(* string functions *)
+fun string_explode str txt =
+  map (fn s => str ^ s) (space_explode "\n" txt)
+
+val transform_cmts_str =
+     Source.of_string 
+  #> ML_Lex.source 
+  #> Source.exhaust 
+  #> Chunks.transform_cmts 
+  #> implode 
+  #> string_explode "";
+
+(* output function *)
+fun output_fn txt =  Chunks.output (map Pretty.str txt)
+
+(* checks and prints open expressions *)
+fun output_ml {context = ctxt, ...} (txt, ovars) =
+  (eval_fn ctxt (ml_val_open ovars txt);
+   output_fn (transform_cmts_str txt))
+
+val parser_ml = Scan.lift (Args.name --
+  (Scan.optional (Args.$$$ "for" |-- OuterParse.!!! (Scan.repeat1 Args.name)) [] --
+   Scan.optional (Args.$$$ "in"  |-- OuterParse.!!! (Scan.repeat1 Args.name)) [])) 
+
+(* checks and prints types and structures *)
+fun output_exp ml {context = ctxt, ...} txt = 
+  (eval_fn ctxt (ml txt);
+   output_fn (string_explode "" txt))
+
+(* checks and expression agains a result pattern *)
+fun output_response {context = ctxt, ...} (lhs, pat) = 
+    (eval_fn ctxt (ml_pat (lhs, pat));
+     output_fn ((string_explode "" lhs) @ (string_explode "> " pat)))
+
+(* checks the expressions, but does not check it against a result pattern *)
+fun output_response_fake {context = ctxt, ...} (lhs, pat) = 
+    (eval_fn ctxt (ml_val lhs);
+     output_fn ((string_explode "" lhs) @ (string_explode "> " pat)))
+
+(* checks the expressions, but does not check it against a result pattern *)
+fun ouput_response_fake_both _ (lhs, pat) = 
+    output_fn ((string_explode "" lhs) @ (string_explode "> " pat))
+
+val single_arg = Scan.lift (Args.name)
+val two_args   = Scan.lift (Args.name -- Args.name)
+
+val _ = ThyOutput.antiquotation "ML" parser_ml output_ml
+val _ = ThyOutput.antiquotation "ML_type" single_arg (output_exp ml_type)
+val _ = ThyOutput.antiquotation "ML_struct" single_arg (output_exp ml_struct)
+val _ = ThyOutput.antiquotation "ML_response" two_args output_response
+val _ = ThyOutput.antiquotation "ML_response_fake" two_args output_response_fake
+val _ = ThyOutput.antiquotation "ML_response_fake_both" two_args ouput_response_fake_both
+
+fun href_link txt =
+let 
+  val raw = Symbol.encode_raw
+  val path = "http://isabelle.in.tum.de/repos/isabelle/raw-file/tip/src/"    
+in
+ (raw "\\href{") ^ (raw path) ^ (raw txt) ^ (raw "}{") ^ txt ^ (raw "}")
+end 
+
+(* checks whether a file exists in the Isabelle distribution *)
+fun check_file_exists _ txt =
+  (if File.exists (Path.append (Path.explode ("~~/src")) (Path.explode txt)) 
+   then output_fn [href_link txt]
+   else error ("Source file " ^ (quote txt) ^ " does not exist."))
+
+val _ = ThyOutput.antiquotation "ML_file" single_arg check_file_exists
+
+
+(* replaces the official subgoal antiquotation with one *)
+(* that is closer to the actual output                  *)
+fun output_goals  {state = node, ...}  _ = 
+let
+  fun subgoals 0 = ""
+    | subgoals 1 = "goal (1 subgoal):"
+    | subgoals n = "goal (" ^ string_of_int n ^ " subgoals):"
+
+  fun proof_state state =
+    (case try Toplevel.proof_of state of
+      SOME prf => prf
+    | _ => error "No proof state")
+
+  val state = proof_state node;
+  val goals = Proof.pretty_goals false state;
+
+  val {prop, ...} = rep_thm (Proof.get_goal state |> snd |> snd);
+  val (As, B) = Logic.strip_horn prop;
+  val output  = (case (length As) of
+                      0 => goals 
+                    | n => (Pretty.str (subgoals n))::goals)  
+in 
+  ThyOutput.output output
+end
+
+
+val _ = ThyOutput.antiquotation "subgoals" (Scan.succeed ()) output_goals
+   
+end;