(* This file has been derived from the ML Kit. *)

open Fnlib Mixture Const Globals Location Asynt;

exception WrongInfix;
exception MixedAssociativity;

type 'Obj InfixStackStr = {
    applyId : IdInfo -> 'Obj -> 'Obj,
    applyObj : 'Obj -> 'Obj -> 'Obj,
    asId : 'Obj -> IdInfo option,
    pair : 'Obj -> 'Obj -> 'Obj
};

datatype StackEntry =
    INFIXentry of IdInfo * int
  | INFIXRentry of IdInfo * int
  | APPentry
;

datatype LastObj = ARG | OPER | VOID;

fun resolveInfix (iStackStr : 'Obj InfixStackStr) statusOfId objs =

  let 
    val { pair, asId, applyId, applyObj } = iStackStr

    fun apply entry (o2 :: o1 :: rest) =
          let val thePair = pair o1 o2 in
            ( case entry of
                  INFIXentry(ii, n) => applyId ii thePair
                | INFIXRentry(ii, n) => applyId ii thePair
                | APPentry => applyObj o1 o2
            ) :: rest
          end
      | apply entry output =
          raise WrongInfix

    and assocLeft APPentry _ = true
      | assocLeft _ APPentry = false
      | assocLeft op1 op2 =
          let fun extract (INFIXentry(_, n))  = (n, true)
                | extract (INFIXRentry(_, n)) = (n, false)
                | extract _ = raise WrongInfix
              val (prec1, left1) = extract op1
              val (prec2, left2) = extract op2 
          in
            if prec1 > prec2 then true
            else if prec1 < prec2 then false
            else if left1 = left2 then left1
            else raise MixedAssociativity
	  end

    and flushHigher entry stack output =
      case stack of
          [] => ([], output)
        | top :: rest =>
            if assocLeft top entry then
              flushHigher entry rest (apply top output)
            else
              (stack, output)

    and flushAll stack output =
      case stack of
          [] => ( case output of
                      [item] => item
                    | _ => raise WrongInfix )
        | top :: rest => flushAll rest (apply top output)

    and process input stack last output =
      case input of
          [] =>
            flushAll stack output
        | this :: rest =>
            ( case asId this of
                    SOME ii =>
                      ( case statusOfId (List.hd (#id(#qualid ii))) of
                            INFIXst n =>
                              operator (INFIXentry(ii,n))
                                        rest stack output
                          | INFIXRst n =>
                              operator (INFIXRentry(ii,n))
                                        rest stack output
                          | NONFIXst =>
                              ( case last of
                                    ARG => operator APPentry
                                                    input stack output
                                  | _ => process rest stack ARG
                                                  (this :: output) ) )
                  | NONE =>
                      ( case last of
                            ARG =>
                              operator APPentry input stack output
                          | _ =>
                              process rest stack ARG (this :: output)
                      ) )

    and operator entry input stack output =
      let val (stack', output') = flushHigher entry stack output 
      in process input (entry :: stack') OPER output' end

  in process objs [] VOID [] end
;