(* Modified: Dave Joe *)

functor MkLilValidate(structure B : BUILDMEANING) 
 :> ILVALIDATE where type exp = Lil.exp where type buffer = B.buffer =
struct

    type buffer = B.buffer
    type tag = Token.tag
    type token = Token.token
    type exp = Lil.exp
	
    type property = Meaning.property
    type decorated = Meaning.decorated

    (* Invariant: stack is non-empty. *)
    datatype context = Ctx of {prev : decorated,
			       stack : property Stack.stack}

    (* initial_context : property -> context *)
    fun initial_context property =
	Ctx {prev = Meaning.injectDecorated (property,#"*"),	(* non-space *)
	     stack = Stack.push (property,Stack.empty)}
	
    (* get_property, get_space_property : context -> property *)
    fun get_property (Ctx{stack,...}) = Stack.top stack
    val get_space_property = Meaning.prop2SpaceProp o get_property

    (* push_property : property * context -> context *)
    fun push_property (property, Ctx{prev,stack}) =
	Ctx{prev = prev,stack = Stack.push (property,stack)}
	
    (* drop_property : context -> context *)
    fun drop_property (Ctx{prev,stack}) =
	Ctx{prev = prev,stack = Stack.drop stack}

    (* get_prev : context -> decorated *)
    fun get_prev (Ctx{prev,...}) = prev
    (* set_prev : context * decorated -> context *)
    fun set_prev (Ctx{prev,stack},decorated) =
	Ctx{prev = decorated,stack = stack}

    (* decorate_* : context * char -> decorated option *)
    fun decorate_print (context,ch) = 
      SOME (Meaning.injectDecorated (get_property context,ch))

    fun decorate_space (context,ch) =
	let val property = get_space_property context
	in
	    if Meaning.isSetAttribute (property,Meaning.Tt) then
		SOME (Meaning.injectDecorated (property,ch))
	    else
		let val new = Meaning.injectDecorated (property,#" ")
		    val prev = get_prev context
		in
		    if Meaning.decoratedEqual (prev,new)
			then NONE
		    else SOME new
		end
	end

    fun decorate_char (context,ch) =
	if CharClass.isPrint ch then
	    decorate_print (context,ch)
	else
	    if CharClass.isSpace ch then
		decorate_space (context,ch)
	    else
		raise Fail ("invalid character -- " ^ str ch)

    (* eval_text : context * string * buffer -> context * buffer *)
    fun eval_text (context,text,buf) =
	let
	  val limit = size text
	  fun loop (0,ctx,buf) = (ctx,buf)
	    | loop (i,ctx,buf) =
	    let val ch = String.sub (text,limit-i)
	      val (ctx,buf) =
		(case decorate_char (ctx,ch)
		   of NONE => (ctx,buf)
		 | SOME d => (set_prev (ctx,d),B.cons(buf,d)))
	    in  loop (i-1,ctx,buf)
	    end
	in
	  loop (limit, context,buf)
	end

    (* update_property : property * tag -> property *)
    local
	open Meaning
	fun checkSize n =
	    if n >= 0 andalso n <= 9 then ()
	    else raise Fail ("invalid size tag -- " ^ Int.toString n)
	fun checkColor n =
	    if n >= 0 andalso n <= 7 then ()
	    else raise Fail ("invalid color tag -- " ^ Int.toString n)
    in
	fun update_property (p,Token.EM) = if not (isSetAttribute (p,S))
					       then invertAttribute (p,Em)
					   else p
	  | update_property (p,Token.PL) = let val p = setUnderline (p,0)
					       val p = clearAttribute (p,S)
					       val p = clearAttribute (p,Em)
					       val p = clearAttribute (p,I)
					       val p = clearAttribute (p,B)
					       val p = clearAttribute (p,Tt)
					   in  p
					   end
	  | update_property (p,Token.S) = let val p = setAttribute (p,S)
					      val p = clearAttribute (p,Em)
					  in  p
					  end
	  | update_property (p,Token.TT) = setAttribute (p,Tt)
	  | update_property (p,Token.U) = let val u = getUnderline p
					  in  if u < 3 
						  then setUnderline (p,u+1)
					      else p
					  end
	  | update_property (p,Token.Num n) = (checkSize n; setSize (p,n))
	  | update_property (p,Token.Clr n) = (checkColor n; setColor (p,n))
	  | update_property (p,Token.Att (Token.B)) = setAttribute (p,B)
	  | update_property (p,Token.Att (Token.I)) = setAttribute (p,I)
    end					  

    (* eval_tag : context * tag * buffer -> context * buffer *)
    fun eval_tag (context,tag,buf) =
	let val property = get_property context
	    val property = update_property (property,tag)
	    val context = push_property (property,context)
	in  (context,buf)
	end
    
    (* eval_token : context * token * buffer -> context * buffer *)
    fun eval_token (context,token,buf) =
	(case token
	   of Token.Tag tag => eval_tag (context,tag,buf)
	    | Token.Closetag tag => (drop_property context,buf)
	    | Token.Text text => eval_text (context,text,buf))

    (* convert : property * exp -> B.buffer *)
    fun convert (property, tokens) =
	let val context = initial_context property
	    val buf = B.newbuf ()
	    fun folder (t,(c,buf)) = eval_token (c,t,buf)
(*
	    fun folder (t,c) = let val (c,list) = eval_token (c,t)
			       in  (list,c)
			       end
	    val (list_list,context) = Listops.foldl_acc folder context tokens
	    val decorated = List.concat list_list
*)
	    val (c,buf) = foldl folder (context,buf) tokens
	in  buf
	end

    (* convert' : exp -> Meaning.meaning *)
    fun convert' e = convert (Meaning.null,e)
	
    fun verify_meaning m1 e2 =
      B.bufferEqual (m1,convert' e2)

    fun equiv' e1 = verify_meaning (convert' e1)

    fun equiv (e1,e2) = equiv' e1 e2

    (* XXX stub *)
    fun check_exp exp = ()
end


structure LilValidate = MkLilValidate(structure B = BuildMeaning)
structure ApproxLilValidate = MkLilValidate(structure B = BuildApproxMeaning)