(*** Parsing functionals.  From Chapter 9.  ***)

infix 5 -- ;
infix 3 >> ;
infix 0 || ;
infix 9 :- -: ;

infix 5 --;
infix 3 >>;
infix 0 ||;

signature PARSE =
  sig
  type token
  type instream
  exception SynError of string * token list
  val reader: (token list -> 'a * token list) -> instream -> 'a
  val -- : ('a -> 'b * 'c) * ('c -> 'd * 'e) -> 'a -> ('b * 'd) * 'e
  val >> : ('a -> 'b * 'c) * ('b -> 'd) -> 'a -> 'd * 'c
  val || : ('a -> 'b) * ('a -> 'b) -> 'a -> 'b
  val :- : ('a -> 'b * 'c) * ('c -> 'd * 'e) -> 'a -> 'd * 'e
  val -: : ('a -> 'b * 'c) * ('c -> 'd * 'e) -> 'a -> 'b * 'e
  val $  : string -> token list -> string * token list
  val ## : token list -> int * token list
  val empty : 'a -> 'b list * 'a
  val id : token list -> string * token list
  val infixes :
      (token list -> 'a * token list) * (string -> int) *
      (string -> 'a -> 'a -> 'a) -> token list -> 'a * token list
  val repeat : ('a -> 'b * 'a) -> 'a -> 'b list * 'a
  end;

functor PARSE (Lex: LEXICAL): PARSE =
  struct
  type token = Lex.token;
  type instream = Lex.instream
  exception SynError of string * token list;

  (*Phrase consisting of the keyword 'a' *)
  fun $a (Lex.Key b :: toks) =
        if a=b then (a,toks) else raise SynError  ("Symbol " ^a^ " expected; " ^ b ^ " found",toks)
    | $a toks = raise SynError ("Symbol " ^a^ " expected",toks);

  (*Phrase consisting of a numeric constant *)
  fun ## (Lex.Num n :: toks) = (n, toks)
    | ## toks = raise SynError ("Number expected",toks);

  (*Phrase consisting of an identifier*)
  fun id (Lex.Id a :: toks) = (a,toks)
    | id toks = raise SynError ("Identifier expected",toks);

  (*Application of f to the result of a phrase*)
  fun (ph>>f) toks = 
      let val (x,toks2) = ph toks
      in  (f x, toks2)  end;

  (*Alternative phrases*)
  fun (ph1 || ph2) toks = ph1 toks   handle SynError _ => ph2 toks;

  (*Consecutive phrases*)
  fun (ph1 -- ph2) toks = 
      let val (x,toks2) = ph1 toks
	  val (y,toks3) = ph2 toks2
      in  ((x,y), toks3)  end;

  fun empty toks = ([],toks);

  (*Zero or more phrases*)
  fun repeat ph toks = (   ph -- repeat ph >> (op::)
                        || empty   ) toks;

  fun infixes (ph,prec_of,apply) = 
    let fun over k toks = next k (ph toks)
        and next k (x, Lex.Key(a)::toks) = ((
              if prec_of a < k then (x, Lex.Key a :: toks)
              else next k ((over (prec_of a) >> apply a x) toks))
            handle Match => (x, Lex.Key(a)::toks))
          | next k (x, toks) = (x, toks)
    in  over 0  end;

  fun reader ph a = (*Scan and parse, checking that no tokens remain*)
	 (case ph (Lex.scan a) of 
	      (x, []) => x
	    | (_, toks) => raise SynError ("Extra characters in phrase",toks)); 
  
  fun debug ph a =   ph (Lex.scan a)  

  fun a -: b = a -- b >> #1
  and a :- b = a -- b >> #2

end;