(* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi *)

functor mkMakeLrTable (structure IntGrammar : INTGRAMMAR
		     structure LrTable : LR_TABLE
		     sharing type LrTable.term = IntGrammar.Grammar.term
		     sharing type LrTable.nonterm = IntGrammar.Grammar.nonterm
		    ) : MAKE_LR_TABLE = 
   struct 
        open Array List
	infix 9 sub
	structure Core = mkCore(structure IntGrammar = IntGrammar)
	structure CoreUtils = mkCoreUtils(structure IntGrammar = IntGrammar
				  	  structure Core = Core)
	structure Graph = mkGraph(structure IntGrammar = IntGrammar
			  	  structure Core = Core
			  	  structure CoreUtils = CoreUtils)
	structure Look = mkLook(structure IntGrammar = IntGrammar)
	structure Lalr = mkLalr(structure IntGrammar = IntGrammar
				structure Core = Core
				structure Graph = Graph
				structure Look = Look)
	structure LrTable = LrTable
	structure IntGrammar = IntGrammar
	structure Grammar = IntGrammar.Grammar
	structure GotoList = ListOrdSet
		(struct
		   type elem = Grammar.nonterm * LrTable.state
		   val eq = fn ((Grammar.NT a,_),(Grammar.NT b,_)) => a=b
		   val gt = fn ((Grammar.NT a,_),(Grammar.NT b,_)) => a>b
		end)
	structure Errs : LR_ERRS =
	    struct
		structure LrTable = LrTable
		datatype err = RR of LrTable.term * LrTable.state * int * int
			     | SR of LrTable.term * LrTable.state * int
			     | NONASSOC of LrTable.term * LrTable.state * int
			     | NOT_REDUCED of int
			     | NS of LrTable.term * int
			     | START of int

	        val summary = fn l =>
		   let val numRR = ref 0
		       val numSR = ref 0
		       val numNONASSOC = ref 0
		       val numSTART = ref 0
		       val numNOT_REDUCED = ref 0
		       val numNS = ref 0
		       fun loop (h::t) = 
		       (case h
		         of RR _ => inc numRR
			  | SR _ => inc numSR
			  | NONASSOC _ => inc numNONASSOC
			  | START _ => inc numSTART
			  | NOT_REDUCED _ => inc numNOT_REDUCED
			  | NS _ => inc numNS; loop t)
		      | loop nil = {rr = !numRR, sr = !numSR,
			        nonassoc = !numNONASSOC, start = !numSTART,
			        not_reduced = !numNOT_REDUCED,
			        nonshift = !numNS}
		  in loop l
		  end

		  val printSummary = fn say => fn l =>
		   let val {rr,sr,nonassoc,start,
			    not_reduced,nonshift} = summary l
		       val say_plural = fn (i,s) =>
			  (say (makestring i); say " ";
			   case i
			     of 1 => (say s)
			      | _ => (say s; say "s"))
		       val say_error = fn (args as (i,s)) =>
			  case i
			  of 0 => ()
			   | i => (say_plural args; say "\n")
		   in say_error(rr,"reduce/reduce conflict");
		      say_error(sr,"shift/reduce conflict");
		      say_error(nonassoc," nonassociative error");
		      if nonshift<>0 then
			   (say "non-shiftable terminal used on the rhs of ";
			   say_plural(start,"rule"); say "\n")
		      else ();
		      if start<>0 then (say "start symbol used on the rhs of ";
					say_plural(start,"rule"); say "\n")
		      else ();
		      if not_reduced<>0 then (say_plural(not_reduced,"rule");
					      say " not reduced\n")
		      else ()
		end
	    end


	open IntGrammar Grammar Errs LrTable Core 

(* rules for resolving conflicts:

	shift/reduce:

		  If either the terminal or the rule has no
		  precedence, a shift/reduce conflict is reported.
		  A shift is chosen for the table.

		  If both have precedences, the action with the
		  higher precedence is chosen.

		  If the precedences are equal, a nonassoc 
	  	  conflict is reported.

      reduce/reduce:

		  A reduce/reduce conflict is reported.  The lowest
		  numbered rule is chosen for reduction.
*)


