(* redundant.sml *)
(* Initially by joev *)

(* Eliminates redundant tags -- that is, those that set attributes *)
(* that are already set, and those that change things to what they *)
(* already are.                                                    *) 

(* Fittingly, this pass is itself redundant since Perry is doing the *)
(* exact same thing in scopedElim.                                   *)



signature REDUNDANTTAGS = 
  sig
    val optimize : Il.exp -> Il.exp
  end


structure RedundantTags :> REDUNDANTTAGS =
  struct

    open Il
    structure T = Token
    structure M = Meaning

    val debug = 
      Params.flag true
      (SOME("-debug-redundant", "turn on debugging for the redundant tag optimizer"))
      "debug-redundant"


    fun fixtags ctx tgs =
      let 
	(* This will be folded from left to right; so tgs' is a reversed *)
	(* list of all the tags *outside* of the current one.            *)
	fun folder (tg,(tgs',ctx)) =
	  let
	    val ctx' = M.addTags (ctx,[tg])
	    val useful = not (M.propertyEqual (ctx,ctx'))
	    fun default_useful () = (tg::tgs',ctx')

	    (* XXX: Is this correct? *)
	    fun killed_by_PL (Token.Num _) = false
	      | killed_by_PL (Token.Clr _) = false
	      | killed_by_PL _ = true

	    fun killed_by_S (Token.EM) = true
	      | killed_by_S _ = false

	    fun killed_by_Clr (Token.Clr _) = true
	      | killed_by_Clr _ = false
	      
	    fun killed_by_Num (Token.Num _) = true
	      | killed_by_Num _ = false

	    fun kill killer = 
	      (tg::(List.filter (not o killer) tgs'),ctx')

	  in
	    if useful then
	      case tg of
		Token.PL => kill killed_by_PL
	      | Token.Num n => kill killed_by_Num
	      | Token.Clr c => kill killed_by_Clr 
	      | _ => default_useful ()
	    else
	      (tgs',ctx)
	  end

	val (rtgs',ctx') =
	  foldl folder ([],ctx) tgs

	val tgs' = rev rtgs'
      in
	(tgs',ctx')
      end

    fun opt_exp ctx (Text s) = Text s
      | opt_exp ctx (Seq [e]) = opt_exp ctx e
      | opt_exp ctx (Seq es) = Seq (List.map (opt_exp ctx) es)
      | opt_exp ctx (Tag (tgs,body)) =
      let
	val (tgs',ctx') = fixtags ctx tgs
	val body' = opt_exp ctx' body
      in Tag (tgs',body')
      end
	  
    val optimize = opt_exp M.null

  end