structure Parser =
    struct
	structure A = Absyn

	structure P = Pos

	structure S = Symbol

	structure T = Tokens


	(* Parsing *)
	open Parsing

	infix 4 << >>
	infix 3 &&
	infix 2 -- ##
	infix 2 wth suchthat return guard
	infixr 1 ||   
	exception Fatal

	val errPos = Error.errPos

	(* Tiger Tokens *)
	val ARRAY = T.litWord "array"
	val BREAK = T.litWord "break"
	val DO = T.litWord "do"
	val ELSE = T.litWord "else"
	val END = T.litWord "end"
	val FOR = T.litWord "for"
	val FUNCTION = T.litWord "function" 
	val IF = T.litWord "if"
	val IN = T.litWord "in"
	val LET = T.litWord "let"
	val NIL = T.litWord "nil"
	val OF = T.litWord "of"
	val TO = T.litWord "to"
	val VAR = T.litWord "var"
	val THEN = T.litWord "then"
	val TYPE = T.litWord "type"
	val WHILE = T.litWord "while"

	val BAR = T.litWord "|"
	val AMPERSAND = T.litWord "&"
	val DOT = T.litWord "."
	val SEMICOLON = T.litWord ";"
	val COLON = T.litWord ":"
	val COMMA = T.litWord ","

	val PLUS = T.litWord "+"
	val MINUS = T.litWord "-"
	val STAR = T.litWord "*"
	val SLASH = T.litWord "/"

	val GTEQ = T.litWord ">="
	val GT = T.litWord ">"
	val LTEQ = T.litWord "<="
	val LT = T.litWord "<"
	val LTGT = T.litWord "<>"
	val EQ = T.litWord "="

	val COLONEQ = T.litWord ":="

	val RBRACE = T.litWord "}"
	val LBRACE = T.litWord "{"
	val RBRACKET = T.litWord "]"
	val LBRACKET = T.litWord "["
	val RPAREN = T.litWord ")"
	val LPAREN = T.litWord "("

	(* Tiger Keywords *)
	val keywords =
	    ["function", "break", "of", "end", "in",
	     "nil", "let", "do", "to", "for", "while", "else",
	     "then", "if", "array", "type", "var", 
	     "|", "&", ".", ";", ":", ",",
	     "+", "-", "/", "*",
	     ">=", ">", "<=", "<", "<>", "=",
	     ":=",
	     "(", ")", "[", "]", "{", "}"
	     ]

	fun isAlpha c = Char.isAlpha c orelse Char.contains "_'" c
	fun isAlphaNum c = isAlpha c orelse Char.isDigit c

	fun isIdent (s: string): bool =
	    case (explode s) of
		[] => false
	      | c :: cs => (isAlpha c) andalso (List.all isAlphaNum cs)

	fun isKeyword (s: string): bool =
	    List.exists (fn x => x = s) keywords

	fun isId (s: string): bool =
	    not (isKeyword s) andalso isIdent s

	val id =
	    T.anyWord suchthat isId wth (fn name => S.symbol name)

	val tyid = id

	val intlit = T.anyInteger wth (fn i => A.IntExp i)

	val stringlit =
	    !! T.anyString wth (fn (s, pos) => A.StringExp (s, pos))

	val nillit = NIL return A.NilExp

	val literal = nillit || intlit || stringlit

	val operator =
	    PLUS return Infix (LeftAssoc, 4, (A.mkBinOp A.PlusOp)) ||
	    MINUS return Infix (LeftAssoc, 4, (A.mkBinOp A.MinusOp)) ||
	    STAR return Infix (LeftAssoc, 5, (A.mkBinOp A.TimesOp)) ||
	    SLASH return Infix (LeftAssoc, 5, (A.mkBinOp A.DivideOp)) ||
	    GTEQ return Infix (NonAssoc, 3, (A.mkBinOp A.GeOp)) ||
	    GT return Infix (NonAssoc, 3, (A.mkBinOp A.GtOp)) ||
	    LTEQ return Infix (NonAssoc, 3, (A.mkBinOp A.LeOp)) ||
	    LT return Infix (NonAssoc, 3, (A.mkBinOp A.LtOp)) ||
	    LTGT return Infix (NonAssoc, 3, (A.mkBinOp A.NeqOp)) ||
	    EQ return Infix (NonAssoc, 3, (A.mkBinOp A.EqOp)) ||
	    AMPERSAND return Infix (LeftAssoc, 2, (A.mkBinOp A.AndOp)) ||
	    BAR return Infix (LeftAssoc, 1, (A.mkBinOp A.OrOp))

	fun tyfield () =
	    !!id << COLON && !!tyid wth
	    (fn ((name, pos1), (tyid, pos2)) =>
	     A.mkTyField (name, tyid, P.union (pos1, pos2)))

	and tyfields () =
	    $tyfield && $tyfields' wth (fn (tf, tfs) => tf :: tfs) ||
	    succeed []

	and tyfields' () =
	    COMMA >> $tyfield && $tyfields'
	    wth (fn (tf, tfs) => tf :: tfs) ||
	    succeed []

	and tydecs() =
	    $tydec && $tydecs' wth (fn (t, ts) => A.TypeDec (t :: ts))

	and tydecs'() =
	    $tydec && $tydecs' wth (fn (t, ts) => t :: ts) ||
	    succeed []

	and tydec() =
	    TYPE >> (!! id) << EQ && (!! ($ty))
	    wth (fn ((name, pos1), (ty, pos2)) =>
		 A.mkTyDec (name, ty, P.union (pos1, pos2)))

	and ty () =
	    !!tyid wth (fn (tyid, pos) => A.NameTy (tyid, pos)) ||
	    LBRACE >> $tyfields << RBRACE wth (fn tfs => A.RecordTy tfs) ||
	    ARRAY >> OF >> !!tyid
	    wth (fn (tyid, pos) => A.ArrayTy (tyid, pos))

	and var() =
	    !!id && $var'
	    wth (fn ((name, pos), k) => k (A.SimpleVar(name, pos)))

	and var'() =
	    DOT >> !!id && $var' wth
	    (fn ((name, pos), k) =>
	     fn v => k (A.mkFieldVar (v, name, pos))) ||
	    !!(LBRACKET >> $exp << RBRACKET) && $var' wth
	    (fn ((e, pos), k) =>
	     fn v => k (A.mkSubscriptVar (v, e, pos))) ||
	    succeed (fn v => v)

	and lvalue () = $var wth (fn v => A.VarExp (v))

	and funcall () =
	    !! (id && LPAREN >> $funargs << RPAREN) wth
		(fn ((name, es), pos) =>
		 A.CallExp {func= name, args= es, pos= pos})

	and funarg () = $exp 

	and funargs' () =
	    COMMA >> $funarg && $funargs'
	    wth (fn (e, es) => e :: es) ||
	    succeed []

	and funargs () =
	    $funarg && $funargs' wth (fn (e, es) => e :: es) ||
	    succeed []

	and exp0 () = (* atomic expressions *)
	    literal ||
	    $funcall ||
	    $lvalue ||
	    LPAREN >> $expseq << RPAREN
	    wth (fn [(e, _)] => e | eps => A.SeqExp eps)

	and operator_or_exp0 () =
	    operator wth (fn opr => Opr opr) ||
	    !! ($exp0) wth (fn ep => Atm ep) 

	and oper0' () =
	    repeat1 ($operator_or_exp0)
	    wth (fn items =>
		 fn item =>
		 result (resolveFixity (item :: items)))

	and exp0' () =
	    repeat1 ($operator_or_exp0)
	    wth (fn items =>
		 fn ep =>
		 result (resolveFixity (Atm ep :: items))) ||
	    succeed (fn ep => ep)	    

	and exp1 () =
	    !! MINUS && $oper0'
	    wth (fn ((_, p), k) => k (Opr (Prefix (6, A.mkNegOp p)))) ||
	    !! ($exp0) && $exp0' wth (fn (ep, k) => k ep)

	and assign () =
	    !!($var << COLONEQ && $exp)
	    wth (fn ((lv, e), pos) =>
		 A.AssignExp {var= lv, exp= e, pos= pos})
		 
	and newArray () =
	    !!(tyid && LBRACKET >> $exp << RBRACKET << OF && $exp)
	    wth (fn (((tyid, size), init), pos) =>
		 A.ArrayExp ({typ=tyid, size= size, init= init, pos= pos}))

	and newRecord () =
	    !! (tyid && LBRACE >> $recFields << RBRACE)
	    wth (fn ((tyid, rfs), pos) =>
		 A.RecordExp {fields= rfs, typ= tyid, pos= pos})

	and recField () =
	    id << EQ && !! ($exp)
	    wth (fn (name, (e, pos)) => (name, e, pos))

	and recFields' () =
	    COMMA >> $recField && $recFields'
	    wth (fn (rf, rfs) => rf :: rfs) ||
	    succeed []

	and recFields () =
	    $recField && $recFields' wth (fn (rf, rfs) => rf :: rfs) ||
	    succeed []
		 
	and ifExp( ) =
	    !!(IF >> $exp << THEN && $exp && $optElse)
	    wth (fn (((test, e1), oe2), pos) =>
		 A.IfExp {test= test, then'= e1, else'= oe2, pos= pos})

	and optElse() =
	    ELSE >> $exp wth (fn e => SOME e) ||
	    succeed NONE

	and breakExp () =
	    !! BREAK wth (fn (_, pos) => A.BreakExp pos)

	and whileExp() =
	    !! (WHILE >> $exp && DO >> $exp) wth
	    (fn ((test, body), pos) =>
	     A.WhileExp {test= test, body= body, pos=pos})

	and forExp () =
	    !! (FOR >> id && COLONEQ >> $exp && TO >> $exp && DO >> $exp) wth
	    (fn ((((index, first), last), body), pos) =>
	     A.ForExp {var= index, escape= ref false,
		       lo=first, hi=last, body= body, pos= pos})
	and letExp() =
	    !! (LET >> $decsIN && $expseq << END) wth
	    (fn ((ds, eps), pos) =>
	     A.LetExp {decs= ds, body= A.SeqExp (eps), pos=pos})

	and expseq () =
	    !! ($exp) && $expseq' wth (fn (ep, eps) => (ep :: eps)) ||
            succeed []

	and expseq'() =
	    SEMICOLON >> !! ($exp) && $expseq'
	    wth (fn (ep, eps) => ep :: eps) ||
	    succeed []

	and exp () = (* ordering is important *)
	    $assign ||
	    $breakExp ||
	    $newArray ||
	    $newRecord ||
	    $exp1 wth (fn (e, _) => e) ||
	    $ifExp ||
	    $whileExp ||
	    $forExp ||
	    $letExp

	and decsIN () =
	    $dec && $decsIN wth (fn (d, ds) => d :: ds) ||
	    IN return []

	and dec () = $vardec || $tydecs || $fundecs

	and vardec () =
	    !! (VAR >> id && $varopttype && COLONEQ >> $exp)
	    wth (fn (((name, otp), e), pos) => A.mkVarDec (name, otp, e, pos))

	and varopttype () =
	    COLON >> !! tyid wth (fn (tyid, pos) => SOME (tyid, pos)) ||
	    succeed NONE

	and fundecs () =
	    $fundec && $fundecs'
	    wth (fn (fd, fds) => A.FunctionDec (fd :: fds))

	and fundecs' () =
	    $fundec && $fundecs' wth (fn (fd, fds) => fd :: fds) ||
	    succeed []
		    
	and fundec() =
	    !! (FUNCTION >> id &&
		LPAREN >> $params << RPAREN &&
		$funopttype && EQ >> $exp)
	    wth (fn ((((name, params), otp), body), pos) =>
		 A.mkFunctionDec (name, params, otp, body, pos))

	and funopttype () =
	    COLON >> !! tyid wth (fn (tyid, pos) => SOME (tyid, pos)) ||
	    succeed NONE

	and param () = 
	    !!id << COLON && !!tyid wth
	    (fn ((name, pos1), (tyid, pos2)) =>
	     A.mkParam (name, tyid, P.union (pos1, pos2)))

	and params () =
	    $param && $params' wth (fn (p, ps) => p :: ps) ||
	    succeed []

	and params' () =
	    COMMA >> $param && $params'
	    wth (fn (p, ps) => p :: ps) ||
	    succeed []

	val top = exp

	(* Initialization Functions *)
	fun parseString (str: string) =
	    let
	        (* transforms string to char stream *)
	        val s = Input.readString str
		(* transforms char stream to (char*T) stream.
		   marks it will line and char numbers *)
		val s = P.markStream s
		(* run the T.token parser on the stream s
		   and create a new token stream *)
		val s = transform T.token s
	    in
		let
		    (* parse the token stream to make sure it
		       is a series of declarations and return it *)
		    val (x, _, _, _) = ($top -- done) (P.initpos, s)
		in
		    x
		end handle Fail pos => errPos pos "Syntax error"
	    end

	fun parseFile (file: string) =
	    let
		val s = Input.readFile file
		val s = P.markStream s
		val s = transform T.token s
	    in
		let
		    val (x, _, _,  _) = ($top -- done) (P.initpos, s)
		in
		    x
		end handle Fail pos => errPos pos "Syntax error"
	    end

	fun parseKeybd () =
	    let
		val s = Input.readKeybd ()
		val s = P.markStream s
		val s = transform T.token s
	    in
		let
		    val (x, _, _,  _) = ($top -- done) (P.initpos, s)
		in
		    x
		end handle Fail pos => errPos pos "Syntax error"
	    end
    
    end