src/Pure/Syntax/scan.ML

 infix 3 >>;
 infix 0 ||;
 
 signature BASIC_SCAN =
 sig
-  val !! : ('a -> string) -> ('a -> 'b) -> 'a -> 'b
+  val !! : ('a * string option -> string) -> ('a -> 'b) -> 'a -> 'b
   val >> : ('a -> 'b * 'c) * ('b -> 'd) -> 'a -> 'd * 'c
   val || : ('a -> 'b) * ('a -> 'b) -> 'a -> 'b
   val -- : ('a -> 'b * 'c) * ('c -> 'd * 'e) -> 'a -> ('b * 'd) * 'e
   val |-- : ('a -> 'b * 'c) * ('c -> 'd * 'e) -> 'a -> 'd * 'e
   val --| : ('a -> 'b * 'c) * ('c -> 'd * 'e) -> 'a -> 'b * 'e

 
 signature SCAN =
 sig
   include BASIC_SCAN
   val fail: 'a -> 'b
+  val fail_with: ('a -> string) -> 'a -> 'b
   val succeed: 'a -> 'b -> 'a * 'b
   val one: ('a -> bool) -> 'a list -> 'a * 'a list
   val any: ('a -> bool) -> 'a list -> 'a list * 'a list
   val any1: ('a -> bool) -> 'a list -> 'a list * 'a list
   val optional: ('a -> 'b * 'a) -> 'b -> 'a -> 'b * 'a

 
 
 (** scanners **)
 
 exception MORE of string option;	(*need more input (use prompt)*)
-exception FAIL;				(*try alternatives*)
+exception FAIL of string option;	(*try alternatives (reason of failure)*)
 exception ABORT of string;		(*dead end*)
 
 
 (* scanner combinators *)
 
 fun (scan >> f) xs = apfst f (scan xs);
 
-fun (scan1 || scan2) xs = scan1 xs handle FAIL => scan2 xs;
+fun (scan1 || scan2) xs = scan1 xs handle FAIL _ => scan2 xs;
 
 fun (scan1 -- scan2) xs =
   let
     val (x, ys) = scan1 xs;
     val (y, zs) = scan2 ys;

 fun (scan1 ^^ scan2) = scan1 -- scan2 >> op ^;
 
 
 (* generic scanners *)
 
-fun fail _ = raise FAIL;
+fun fail _ = raise FAIL None;
+fun fail_with msg_of xs = raise FAIL (Some (msg_of xs));
 fun succeed y xs = (y, xs);
 
 fun one _ [] = raise MORE None
   | one pred (x :: xs) =
-      if pred x then (x, xs) else raise FAIL;
+      if pred x then (x, xs) else raise FAIL None;
 
 fun $$ _ [] = raise MORE None
   | $$ a (x :: xs) =
-      if a = x then (x, xs) else raise FAIL;
+      if a = x then (x, xs) else raise FAIL None;
 
 fun any _ [] = raise MORE None
   | any pred (lst as x :: xs) =
       if pred x then apfst (cons x) (any pred xs)
       else ([], lst);

 fun repeat scan xs = (scan -- repeat scan >> op :: || succeed []) xs;
 fun repeat1 scan = scan -- repeat scan >> op ::;
 
 fun max leq scan1 scan2 xs =
   (case (option scan1 xs, option scan2 xs) of
-    ((None, _), (None, _)) => raise FAIL
+    ((None, _), (None, _)) => raise FAIL None		(*looses FAIL msg!*)
   | ((Some tok1, xs'), (None, _)) => (tok1, xs')
   | ((None, _), (Some tok2, xs')) => (tok2, xs')
   | ((Some tok1, xs1'), (Some tok2, xs2')) =>
       if leq (tok2, tok1) then (tok1, xs1') else (tok2, xs2'));
 

   in (y, xs') end;
 
 
 (* exception handling *)
 
-fun !! err scan xs = scan xs handle FAIL => raise ABORT (err xs);
-fun try scan xs = scan xs handle MORE _ => raise FAIL | ABORT _ => raise FAIL;
-fun force scan xs = scan xs handle MORE _ => raise FAIL;
+fun !! err scan xs = scan xs handle FAIL msg => raise ABORT (err (xs, msg));
+fun try scan xs = scan xs handle MORE _ => raise FAIL None | ABORT _ => raise FAIL None;
+fun force scan xs = scan xs handle MORE _ => raise FAIL None;
 fun prompt str scan xs = scan xs handle MORE None => raise MORE (Some str);
 fun error scan xs = scan xs handle ABORT msg => Library.error msg;
 
 
 (* finite scans *)

 	  if c < d then lit lt res chs
 	  else if c > d then lit gt res chs
 	  else lit eq (if a = no_literal then res else Some (a, cs)) cs;
   in
     (case lit lex None chrs of
-      None => raise FAIL
+      None => raise FAIL None
     | Some res => res)
   end;
 
 
 end;