Home My Page Projects Code Snippets Project Openings 3D graphics for Standard ML
Summary Activity SCM

SCM Repository

[sml3d] View of /trunk/sml3d/gen/gen-from-xml/spec-db/db-xml-print.sml
ViewVC logotype

View of /trunk/sml3d/gen/gen-from-xml/spec-db/db-xml-print.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1377 - (download) (annotate)
Fri Apr 4 20:45:22 2014 UTC (4 years, 11 months ago) by jhr
File size: 5610 byte(s)
  Working on FI generation tools
(* db-xml-print.sml
 *
 * COPYRIGHT (c) 2014 The SML3d Project (http://sml3d.cs.uchicago.edu)
 * All rights reserved.
 *
 * Print the database in XML format to a file.  See ../README (or xml-spec.grm) for details about
 * the format.
 *)

structure DBXMLPrint : sig

    val print : TextIO.outstream * DBXMLRep.db -> unit

  end = struct

    structure X = DBXMLRep
    structure F = Format

    datatype outs = OS of TextIO.outstream * int

    fun indent (OS(outS, i)) = TextIO.output(outS, StringCvt.padLeft #" " i "")
    fun incIndent (OS(outS, i)) = OS(outS, i+2)
    fun pr (OS(outS, _), s) = TextIO.output(outS, s)
    fun prln (out, s) = (indent out; pr(out, s))
    fun prf (outS, fmt, items) = pr(outS, F.format fmt items)
handle ex => (print(concat["fmt = \"", String.toString fmt, "\"\n"]); raise ex)
    fun nest outS f = f (incIndent outS)

    fun prSTag tag "" = let
	  val tag = concat ["<", tag]
	  in
	    fn (outS, _) => pr(outS, tag)
	  end
      | prSTag tag attrFmt = let
	  val fmt = concat ["<", tag, " ", attrFmt]
	  in
	    fn (outS, attrs) => prf(outS, fmt, attrs)
	  end

    fun prList (tag, fmtAttrs, prContent) = let
	  val prSTag = prSTag tag fmtAttrs
	  fun prItem (outS, attrs, []) = (indent outS; prSTag(outS, attrs); pr(outS, "/>\n"))
	    | prItem (outS, attrs, l) = let
		val outS' = incIndent outS
		in
		  indent outS; prSTag(outS, attrs); pr(outS, ">\n");
		  List.app (prContent outS) l;
		  prln(outS, concat["</", tag, ">\n"])
		end
	  in
	    prItem
	  end

    fun prAttr (outS, attr, v) = prf(outS, " %s=\"%s\"", [F.STR v])

    fun prOptAttr (outS, attr, SOME v) = prAttr (outS, attr, v)
      | prOptAttr (_, _, NONE) = ()

    val prTypes = let
	  fun prTy outS {name, def} = (
                indent outS;
                prf (outS, "<type name=\"%s\" def=\"%s\" />\n",
                  [F.ATOM name, F.STR(CType.toString def)]))
	  in
	    prList ("types", "", prTy)
	  end

    val prEnums = let
	  fun prEnum outS {name, ty=NONE, value} = (
                indent outS;
                prf (outS, "<enum name=\"%s\" value=\"%d\" />\n",
                  [F.ATOM name, F.LINT value]))
	    | prEnum outS {name, ty=SOME ty, value} = (
		indent outS;
                prf (outS, "<enum name=\"%s\" ctype=\"%s\" value=\"%d\" />\n",
                  [F.ATOM name, F.STR(CType.toString ty), F.LINT value]))
	  in
	    prList ("enums", "", prEnum)
	  end

    val prCommands = let
          fun prProto outS (X.Proto{name, retTy, params}) = let
                fun prReturn outS = (
                      indent outS;
                      prf (outS, "<return-type ctype=\"%s\"",
                        [F.STR(CType.toString(#cty retTy))]);
                      prOptAttr (outS, "mlty", #mlty retTy);
                      pr (outS, "/>\n"))
                fun prParam outS (X.Param{name, group, cty, mlty}) = (
                      indent outS;
                      prf (outS, "<param name=\"%s\"", [F.ATOM name]);
		      prOptAttr (outS, "group", Option.map Atom.toString group);
		      prAttr (outS, "ctype", CType.toString cty);
                      prOptAttr (outS, "mlty", mlty);
                      pr (outS, "/>\n"))
                in
                  indent outS;
                  prf (outS, "<proto name=\"%s\">\n", [F.ATOM name]);
                  nest outS prReturn;
                  List.app (nest outS prParam) params;
                  prln (outS, "</proto>\n")
                end
	  val prCmdTag = prSTag "command" "name=\"%s\""
          fun prCmd outS (X.Cmd{name, protos}) = (
		indent outS;
		prCmdTag (outS, [F.ATOM name]);
		List.app (nest outS prProto) protos;
		prln (outS, "</command>"))
          in
	    prList ("commands", "", prCmd)
          end

    fun prIdList (tag, attrFmt) = let
	  fun prId outS id = (indent outS; prf(outS, "<id name=\"%s\"/>\n", [F.ATOM id]))
	  in
	    prList (tag, attrFmt, prId)
	  end

    val prGroups = let
	  val prGrpWBitmask = prIdList ("group", "name=\"%s\" bitmask=\"true\"")
	  val prGrp = prIdList ("group", "name=\"%s\"")
	  fun prGroup outS (X.EnumGrp{name, bitmask=true, consts}) =
		prGrpWBitmask (outS, [F.ATOM name], consts)
	    | prGroup outS (X.EnumGrp{name, consts, ...}) = prGrp (outS, [F.ATOM name], consts)
	  in
	    prList ("groups", "", prGroup)
	  end

    val prFeatures = let
	  val prTys = prIdList ("types", "")
	  val prEnums = prIdList ("enums", "")
	  val prCmds = prIdList ("commands", "")
	  fun prFeature outS (X.Feature{name, version, types, enums, commands}) = let
		val outS' = incIndent outS
		in
		  indent outS;
		  prf(outS, "<feature name=\"%s\" version=\"%s\">\n", [
		      F.ATOM name, F.STR(String.concatWith "." (List.map Int.toString version))
		    ]);
		  prTys (outS', [], types);
		  prEnums (outS', [], enums);
		  prCmds (outS', [], commands);
		  prln(outS, "</feature>\n")
		end
	  in
	    prList ("features", "", prFeature)
	  end

    val prDBTag = prSTag "spec-db" "registry=\"%s\" api=\"%s\" profile=\"%s\" extensions=\"%s\""

    fun print (outStrm, X.DB content) = let
          val outS = OS(outStrm, 0)
          in
	    prDBTag (outS, [
		F.STR(#registry content),
		F.STR(#api content),
		F.STR(#profile content),
		F.STR(#extensions content)
	      ]);
            nest outS (fn outS => (
	      prTypes (outS, [], #types content);
	      prEnums (outS, [], #enums content);
	      prCommands (outS, [], #commands content);
	      prGroups (outS, [], #groups content);
	      prFeatures (outS, [], #features content)));
            pr (outS, "</spec-db>\n");
            TextIO.flushOut outStrm
          end

  end

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0