(* tilvalidate.sml *)
(* Part of ICFP 2001 Programming Contest Entry *)
(* Initial version by joev.                    *)

(* Translation from the tree-style IR into a meaning. *)

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

    structure M = Meaning
    open Il;

    type buffer = B.buffer

    val debug = 
	Params.flag false
		    (SOME("-debug-tilvalidate", "turn on debugging for the tree validator"))
		    "debug-tilvalidate"


    fun processtags (tgs,ctx) = M.addTags (ctx,tgs)

    val is_whitespace = StringUtil.charspec "\009\010\013\032";

    (* XXX: Doesn't rule out bad input characters. *)
    val is_printing = not o is_whitespace

    val space_context = M.prop2SpaceProp

    (* BEGINNING of stuff that depends on the outcome of the 
     input-vs-output whitespace ambiguity *)
    (* The ambiguity has been resolved, and this implementation is *)
    (* correct. *)

    type state = B.buffer * (M.decorated option) (* for the last character *)

    (* whitespace_match : (state,property) -> bool *)
    (* Returns true iff a the last character emitted was a space *)
    (* with the space context given by property. *)
    fun whitespace_match ((_,SOME dec),sctx) =
      let val (lastsctx,lastc) = M.projectDecorated dec
      in
	(is_whitespace lastc) andalso
	M.propertyEqual (lastsctx,sctx)
      end
      (* The next case depends on the initial-whitespace ambiguity. *)
      (* The ambiguity has been resolved; this is correct.          *)
      | whitespace_match ((_,NONE),_) = false

    (* emit : state * (decorated option) -> state        *)
    fun emit ((buf,last),SOME dec) = (B.cons (buf,dec),SOME dec)
      | emit (state,NONE) = state
      
    (* END, hopefully, of stuff that depends on the outcome of the
     input-vs-output whitespace ambiguity *)

    (* cvt_char : (state*property) -> char -> decorated *)
    fun cvt_char (state,ctx) c : M.decorated option =
      if is_printing c then SOME (M.injectDecorated (ctx,c))
      else (* XXX: assuming is_whitespace c *)
	let
	  val sctx = space_context ctx
	in
	  if M.isSetAttribute (ctx,M.Tt) then
	    SOME (M.injectDecorated (sctx,c))
	  else 
	    if whitespace_match (state,sctx) then
	      NONE
	    else
	      SOME (M.injectDecorated (sctx,#" "))
	end

(*
    fun cvt_chars (state,ctx) [] = state
      | cvt_chars (state,ctx) (c::cs) =
      let 
	val out = cvt_char (state,ctx) c
	val state' = emit (state,out)
	val state'' = cvt_chars (state',ctx) cs
      in state''
      end
*)

    fun cvt_string (state,ctx) s =
      let
	val count = size s
	fun loop (state,0,pos) = state
	  | loop (state,i,pos) = 
	  let
	    val out = cvt_char (state,ctx) (String.sub (s,pos))
	    val state' = emit (state,out)
	  in loop (state',i-1,pos+1)
	  end
      in loop (state,count,0)
      end

    fun cvt_seq (state,ctx) [] = state
      | cvt_seq (state,ctx) (e::es) =
      let
	val state' = cvt_exp (state,ctx) e
	val state'' = cvt_seq (state',ctx) es
      in state''
      end

    and cvt_exp (state,ctx) (Text s) = cvt_string (state,ctx) s
(*      cvt_chars (state,ctx) (explode s) *)
      | cvt_exp (state,ctx) (Seq es) =
      cvt_seq (state,ctx) es
      | cvt_exp (state,ctx) (Tag (tgs,e)) =
      let
	(* XXX: Should check that tags satisfy invariants. *)
	val ctx' = processtags (tgs,ctx)
      in
	cvt_exp (state,ctx') e
      end

(*
    fun convert (p,e) = M.decoratedList2meaning (#1 (cvt_exp (NONE,p) e))
*)
    fun convert (p,e) = #1 (cvt_exp ((B.newbuf(),NONE),p) e)

    fun convert' e = convert (M.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 TilValidate = MkTilValidate(structure B = BuildMeaning)
structure ApproxTilValidate = MkTilValidate(structure B = BuildApproxMeaning)
