
(* 
    Remove useless tags (tags which affect 0 characters).
    This is similar to redundant tag elmination, but is
    "backwards".
     - Tom 7
*)

structure Useless :> sig val useless : Il.exp -> Il.exp end =
struct

  open Token
  open Il

  type who = bool ref

  val newwho = ref

  fun setwho a = a := true
  val deref = !

  (* need more fine-grained info than Meaning.property provides. *)
  type prop = {pb : (bool * who) list,
               pem : (bool * who) list,
               pi : (bool * who) list,
               ps : (bool * who) list,
               ptt : (bool * who) list,
               pu : (int * who) list,
               psize : (int * who) list,
               pcolor : (int * who) list}

  fun used ((_, w)::_) = w := true
    | used _ = ()

  fun usedn 0 _ = ()
    | usedn _ nil = ()
    | usedn n ((_, w)::r) = 
         let in
           w:= true;
           usedn (n - 1) r
         end

  val allwhite = StringUtil.all (StringUtil.charspec " \n\r\t")

  fun usl (pr as {pb, pem, pi, ps, ptt, pu, psize, pcolor} : prop) e =
    case e of
      Seq s => Seq (map (usl pr) s)
    | Text s => 
        if allwhite s then
          let in
            used ptt;
            used psize;
            used pcolor;
            usedn 3 pu;
            e
          end
        else
          let in
            map used [pb, pem, pi, ps, ptt];
            map used [psize, pcolor];
            usedn 3 pu;
            e
          end
    | Tag (nil, ee) => usl pr ee
    | Tag (t::r, ee) =>
        let 
          val br = newwho false

	  fun nnil nil = nil
	    | nnil l = (false, br) :: l

          val npr =
          (case t of
             Att B => {pb=(true,br)::pb,
                       pem=pem, pi=pi, ps=ps, ptt=ptt, pu=pu,
                       pcolor=pcolor, psize=psize}
           | Att I => {pi=(true,br)::pi,
                       pem=pem, pb=pb, ps=ps, ptt=ptt, pu=pu,
                       pcolor=pcolor, psize=psize}
           | TT => {ptt=(true,br)::ptt,
                    pem=pem, pb=pb, ps=ps, pi=pi, pu=pu,
                    pcolor=pcolor, psize=psize}
           | Clr i => {pcolor=(i,br)::pcolor,
                       pem=pem, pb=pb, ps=ps, pi=pi, pu=pu,
                       ptt=ptt, psize=psize}
           | Num i => {psize=(i,br)::psize,
                       pem=pem, pb=pb, ps=ps, pi=pi, pu=pu,
                       ptt=ptt, pcolor=pcolor}
           (* PL acts specially (as usual..), since
              it might be redundant wrt the default context. *)
           | PL => {psize=psize,
                    pem=nnil pem, 
                    pb=nnil pb,
                    ps=nnil ps, 
                    pi=nnil pi, 
                    pu=case pu of nil => nil | l => (0,br)::(0,br)::(0,br)::l,
                    ptt=nnil ptt, 
                    pcolor=pcolor}
           | S => 
               let in
                 {psize=psize,
                  pem=(true,br)::pem, pb=pb, ps=(false,br)::ps, 
                  pi=pi, 
                  pu=pu,
                  ptt=ptt, pcolor=pcolor}
               end
           | EM =>
               let 
                 fun geta nil = false
                   | geta ((s,_)::_) = s
               in
                 (* use S attribute, since the behavior of
                    this tag depends on it. *)
                 used ps;
                 used pem;
                 if geta ps then pr
                 else {psize=psize,
                       pem=(not (geta pem), br)::pem,
                       pb=pb, ps=ps, pi=pi, pu=pu, ptt=ptt,
                       pcolor=pcolor}
               end
           | U =>
               let 
                 val ul =
                   case pu of
                     nil => 0
                   | ((s,_)::_) => s
               in
                 usedn 3 pu;
                 {psize=psize, pem=pem, pb=pb, ps=ps, pi=pi,
                  pu=(if ul >= 3 then 3 else ul+1, br)::pu, 
                  ptt=ptt, pcolor=pcolor}
               end)
          val ne = usl npr (Tag (r, ee))
        in
          (* if tag was not used, discard it. *)
          if deref br then
            mktag([t], ne)
          else ne
        end

  fun useless e =
    usl {psize=nil, pem=nil, pb=nil, ps=nil,
         pi=nil, pu=nil, ptt=nil, pcolor=nil} e

end
