html-attrs-fn.sml

这是我们参加06年全国开源软件的竞赛作品

(* html-attrs-fn.sml
 *
 * COPYRIGHT (c) 1996 AT&T Research.
 *
 * This provides support for parsing element start tags.
 *)

functor HTMLAttrsFn (Err : HTML_ERROR) : HTML_ATTRS =
  struct

    open HTMLAttrVals	(* inherit types *)

    fun attrValToString (NAME s) = s
      | attrValToString (STRING s) = s
      | attrValToString IMPLICIT = ""

    datatype attr_ty
      = AT_TEXT			(* either a string or name value *)
      | AT_NAMES of string list	(* one of a list of names *)
      | AT_NUMBER		(* an integer attribute *)
      | AT_IMPLICIT
      | AT_INSTANCE		(* if an attribute FOO has type AT_NAMES with *)
				(* values BAR and BAZ, then BAR and BAZ are *)
				(* legal attributes, being shorthand for *)
				(* FOO=BAR and FOO=BAZ.  We introduce an *)
				(* (k, AT_INSTANCE) entry for BAR and BAZ, where *)
				(* k is the slot that FOO has been assigned. *)

    type context = Err.context

    structure HTbl = HashTableFn (struct
	type hash_key = string
	val hashVal = HashString.hashString
	val sameKey = (op = : (string * string) -> bool)
      end)

  (* an attribute map (attr_map) is a map from attribute names to attribute
   * value slots and types.
   *)
    abstype attr_map = AMap of {
	numAttrs : int,
	attrTbl : (int * attr_ty) HTbl.hash_table
      }
    and attr_vec = AVec of {
	vec : attr_val option Array.array,
	ctx : context
      }
    with
  (* create an attr_map from the list of attribute names and types. *)
    fun mkAttrs data = let
	  val n = length data
	  val tbl = HTbl.mkTable (n, Fail "Attrs")
	  fun ins ((name, ty), id) = (
		HTbl.insert tbl (name, (id, ty));
		case ty
		 of (AT_NAMES l) => let
		      fun ins' nm = if (nm <> name)
			    then HTbl.insert tbl (nm, (id, AT_INSTANCE))
			    else ()
		      in
			List.app ins' l
		      end
		  | _ => ()
		(* end case *);
		id+1)
	  in
	    List.foldl ins 0 data;
	    AMap{numAttrs = n, attrTbl = tbl}
	  end
  (* create an atttribute vector of attribute values using the attribute
   * map to assign slots and typecheck the values.
   *)
    fun attrListToVec (ctx, AMap{numAttrs, attrTbl}, attrs) = let
	  val attrArray = Array.array (numAttrs, NONE)
	  fun update (_, NONE) = ()
	    | update (id, SOME v) = (case Array.sub(attrArray, id)
		 of NONE => Array.update(attrArray, id, SOME v)
		  | (SOME _) => (* ignore multiple attribute definition *) ()
		(* end case *))
	(* compare two names for case-insensitive equality, where the second
	 * name is known to be all uppercase.
	 *)
	  fun eqName name name' = let
		fun cmpC (c1, c2) = Char.compare(Char.toUpper c1, c2)
		in
		  (String.collate cmpC (name, name')) = EQUAL
		end
	  fun ins (attrName, attrVal) = let
		fun error () = (
		      Err.badAttrVal ctx (attrName, attrValToString attrVal);
		      NONE)
		fun cvt (AT_IMPLICIT, IMPLICIT) = SOME IMPLICIT
		  | cvt (AT_INSTANCE, IMPLICIT) = SOME(NAME attrName)
		  | cvt (AT_TEXT, v) = SOME v
		  | cvt (AT_NUMBER, v) = SOME v
		  | cvt (AT_NAMES names, (NAME s | STRING s)) = (
		      case (List.find (eqName s) names)
		       of NONE => error()
			| (SOME name) => SOME(NAME name)
		      (* end case *))
		  | cvt (AT_IMPLICIT, (NAME s | STRING s)) =
		      if (s = attrName)
			then SOME IMPLICIT
			else error()
		  | cvt _ = error()
		in
		  case (HTbl.find attrTbl attrName)
		   of NONE => Err.unknownAttr ctx attrName
		    | (SOME(id, ty)) => update (id, cvt (ty, attrVal))
		  (* end case *)
		end
	  in
	    List.app ins attrs;
	    AVec{vec = attrArray, ctx = ctx}
	  end
  (* given an attribute map and attribute name, return a function that
   * fetches a value from the attribute's slot in an attribute vector.
   *)
    fun bindFindAttr (AMap{attrTbl, ...}, attr) = let
	  val (id, _) = HTbl.lookup attrTbl attr
	  in
	    fn (AVec{vec, ...}) => Array.sub(vec, id)
	  end
  (* return the context of the element that contains the attribute vector *)
    fun getContext (AVec{ctx, ...}) = ctx
    end (* abstype *)

    fun getFlag (attrMap, attr) = let
	  val getFn = bindFindAttr (attrMap, attr)
	  fun get attrVec = (case (getFn attrVec)
		 of NONE => false
		 | _ => true
		(* end case *))
	  in
	    get
	  end
    fun getCDATA (attrMap, attr) = let
	  val getFn = bindFindAttr (attrMap, attr)
	  fun get attrVec = (case (getFn attrVec)
		 of NONE => NONE
		  | (SOME((STRING s) | (NAME s))) => SOME s
		  | _ => (
		      Err.missingAttrVal (getContext attrVec) attr;
		      NONE)
		(* end case *))
	  in
	    get
	  end
    fun getNAMES fromString (attrMap, attr) = let
	  val getFn = bindFindAttr (attrMap, attr)
	  fun get attrVec = (case (getFn attrVec)
		 of NONE => NONE
		  | (SOME(NAME s)) => fromString s
		  | (SOME v) =>
		    (** This case should be impossible, since attrListToVec
		     ** ensures that AT_NAMES valued attributes are always NAME.
		     **)
		      raise Fail "getNAMES"
		(* end case *))
	  in
	    get
	  end
    fun getNUMBER (attrMap, attr) = let
	  val getFn = bindFindAttr (attrMap, attr)
	  fun get attrVec = (case (getFn attrVec)
		 of NONE => NONE
		  | (SOME((STRING s) | (NAME s))) => (case (Int.fromString s)
		       of NONE =>  (
			    Err.badAttrVal (getContext attrVec) (attr, s);
			    NONE)
			| someN => someN
		      (* end case *))
		(* end case *))
	  in
	    get
	  end
    fun getChar (attrMap, attr) = let
	  val getFn = bindFindAttr (attrMap, attr)
	  fun get attrVec = (case (getFn attrVec)
		 of NONE => NONE
		  | (SOME((STRING s) | (NAME s))) =>
		      if (size s = 1) then SOME(String.sub(s, 0))
(** NOTE: we should probably accept &#xx; as a character value **)
			else  (
			Err.badAttrVal (getContext attrVec) (attr, s);
			NONE)
		(* end case *))
	  in
	    get
	  end

    fun require (getFn, attrMap, attr, dflt) = let
	  val getFn = getFn (attrMap, attr)
	  fun get attrVec = (case getFn attrVec
		 of NONE => (Err.missingAttr (getContext attrVec) attr; dflt)
		  | (SOME v) => v
		(* end case *))
	  in
	    get
	  end

  (**** Element ISINDEX ****)
    local
      val attrMap = mkAttrs [
	      ("PROMPT",	AT_TEXT)
	    ]
      val getPROMPT	= getCDATA (attrMap, "PROMPT")
    in
  (* the ISINDEX element can occur in both the HEAD an BODY, so there are
   * two datatype constructors for it.  We just define the argument of the
   * constructor here.
   *)
    fun mkISINDEX (ctx, attrs) = {
	    prompt	= getPROMPT (attrListToVec(ctx, attrMap, attrs))
	  }
    end (* local *)

  (**** Element BASE ****)
    local
      val attrMap = mkAttrs [
	      ("HREF",		AT_TEXT)
	    ]
      val getHREF	= require (getCDATA, attrMap, "HREF", "")
    in
    fun mkBASE (ctx, attrs) = HTML.Head_BASE{
	    href = getHREF(attrListToVec(ctx, attrMap, attrs))
	  }
    end (* local *)

  (**** Element META ****)
    local
      val attrMap = mkAttrs [
	      ("HTTP-EQUIV",	AT_TEXT),
	      ("NAME",		AT_TEXT),
	      ("CONTENT",	AT_TEXT)
	    ]
      val getHTTP_EQUIV	= getCDATA (attrMap, "HTTP-EQUIV")
      val getNAME	= getCDATA (attrMap, "NAME")
      val getCONTENT	= require (getCDATA, attrMap, "CONTENT", "")
    in
    fun mkMETA (ctx, attrs) = let
	  val attrVec = attrListToVec(ctx, attrMap, attrs)
	  in
	    HTML.Head_META{
		httpEquiv = getHTTP_EQUIV attrVec,
		name = getNAME attrVec,
		content = getCONTENT attrVec
	      }
	  end
    end (* local *)

  (**** Element LINK ****)
    local
      val attrMap = mkAttrs [
	      ("HREF",		AT_TEXT),
	      ("ID",		AT_TEXT),
	      ("TITLE",		AT_TEXT),
	      ("REL",		AT_TEXT),
	      ("REV",		AT_TEXT)
	    ]
      val getHREF	= getCDATA (attrMap, "HREF")
      val getID		= getCDATA (attrMap, "ID")
      val getREL	= getCDATA (attrMap, "REL")
      val getREV	= getCDATA (attrMap, "REV")
      val getTITLE	= getCDATA (attrMap, "TITLE")
    in
    fun mkLINK (ctx, attrs) = let
	  val attrVec = attrListToVec(ctx, attrMap, attrs)
	  in
	    HTML.Head_LINK{
		href = getHREF attrVec,
		id = getID attrVec,
		rel = getREL attrVec,
		rev = getREV attrVec,
		title = getTITLE attrVec
	      }
	  end
    end (* local *)

  (**** Element BODY ****)
    local
      val attrMap = mkAttrs [
	      ("BACKGROUND",	AT_TEXT),
	      ("BGCOLOR",	AT_TEXT),
	      ("TEXT",		AT_TEXT),
	      ("LINK",		AT_TEXT),
	      ("VLINK",		AT_TEXT),
	      ("ALINK",		AT_TEXT)
	    ]
      val getBACKGROUND	= getCDATA (attrMap, "BACKGROUND")
      val getBGCOLOR	= getCDATA (attrMap, "BGCOLOR")
      val getTEXT	= getCDATA (attrMap, "TEXT")
      val getLINK	= getCDATA (attrMap, "LINK")
      val getVLINK	= getCDATA (attrMap, "VLINK")
      val getALINK	= getCDATA (attrMap, "ALINK")
    in
    fun mkBODY (ctx, attrs, blk) = let
	  val attrVec = attrListToVec(ctx, attrMap, attrs)
	  in
	    HTML.BODY{
		background = getBACKGROUND attrVec,
		bgcolor = getBGCOLOR attrVec,
		text = getTEXT attrVec,
		link = getLINK attrVec,
		vlink = getVLINK attrVec,
		alink = getALINK attrVec,
		content = blk
	      }
	  end
    end (* local *)

  (**** Elements H1, H2, H3, H4, H5, H6 and P ****)
    local
      val attrMap = mkAttrs [
	      ("ALIGN",		AT_NAMES["LEFT", "CENTER", "RIGHT"])
	    ]
      val getALIGN	= getNAMES HTML.HAlign.fromString (attrMap, "ALIGN")
    in
    fun mkHn (n, ctx, attrs, text) = HTML.Hn{
	    n = n,
	    align = getALIGN(attrListToVec(ctx, attrMap, attrs)),
	    content = text
	  }
    fun mkP (ctx, attrs, text) = HTML.P{
	    align = getALIGN(attrListToVec(ctx, attrMap, attrs)),
	    content = text
	  }
    end (* local *)

  (**** Element UL ****)
    local
      val attrMap = mkAttrs [
	      ("COMPACT",	AT_IMPLICIT),
	      ("TYPE",		AT_NAMES["DISC", "SQUARE", "CIRCLE"])
	    ]
      val getCOMPACT = getFlag(attrMap, "COMPACT")
      val getTYPE = getNAMES HTML.ULStyle.fromString (attrMap, "TYPE")
    in
    fun mkUL (ctx, attrs, items) = let
	  val attrVec = attrListToVec(ctx, attrMap, attrs)
	  in
	    HTML.UL{
		ty = getTYPE attrVec,
		compact = getCOMPACT attrVec,
		content = items
	      }
	  end
    end (* local *)

  (**** Element OL ****)
    local
      val attrMap = mkAttrs [
	      ("COMPACT",	AT_IMPLICIT),
	      ("START",		AT_NUMBER),
	      ("TYPE",		AT_TEXT)
	    ]
      val getCOMPACT = getFlag(attrMap, "COMPACT")
      val getSTART = getNUMBER(attrMap, "START")
      val getTYPE = getCDATA(attrMap, "TYPE")
    in
    fun mkOL (ctx, attrs, items) = let
	  val attrVec = attrListToVec(ctx, attrMap, attrs)
	  in
	    HTML.OL{
		compact = getCOMPACT attrVec,
		start = getSTART attrVec,
		ty = getTYPE attrVec,
		content = items
	      }
	  end
    end (* local *)

  (**** Elements DIR, MENU and DL ****)
    local
      val attrMap = mkAttrs [
	      ("COMPACT",	AT_IMPLICIT)
	    ]
      val getCOMPACT = getFlag(attrMap, "COMPACT")
    in
    fun mkDIR (ctx, attrs, items) = HTML.DIR{
	    compact = getCOMPACT (attrListToVec(ctx, attrMap, attrs)),
	    content = items
	  }
    fun mkMENU (ctx, attrs, items) = HTML.MENU{
	    compact = getCOMPACT (attrListToVec(ctx, attrMap, attrs)),
	    content = items
	  }
    fun mkDL (ctx, attrs, items) = HTML.DL{
	    compact = getCOMPACT (attrListToVec(ctx, attrMap, attrs)),
	    content = items
	  }
    end (* local *)

  (**** Element LI ****)
    local
      val attrMap = mkAttrs [
	      ("TYPE",		AT_TEXT),
	      ("VALUE",		AT_NUMBER)
	    ]
      val getTYPE = getCDATA(attrMap, "TYPE")
      val getVALUE = getNUMBER(attrMap, "VALUE")
    in
    fun mkLI (ctx, attrs, text) = let
	  val attrVec = attrListToVec(ctx, attrMap, attrs)
	  in
	    HTML.LI{
		ty = getTYPE attrVec,
		value = getVALUE attrVec,
		content = text
	      }
	  end
    end (* local *)

  (**** Element PRE ****)
    local
      val attrMap = mkAttrs [
	      ("WIDTH",		AT_NUMBER)
	    ]
      val getWIDTH = getNUMBER(attrMap, "WIDTH")
    in
    fun mkPRE (ctx, attrs, text) = HTML.PRE{
	    width = getWIDTH (attrListToVec (ctx, attrMap, attrs)),
	    content = text
	  }
    end (* local *)

  (**** Element DIV ****)
    local
      val attrMap = mkAttrs [
	      ("ALIGN",		AT_NAMES["LEFT", "CENTER", "RIGHT"])
	    ]
      val getALIGN	= require (getNAMES HTML.HAlign.fromString,
			    attrMap, "ALIGN", HTML.HAlign.left)
    in
    fun mkDIV (ctx, attrs, content) = HTML.DIV{
	    align = getALIGN(attrListToVec(ctx, attrMap, attrs)),
	    content = content
	  }
    end (* local *)

  (**** Element FORM ****)
    local
      val attrMap = mkAttrs [
	      ("ACTION",	AT_TEXT),
	      ("METHOD",	AT_NAMES["GET", "PUT"]),
	      ("ENCTYPE",	AT_TEXT)
	    ]
      val getACTION	= getCDATA (attrMap, "ACTION")
      val getMETHOD	= require (getNAMES HTML.HttpMethod.fromString,
			    attrMap, "METHOD", HTML.HttpMethod.get)
      val getENCTYPE	= getCDATA (attrMap, "ENCTYPE")
    in
    fun mkFORM (ctx, attrs, contents) = let
	  val attrVec = attrListToVec(ctx, attrMap, attrs)
	  in
	    HTML.FORM{
		action = getACTION attrVec,