(* method for filling tables - first compute the reductions called for in a
   state, then add the shifts for the state to this information.

How to compute the reductions:

   A reduction initially is given as an item and a lookahead set calling
for reduction by that item.  The first reduction is mapped to a list of
terminal * rule pairs.  Each additional reduction is then merged into this
list and reduce/reduce conflicts are resolved according to the rule
given.

Missed Errors:

   This method misses some reduce/reduce conflicts that exist because
some reductions are removed from the list before conflicting reductions
can be compared against them.  All reduce/reduce conflicts, however,
can be generated given a list of the reduce/reduce conflicts generated
by this method.
	
   This can be done by taking the transitive closure of the relation given
by the list.  If reduce/reduce (a,b) and reduce/reduce (b,c)  are true,
then reduce/reduce (a,c) is true.   The relation is symmetric and transitive.
		  
Adding shifts:

    Finally scan the list merging in shifts and resolving conflicts
according to the rule given.

Missed Shift/Reduce Errors:

    Some errors may be missed by this method because some reductions were
removed as the result of reduce/reduce conflicts.  For a shift/reduce
conflict of term a, reduction by rule n, shift/reduce conficts exist
for all rules y such that reduce/reduce (x,y) or reduce/reduce (y,x)
is true.
*)

    val mergeReduces =
	let val merge = fn state =>
	  let fun f (j as (pair1 as (T t1,action1)) :: r1,
		     k as (pair2 as (T t2,action2)) :: r2,result,errs) =
	  	    if t1 < t2 then f(r1,k,pair1::result,errs)
		    else if t1 > t2 then f(j,r2,pair2::result,errs)
		    else let val REDUCE num1 = action1
			     val REDUCE num2 = action2
			     val errs = RR(T t1,state,num1,num2) :: errs
			     val action = if num1 < num2 then pair1 else pair2
		         in f(r1,r2,action::result,errs)
		          end
		| f (nil,nil,result,errs) = (rev result,errs)
		| f (pair1::r,nil,result,errs) = f(r,nil,pair1::result,errs)
		| f (nil,pair2 :: r,result,errs) = f(nil,r,pair2::result,errs)
	    in f
	    end
	 in fn state => fn ((ITEM {rule=RULE {rulenum,...},...}, lookahead),
		 (reduces,errs)) =>
		let val action = REDUCE rulenum
		    val actions = map (fn a=>(a,action)) lookahead
		in case reduces
		   of nil => (actions,errs)
		    | _ =>  merge state (reduces,actions,nil,errs)
		end
	 end

  val computeActions = fn (rules,precedence,graph,defaultReductions) =>
     
    let val rulePrec =
	  let val precData = array(length rules,NONE : int option)
	  in app (fn RULE {rulenum=r,precedence=p,...} => update(precData,r,p))
	     rules;
	     fn i => precData sub i
	  end

	fun mergeShifts(state,shifts,nil) = (shifts,nil)
	  | mergeShifts(state,nil,reduces) = (reduces,nil)
	  | mergeShifts(state,shifts,reduces) =
	  let fun f(shifts as (pair1 as (T t1,_)) :: r1,
			reduces as (pair2 as (T t2,action)) :: r2,
			result,errs) =
		if t1 < t2 then f(r1,reduces,pair1 :: result,errs)
		else if t1 > t2 then f(shifts,r2,pair2 :: result,errs)
		else let val REDUCE rulenum = action
			 val (term1,_) = pair1
		     in case (precedence term1,rulePrec rulenum)
		      of (SOME i,SOME j) =>
		         if i>j then f(r1,r2,pair1 :: result,errs)
		         else if j>i then f(r1,r2,pair2 :: result,errs)
			 else
		 	   f(r1,r2,pair2 :: result,
				    NONASSOC (term1,state,rulenum)::errs)
		       | (_,_) =>
			   f(r1,r2,pair1 :: result,
			     SR (term1,state,rulenum)::errs)
		     end
	   	| f (nil,nil,result,errs) = (rev result,errs)
	   	| f (nil,h::t,result,errs) =
		   	f (nil,t,h::result,errs)
	   	| f (h::t,nil,result,errs) = 
		   	f (t,nil,h::result,errs)
	  in f(shifts,reduces,nil,nil)
	  end

	fun mapCore ({edge=symbol,to=CORE (_,state)}::r,shifts,gotos) =
	        (case symbol
		 of (TERM t) => mapCore (r,(t,SHIFT(STATE state))::shifts,gotos)
		  | (NONTERM nt) => mapCore(r,shifts,(nt,STATE state)::gotos)
		)
	  | mapCore (nil,shifts,gotos) = (rev shifts,rev gotos)

  in fn (Lalr.LCORE (reduceItems,state),c as CORE (shiftItems,state')) =>
	if DEBUG andalso (state <> state') then
		 let exception MkTable in raise MkTable end
	else
	 let val (shifts,gotos) = mapCore (Graph.edges(c,graph),nil,nil)
	     val tableState = STATE state
	 in case reduceItems
		of nil => ((shifts,ERROR),gotos,nil)
		 | h :: nil =>
		    let val (ITEM {rule=RULE {rulenum,...},...}, l) = h
		        val (reduces,_) = mergeReduces tableState (h,(nil,nil))
			val (actions,errs) = mergeShifts(tableState,
							 shifts,reduces)
		        val (actions,anyReduce) =
			   let fun hasReduce (nil,actions) = (rev actions,true)
				 | hasReduce ((a as (_,SHIFT _)) :: r,actions) =
						hasReduce(r,a::actions)
				 | hasReduce (_ :: r,actions) =
						 hasReduce(r,actions)
			       fun loop (nil,actions) = (rev actions,false)
				 | loop ((a as (_,SHIFT _)) :: r,actions) =
						loop(r,a::actions)
				 | loop ((a as (_,REDUCE _)) :: r,actions) =
						hasReduce(r,actions)
				 | loop (_ :: r,actions) = loop(r,actions)
			  in if defaultReductions then loop(actions,nil)
			     else (actions,false)
			  end
		     in ((actions,if anyReduce then REDUCE rulenum else ERROR),
			 gotos,errs)
		     end
		 | l =>
		  let val (reduces,errs1) =
			 fold (mergeReduces tableState) l (nil,nil)
		      val (actions,errs2) =
			 mergeShifts(tableState,shifts,reduces)
	     	  in ((actions,ERROR),gotos,errs1@errs2)
		  end
	 end
   end			

	val mkTable = fn (grammar as GRAMMAR{rules,terms,nonterms,start,
				  precedence,termToString,noshift,
				  nontermToString,eop},defaultReductions) =>
	     let val symbolToString = fn (TERM t) => termToString t
				       | (NONTERM nt) => nontermToString nt
	         val {rules,graph,produces,epsProds,...} = Graph.mkGraph grammar
		 val {nullable,first} =
		   Look.mkFuncs{rules=rules,produces=produces,nonterms=nonterms}
		 val lcores = Lalr.addLookahead
					    {graph=graph,
					     nullable=nullable,
					     produces=produces,
					     eop=eop,
					     nonterms=nonterms,
					     first=first,
					     rules=rules,
					     epsProds=epsProds,
					     print=(fn s=>output(std_out,s)),
					     termToString = termToString,
					     nontermToString = nontermToString}

		  fun zip (h::t,h'::t') = (h,h') :: zip(t,t')
		    | zip (nil,nil) = nil
		    | zip _ = let exception MkTable in raise MkTable end
		  
		  fun unzip l =
		   let fun f ((a,b,c)::r,j,k,l) = f(r,a::j,b::k,c::l)
			 | f (nil,j,k,l) = (rev j,rev k,rev l)
		   in f(l,nil,nil,nil)
		   end
		
		   val (actions,gotos,errs) =
			let val doState =
		            computeActions(rules,precedence,graph,
					   defaultReductions)
			in unzip (map doState (zip(lcores,Graph.nodes graph)))
			end

		  (* add goto from state 0 to a new state.  The new state
		     has accept actions for all of the end-of-parse symbols *)

		   val (actions,gotos,errs) =
		     case gotos
		     of nil => (actions,gotos,errs)
		      | h :: t =>
			let val newStateActions = 
		           (map (fn t => (t,ACCEPT)) (Look.make_set eop),ERROR)
			   val state0Goto = 
			       GotoList.insert((start,STATE (length actions)),h)
			in (actions @ [newStateActions],
			    state0Goto :: (t @ [nil]),
			    errs @ [nil])
			end 

		val startErrs =
	 	  fold (fn (RULE {rhs,rulenum,...},r) =>
			if (exists (fn NONTERM a => a=start
				     | _ => false) rhs)
			  then START rulenum :: r
			  else r) rules nil

		val nonshiftErrs =
	 	  fold (fn (RULE {rhs,rulenum,...},r) =>
		          (fold (fn (nonshift,r) =>
			   if (exists (fn TERM a => a=nonshift
				     | _ => false) rhs)
			    then NS(nonshift,rulenum) :: r
			    else r) noshift r)
		       ) rules nil

		val notReduced =
		  let val ruleReduced = array(length rules,false)
		      val test = fn REDUCE i => update(ruleReduced,i,true)
				  | _ => ()
		      val _ = app (fn (actions,default) =>
				     (app (fn (_,r) => test r) actions;
				      test default)
				  ) actions;
		      fun scan (i,r) =
			 if i >= 0 then
			      scan(i-1, if ruleReduced sub i then r
					else NOT_REDUCED i :: r)
			else r
		  in scan(Array.length ruleReduced-1,nil)
	    	  end handle Subscript =>
			(if DEBUG then
				print "rules not numbered correctly!"
			 else (); nil)

		val numstates = length actions

	        val allErrs = startErrs @ notReduced @ nonshiftErrs @ 
			      (fold (op @) errs nil)

                val convert_to_pairlist : ('a * 'b) list -> ('a,'b) pairlist =
		     let fun f nil = EMPTY
                           | f ((a,b) :: r) = PAIR(a,b,f r)
                     in f
                     end
	      in (mkLrTable {actions=arrayoflist(map (fn (a,b) =>
				     (convert_to_pairlist a,b)) actions),
			     gotos=arrayoflist (map convert_to_pairlist gotos),
			     numRules=length rules,numStates=length actions,
			     initialState=STATE 0},
		  let val errArray = arrayoflist errs
		  in fn (STATE state) => errArray sub state
		  end,

		  fn print =>
 		    let val printCore =
			  prCore(symbolToString,nontermToString,print)
			val core = Graph.core graph
		    in fn STATE state =>
			 printCore (if state=(numstates-1) then
					 Core.CORE (nil,state)
				        else (core state))
		    end,
		    allErrs)
              end
end;
