src/HOL/Import/scan.ML

Show the use of reflection attribute; fixed comments about the order of absorbing equations : f (C x) = x ; now automaically tried as last;

(*  Title:      HOL/Import/scan.ML
    ID:         $Id$
    Author:     Sebastian Skalberg, TU Muenchen / Steven Obua, TU Muenchen

Scanner combinators for sequences.
*)

signature SCANNER =
sig

    include SCANNER_SEQ

    exception SyntaxError

    type ('a,'b) scanner = 'a seq -> 'b * 'a seq

    val :--      : ('a,'b) scanner * ('b -> ('a,'c) scanner)
		   -> ('a,'b*'c) scanner
    val --       : ('a,'b) scanner * ('a,'c) scanner -> ('a,'b*'c) scanner
    val >>       : ('a,'b) scanner * ('b -> 'c) -> ('a,'c) scanner
    val --|      : ('a,'b) scanner * ('a,'c) scanner -> ('a,'b) scanner
    val |--      : ('a,'b) scanner * ('a,'c) scanner -> ('a,'c) scanner
    val ^^       : ('a,string) scanner * ('a,string) scanner
		   -> ('a,string) scanner 
    val ||       : ('a,'b) scanner * ('a,'b) scanner -> ('a,'b) scanner
    val one      : ('a -> bool) -> ('a,'a) scanner
    val anyone   : ('a,'a) scanner
    val succeed  : 'b -> ('a,'b) scanner
    val any      : ('a -> bool) -> ('a,'a list) scanner
    val any1     : ('a -> bool) -> ('a,'a list) scanner
    val optional : ('a,'b) scanner -> 'b -> ('a,'b) scanner
    val option   : ('a,'b) scanner -> ('a,'b option) scanner
    val repeat   : ('a,'b) scanner -> ('a,'b list) scanner
    val repeat1  : ('a,'b) scanner -> ('a,'b list) scanner
    val repeat_fixed : int -> ('a, 'b) scanner -> ('a, 'b list) scanner  
    val ahead    : ('a,'b) scanner -> ('a,'b) scanner
    val unless   : ('a, 'b) scanner -> ('a,'c) scanner -> ('a,'c) scanner
    val $$       : ''a -> (''a,''a) scanner
    val !!       : ('a seq -> string) -> ('a,'b) scanner -> ('a,'b) scanner
    
    val scan_id : (string, string) scanner
    val scan_nat : (string, int) scanner

    val this : ''a list -> (''a, ''a list) scanner
    val this_string : string -> (string, string) scanner
end

functor Scanner (structure Seq : SCANNER_SEQ) : SCANNER =
struct

infix 7 |-- --|
infix 5 :-- -- ^^
infix 3 >>
infix 0 ||

exception SyntaxError
exception Fail of string

type 'a seq = 'a Seq.seq
type ('a,'b) scanner = 'a seq -> 'b * 'a seq

val pull = Seq.pull

fun (sc1 :-- sc2) toks =
    let
	val (x,toks2) = sc1 toks
	val (y,toks3) = sc2 x toks2
    in
	((x,y),toks3)
    end

fun (sc1 -- sc2) toks =
    let
	val (x,toks2) = sc1 toks
	val (y,toks3) = sc2 toks2
    in
	((x,y),toks3)
    end

fun (sc >> f) toks =
    let
	val (x,toks2) = sc toks
    in
	(f x,toks2)
    end

fun (sc1 --| sc2) toks =
    let
	val (x,toks2) = sc1 toks
	val (_,toks3) = sc2 toks2
    in
	(x,toks3)
    end

fun (sc1 |-- sc2) toks =
    let
	val (_,toks2) = sc1 toks
    in
	sc2 toks2
    end

fun (sc1 ^^ sc2) toks =
    let
	val (x,toks2) = sc1 toks
	val (y,toks3) = sc2 toks2
    in
	(x^y,toks3)
    end

fun (sc1 || sc2) toks =
    (sc1 toks)
    handle SyntaxError => sc2 toks

fun anyone toks = case pull toks of NONE => raise SyntaxError | SOME x => x

fun one p toks = case anyone toks of x as (t, toks) => if p t then x else raise SyntaxError

fun succeed e toks = (e,toks)

fun any p toks =
    case pull toks of
	NONE =>  ([],toks)
      | SOME(x,toks2) => if p x
			 then
			     let
				 val (xs,toks3) = any p toks2
			     in
				 (x::xs,toks3)
			     end
			 else ([],toks)

fun any1 p toks =
    let
	val (x,toks2) = one p toks
	val (xs,toks3) = any p toks2
    in
	(x::xs,toks3)
    end

fun optional sc def =  sc || succeed def
fun option sc = (sc >> SOME) || succeed NONE

(*
fun repeat sc =
    let
	fun R toks =
	    let
		val (x,toks2) = sc toks
		val (xs,toks3) = R toks2
	    in
		(x::xs,toks3)
	    end
	    handle SyntaxError => ([],toks)
    in
	R
    end
*)

(* A tail-recursive version of repeat.  It is (ever so) slightly slower
 * than the above, non-tail-recursive version (due to the garbage generation
 * associated with the reversal of the list).  However,  this version will be
 * able to process input where the former version must give up (due to stack
 * overflow).  The slowdown seems to be around the one percent mark.
 *)
fun repeat sc =
    let
	fun R xs toks =
	    case SOME (sc toks) handle SyntaxError => NONE of
		SOME (x,toks2) => R (x::xs) toks2
	      | NONE => (List.rev xs,toks)
    in
	R []
    end

fun repeat1 sc toks =
    let
	val (x,toks2) = sc toks
	val (xs,toks3) = repeat sc toks2
    in
	(x::xs,toks3)
    end

fun repeat_fixed n sc =
    let
	fun R n xs toks =
	    if (n <= 0) then (List.rev xs, toks)
	    else case (sc toks) of (x, toks2) => R (n-1) (x::xs) toks2
    in
	R n []
    end

fun ahead (sc:'a->'b*'a) toks = (#1 (sc toks),toks)

fun unless test sc toks =
    let
	val test_failed = (test toks;false) handle SyntaxError => true
    in
	if test_failed
	then sc toks
	else raise SyntaxError
    end

fun $$ arg = one (fn x => x = arg)

fun !! f sc toks = (sc toks
		    handle SyntaxError => raise Fail (f toks))

val scan_id = one Symbol.is_letter ^^ (any Symbol.is_letdig >> implode);

val nat_of_list = the o Int.fromString o implode 

val scan_nat = repeat1 (one Symbol.is_digit) >> nat_of_list 

fun this [] = (fn toks => ([], toks))
  | this (xs' as (x::xs)) = one (fn y => x=y) -- this xs >> K xs'

fun this_string s = this (explode s) >> K s

end