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

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

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

  (*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")
    | $a _ = raise SynError ("Symbol " ^a^ " expected");

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

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

  (*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
	    | (_, _::_) => raise SynError ("Extra characters in phrase")); 
  
  fun debug ph a =   ph (Lex.scan a)  

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

end;