20171018 nodes2grafana initial (FreeBSD)

Makefile.in

@@ -0,0 +1,77 @@
+all: conf build test etc dashboard dist
+
+conf: Makefile conf/substitutions.sed
+
+Makefile: Makefile.in conf/substitutions.sed conf/Makefile conf/substitutions.conf conf/substitute.sh
+
+conf/substitutions.sed: conf/Makefile conf/substitutions.conf
+
+conf/substitutions.conf:
+	cd conf && make
+
+build: src/Makefile src/nodes2prom src/json-pp
+
+src/Makefile: src/Makefile.in
+	conf/substitute.sh $> $@
+
+src/nodes2prom: src/Makefile
+	cd src && make nodes2prom
+
+src/json-pp: src/Makefile
+	cd src && make json-pp
+
+test: test/Makefile test/tmp
+
+test/Makefile: test/Makefile.in
+	conf/substitute.sh $> $@
+
+test/tmp:
+	cd test && make test
+
+etc: etc/Makefile etc/crontab etc/nodes2prometheus.sh
+
+etc/Makefile: etc/Makefile.in
+	conf/substitute.sh $> $@
+
+etc/crontab:
+	cd etc && make
+
+etc/nodes2prometheus.sh:
+	cd etc && make
+
+dashboard: dashboard/Makefile dashboard/%%DASHBOARD_PREFIX%%status.json
+
+dashboard/Makefile: dashboard/Makefile.in
+	conf/substitute.sh $> $@
+
+dashboard/%%DASHBOARD_PREFIX%%status.json:
+	cd dashboard && make
+
+dist: dist/Makefile dist/nodes2grafana.txz
+
+dist/Makefile: dist/Makefile.in
+	conf/substitute.sh $> $@
+
+dist/nodes2grafana.txz:
+	cd dist && rm -f $@ && make
+
+install: install-bin install-crontab install-dashboard
+
+install-bin: src/nodes2prom src/json-pp etc/nodes2prometheus.sh
+	%%INSTALL_BIN_CMD%% $> %%BIN_DIR%%
+
+install-crontab: etc/crontab
+	grep nodes2prometheus.sh %%ETC_DIR%%/crontab > /tmp/crontab.old || \
+	cat $> >> %%ETC_DIR%%/crontab
+	-diff /tmp/crontab.old $>
+
+install-dashboard: dashboard/%%DASHBOARD_PREFIX%%status.json
+	%%INSTALL_DATA_CMD%% $> %%DASHBOARD_DIR%%
+
+clean:
+	cd conf && make clean
+	[ ! -r test/Makefile ] || { cd test && make clean && rm -f Makefile ; }
+	[ ! -r etc/Makefile ] || { cd etc && make clean && rm -f Makefile ; }
+	[ ! -r src/Makefile ] || { cd src && make clean && rm -f Makefile ; }
+	[ ! -r dashboard/Makefile ] || { cd dashboard && make clean && rm -f Makefile ; }
+	[ ! -r dist/Makefile ] || { cd dist && make clean && rm -f Makefile ; }

README.md

@@ -0,0 +1,22 @@
+# nodes2grafana
+
+nodes2grafana ist ein Konverter für `nodes.json` -> prometheus Textformat. Mit dem erforderlichen Drumrum, incl. grafana Dashboards.
+
+Benötigt wird außer den üblichen verdächtigen Un*x-utilities nur [SML/NJ](http://www.smlnj.org/).
+
+Zwecks Konfigurationsanpassung (Pfade, Metriknamen) die Datei `conf/substitutions.conf.default` nach `/etc/nodes2grafana.conf` kopieren und die zu ändernden Werte anpassen.
+Zeilen, die gegenüber der substitutions.conf.default nicht geändert wurden, können auch weggelassen werden.
+
+Anschließend:
+
+    cd conf && make && cd .. && make
+    # make install
+    make clean
+
+# TODO
+
+- Auch für GNU/Linux gängig machen (gmake, wget, sed etc., pax, install, ...)
+- status-group dashboard
+- `graph.json` -> grafana
+- Doku:-)
+

conf/Makefile

@@ -0,0 +1,22 @@
+../Makefile:	../Makefile.in substitutions.sed substitute.sh
+	./substitute.sh ../Makefile.in ../Makefile
+
+substitutions.sed: substitutions.conf
+	sed -n -E \
+		-e 's@^[[:space:]]*#.*@@' \
+		-e 's@!@\\!@g' \
+		-e 's@^([[:alnum:]_]+)[[:space:]]+(.+)@s!%%\1%%!\2!g@p' \
+		$> > $@
+
+substitutions.conf: substitutions.conf.local substitutions.conf.default
+	cp -p substitutions.conf.local $@
+	awk '{ print $$1 }' substitutions.conf.local | fgrep -v -f - substitutions.conf.default >> $@
+
+substitutions.conf.local:
+	[ -e $@ ] || \
+	{ ETC_CONF=`sed -n -E -e 's/^ETC_DIR[[:space:]]+(.*)$$/\1/p' substitutions.conf.default | head -n 1`/nodes2grafana.conf ; \
+	  if [ -e $$ETC_CONF ] ; then ln -s $$ETC_CONF $@ ; else touch $@ ; fi ; }
+
+clean:
+	rm -f substitutions.sed substitutions.conf
+	[ -L substitutions.conf.local ] && rm -f substitutions.conf.local || [ -s substitutions.conf.local ] || rm -f substitutions.conf.local

conf/substitute.sh

@@ -0,0 +1,3 @@
+#!/bin/sh
+
+sed -f `dirname $0`/substitutions.sed $1 > $2

conf/substitutions.conf.default

@@ -0,0 +1,19 @@
+NODES_URL	https://map.ffdo.de/data/nodes.json
+FETCH_CMD	fetch -q -T 30 --no-verify-peer -o
+#FETCH_CMD	wget -O
+PROM_SEPERATOR	_
+PROM_PREFIX	ffdo_nodes
+SUMMARY_PREFIX	summary
+INFO_PREFIX	info
+STATS_PREFIX	detail
+HEAP_SUFFIX	x86-bsd
+EXPORT_DIR	/var/tmp/node_exporter
+BIN_DIR		/usr/local/bin
+ETC_DIR		/etc
+INSTALL_BIN_CMD	install -o 0 -g 0 -p -S -v
+#INSTALL_BIN_CMD	cp -a
+INSTALL_DATA_CMD	install -o 0 -g 0 -p -S -v -m 644
+#INSTALL_DATA_CMD	cp -a
+DASHBOARD_DIR	/var/db/grafana/dashboards
+DASHBOARD_PREFIX	FF-DO-
+MAP_NODE_URL	https://map.ffdo.de/meshviewer/#!v:m;n:

dashboard/Makefile.in

@@ -0,0 +1,12 @@
+all:	dashboard
+
+dashboard: %%DASHBOARD_PREFIX%%status.json
+
+%%DASHBOARD_PREFIX%%status.json: status.json.in
+	../conf/substitute.sh $> $@
+
+install: %%DASHBOARD_PREFIX%%status.json
+	%%INSTALL_DATA_CMD%% $> %%DASHBOARD_DIR%%
+
+clean:
+	rm -f %%DASHBOARD_PREFIX%%status.json

dist/Makefile.in

@@ -0,0 +1,32 @@
+DISTFILES=	Makefile.in README \
+		conf/Makefile conf/substitute.sh conf/substitutions.conf.default \
+		etc/*.in src test/Makefile.in dashboard/*.in dist/Makefile.in
+DISTTARGET=	nodes2grafana
+DISTDIR=	tmp/${DISTTARGET}
+DISTEXCLUDE=	--exclude=${DISTTARGET}/src/Makefile \
+		--exclude=${DISTTARGET}/src/promconfig.sml \
+		--exclude=${DISTTARGET}/src/.cm \
+		--exclude=${DISTTARGET}/src/nodes2prom \
+		--exclude=${DISTTARGET}/src/nodes2prom.%%HEAP_SUFFIX%% \
+		--exclude=${DISTTARGET}/src/json-pp \
+		--exclude=${DISTTARGET}/src/json-pp.%%HEAP_SUFFIX%% \
+		--exclude=${DISTTARGET}/src/JSON/.cm
+
+DISTTARFILE=	${DISTTARGET}.txz
+
+all: ${DISTTARFILE}
+
+${DISTTARFILE}: ${DISTDIR} Makefile
+	tar cvJf ${DISTTARFILE} -C tmp ${DISTEXCLUDE} ${DISTTARGET}
+
+${DISTDIR}: tmp
+	rm -rf $@
+	mkdir -p $@
+	cd .. && pax -rw -pe ${DISTFILES} dist/${DISTDIR}
+
+tmp:
+	mkdir $@
+
+clean:
+	rm -rf tmp
+	rm -f ${DISTTARFILE}

etc/Makefile.in

@@ -0,0 +1,11 @@
+all:	crontab nodes2prometheus.sh
+
+crontab: crontab.in
+	../conf/substitute.sh $> $@
+
+nodes2prometheus.sh: nodes2prometheus.sh.in
+	../conf/substitute.sh $> $@
+	chmod +x $@
+
+clean:
+	rm -f crontab nodes2prometheus.sh

etc/crontab.in

@@ -0,0 +1,2 @@
+# nodes2prometheus.sh: nodes.json -> prometheus text format
+*	*	*	*	*	nobody	[ ! -d %%EXPORT_DIR%% ] || %%BIN_DIR%%/nodes2prometheus.sh

etc/nodes2prometheus.sh.in

@@ -0,0 +1,27 @@
+#!/bin/sh
+
+# Einzeldaten und Summen von nodes.json als labeled metrics for prometheus
+
+ME="`basename $0`"
+
+PROM_PREFIX=%%PROM_PREFIX%%
+PROMDIR=%%EXPORT_DIR%%
+[ -d $PROMDIR -a -w $PROMDIR ] || PROMDIR=/tmp
+PROMFILE=$PROMDIR/$PROM_PREFIX.prom
+
+NODES_URL="%%NODES_URL%%"
+NODESFILE=/tmp/nodes.json.$$
+NODES2PROM=%%BIN_DIR%%/nodes2prom
+[ -f $NODES2PROM -a -x $NODES2PROM ] || NODES2PROM=./nodes2prom
+
+if timeout -s HUP -k 2 50 \
+   %%FETCH_CMD%% $NODESFILE "$NODES_URL"
+then
+	$NODES2PROM $NODESFILE > $PROMFILE.new && \
+	mv $PROMFILE.new $PROMFILE
+	rm -f $NODESFILE
+else
+	logger -t "$ME" "failed to fetch $NODES_URL"
+	rm -f $NODESFILE
+	exit 1
+fi

src/JSON/README

@@ -0,0 +1,15 @@
+This library supports the reading and writing of structured data using
+the "JavaScript Object Notation" (JSON).  This format is specified by
+RFC 7159 (https://tools.ietf.org/html/rfc7159).
+
+There are two levels of I/O supported.  The "stream" level supports
+event-based parsing (e.g., like a SAX parser for XML) and output at
+the same level.  Use this mode to extract small amounts of information
+from large files or when you want to directly build your own representation
+of the file.  The "file" level supports a "DOM-style" approach that reads/writes
+trees (see json.sml for the representation).
+
+TODO:
+  add support for UBJSON (http://ubjson.org) or possibly one of the
+  other binary JSON representations
+

src/JSON/json-lib.cm

@@ -0,0 +1,33 @@
+(* json-lib.cm
+ *
+ * COPYRIGHT (c) 2008 The Fellowship of SML/NJ (http://www.smlnj.org)
+ * All rights reserved.
+ *)
+
+Library
+
+(* DOM-style API (tree based) *)
+  structure JSON
+  structure JSONParser
+  structure JSONPrinter
+  structure JSONUtil
+
+(* SAX-style API (event based) *)
+  structure JSONStreamParser
+  structure JSONStreamPrinter
+
+is
+
+  $/basis.cm
+  $/smlnj-lib.cm
+  $/ml-lpt-lib.cm
+
+  json.lex : ml-ulex
+  json.sml
+  json-parser.sml
+  json-printer.sml
+  json-stream-parser.sml
+  json-stream-printer.sml
+  json-tokens.sml
+  json-util.sml
+

src/JSON/json-lib.mlb

@@ -0,0 +1,47 @@
+(* json-lib.mlb
+ *
+ * COPYRIGHT (c) 2008 The Fellowship of SML/NJ (http://www.smlnj.org)
+ * All rights reserved.
+ *
+ * An MLB file for the JSON library, so that it can be used by MLton programs.
+ *
+ * TODO:
+ *	This is not complete, since MLton does not have the ml-lpt-lib yet.
+ *)
+
+local
+
+  $(SML_LIB)/basis/basis.mlb
+  $(SML_LIB)/smlnj-lib/Util/smlnj-lib.mlb
+  $(SML_LIB)/mllpt-lib/ml-lpt-lib.mlb
+
+  ann
+    "nonexhaustiveMatch warn" "redundantMatch warn"
+    "sequenceNonUnit ignore"
+    "warnUnused false" "forceUsed"
+  in
+
+    json-tokens.sml
+    json.lex.sml
+    json.sml
+    json-stream-parser.sml
+    json-parser.sml
+    json-stream-printer.sml
+    json-printer.sml
+    json-util.sml
+
+  end
+
+in
+
+(* DOM-style API (tree based) *)
+  structure JSON
+  structure JSONParser
+  structure JSONPrinter
+  structure JSONUtil
+
+(* SAX-style API (event based) *)
+  structure JSONStreamParser
+  structure JSONStreamPrinter
+
+end

src/JSON/json-parser.sml

@@ -0,0 +1,100 @@
+(* json-parser.sml
+ *
+ * COPYRIGHT (c) 2008 The Fellowship of SML/NJ (http://www.smlnj.org)
+ * All rights reserved.
+ *)
+
+structure JSONParser : sig
+
+    val parse : TextIO.instream -> JSON.value
+
+    val parseFile : string -> JSON.value
+
+  end = struct
+
+    structure Lex = JSONLexer
+    structure T = JSONTokens
+    structure J = JSON
+
+    fun parse' (srcMap, inStrm) = let
+	  fun error (pos, msg, tok) = raise Fail(concat[
+		  "error ", AntlrStreamPos.spanToString srcMap pos, ": ",
+		  msg, ", found '", JSONTokens.toString tok, "'"
+		])
+	  val lexer = Lex.lex srcMap
+	  fun parse_sequence (is_tok_end, parse_item) (strm : Lex.strm, itms) = let
+		fun is_tok_sep tok = case tok of T.COMMA => true | _ => false
+		val (tok, pos, strm') = lexer strm
+		in if is_tok_sep tok
+		   then error (pos, "parsing sequence", tok)
+		   else if is_tok_end tok
+			then (strm', itms)
+			else let val (strm'', itm) = parse_item strm
+				 val (tok', pos', strm''') = lexer strm''
+			     in if is_tok_end tok'
+				then (strm''', itm :: itms)
+				else if is_tok_sep tok'
+				     then let val (tok'', pos'', _) = lexer strm'''
+					  in if is_tok_end tok''
+					     then error (pos'', "parsing sequence", tok'')
+					     else parse_sequence (is_tok_end, parse_item) (strm''', itm :: itms)
+					  end
+				     else error (pos', "parsing sequence", tok')
+				 end
+		end
+	  fun parseValue (strm : Lex.strm) = let
+		val (tok, pos, strm) = lexer strm
+		in
+		  case tok
+		   of T.LB => parseArray strm
+		    | T.LCB => parseObject strm
+		    | T.KW_null => (strm, J.NULL)
+		    | T.KW_true => (strm, J.BOOL true)
+		    | T.KW_false => (strm, J.BOOL false)
+		    | T.INT n => (strm, J.INT n)
+		    | T.FLOAT f => (strm, J.FLOAT f)
+		    | T.STRING s => (strm, J.STRING s)
+		    | _ => error (pos, "parsing value", tok)
+		  (* end case *)
+		end
+	  and parseArray (strm : Lex.strm) = let
+		fun is_RB tok = case tok of T.RB => true | _ => false
+		val (strm', elmnts) = parse_sequence (is_RB, parseValue) (strm, [])
+		in (strm', J.ARRAY(List.rev elmnts))
+		end
+	  and parseObject (strm : Lex.strm) = let
+		fun is_RCB tok = case tok of T.RCB => true | _ => false
+		fun parse_field strm = let
+			val (tok, pos, strm') = lexer strm
+			in case tok
+			    of T.STRING s =>
+				(case lexer strm'
+				  of (T.COLON, _, strm'') => let
+					val (strm''', v) = parseValue strm''
+					in (strm''', (s, v))
+					end
+				   | (tok', pos', _) => error (pos', "parsing field", tok')
+				 (* end case *))
+			     | _ => error (pos, "parsing field", tok)
+			   (* end case *)
+			end
+		val (strm', flds) = parse_sequence (is_RCB, parse_field) (strm, [])
+		in (strm', J.OBJECT(List.rev flds))
+		end
+	  in
+	    #2 (parseValue (Lex.streamifyInstream inStrm))
+	  end
+
+    fun parse inStrm = parse' (AntlrStreamPos.mkSourcemap (), inStrm)
+
+    fun parseFile fileName = let
+	  val inStrm = TextIO.openIn fileName
+	  val v = parse' (AntlrStreamPos.mkSourcemap' fileName, inStrm)
+		handle ex => (TextIO.closeIn inStrm; raise ex)
+	  in
+	    TextIO.closeIn inStrm;
+	    v
+	  end
+
+  end
+

src/JSON/json-printer.sml

@@ -0,0 +1,44 @@
+(* json-printer.sml
+ *
+ * COPYRIGHT (c) 2008 The Fellowship of SML/NJ (http://www.smlnj.org)
+ * All rights reserved.
+ *
+ * A printer for JSON values.
+ *)
+
+structure JSONPrinter : sig
+
+    val print : TextIO.outstream * JSON.value -> unit
+    val print' : {strm : TextIO.outstream, pretty : bool} -> JSON.value -> unit
+
+  end = struct
+
+    structure J = JSON
+    structure JSP = JSONStreamPrinter
+
+    fun printWith printer = let
+	  fun pr (J.OBJECT fields) = let
+		fun prField (key, v) = (JSP.objectKey(printer, key); pr v)
+		in
+		  JSP.beginObject printer;
+		  List.app prField fields;
+		  JSP.endObject printer
+		end
+	    | pr (J.ARRAY vs) = (
+		JSP.beginArray printer;
+		List.app pr vs;
+		JSP.endArray printer)
+	    | pr J.NULL = JSP.null printer
+	    | pr (J.BOOL b) = JSP.boolean (printer, b)
+	    | pr (J.INT n) = JSP.integer (printer, n)
+	    | pr (J.FLOAT f) = JSP.float (printer, f)
+	    | pr (J.STRING s) = JSP.string (printer, s)
+	  in
+	    fn v => (pr v; JSP.close printer)
+	  end
+
+    fun print (strm, v) = printWith (JSP.new strm) v
+
+    fun print' {strm, pretty} = printWith (JSP.new' {strm=strm, pretty=pretty})
+
+  end

src/JSON/json-stream-parser.sml

@@ -0,0 +1,142 @@
+(* json-stream-parser.sml
+ *
+ * COPYRIGHT (c) 2008 The Fellowship of SML/NJ (http://www.smlnj.org)
+ * All rights reserved.
+ *)
+
+structure JSONStreamParser : sig
+
+  (* callback functions for the different parsing events *)
+    type 'ctx callbacks = {
+	null : 'ctx -> 'ctx,
+	boolean : 'ctx * bool -> 'ctx,
+	integer : 'ctx * IntInf.int -> 'ctx,
+	float : 'ctx * real -> 'ctx,
+	string : 'ctx * string -> 'ctx,
+	startObject : 'ctx -> 'ctx,
+	objectKey : 'ctx * string -> 'ctx,
+	endObject : 'ctx -> 'ctx,
+	startArray : 'ctx -> 'ctx,
+	endArray : 'ctx -> 'ctx,
+	error : 'ctx * string -> 'ctx
+      }
+
+    val parse : 'ctx callbacks -> (TextIO.instream * 'ctx) -> 'ctx
+
+    val parseFile : 'ctx callbacks -> (string * 'ctx) -> 'ctx
+
+  end = struct
+
+    structure Lex = JSONLexer
+    structure T = JSONTokens
+
+  (* callback functions for the different parsing events *)
+    type 'ctx callbacks = {
+	null : 'ctx -> 'ctx,
+	boolean : 'ctx * bool -> 'ctx,
+	integer : 'ctx * IntInf.int -> 'ctx,
+	float : 'ctx * real -> 'ctx,
+	string : 'ctx * string -> 'ctx,
+	startObject : 'ctx -> 'ctx,
+	objectKey : 'ctx * string -> 'ctx,
+	endObject : 'ctx -> 'ctx,
+	startArray : 'ctx -> 'ctx,
+	endArray : 'ctx -> 'ctx,
+	error : 'ctx * string -> 'ctx
+      }
+
+    fun error (cb : 'a callbacks, ctx, msg) = (
+	  #error cb (ctx, msg);
+	  raise Fail "error")
+
+    fun parser (cb : 'a callbacks) (srcMap, inStrm, ctx) = let
+	  val lexer = Lex.lex (AntlrStreamPos.mkSourcemap ())
+	  fun parseValue (strm : Lex.strm, ctx) = let
+		val (tok, pos, strm) = lexer strm
+		in
+		  case tok
+		   of T.LB => parseArray (strm, ctx)
+		    | T.LCB => parseObject (strm, ctx)
+		    | T.KW_null => (strm, #null cb ctx)
+		    | T.KW_true => (strm, #boolean cb (ctx, true))
+		    | T.KW_false => (strm, #boolean cb (ctx, false))
+		    | T.INT n => (strm, #integer cb (ctx, n))
+		    | T.FLOAT f => (strm, #float cb (ctx, f))
+		    | T.STRING s => (strm, #string cb (ctx, s))
+		    | _ => error (cb, ctx, "error parsing value")
+		  (* end case *)
+		end
+	  and parseArray (strm : Lex.strm, ctx) = (case lexer strm
+		 of (T.RB, _, strm) => (strm, #endArray cb (#startArray cb ctx))
+		  | _ => let
+		      fun loop (strm, ctx) = let
+			    val (strm, ctx) = parseValue (strm, ctx)
+			  (* expect either a "," or a "]" *)
+			    val (tok, pos, strm) = lexer strm
+			    in
+			      case tok
+			       of T.RB => (strm, ctx)
+				| T.COMMA => loop (strm, ctx)
+				| _ => error (cb, ctx, "error parsing array")
+			      (* end case *)
+			    end
+		      val ctx = #startArray cb ctx
+		      val (strm, ctx) = loop (strm, #startArray cb ctx)
+		      in
+			(strm, #endArray cb ctx)
+		      end
+		(* end case *))
+	  and parseObject (strm : Lex.strm, ctx) = let
+		fun parseField (strm, ctx) = (case lexer strm
+		       of (T.STRING s, pos, strm) => let
+			    val ctx = #objectKey cb (ctx, s)
+			    in
+			      case lexer strm
+			       of (T.COLON, _, strm) => parseValue (strm, ctx)
+				| _ => error (cb, ctx, "error parsing field")
+			      (* end case *)
+			    end
+			| _ => (strm, ctx)
+		      (* end case *))
+		fun loop (strm, ctx) = let
+		      val (strm, ctx) = parseField (strm, ctx)
+		      in
+			(* expect either "," or "}" *)
+			case lexer strm
+			 of (T.RCB, pos, strm) => (strm, ctx)
+			  | (T.COMMA, pos, strm) => loop (strm, ctx)
+			  | _ => error (cb, ctx, "error parsing object")
+			(* end case *)
+		      end
+		val ctx = #startObject cb ctx
+		val (strm, ctx) = loop (strm, #startObject cb ctx)
+		in
+		  (strm, #endObject cb ctx)
+		end
+	  in
+	    #2 (parseValue (Lex.streamifyInstream inStrm, ctx))
+	  end
+
+    fun parse cb = let
+	  val parser = parser cb
+	  fun parse' (inStrm, ctx) =
+		parser(AntlrStreamPos.mkSourcemap (), inStrm, ctx)
+	  in
+	    parse'
+	  end
+
+    fun parseFile cb = let
+	  val parser = parser cb
+	  fun parse (fileName, ctx) = let
+		val inStrm = TextIO.openIn fileName
+		val ctx = parser (AntlrStreamPos.mkSourcemap' fileName, inStrm, ctx)
+		      handle ex => (TextIO.closeIn inStrm; raise ex)
+		in
+		  TextIO.closeIn inStrm;
+		  ctx
+		end
+	  in
+	    parse
+	  end
+
+  end

src/JSON/json-stream-printer.sml

@@ -0,0 +1,155 @@
+(* json-stream-printer.sml
+ *
+ * COPYRIGHT (c) 2008 The Fellowship of SML/NJ (http://www.smlnj.org)
+ * All rights reserved.
+ *)
+
+structure JSONStreamPrinter : sig
+
+    type printer
+
+    val null : printer -> unit
+    val boolean : printer * bool -> unit
+    val integer : printer * IntInf.int -> unit
+    val float : printer * real -> unit
+    val string : printer * string -> unit
+    val beginObject : printer -> unit
+    val objectKey : printer * string -> unit
+    val endObject : printer -> unit
+    val beginArray : printer -> unit
+    val endArray : printer -> unit
+
+    val new : TextIO.outstream -> printer
+    val new' : {strm : TextIO.outstream, pretty : bool} -> printer
+    val close : printer -> unit
+
+  end = struct
+
+    structure F = Format
+
+    datatype printer = P of {
+	strm : TextIO.outstream,
+	indent : int ref,
+	ctx : context ref,
+	pretty : bool
+      }
+
+  (* the context is used to keep track of the printing state for indentation
+   * and punctuation, etc.
+   *)
+    and context
+      = TOP			(* top-most context *)
+      | FIRST of context	(* first element of object or array; the argument *)
+				(* must be one of OBJECT or ARRAY. *)
+      | OBJECT of context	(* in an object (after the first element) *)
+      | ARRAY of context	(* in an array (after the first element) *)
+      | KEY of context		(* after the key of a object field *)
+
+    fun new' {strm, pretty} = P{
+	    strm = strm,
+	    indent = ref 0,
+	    ctx = ref TOP,
+	    pretty = pretty
+	  }
+
+    fun new strm = new' {strm = strm, pretty = false}
+
+    fun close (P{ctx = ref TOP, strm, ...}) = TextIO.output(strm, "\n")
+      | close _ = raise Fail "premature close"
+
+    fun pr (P{strm, ...}, s) = TextIO.output(strm, s)
+
+    fun indent (P{pretty = false, ...}, _) = ()
+      | indent (P{strm, indent, ...}, offset) = let
+	  val tenSpaces = "          "
+	  fun prIndent n = if (n <= 10)
+		then TextIO.output(strm, String.extract(tenSpaces, 10-n, NONE))
+		else (TextIO.output(strm, tenSpaces); prIndent(n-10))
+	  in
+	    prIndent (!indent+offset)
+	  end
+
+    fun incIndent (P{indent, ...}, n) = indent := !indent + n;
+    fun decIndent (P{indent, ...}, n) = indent := !indent - n;
+
+    fun nl (P{pretty = false, ...}) = ()
+      | nl (P{strm, ...}) = TextIO.output(strm, "\n")
+
+    fun comma (P{strm, pretty = false, ...}) = TextIO.output(strm, ",")
+      | comma (p as P{strm, ...}) = (
+	  TextIO.output(strm, ",\n"); indent(p, 0))
+
+    fun optComma (p as P{ctx, pretty, ...}) = (case !ctx
+	   of FIRST ctx' => (indent(p, 0); ctx := ctx')
+	    | OBJECT _ => comma p
+	    | ARRAY _ => comma p
+	    | KEY ctx' => (
+		pr (p, if pretty then " : " else ":");
+		ctx := ctx')
+	    | _ => ()
+	  (* end case *))
+
+  (* print a value, which may be proceeded by a comma if it is in a sequence *)
+    fun prVal (p, v) = (optComma p; pr(p, v))
+
+    fun null p = prVal (p, "null")
+    fun boolean (p, false) = prVal (p, "false")
+      | boolean (p, true) = prVal (p, "true")
+    fun integer (p, n) = prVal (p, F.format "%d" [F.LINT n])
+    fun float (p, f) = prVal (p, F.format "%g" [F.REAL f])
+(* FIXME: need to deal with UTF-* escapes *)
+    (* fun string (p, s) = prVal (p, F.format "\"%s\"" [F.STR(String.toCString s)]) *)
+    fun string (p, s) = (* RFC 7159 *)
+	let fun esc #"\"" = "\\\""
+	      | esc #"\\" = "\\\\"
+	      | esc #"\b" = "\\b"
+	      | esc #"\f" = "\\f"
+	      | esc #"\n" = "\\n"
+	      | esc #"\r" = "\\r"
+	      | esc #"\t" = "\\t"
+	      | esc c = if c < #" "
+			then "\\u" ^ (StringCvt.padLeft #"0" 4 (Int.fmt StringCvt.HEX (ord c)))
+			else str c
+	in prVal (p, "\"" ^ (String.translate esc s) ^ "\"")
+	end
+    fun beginObject (p as P{ctx, ...}) = (
+	  optComma p;
+	  pr (p, "{"); incIndent(p, 1); nl p;
+	  ctx := FIRST(OBJECT(!ctx)))
+
+    fun objectKey (p as P{ctx = ref(KEY _), ...}, field) =
+	  raise Fail(concat["objectKey \"", field, "\" where value was expected"])
+      | objectKey (p as P{ctx, ...}, field) = (
+	  string (p, field);
+	  ctx := KEY(!ctx))
+
+    fun endObject (p as P{ctx, ...}) = let
+	  fun prEnd ctx' = (
+		ctx := ctx';
+		indent(p, 0); pr(p, "}"); decIndent (p, 1))
+	  in
+	    case !ctx
+	     of OBJECT ctx' => (nl p; prEnd ctx')
+	      | FIRST(OBJECT ctx') => prEnd ctx'
+	      | _ => raise Fail "endObject not in object context"
+	    (* end case *)
+	  end
+
+    fun beginArray (p as P{ctx, ...}) = (
+	  optComma p;
+	  pr (p, "["); incIndent(p, 1); nl p;
+	  ctx := FIRST(ARRAY(!ctx)))
+
+    fun endArray (p as P{ctx, ...}) = let
+	  fun prEnd ctx' = (
+		ctx := ctx';
+		nl p; indent(p, 0); pr(p, "]"); decIndent (p, 1))
+	  in
+	    case !ctx
+	     of ARRAY ctx' => prEnd ctx'
+	      | FIRST(ARRAY ctx') => prEnd ctx'
+	      | _ => raise Fail "endArray not in array context"
+	    (* end case *)
+	  end
+
+  end

src/JSON/json-tokens.sml

@@ -0,0 +1,47 @@
+(* json-tokens.sml
+ *
+ * COPYRIGHT (c) 2008 The Fellowship of SML/NJ (http://www.smlnj.org)
+ * All rights reserved.
+ *
+ * The tokens returned by the JSON lexer.
+ *)
+
+structure JSONTokens =
+  struct
+
+    datatype token
+      = EOF		(* end-of-file *)
+      | LB | RB		(* "[" "]" *)
+      | LCB | RCB	(* "{" "}" *)
+      | COMMA		(* "," *)
+      | COLON		(* ":" *)
+      | KW_null		(* "null" *)
+      | KW_true		(* "true" *)
+      | KW_false	(* "false" *)
+      | INT of IntInf.int
+      | FLOAT of real
+      | STRING of string
+
+    fun toString EOF = "<eof>"
+      | toString LB = "["
+      | toString RB = "]"
+      | toString LCB = "{"
+      | toString RCB = "}"
+      | toString COMMA = ","
+      | toString COLON = ":"
+      | toString KW_null = "null"
+      | toString KW_true = "true"
+      | toString KW_false = "false"
+      | toString (INT i) =
+	  if (i < 0) then "-" ^ IntInf.toString(~i)
+	  else IntInf.toString i
+      | toString (FLOAT f) =
+	  if (f < 0.0) then "-" ^ Real.toString(~f)
+	  else Real.toString f
+      | toString (STRING s) = let
+	  fun f (wchr, l) = UTF8.toString wchr :: l
+	  in
+	    String.concat("\"" :: (List.foldr f ["\""] (UTF8.explode s)))
+	  end
+
+  end

src/JSON/json-util.sml

@@ -0,0 +1,273 @@
+(* json-util.sml
+ *
+ * COPYRIGHT (c) 2017 The Fellowship of SML/NJ (http://www.smlnj.org)
+ * All rights reserved.
+ *
+ * Utility functions for processing the JSON in-memory representation.
+ *)
+
+structure JSONUtil : sig
+
+  (* exceptions for conversion functions *)
+    exception NotBool of JSON.value
+    exception NotInt of JSON.value
+    exception NotNumber of JSON.value
+    exception NotString of JSON.value
+
+  (* exception that is raised when trying to process a non-object value as an object *)
+    exception NotObject of JSON.value
+
+  (* exception that is raised when the given field is not found in an object *)
+    exception FieldNotFound of JSON.value * string
+
+  (* exception that is raised when trying to process a non-array value as an array *)
+    exception NotArray of JSON.value
+
+  (* exception that is raise when access to an array value is out of bounds *)
+    exception ArrayBounds of JSON.value * int
+
+  (* map the above exceptions to a message string; we use General.exnMessage for other
+   * exceptions.
+   *)
+    val exnMessage : exn -> string
+
+  (* conversion functions for atomic values.  These raise the corresponding
+   * "NotXXX" exceptions when their argument has the wrong shape.  Also note
+   * that asNumber will accept both integers and floats and asInt may raise
+   * Overflow if the number is too large.
+   *)
+    val asBool : JSON.value -> bool
+    val asInt : JSON.value -> Int.int
+    val asIntInf : JSON.value -> IntInf.int
+    val asNumber : JSON.value -> Real.real
+    val asString : JSON.value -> string
+
+  (* find a field in an object; this function raises the NotObject exception when
+   * the supplied value is not an object.
+   *)
+    val findField : JSON.value -> string -> JSON.value option
+
+  (* lookup a field in an object; this function raises the NotObject exception when
+   * the supplied value is not an object and raises FieldNotFound if the value is
+   * an object, but does not have the specified field.
+   *)
+    val lookupField : JSON.value -> string -> JSON.value
+
+  (* convert a JSON array to an SML vector *)
+    val asArray : JSON.value -> JSON.value vector
+
+  (* map a conversion function over a JSON array to produce a list; this function
+   * raises the NotArray exception if the second argument is not an array.
+   *)
+    val arrayMap : (JSON.value -> 'a) -> JSON.value -> 'a list
+
+  (* path specification for indexing into JSON values *)
+    datatype edge
+      = SUB of int      (* index into array component *)
+      | SEL of string   (* select field of object *)
+
+    type path = edge list
+
+  (* `get (jv, path)` returns the component of `jv` named by `path`.  It raises
+   * the NotObject, NotArray, and FieldNotFound exceptions if there is an inconsistency
+   * between the path and the structure of `jv`.
+   *)
+    val get : JSON.value * path -> JSON.value
+
+  (* `replace (jv, path, v)` replaces the component of `jv` named by `path`
+   * with the value `v`.
+   *)
+    val replace : JSON.value * path * JSON.value -> JSON.value
+
+  (* `insert (jv, path, lab, v)` inserts `lab : v` into the object named by `path`
+   * in `jv`
+   *)
+    val insert : JSON.value * path * string * JSON.value -> JSON.value
+
+  (* `append (jv, path, vs)` appends the list of values `vs` onto the array named by `path`
+   * in `jv`
+   *)
+    val append : JSON.value * path * JSON.value list -> JSON.value
+
+  end = struct
+
+    structure J = JSON
+
+    exception NotBool of J.value
+    exception NotInt of J.value
+    exception NotNumber of J.value
+    exception NotString of J.value
+
+    exception NotObject of J.value
+    exception FieldNotFound of J.value * string
+
+    exception NotArray of J.value
+    exception ArrayBounds of J.value * int
+
+  (* conversion functions for atomic values *)
+    fun asBool (J.BOOL b) = b
+      | asBool v = raise NotBool v
+
+    fun asInt (J.INT n) = Int.fromLarge n
+      | asInt v = raise NotInt v
+
+    fun asIntInf (J.INT n) = n
+      | asIntInf v = raise NotInt v
+
+    fun asNumber (J.INT n) = Real.fromLargeInt n
+      | asNumber (J.FLOAT f) = f
+      | asNumber v = raise NotNumber v
+
+    fun asString (J.STRING s) = s
+      | asString v = raise NotString v
+
+    fun findField (J.OBJECT fields) = let
+	  fun find lab = (case List.find (fn (l, v) => (l = lab)) fields
+		 of NONE => NONE
+		  | SOME(_, v) => SOME v
+		(* end case *))
+	  in
+	    find
+	  end
+      | findField v = raise NotObject v
+
+    fun lookupField (v as J.OBJECT fields) = let
+	  fun find lab = (case List.find (fn (l, v) => (l = lab)) fields
+		 of NONE => raise FieldNotFound(v, lab)
+		  | SOME(_, v) => v
+		(* end case *))
+	  in
+	    find
+	  end
+      | lookupField v = raise NotObject v
+
+    fun asArray (J.ARRAY vs) = Vector.fromList vs
+      | asArray v = raise NotArray v
+
+    fun arrayMap f (J.ARRAY vs) = List.map f vs
+      | arrayMap f v = raise NotArray v
+
+  (* map the above exceptions to a message string; we use General.exnMessage for other
+   * exceptions.
+   *)
+    fun exnMessage exn = let
+	  fun v2s (J.ARRAY _) = "array"
+	    | v2s (J.BOOL false) = "'false'"
+	    | v2s (J.BOOL true) = "'true'"
+	    | v2s (J.FLOAT _) = "number"
+	    | v2s (J.INT _) = "number"
+	    | v2s J.NULL = "'null'"
+	    | v2s (J.OBJECT _) = "object"
+	    | v2s (J.STRING _) = "string"
+	  in
+	    case exn
+	     of NotBool v => String.concat[
+		    "expected boolean, but found ", v2s v
+		  ]
+	      | NotInt(J.FLOAT _) => "expected integer, but found floating-point number"
+	      | NotInt v => String.concat[
+		    "expected integer, but found ", v2s v
+		  ]
+	      | NotNumber v => String.concat[
+		    "expected number, but found ", v2s v
+		  ]
+	      | NotString v => String.concat[
+		    "expected string, but found ", v2s v
+		  ]
+	      | NotObject v => String.concat[
+		    "expected object, but found ", v2s v
+		  ]
+	      | FieldNotFound(v, fld) => String.concat[
+		    "no definition for field \"", fld, "\" in object"
+		  ]
+	      | NotArray v => String.concat[
+		    "expected array, but found ", v2s v
+		  ]
+	      | _ => General.exnMessage exn
+	    (* end case *)
+	  end
+
+  (* path specification for indexing into JSON values *)
+    datatype edge
+      = SEL of string   (* select field of object *)
+      | SUB of int      (* index into array component *)
+
+    type path = edge list
+
+    fun get (v, []) = v
+      | get (v as J.OBJECT fields, SEL lab :: rest) =
+	  (case List.find (fn (l, v) => (l = lab)) fields
+	   of NONE => raise FieldNotFound(v, lab)
+	    | SOME(_, v) => get (v, rest)
+	  (* end case *))
+      | get (v, SEL _ :: _) = raise NotObject v
+      | get (J.ARRAY vs, SUB i :: rest) = get (List.nth(vs, i), rest)
+      | get (v, SUB _ :: _) = raise (NotArray v)
+
+  (* top-down zipper to support functional editing *)
+    datatype zipper
+      = ZNIL
+      | ZOBJ of {
+            prefix : (string * J.value) list,
+            label : string,
+            child : zipper,
+            suffix : (string * J.value) list
+          }
+      | ZARR of {
+            prefix : J.value list,
+            child : zipper,
+            suffix : J.value list
+          }
+
+  (* follow a path into a JSON value while constructing a zipper *)
+    fun unzip (v, []) = (ZNIL, v)
+      | unzip (v as J.OBJECT fields, SEL lab :: rest) = let
+          fun find (_, []) = raise FieldNotFound(v, lab)
+            | find (pre, (l, v)::flds) = if (l = lab)
+                then let
+		  val (zipper, v) = unzip (v, rest)
+		  in
+		    (ZOBJ{prefix=pre, label=lab, suffix=flds, child=zipper}, v)
+                  end
+                else find ((l, v)::pre, flds)
+          in
+            find ([], fields)
+          end
+      | unzip (v, SEL _ :: _) = raise NotObject v
+      | unzip (v as J.ARRAY vs, SUB i :: rest) = let
+          fun sub (_, [], _) = raise ArrayBounds(v, i)
+            | sub (prefix, v::vs, 0) = let
+		val (zipper, v) = unzip (v, rest)
+		in
+		  (ZARR{prefix = prefix, child = zipper, suffix = vs}, v)
+		end
+            | sub (prefix, v::vs, i) = sub(v::prefix, vs, i-1)
+	  in
+	    sub ([], vs, i)
+	  end
+      | unzip (v, SUB _ :: _) = raise NotArray v
+
+  (* zip up a zipper *)
+    fun zip (zipper, v) = let
+	  fun zip' ZNIL = v
+            | zip' (ZOBJ{prefix, label, suffix, child}) =
+                J.OBJECT(List.revAppend(prefix, (label, zip' child)::suffix))
+            | zip' (ZARR{prefix, child, suffix}) =
+                J.ARRAY(List.revAppend(prefix, zip' child :: suffix))
+          in
+	    zip' zipper
+	  end
+
+    fun replace (jv, path, v) = zip (#1 (unzip (jv, path)), v)
+
+    fun insert (jv, path, label, v) = (case unzip (jv, path)
+	   of (zipper, J.OBJECT fields) => zip (zipper, J.OBJECT((label, v)::fields))
+	    | (_, v) => raise NotObject v
+	  (* end case *))
+
+    fun append (jv, path, vs) = (case unzip (jv, path)
+	   of (zipper, J.ARRAY jvs) => zip (zipper, J.ARRAY(jvs @ vs))
+	    | (_, v) => raise NotArray v
+	  (* end case *))
+
+  end

src/JSON/json.lex

@@ -0,0 +1,79 @@
+(* json.lex
+ *
+ * COPYRIGHT (c) 2008 The Fellowship of SML/NJ (http://www.smlnj.org)
+ * All rights reserved.
+ *
+ * Lexer for JSON files.
+ *
+ * TODO:
+ *	EOF rules for strings
+ *	newlines in strings
+ *	error messages for unknown characters
+ *)
+
+%name JSONLexer;
+
+%defs (
+  structure T = JSONTokens
+  type lex_result = T.token
+  fun eof () = T.EOF
+  fun int s = T.INT(valOf(IntInf.fromString s))
+  fun float s = T.FLOAT(valOf(LargeReal.fromString s))
+(* support for incremental construction of strings *)
+  val sbuf : string list ref = ref []
+  fun addStr s = sbuf := s :: !sbuf
+  fun addUChr lit = let
+      (* trim the "\u" prefix *)
+	val digits = Substring.triml 2 (Substring.full lit)
+	val SOME(w, _) = Word.scan StringCvt.HEX Substring.getc digits
+	in
+	  addStr(UTF8.encode w)
+	end
+  fun finishString () = (T.STRING(String.concat(List.rev(!sbuf))) before sbuf := [])
+);
+
+%let digit1_9 = [1-9];
+%let digit = [0-9];
+%let digits = {digit}+;
+%let int = "-"?({digit} | {digit1_9}{digits}+);
+%let frac = "."{digits};
+%let exp = [eE][+-]?{digits};
+%let xdigit = {digit}|[a-fA-F];
+
+%states S;
+
+<INITIAL>[\ \t\n\r]+		=> ( skip() );
+
+<INITIAL>"{"			=> ( T.LCB );
+<INITIAL>"}"			=> ( T.RCB );
+<INITIAL>"["			=> ( T.LB );
+<INITIAL>"]"			=> ( T.RB );
+<INITIAL>","			=> ( T.COMMA );
+<INITIAL>":"			=> ( T.COLON );
+<INITIAL>"null"			=> ( T.KW_null );
+<INITIAL>"true"			=> ( T.KW_true );
+<INITIAL>"false"		=> ( T.KW_false );
+
+<INITIAL>{int}			=> ( T.INT(valOf(IntInf.fromString yytext)) );
+
+<INITIAL>{int}{frac}		=> ( float yytext );
+<INITIAL>{int}{exp}		=> ( float yytext );
+<INITIAL>{int}{frac}{exp}	=> ( float yytext );
+
+<INITIAL>"\""			=> ( YYBEGIN S; continue() );
+<S>"\\\\"			=> ( addStr "\\"; continue() );
+<S>"\\\""			=> ( addStr "\""; continue() );
+<S>"\\/"			=> ( addStr "/"; continue() );
+<S>"\\b"			=> ( addStr "\b"; continue() );
+<S>"\\f"			=> ( addStr "\f"; continue() );
+<S>"\\n"			=> ( addStr "\n"; continue() );
+<S>"\\r"			=> ( addStr "\r"; continue() );
+<S>"\\t"			=> ( addStr "\t"; continue() );
+<S>"\\u"{xdigit}{4}		=> ( addUChr yytext; continue() );
+<S>[^\\"]+			=> ( addStr yytext; continue() );
+<S>"\""				=> ( YYBEGIN INITIAL; finishString() );
+
+<INITIAL>"/*"(~(.*"*/".*))"*/"	=> ( skip() );
+
+(* FIXME: add some error reporting *)
+<INITIAL>.			=> ( skip() );

src/JSON/json.lex.sml

@@ -0,0 +1,930 @@
+structure JSONLexer  = struct
+
+    datatype yystart_state = 
+S | INITIAL
+    structure UserDeclarations = 
+      struct
+
+ 
+  structure T = JSONTokens
+  type lex_result = T.token
+  fun eof () = T.EOF
+  fun int s = T.INT(valOf(IntInf.fromString s))
+  fun float s = T.FLOAT(valOf(LargeReal.fromString s))
+(* support for incremental construction of strings *)
+  val sbuf : string list ref = ref []
+  fun addStr s = sbuf := s :: !sbuf
+  fun addUChr lit = let
+      (* trim the "\u" prefix *)
+	val digits = Substring.triml 2 (Substring.full lit)
+	val SOME(w, _) = Word.scan StringCvt.HEX Substring.getc digits
+	in
+	  addStr(UTF8.encode w)
+	end
+  fun finishString () = (T.STRING(String.concat(List.rev(!sbuf))) before sbuf := [])
+
+
+      end
+
+    local
+    datatype yymatch 
+      = yyNO_MATCH
+      | yyMATCH of ULexBuffer.stream * action * yymatch
+    withtype action = ULexBuffer.stream * yymatch -> UserDeclarations.lex_result
+
+    val yytable : ((UTF8.wchar * UTF8.wchar * int) list * int list) Vector.vector = 
+Vector.fromList []
+    fun yystreamify' p input = ULexBuffer.mkStream (p, input)
+
+    fun yystreamifyReader' p readFn strm = let
+          val s = ref strm
+	  fun iter(strm, n, accum) = 
+	        if n > 1024 then (String.implode (rev accum), strm)
+		else (case readFn strm
+		       of NONE => (String.implode (rev accum), strm)
+			| SOME(c, strm') => iter (strm', n+1, c::accum))
+          fun input() = let
+	        val (data, strm) = iter(!s, 0, [])
+	        in
+	          s := strm;
+		  data
+	        end
+          in
+            yystreamify' p input
+          end
+
+    fun yystreamifyInstream' p strm = yystreamify' p (fn ()=>TextIO.input strm)
+
+    fun innerLex 
+(yystrm_, yyss_, yysm) = let
+        (* current start state *)
+          val yyss = ref yyss_
+	  fun YYBEGIN ss = (yyss := ss)
+	(* current input stream *)
+          val yystrm = ref yystrm_
+	  fun yysetStrm strm = yystrm := strm
+	  fun yygetPos() = ULexBuffer.getpos (!yystrm)
+	  fun yystreamify input = yystreamify' (yygetPos()) input
+	  fun yystreamifyReader readFn strm = yystreamifyReader' (yygetPos()) readFn strm
+	  fun yystreamifyInstream strm = yystreamifyInstream' (yygetPos()) strm
+        (* start position of token -- can be updated via skip() *)
+	  val yystartPos = ref (yygetPos())
+	(* get one char of input *)
+	  fun yygetc strm = (case UTF8.getu ULexBuffer.getc strm
+                of (SOME (0w10, s')) => 
+		     (AntlrStreamPos.markNewLine yysm (ULexBuffer.getpos strm);
+		      SOME (0w10, s'))
+		 | x => x)
+          fun yygetList getc strm = let
+            val get1 = UTF8.getu getc
+            fun iter (strm, accum) = 
+	        (case get1 strm
+	          of NONE => rev accum
+	           | SOME (w, strm') => iter (strm', w::accum)
+	         (* end case *))
+          in
+            iter (strm, [])
+          end
+	(* create yytext *)
+	  fun yymksubstr(strm) = ULexBuffer.subtract (strm, !yystrm)
+	  fun yymktext(strm) = Substring.string (yymksubstr strm)
+	  fun yymkunicode(strm) = yygetList Substring.getc (yymksubstr strm)
+          open UserDeclarations
+          fun lex () = let
+            fun yystuck (yyNO_MATCH) = raise Fail "lexer reached a stuck state"
+	      | yystuck (yyMATCH (strm, action, old)) = 
+		  action (strm, old)
+	    val yypos = yygetPos()
+	    fun yygetlineNo strm = AntlrStreamPos.lineNo yysm (ULexBuffer.getpos strm)
+	    fun yygetcolNo  strm = AntlrStreamPos.colNo  yysm (ULexBuffer.getpos strm)
+	    fun yyactsToMatches (strm, [],	  oldMatches) = oldMatches
+	      | yyactsToMatches (strm, act::acts, oldMatches) = 
+		  yyMATCH (strm, act, yyactsToMatches (strm, acts, oldMatches))
+	    fun yygo actTable = 
+		(fn (~1, _, oldMatches) => yystuck oldMatches
+		  | (curState, strm, oldMatches) => let
+		      val (transitions, finals') = Vector.sub (yytable, curState)
+		      val finals = map (fn i => Vector.sub (actTable, i)) finals'
+		      fun tryfinal() = 
+		            yystuck (yyactsToMatches (strm, finals, oldMatches))
+		      fun find (c, []) = NONE
+			| find (c, (c1, c2, s)::ts) = 
+		            if c1 <= c andalso c <= c2 then SOME s
+			    else find (c, ts)
+		      in case yygetc strm
+			  of SOME(c, strm') => 
+			       (case find (c, transitions)
+				 of NONE => tryfinal()
+				  | SOME n => 
+				      yygo actTable
+					(n, strm', 
+					 yyactsToMatches (strm, finals, oldMatches)))
+			   | NONE => tryfinal()
+		      end)
+	    val yylastwasnref = ref (ULexBuffer.lastWasNL (!yystrm))
+	    fun continue() = let val yylastwasn = !yylastwasnref in
+let
+fun yyAction0 (strm, lastMatch : yymatch) = (yystrm := strm;   skip() )
+fun yyAction1 (strm, lastMatch : yymatch) = (yystrm := strm;   T.LCB )
+fun yyAction2 (strm, lastMatch : yymatch) = (yystrm := strm;   T.RCB )
+fun yyAction3 (strm, lastMatch : yymatch) = (yystrm := strm;   T.LB )
+fun yyAction4 (strm, lastMatch : yymatch) = (yystrm := strm;   T.RB )
+fun yyAction5 (strm, lastMatch : yymatch) = (yystrm := strm;   T.COMMA )
+fun yyAction6 (strm, lastMatch : yymatch) = (yystrm := strm;   T.COLON )
+fun yyAction7 (strm, lastMatch : yymatch) = (yystrm := strm;   T.KW_null )
+fun yyAction8 (strm, lastMatch : yymatch) = (yystrm := strm;   T.KW_true )
+fun yyAction9 (strm, lastMatch : yymatch) = (yystrm := strm;   T.KW_false )
+fun yyAction10 (strm, lastMatch : yymatch) = let
+      val yytext = yymktext(strm)
+      in
+        yystrm := strm;   T.INT(valOf(IntInf.fromString yytext)) 
+      end
+fun yyAction11 (strm, lastMatch : yymatch) = let
+      val yytext = yymktext(strm)
+      in
+        yystrm := strm;   float yytext 
+      end
+fun yyAction12 (strm, lastMatch : yymatch) = let
+      val yytext = yymktext(strm)
+      in
+        yystrm := strm;   float yytext 
+      end
+fun yyAction13 (strm, lastMatch : yymatch) = let
+      val yytext = yymktext(strm)
+      in
+        yystrm := strm;   float yytext 
+      end
+fun yyAction14 (strm, lastMatch : yymatch) = (yystrm := strm;
+        YYBEGIN S; continue() )
+fun yyAction15 (strm, lastMatch : yymatch) = (yystrm := strm;
+        addStr "\\"; continue() )
+fun yyAction16 (strm, lastMatch : yymatch) = (yystrm := strm;
+        addStr "\""; continue() )
+fun yyAction17 (strm, lastMatch : yymatch) = (yystrm := strm;
+        addStr "/"; continue() )
+fun yyAction18 (strm, lastMatch : yymatch) = (yystrm := strm;
+        addStr "\b"; continue() )
+fun yyAction19 (strm, lastMatch : yymatch) = (yystrm := strm;
+        addStr "\f"; continue() )
+fun yyAction20 (strm, lastMatch : yymatch) = (yystrm := strm;
+        addStr "\n"; continue() )
+fun yyAction21 (strm, lastMatch : yymatch) = (yystrm := strm;
+        addStr "\r"; continue() )
+fun yyAction22 (strm, lastMatch : yymatch) = (yystrm := strm;
+        addStr "\t"; continue() )
+fun yyAction23 (strm, lastMatch : yymatch) = let
+      val yytext = yymktext(strm)
+      in
+        yystrm := strm;   addUChr yytext; continue() 
+      end
+fun yyAction24 (strm, lastMatch : yymatch) = let
+      val yytext = yymktext(strm)
+      in
+        yystrm := strm;   addStr yytext; continue() 
+      end
+fun yyAction25 (strm, lastMatch : yymatch) = (yystrm := strm;
+        YYBEGIN INITIAL; finishString() )
+fun yyAction26 (strm, lastMatch : yymatch) = (yystrm := strm;   skip() )
+fun yyAction27 (strm, lastMatch : yymatch) = (yystrm := strm;   skip() )
+fun yyQ33 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yyAction2(strm, yyNO_MATCH)
+        | SOME(inp, strm') => yyAction2(strm, yyNO_MATCH)
+      (* end case *))
+fun yyQ32 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yyAction1(strm, yyNO_MATCH)
+        | SOME(inp, strm') => yyAction1(strm, yyNO_MATCH)
+      (* end case *))
+fun yyQ36 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yyAction8(strm, yyNO_MATCH)
+        | SOME(inp, strm') => yyAction8(strm, yyNO_MATCH)
+      (* end case *))
+fun yyQ35 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yystuck(lastMatch)
+        | SOME(inp, strm') =>
+            if inp = 0wx65
+              then yyQ36(strm', lastMatch)
+              else yystuck(lastMatch)
+      (* end case *))
+fun yyQ34 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yystuck(lastMatch)
+        | SOME(inp, strm') =>
+            if inp = 0wx75
+              then yyQ35(strm', lastMatch)
+              else yystuck(lastMatch)
+      (* end case *))
+fun yyQ31 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yyAction27(strm, yyNO_MATCH)
+        | SOME(inp, strm') =>
+            if inp = 0wx72
+              then yyQ34(strm', yyMATCH(strm, yyAction27, yyNO_MATCH))
+              else yyAction27(strm, yyNO_MATCH)
+      (* end case *))
+fun yyQ39 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yyAction7(strm, yyNO_MATCH)
+        | SOME(inp, strm') => yyAction7(strm, yyNO_MATCH)
+      (* end case *))
+fun yyQ38 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yystuck(lastMatch)
+        | SOME(inp, strm') =>
+            if inp = 0wx6C
+              then yyQ39(strm', lastMatch)
+              else yystuck(lastMatch)
+      (* end case *))
+fun yyQ37 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yystuck(lastMatch)
+        | SOME(inp, strm') =>
+            if inp = 0wx6C
+              then yyQ38(strm', lastMatch)
+              else yystuck(lastMatch)
+      (* end case *))
+fun yyQ30 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yyAction27(strm, yyNO_MATCH)
+        | SOME(inp, strm') =>
+            if inp = 0wx75
+              then yyQ37(strm', yyMATCH(strm, yyAction27, yyNO_MATCH))
+              else yyAction27(strm, yyNO_MATCH)
+      (* end case *))
+fun yyQ43 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yyAction9(strm, yyNO_MATCH)
+        | SOME(inp, strm') => yyAction9(strm, yyNO_MATCH)
+      (* end case *))
+fun yyQ42 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yystuck(lastMatch)
+        | SOME(inp, strm') =>
+            if inp = 0wx65
+              then yyQ43(strm', lastMatch)
+              else yystuck(lastMatch)
+      (* end case *))
+fun yyQ41 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yystuck(lastMatch)
+        | SOME(inp, strm') =>
+            if inp = 0wx73
+              then yyQ42(strm', lastMatch)
+              else yystuck(lastMatch)
+      (* end case *))
+fun yyQ40 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yystuck(lastMatch)
+        | SOME(inp, strm') =>
+            if inp = 0wx6C
+              then yyQ41(strm', lastMatch)
+              else yystuck(lastMatch)
+      (* end case *))
+fun yyQ29 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yyAction27(strm, yyNO_MATCH)
+        | SOME(inp, strm') =>
+            if inp = 0wx61
+              then yyQ40(strm', yyMATCH(strm, yyAction27, yyNO_MATCH))
+              else yyAction27(strm, yyNO_MATCH)
+      (* end case *))
+fun yyQ28 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yyAction4(strm, yyNO_MATCH)
+        | SOME(inp, strm') => yyAction4(strm, yyNO_MATCH)
+      (* end case *))
+fun yyQ27 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yyAction3(strm, yyNO_MATCH)
+        | SOME(inp, strm') => yyAction3(strm, yyNO_MATCH)
+      (* end case *))
+fun yyQ26 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yyAction6(strm, yyNO_MATCH)
+        | SOME(inp, strm') => yyAction6(strm, yyNO_MATCH)
+      (* end case *))
+fun yyQ48 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yyAction12(strm, yyNO_MATCH)
+        | SOME(inp, strm') =>
+            if inp = 0wx30
+              then yyQ48(strm', yyMATCH(strm, yyAction12, yyNO_MATCH))
+            else if inp < 0wx30
+              then yyAction12(strm, yyNO_MATCH)
+            else if inp <= 0wx39
+              then yyQ48(strm', yyMATCH(strm, yyAction12, yyNO_MATCH))
+              else yyAction12(strm, yyNO_MATCH)
+      (* end case *))
+fun yyQ47 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yystuck(lastMatch)
+        | SOME(inp, strm') =>
+            if inp = 0wx30
+              then yyQ48(strm', lastMatch)
+            else if inp < 0wx30
+              then yystuck(lastMatch)
+            else if inp <= 0wx39
+              then yyQ48(strm', lastMatch)
+              else yystuck(lastMatch)
+      (* end case *))
+fun yyQ46 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yystuck(lastMatch)
+        | SOME(inp, strm') =>
+            if inp = 0wx2D
+              then yyQ47(strm', lastMatch)
+            else if inp < 0wx2D
+              then if inp = 0wx2B
+                  then yyQ47(strm', lastMatch)
+                  else yystuck(lastMatch)
+            else if inp = 0wx30
+              then yyQ48(strm', lastMatch)
+            else if inp < 0wx30
+              then yystuck(lastMatch)
+            else if inp <= 0wx39
+              then yyQ48(strm', lastMatch)
+              else yystuck(lastMatch)
+      (* end case *))
+fun yyQ52 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yyAction13(strm, yyNO_MATCH)
+        | SOME(inp, strm') =>
+            if inp = 0wx30
+              then yyQ52(strm', yyMATCH(strm, yyAction13, yyNO_MATCH))
+            else if inp < 0wx30
+              then yyAction13(strm, yyNO_MATCH)
+            else if inp <= 0wx39
+              then yyQ52(strm', yyMATCH(strm, yyAction13, yyNO_MATCH))
+              else yyAction13(strm, yyNO_MATCH)
+      (* end case *))
+fun yyQ51 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yystuck(lastMatch)
+        | SOME(inp, strm') =>
+            if inp = 0wx30
+              then yyQ52(strm', lastMatch)
+            else if inp < 0wx30
+              then yystuck(lastMatch)
+            else if inp <= 0wx39
+              then yyQ52(strm', lastMatch)
+              else yystuck(lastMatch)
+      (* end case *))
+fun yyQ50 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yystuck(lastMatch)
+        | SOME(inp, strm') =>
+            if inp = 0wx2D
+              then yyQ51(strm', lastMatch)
+            else if inp < 0wx2D
+              then if inp = 0wx2B
+                  then yyQ51(strm', lastMatch)
+                  else yystuck(lastMatch)
+            else if inp = 0wx30
+              then yyQ52(strm', lastMatch)
+            else if inp < 0wx30
+              then yystuck(lastMatch)
+            else if inp <= 0wx39
+              then yyQ52(strm', lastMatch)
+              else yystuck(lastMatch)
+      (* end case *))
+fun yyQ49 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yyAction11(strm, yyNO_MATCH)
+        | SOME(inp, strm') =>
+            if inp = 0wx45
+              then yyQ50(strm', yyMATCH(strm, yyAction11, yyNO_MATCH))
+            else if inp < 0wx45
+              then if inp = 0wx30
+                  then yyQ49(strm', yyMATCH(strm, yyAction11, yyNO_MATCH))
+                else if inp < 0wx30
+                  then yyAction11(strm, yyNO_MATCH)
+                else if inp <= 0wx39
+                  then yyQ49(strm', yyMATCH(strm, yyAction11, yyNO_MATCH))
+                  else yyAction11(strm, yyNO_MATCH)
+            else if inp = 0wx65
+              then yyQ50(strm', yyMATCH(strm, yyAction11, yyNO_MATCH))
+              else yyAction11(strm, yyNO_MATCH)
+      (* end case *))
+fun yyQ44 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yystuck(lastMatch)
+        | SOME(inp, strm') =>
+            if inp = 0wx30
+              then yyQ49(strm', lastMatch)
+            else if inp < 0wx30
+              then yystuck(lastMatch)
+            else if inp <= 0wx39
+              then yyQ49(strm', lastMatch)
+              else yystuck(lastMatch)
+      (* end case *))
+fun yyQ45 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yyAction10(strm, yyNO_MATCH)
+        | SOME(inp, strm') =>
+            if inp = 0wx3A
+              then yyAction10(strm, yyNO_MATCH)
+            else if inp < 0wx3A
+              then if inp = 0wx2F
+                  then yyAction10(strm, yyNO_MATCH)
+                else if inp < 0wx2F
+                  then if inp = 0wx2E
+                      then yyQ44(strm', yyMATCH(strm, yyAction10, yyNO_MATCH))
+                      else yyAction10(strm, yyNO_MATCH)
+                  else yyQ45(strm', yyMATCH(strm, yyAction10, yyNO_MATCH))
+            else if inp = 0wx46
+              then yyAction10(strm, yyNO_MATCH)
+            else if inp < 0wx46
+              then if inp = 0wx45
+                  then yyQ46(strm', yyMATCH(strm, yyAction10, yyNO_MATCH))
+                  else yyAction10(strm, yyNO_MATCH)
+            else if inp = 0wx65
+              then yyQ46(strm', yyMATCH(strm, yyAction10, yyNO_MATCH))
+              else yyAction10(strm, yyNO_MATCH)
+      (* end case *))
+fun yyQ25 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yyAction10(strm, yyNO_MATCH)
+        | SOME(inp, strm') =>
+            if inp = 0wx3A
+              then yyAction10(strm, yyNO_MATCH)
+            else if inp < 0wx3A
+              then if inp = 0wx2F
+                  then yyAction10(strm, yyNO_MATCH)
+                else if inp < 0wx2F
+                  then if inp = 0wx2E
+                      then yyQ44(strm', yyMATCH(strm, yyAction10, yyNO_MATCH))
+                      else yyAction10(strm, yyNO_MATCH)
+                  else yyQ45(strm', yyMATCH(strm, yyAction10, yyNO_MATCH))
+            else if inp = 0wx46
+              then yyAction10(strm, yyNO_MATCH)
+            else if inp < 0wx46
+              then if inp = 0wx45
+                  then yyQ46(strm', yyMATCH(strm, yyAction10, yyNO_MATCH))
+                  else yyAction10(strm, yyNO_MATCH)
+            else if inp = 0wx65
+              then yyQ46(strm', yyMATCH(strm, yyAction10, yyNO_MATCH))
+              else yyAction10(strm, yyNO_MATCH)
+      (* end case *))
+fun yyQ24 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yyAction10(strm, yyNO_MATCH)
+        | SOME(inp, strm') =>
+            if inp = 0wx45
+              then yyQ46(strm', yyMATCH(strm, yyAction10, yyNO_MATCH))
+            else if inp < 0wx45
+              then if inp = 0wx2E
+                  then yyQ44(strm', yyMATCH(strm, yyAction10, yyNO_MATCH))
+                  else yyAction10(strm, yyNO_MATCH)
+            else if inp = 0wx65
+              then yyQ46(strm', yyMATCH(strm, yyAction10, yyNO_MATCH))
+              else yyAction10(strm, yyNO_MATCH)
+      (* end case *))
+fun yyQ57 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yystuck(lastMatch)
+        | SOME(inp, strm') =>
+            if inp = 0wx2A
+              then yyQ57(strm', lastMatch)
+              else yyQ56(strm', lastMatch)
+      (* end case *))
+and yyQ56 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yystuck(lastMatch)
+        | SOME(inp, strm') =>
+            if inp = 0wx2A
+              then yyQ57(strm', lastMatch)
+              else yyQ56(strm', lastMatch)
+      (* end case *))
+fun yyQ55 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yyAction26(strm, yyNO_MATCH)
+        | SOME(inp, strm') =>
+            if inp = 0wx2A
+              then yyQ57(strm', yyMATCH(strm, yyAction26, yyNO_MATCH))
+              else yyQ56(strm', yyMATCH(strm, yyAction26, yyNO_MATCH))
+      (* end case *))
+fun yyQ53 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yystuck(lastMatch)
+        | SOME(inp, strm') =>
+            if inp = 0wx2A
+              then yyQ54(strm', lastMatch)
+              else yyQ53(strm', lastMatch)
+      (* end case *))
+and yyQ54 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yystuck(lastMatch)
+        | SOME(inp, strm') =>
+            if inp = 0wx2B
+              then yyQ53(strm', lastMatch)
+            else if inp < 0wx2B
+              then if inp = 0wx2A
+                  then yyQ54(strm', lastMatch)
+                  else yyQ53(strm', lastMatch)
+            else if inp = 0wx2F
+              then yyQ55(strm', lastMatch)
+              else yyQ53(strm', lastMatch)
+      (* end case *))
+fun yyQ23 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yyAction27(strm, yyNO_MATCH)
+        | SOME(inp, strm') =>
+            if inp = 0wx2A
+              then yyQ53(strm', yyMATCH(strm, yyAction27, yyNO_MATCH))
+              else yyAction27(strm, yyNO_MATCH)
+      (* end case *))
+fun yyQ59 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yyAction10(strm, yyNO_MATCH)
+        | SOME(inp, strm') =>
+            if inp = 0wx3A
+              then yyAction10(strm, yyNO_MATCH)
+            else if inp < 0wx3A
+              then if inp = 0wx2F
+                  then yyAction10(strm, yyNO_MATCH)
+                else if inp < 0wx2F
+                  then if inp = 0wx2E
+                      then yyQ44(strm', yyMATCH(strm, yyAction10, yyNO_MATCH))
+                      else yyAction10(strm, yyNO_MATCH)
+                  else yyQ45(strm', yyMATCH(strm, yyAction10, yyNO_MATCH))
+            else if inp = 0wx46
+              then yyAction10(strm, yyNO_MATCH)
+            else if inp < 0wx46
+              then if inp = 0wx45
+                  then yyQ46(strm', yyMATCH(strm, yyAction10, yyNO_MATCH))
+                  else yyAction10(strm, yyNO_MATCH)
+            else if inp = 0wx65
+              then yyQ46(strm', yyMATCH(strm, yyAction10, yyNO_MATCH))
+              else yyAction10(strm, yyNO_MATCH)
+      (* end case *))
+fun yyQ58 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yyAction10(strm, yyNO_MATCH)
+        | SOME(inp, strm') =>
+            if inp = 0wx45
+              then yyQ46(strm', yyMATCH(strm, yyAction10, yyNO_MATCH))
+            else if inp < 0wx45
+              then if inp = 0wx2E
+                  then yyQ44(strm', yyMATCH(strm, yyAction10, yyNO_MATCH))
+                  else yyAction10(strm, yyNO_MATCH)
+            else if inp = 0wx65
+              then yyQ46(strm', yyMATCH(strm, yyAction10, yyNO_MATCH))
+              else yyAction10(strm, yyNO_MATCH)
+      (* end case *))
+fun yyQ22 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yyAction27(strm, yyNO_MATCH)
+        | SOME(inp, strm') =>
+            if inp = 0wx31
+              then yyQ59(strm', yyMATCH(strm, yyAction27, yyNO_MATCH))
+            else if inp < 0wx31
+              then if inp = 0wx30
+                  then yyQ58(strm', yyMATCH(strm, yyAction27, yyNO_MATCH))
+                  else yyAction27(strm, yyNO_MATCH)
+            else if inp <= 0wx39
+              then yyQ59(strm', yyMATCH(strm, yyAction27, yyNO_MATCH))
+              else yyAction27(strm, yyNO_MATCH)
+      (* end case *))
+fun yyQ21 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yyAction5(strm, yyNO_MATCH)
+        | SOME(inp, strm') => yyAction5(strm, yyNO_MATCH)
+      (* end case *))
+fun yyQ20 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yyAction14(strm, yyNO_MATCH)
+        | SOME(inp, strm') => yyAction14(strm, yyNO_MATCH)
+      (* end case *))
+fun yyQ60 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yyAction0(strm, yyNO_MATCH)
+        | SOME(inp, strm') =>
+            if inp = 0wxD
+              then yyQ60(strm', yyMATCH(strm, yyAction0, yyNO_MATCH))
+            else if inp < 0wxD
+              then if inp = 0wx9
+                  then yyQ60(strm', yyMATCH(strm, yyAction0, yyNO_MATCH))
+                else if inp < 0wx9
+                  then yyAction0(strm, yyNO_MATCH)
+                else if inp <= 0wxA
+                  then yyQ60(strm', yyMATCH(strm, yyAction0, yyNO_MATCH))
+                  else yyAction0(strm, yyNO_MATCH)
+            else if inp = 0wx20
+              then yyQ60(strm', yyMATCH(strm, yyAction0, yyNO_MATCH))
+              else yyAction0(strm, yyNO_MATCH)
+      (* end case *))
+fun yyQ19 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yyAction0(strm, yyNO_MATCH)
+        | SOME(inp, strm') =>
+            if inp = 0wxD
+              then yyQ60(strm', yyMATCH(strm, yyAction0, yyNO_MATCH))
+            else if inp < 0wxD
+              then if inp = 0wx9
+                  then yyQ60(strm', yyMATCH(strm, yyAction0, yyNO_MATCH))
+                else if inp < 0wx9
+                  then yyAction0(strm, yyNO_MATCH)
+                else if inp <= 0wxA
+                  then yyQ60(strm', yyMATCH(strm, yyAction0, yyNO_MATCH))
+                  else yyAction0(strm, yyNO_MATCH)
+            else if inp = 0wx20
+              then yyQ60(strm', yyMATCH(strm, yyAction0, yyNO_MATCH))
+              else yyAction0(strm, yyNO_MATCH)
+      (* end case *))
+fun yyQ18 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yyAction27(strm, yyNO_MATCH)
+        | SOME(inp, strm') => yyAction27(strm, yyNO_MATCH)
+      (* end case *))
+fun yyQ1 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE =>
+            if ULexBuffer.eof(!(yystrm))
+              then let
+                val yycolno = ref(yygetcolNo(!(yystrm)))
+                val yylineno = ref(yygetlineNo(!(yystrm)))
+                in
+                  (case (!(yyss))
+                   of _ => (UserDeclarations.eof())
+                  (* end case *))
+                end
+              else yystuck(lastMatch)
+        | SOME(inp, strm') =>
+            if inp = 0wx3A
+              then yyQ26(strm', lastMatch)
+            else if inp < 0wx3A
+              then if inp = 0wx22
+                  then yyQ20(strm', lastMatch)
+                else if inp < 0wx22
+                  then if inp = 0wxD
+                      then yyQ19(strm', lastMatch)
+                    else if inp < 0wxD
+                      then if inp = 0wx9
+                          then yyQ19(strm', lastMatch)
+                        else if inp < 0wx9
+                          then yyQ18(strm', lastMatch)
+                        else if inp <= 0wxA
+                          then yyQ19(strm', lastMatch)
+                          else yyQ18(strm', lastMatch)
+                    else if inp = 0wx20
+                      then yyQ19(strm', lastMatch)
+                      else yyQ18(strm', lastMatch)
+                else if inp = 0wx2E
+                  then yyQ18(strm', lastMatch)
+                else if inp < 0wx2E
+                  then if inp = 0wx2C
+                      then yyQ21(strm', lastMatch)
+                    else if inp = 0wx2D
+                      then yyQ22(strm', lastMatch)
+                      else yyQ18(strm', lastMatch)
+                else if inp = 0wx30
+                  then yyQ24(strm', lastMatch)
+                else if inp = 0wx2F
+                  then yyQ23(strm', lastMatch)
+                  else yyQ25(strm', lastMatch)
+            else if inp = 0wx6E
+              then yyQ30(strm', lastMatch)
+            else if inp < 0wx6E
+              then if inp = 0wx5D
+                  then yyQ28(strm', lastMatch)
+                else if inp < 0wx5D
+                  then if inp = 0wx5B
+                      then yyQ27(strm', lastMatch)
+                      else yyQ18(strm', lastMatch)
+                else if inp = 0wx66
+                  then yyQ29(strm', lastMatch)
+                  else yyQ18(strm', lastMatch)
+            else if inp = 0wx7B
+              then yyQ32(strm', lastMatch)
+            else if inp < 0wx7B
+              then if inp = 0wx74
+                  then yyQ31(strm', lastMatch)
+                  else yyQ18(strm', lastMatch)
+            else if inp = 0wx7D
+              then yyQ33(strm', lastMatch)
+              else yyQ18(strm', lastMatch)
+      (* end case *))
+fun yyQ17 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yyAction23(strm, yyNO_MATCH)
+        | SOME(inp, strm') => yyAction23(strm, yyNO_MATCH)
+      (* end case *))
+fun yyQ16 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yystuck(lastMatch)
+        | SOME(inp, strm') =>
+            if inp = 0wx41
+              then yyQ17(strm', lastMatch)
+            else if inp < 0wx41
+              then if inp = 0wx30
+                  then yyQ17(strm', lastMatch)
+                else if inp < 0wx30
+                  then yystuck(lastMatch)
+                else if inp <= 0wx39
+                  then yyQ17(strm', lastMatch)
+                  else yystuck(lastMatch)
+            else if inp = 0wx61
+              then yyQ17(strm', lastMatch)
+            else if inp < 0wx61
+              then if inp <= 0wx46
+                  then yyQ17(strm', lastMatch)
+                  else yystuck(lastMatch)
+            else if inp <= 0wx66
+              then yyQ17(strm', lastMatch)
+              else yystuck(lastMatch)
+      (* end case *))
+fun yyQ15 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yystuck(lastMatch)
+        | SOME(inp, strm') =>
+            if inp = 0wx41
+              then yyQ16(strm', lastMatch)
+            else if inp < 0wx41
+              then if inp = 0wx30
+                  then yyQ16(strm', lastMatch)
+                else if inp < 0wx30
+                  then yystuck(lastMatch)
+                else if inp <= 0wx39
+                  then yyQ16(strm', lastMatch)
+                  else yystuck(lastMatch)
+            else if inp = 0wx61
+              then yyQ16(strm', lastMatch)
+            else if inp < 0wx61
+              then if inp <= 0wx46
+                  then yyQ16(strm', lastMatch)
+                  else yystuck(lastMatch)
+            else if inp <= 0wx66
+              then yyQ16(strm', lastMatch)
+              else yystuck(lastMatch)
+      (* end case *))
+fun yyQ14 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yystuck(lastMatch)
+        | SOME(inp, strm') =>
+            if inp = 0wx41
+              then yyQ15(strm', lastMatch)
+            else if inp < 0wx41
+              then if inp = 0wx30
+                  then yyQ15(strm', lastMatch)
+                else if inp < 0wx30
+                  then yystuck(lastMatch)
+                else if inp <= 0wx39
+                  then yyQ15(strm', lastMatch)
+                  else yystuck(lastMatch)
+            else if inp = 0wx61
+              then yyQ15(strm', lastMatch)
+            else if inp < 0wx61
+              then if inp <= 0wx46
+                  then yyQ15(strm', lastMatch)
+                  else yystuck(lastMatch)
+            else if inp <= 0wx66
+              then yyQ15(strm', lastMatch)
+              else yystuck(lastMatch)
+      (* end case *))
+fun yyQ13 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yystuck(lastMatch)
+        | SOME(inp, strm') =>
+            if inp = 0wx41
+              then yyQ14(strm', lastMatch)
+            else if inp < 0wx41
+              then if inp = 0wx30
+                  then yyQ14(strm', lastMatch)
+                else if inp < 0wx30
+                  then yystuck(lastMatch)
+                else if inp <= 0wx39
+                  then yyQ14(strm', lastMatch)
+                  else yystuck(lastMatch)
+            else if inp = 0wx61
+              then yyQ14(strm', lastMatch)
+            else if inp < 0wx61
+              then if inp <= 0wx46
+                  then yyQ14(strm', lastMatch)
+                  else yystuck(lastMatch)
+            else if inp <= 0wx66
+              then yyQ14(strm', lastMatch)
+              else yystuck(lastMatch)
+      (* end case *))
+fun yyQ12 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yyAction22(strm, yyNO_MATCH)
+        | SOME(inp, strm') => yyAction22(strm, yyNO_MATCH)
+      (* end case *))
+fun yyQ11 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yyAction21(strm, yyNO_MATCH)
+        | SOME(inp, strm') => yyAction21(strm, yyNO_MATCH)
+      (* end case *))
+fun yyQ10 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yyAction20(strm, yyNO_MATCH)
+        | SOME(inp, strm') => yyAction20(strm, yyNO_MATCH)
+      (* end case *))
+fun yyQ9 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yyAction19(strm, yyNO_MATCH)
+        | SOME(inp, strm') => yyAction19(strm, yyNO_MATCH)
+      (* end case *))
+fun yyQ8 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yyAction18(strm, yyNO_MATCH)
+        | SOME(inp, strm') => yyAction18(strm, yyNO_MATCH)
+      (* end case *))
+fun yyQ7 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yyAction15(strm, yyNO_MATCH)
+        | SOME(inp, strm') => yyAction15(strm, yyNO_MATCH)
+      (* end case *))
+fun yyQ6 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yyAction17(strm, yyNO_MATCH)
+        | SOME(inp, strm') => yyAction17(strm, yyNO_MATCH)
+      (* end case *))
+fun yyQ5 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yyAction16(strm, yyNO_MATCH)
+        | SOME(inp, strm') => yyAction16(strm, yyNO_MATCH)
+      (* end case *))
+fun yyQ4 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yystuck(lastMatch)
+        | SOME(inp, strm') =>
+            if inp = 0wx66
+              then yyQ9(strm', lastMatch)
+            else if inp < 0wx66
+              then if inp = 0wx30
+                  then yystuck(lastMatch)
+                else if inp < 0wx30
+                  then if inp = 0wx23
+                      then yystuck(lastMatch)
+                    else if inp < 0wx23
+                      then if inp = 0wx22
+                          then yyQ5(strm', lastMatch)
+                          else yystuck(lastMatch)
+                    else if inp = 0wx2F
+                      then yyQ6(strm', lastMatch)
+                      else yystuck(lastMatch)
+                else if inp = 0wx5D
+                  then yystuck(lastMatch)
+                else if inp < 0wx5D
+                  then if inp = 0wx5C
+                      then yyQ7(strm', lastMatch)
+                      else yystuck(lastMatch)
+                else if inp = 0wx62
+                  then yyQ8(strm', lastMatch)
+                  else yystuck(lastMatch)
+            else if inp = 0wx73
+              then yystuck(lastMatch)
+            else if inp < 0wx73
+              then if inp = 0wx6F
+                  then yystuck(lastMatch)
+                else if inp < 0wx6F
+                  then if inp = 0wx6E
+                      then yyQ10(strm', lastMatch)
+                      else yystuck(lastMatch)
+                else if inp = 0wx72
+                  then yyQ11(strm', lastMatch)
+                  else yystuck(lastMatch)
+            else if inp = 0wx75
+              then yyQ13(strm', lastMatch)
+            else if inp = 0wx74
+              then yyQ12(strm', lastMatch)
+              else yystuck(lastMatch)
+      (* end case *))
+fun yyQ3 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yyAction25(strm, yyNO_MATCH)
+        | SOME(inp, strm') => yyAction25(strm, yyNO_MATCH)
+      (* end case *))
+fun yyQ2 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE => yyAction24(strm, yyNO_MATCH)
+        | SOME(inp, strm') =>
+            if inp = 0wx23
+              then yyQ2(strm', yyMATCH(strm, yyAction24, yyNO_MATCH))
+            else if inp < 0wx23
+              then if inp = 0wx22
+                  then yyAction24(strm, yyNO_MATCH)
+                  else yyQ2(strm', yyMATCH(strm, yyAction24, yyNO_MATCH))
+            else if inp = 0wx5C
+              then yyAction24(strm, yyNO_MATCH)
+              else yyQ2(strm', yyMATCH(strm, yyAction24, yyNO_MATCH))
+      (* end case *))
+fun yyQ0 (strm, lastMatch : yymatch) = (case (yygetc(strm))
+       of NONE =>
+            if ULexBuffer.eof(!(yystrm))
+              then let
+                val yycolno = ref(yygetcolNo(!(yystrm)))
+                val yylineno = ref(yygetlineNo(!(yystrm)))
+                in
+                  (case (!(yyss))
+                   of _ => (UserDeclarations.eof())
+                  (* end case *))
+                end
+              else yystuck(lastMatch)
+        | SOME(inp, strm') =>
+            if inp = 0wx23
+              then yyQ2(strm', lastMatch)
+            else if inp < 0wx23
+              then if inp = 0wx22
+                  then yyQ3(strm', lastMatch)
+                  else yyQ2(strm', lastMatch)
+            else if inp = 0wx5C
+              then yyQ4(strm', lastMatch)
+              else yyQ2(strm', lastMatch)
+      (* end case *))
+in
+  (case (!(yyss))
+   of S => yyQ0(!(yystrm), yyNO_MATCH)
+    | INITIAL => yyQ1(!(yystrm), yyNO_MATCH)
+  (* end case *))
+end
+end
+            and skip() = (yystartPos := yygetPos(); 
+			  yylastwasnref := ULexBuffer.lastWasNL (!yystrm);
+			  continue())
+	    in (continue(), (!yystartPos, yygetPos()), !yystrm, !yyss) end
+          in 
+            lex()
+          end
+  in
+    type pos = AntlrStreamPos.pos
+    type span = AntlrStreamPos.span
+    type tok = UserDeclarations.lex_result
+
+    datatype prestrm = STRM of ULexBuffer.stream * 
+		(yystart_state * tok * span * prestrm * yystart_state) option ref
+    type strm = (prestrm * yystart_state)
+
+    fun lex sm 
+(STRM (yystrm, memo), ss) = (case !memo
+	  of NONE => let
+	     val (tok, span, yystrm', ss') = innerLex 
+(yystrm, ss, sm)
+	     val strm' = STRM (yystrm', ref NONE);
+	     in 
+	       memo := SOME (ss, tok, span, strm', ss');
+	       (tok, span, (strm', ss'))
+	     end
+	   | SOME (ss', tok, span, strm', ss'') => 
+	       if ss = ss' then
+		 (tok, span, (strm', ss''))
+	       else (
+		 memo := NONE;
+		 lex sm 
+(STRM (yystrm, memo), ss))
+         (* end case *))
+
+    fun streamify input = (STRM (yystreamify' 0 input, ref NONE), INITIAL)
+    fun streamifyReader readFn strm = (STRM (yystreamifyReader' 0 readFn strm, ref NONE), 
+				       INITIAL)
+    fun streamifyInstream strm = (STRM (yystreamifyInstream' 0 strm, ref NONE), 
+				  INITIAL)
+
+    fun getPos (STRM (strm, _), _) = ULexBuffer.getpos strm
+
+  end
+end

src/JSON/json.sml

@@ -0,0 +1,22 @@
+(* json.sml
+ *
+ * COPYRIGHT (c) 2008 The Fellowship of SML/NJ (http://www.smlnj.org)
+ * All rights reserved.
+ *
+ * This is the tree representation of a JSON data as produced/consumed
+ * by the tree parser.
+ *)
+
+structure JSON =
+  struct
+
+    datatype value
+      = OBJECT of (string * value) list
+      | ARRAY of value list
+      | NULL
+      | BOOL of bool
+      | INT of IntInf.int
+      | FLOAT of real
+      | STRING of string
+
+  end

src/JSON/patch/README.orig

@@ -0,0 +1,15 @@
+This library supports the reading and writing of structured data using
+the "JavaScript Object Notation" (JSON).  This format is specified by
+RFC 426 (http://tools.ietf.org/html/rfc4627).
+
+There are two levels of I/O supported.  The "stream" level supports
+event-based parsing (e.g., like a SAX parser for XML) and output at
+the same level.  Use this mode to extract small amounts of information
+from large files or when you want to directly build your own representation
+of the file.  The "file" level supports a "DOM-style" approach that reads/writes
+trees (see json.sml for the representation).
+
+TODO:
+  add support for UBJSON (http://ubjson.org) or possibly one of the
+  other binary JSON representations
+

src/JSON/patch/README.patch

@@ -0,0 +1,10 @@
+--- README.orig	2015-06-03 00:02:41.000000000 +0200
++++ README	2017-10-16 17:08:22.042559000 +0200
+@@ -1,6 +1,6 @@
+ This library supports the reading and writing of structured data using
+ the "JavaScript Object Notation" (JSON).  This format is specified by
+-RFC 426 (http://tools.ietf.org/html/rfc4627).
++RFC 7159 (https://tools.ietf.org/html/rfc7159).
+ 
+ There are two levels of I/O supported.  The "stream" level supports
+ event-based parsing (e.g., like a SAX parser for XML) and output at

src/JSON/patch/json-parser.sml.orig

@@ -0,0 +1,101 @@
+(* json-parser.sml
+ *
+ * COPYRIGHT (c) 2008 The Fellowship of SML/NJ (http://www.smlnj.org)
+ * All rights reserved.
+ *)
+
+structure JSONParser : sig
+
+    val parse : TextIO.instream -> JSON.value
+
+    val parseFile : string -> JSON.value
+
+  end = struct
+
+    structure Lex = JSONLexer
+    structure T = JSONTokens
+    structure J = JSON
+
+    fun parse' (srcMap, inStrm) = let
+	  fun error (pos, msg, tok) = raise Fail(concat[
+		  "error ", AntlrStreamPos.spanToString srcMap pos, ": ",
+		  msg, ", found '", JSONTokens.toString tok, "'"
+		])
+	  val lexer = Lex.lex srcMap
+	  fun parseValue (strm : Lex.strm) = let
+		val (tok, pos, strm) = lexer strm
+		in
+		  case tok
+		   of T.LB => parseArray strm
+		    | T.LCB => parseObject strm
+		    | T.KW_null => (strm, J.NULL)
+		    | T.KW_true => (strm, J.BOOL true)
+		    | T.KW_false => (strm, J.BOOL false)
+		    | T.INT n => (strm, J.INT n)
+		    | T.FLOAT f => (strm, J.FLOAT f)
+		    | T.STRING s => (strm, J.STRING s)
+		    | _ => error (pos, "parsing value", tok)
+		  (* end case *)
+		end
+	  and parseArray (strm : Lex.strm) = (case lexer strm
+		 of (T.RB, _, strm) => (strm, J.ARRAY[])
+		  | _ => let
+		      fun loop (strm, items) = let
+			    val (strm, v) = parseValue strm
+			  (* expect either a "," or a "]" *)
+			    val (tok, pos, strm) = lexer strm
+			    in
+			      case tok
+			       of T.RB => (strm, v::items)
+				| T.COMMA => loop (strm, v::items)
+				| _ => error (pos, "parsing array", tok)
+			      (* end case *)
+			    end
+		      val (strm, items) = loop (strm, [])
+		      in
+			(strm, J.ARRAY(List.rev items))
+		      end
+		(* end case *))
+	  and parseObject (strm : Lex.strm) = let
+		fun parseField strm = (case lexer strm
+		       of (T.STRING s, pos, strm) => (case lexer strm
+			     of (T.COLON, _, strm) => let
+				  val (strm, v) = parseValue strm
+				  in
+				    SOME(strm, (s, v))
+				  end
+			      | (tok, pos, _) => error (pos, "parsing field", tok)
+			    (* end case *))
+			| _ => NONE
+		      (* end case *))
+		fun loop (strm, flds) = (case parseField strm
+		       of SOME(strm, fld) => (
+			  (* expect either "," or "}" *)
+			    case lexer strm
+			     of (T.RCB, pos, strm) => (strm, fld::flds)
+			      | (T.COMMA, pos, strm) => loop (strm, fld::flds)
+			      | (tok, pos, _) => error (pos, "parsing object", tok)
+			    (* end case *))
+			| NONE => (strm, flds)
+		      (* end case *))
+		val (strm, flds) = loop (strm, [])
+		in
+		  (strm, J.OBJECT(List.rev flds))
+		end
+	  in
+	    #2 (parseValue (Lex.streamifyInstream inStrm))
+	  end
+
+    fun parse inStrm = parse' (AntlrStreamPos.mkSourcemap (), inStrm)
+
+    fun parseFile fileName = let
+	  val inStrm = TextIO.openIn fileName
+	  val v = parse' (AntlrStreamPos.mkSourcemap' fileName, inStrm)
+		handle ex => (TextIO.closeIn inStrm; raise ex)
+	  in
+	    TextIO.closeIn inStrm;
+	    v
+	  end
+
+  end
+

src/JSON/patch/json-parser.sml.patch

@@ -0,0 +1,102 @@
+--- json-parser.sml.orig	2011-05-10 20:58:08.000000000 +0200
++++ json-parser.sml	2017-10-03 23:21:14.612060000 +0200
+@@ -22,6 +22,26 @@
+ 		  msg, ", found '", JSONTokens.toString tok, "'"
+ 		])
+ 	  val lexer = Lex.lex srcMap
++	  fun parse_sequence (is_tok_end, parse_item) (strm : Lex.strm, itms) = let
++		fun is_tok_sep tok = case tok of T.COMMA => true | _ => false
++		val (tok, pos, strm') = lexer strm
++		in if is_tok_sep tok
++		   then error (pos, "parsing sequence", tok)
++		   else if is_tok_end tok
++			then (strm', itms)
++			else let val (strm'', itm) = parse_item strm
++				 val (tok', pos', strm''') = lexer strm''
++			     in if is_tok_end tok'
++				then (strm''', itm :: itms)
++				else if is_tok_sep tok'
++				     then let val (tok'', pos'', _) = lexer strm'''
++					  in if is_tok_end tok''
++					     then error (pos'', "parsing sequence", tok'')
++					     else parse_sequence (is_tok_end, parse_item) (strm''', itm :: itms)
++					  end
++				     else error (pos', "parsing sequence", tok')
++				 end
++		end
+ 	  fun parseValue (strm : Lex.strm) = let
+ 		val (tok, pos, strm) = lexer strm
+ 		in
+@@ -37,50 +57,29 @@
+ 		    | _ => error (pos, "parsing value", tok)
+ 		  (* end case *)
+ 		end
+-	  and parseArray (strm : Lex.strm) = (case lexer strm
+-		 of (T.RB, _, strm) => (strm, J.ARRAY[])
+-		  | _ => let
+-		      fun loop (strm, items) = let
+-			    val (strm, v) = parseValue strm
+-			  (* expect either a "," or a "]" *)
+-			    val (tok, pos, strm) = lexer strm
+-			    in
+-			      case tok
+-			       of T.RB => (strm, v::items)
+-				| T.COMMA => loop (strm, v::items)
+-				| _ => error (pos, "parsing array", tok)
+-			      (* end case *)
+-			    end
+-		      val (strm, items) = loop (strm, [])
+-		      in
+-			(strm, J.ARRAY(List.rev items))
+-		      end
+-		(* end case *))
++	  and parseArray (strm : Lex.strm) = let
++		fun is_RB tok = case tok of T.RB => true | _ => false
++		val (strm', elmnts) = parse_sequence (is_RB, parseValue) (strm, [])
++		in (strm', J.ARRAY(List.rev elmnts))
++		end
+ 	  and parseObject (strm : Lex.strm) = let
+-		fun parseField strm = (case lexer strm
+-		       of (T.STRING s, pos, strm) => (case lexer strm
+-			     of (T.COLON, _, strm) => let
+-				  val (strm, v) = parseValue strm
+-				  in
+-				    SOME(strm, (s, v))
+-				  end
+-			      | (tok, pos, _) => error (pos, "parsing field", tok)
+-			    (* end case *))
+-			| _ => NONE
+-		      (* end case *))
+-		fun loop (strm, flds) = (case parseField strm
+-		       of SOME(strm, fld) => (
+-			  (* expect either "," or "}" *)
+-			    case lexer strm
+-			     of (T.RCB, pos, strm) => (strm, fld::flds)
+-			      | (T.COMMA, pos, strm) => loop (strm, fld::flds)
+-			      | (tok, pos, _) => error (pos, "parsing object", tok)
+-			    (* end case *))
+-			| NONE => (strm, flds)
+-		      (* end case *))
+-		val (strm, flds) = loop (strm, [])
+-		in
+-		  (strm, J.OBJECT(List.rev flds))
++		fun is_RCB tok = case tok of T.RCB => true | _ => false
++		fun parse_field strm = let
++			val (tok, pos, strm') = lexer strm
++			in case tok
++			    of T.STRING s =>
++				(case lexer strm'
++				  of (T.COLON, _, strm'') => let
++					val (strm''', v) = parseValue strm''
++					in (strm''', (s, v))
++					end
++				   | (tok', pos', _) => error (pos', "parsing field", tok')
++				 (* end case *))
++			     | _ => error (pos, "parsing field", tok)
++			   (* end case *)
++			end
++		val (strm', flds) = parse_sequence (is_RCB, parse_field) (strm, [])
++		in (strm', J.OBJECT(List.rev flds))
+ 		end
+ 	  in
+ 	    #2 (parseValue (Lex.streamifyInstream inStrm))

src/JSON/patch/json-stream-printer.sml.orig

@@ -0,0 +1,143 @@
+(* json-stream-printer.sml
+ *
+ * COPYRIGHT (c) 2008 The Fellowship of SML/NJ (http://www.smlnj.org)
+ * All rights reserved.
+ *)
+
+structure JSONStreamPrinter : sig
+
+    type printer
+
+    val null : printer -> unit
+    val boolean : printer * bool -> unit
+    val integer : printer * IntInf.int -> unit
+    val float : printer * real -> unit
+    val string : printer * string -> unit
+    val beginObject : printer -> unit
+    val objectKey : printer * string -> unit
+    val endObject : printer -> unit
+    val beginArray : printer -> unit
+    val endArray : printer -> unit
+
+    val new : TextIO.outstream -> printer
+    val new' : {strm : TextIO.outstream, pretty : bool} -> printer
+    val close : printer -> unit
+
+  end = struct
+
+    structure F = Format
+
+    datatype printer = P of {
+	strm : TextIO.outstream,
+	indent : int ref,
+	ctx : context ref,
+	pretty : bool
+      }
+
+  (* the context is used to keep track of the printing state for indentation
+   * and punctuation, etc.
+   *)
+    and context
+      = TOP			(* top-most context *)
+      | FIRST of context	(* first element of object or array; the argument *)
+				(* must be one of OBJECT or ARRAY. *)
+      | OBJECT of context	(* in an object (after the first element) *)
+      | ARRAY of context	(* in an array (after the first element) *)
+      | KEY of context		(* after the key of a object field *)
+
+    fun new' {strm, pretty} = P{
+	    strm = strm,
+	    indent = ref 0,
+	    ctx = ref TOP,
+	    pretty = pretty
+	  }
+
+    fun new strm = new' {strm = strm, pretty = false}
+
+    fun close (P{ctx = ref TOP, strm, ...}) = TextIO.output(strm, "\n")
+      | close _ = raise Fail "premature close"
+
+    fun pr (P{strm, ...}, s) = TextIO.output(strm, s)
+
+    fun indent (P{pretty = false, ...}, _) = ()
+      | indent (P{strm, indent, ...}, offset) = let
+	  val tenSpaces = "          "
+	  fun prIndent n = if (n <= 10)
+		then TextIO.output(strm, String.extract(tenSpaces, 10-n, NONE))
+		else (TextIO.output(strm, tenSpaces); prIndent(n-10))
+	  in
+	    prIndent ((!indent+offset) * 2)
+	  end
+
+    fun incIndent (P{indent, ...}, n) = indent := !indent + n;
+    fun decIndent (P{indent, ...}, n) = indent := !indent - n;
+
+    fun nl (P{pretty = false, ...}) = ()
+      | nl (P{strm, ...}) = TextIO.output(strm, "\n")
+
+    fun comma (P{strm, pretty = false, ...}) = TextIO.output(strm, ",")
+      | comma (p as P{strm, ...}) = (
+	  TextIO.output(strm, ",\n"); indent(p, 0))
+
+    fun optComma (p as P{ctx, pretty, ...}) = (case !ctx
+	   of FIRST ctx' => (indent(p, 0); ctx := ctx')
+	    | OBJECT _ => comma p
+	    | ARRAY _ => comma p
+	    | KEY ctx' => (
+		pr (p, if pretty then " : " else ":");
+		ctx := ctx')
+	    | _ => ()
+	  (* end case *))
+
+  (* print a value, which may be proceeded by a comma if it is in a sequence *)
+    fun prVal (p, v) = (optComma p; pr(p, v))
+
+    fun null p = prVal (p, "null")
+    fun boolean (p, false) = prVal (p, "false")
+      | boolean (p, true) = prVal (p, "true")
+    fun integer (p, n) = prVal (p, F.format "%d" [F.LINT n])
+    fun float (p, f) = prVal (p, F.format "%g" [F.REAL f])
+(* FIXME: need to deal with UTF-* escapes *)
+    fun string (p, s) = prVal (p, F.format "\"%s\"" [F.STR(String.toCString s)])
+
+    fun beginObject (p as P{ctx, ...}) = (
+	  optComma p;
+	  pr (p, "{"); incIndent(p, 2); nl p;
+	  ctx := FIRST(OBJECT(!ctx)))
+
+    fun objectKey (p as P{ctx = ref(KEY _), ...}, field) =
+	  raise Fail(concat["objectKey \"", field, "\" where value was expected"])
+      | objectKey (p as P{ctx, ...}, field) = (
+	  string (p, field);
+	  ctx := KEY(!ctx))
+
+    fun endObject (p as P{ctx, ...}) = let
+	  fun prEnd ctx' = (
+		ctx := ctx';
+		indent(p, ~1); pr(p, "}"); decIndent (p, 2))
+	  in
+	    case !ctx
+	     of OBJECT ctx' => (nl p; prEnd ctx')
+	      | FIRST(OBJECT ctx') => prEnd ctx'
+	      | _ => raise Fail "endObject not in object context"
+	    (* end case *)
+	  end
+
+    fun beginArray (p as P{ctx, ...}) = (
+	  optComma p;
+	  pr (p, "["); incIndent(p, 2); nl p;
+	  ctx := FIRST(ARRAY(!ctx)))
+
+    fun endArray (p as P{ctx, ...}) = let
+	  fun prEnd ctx' = (
+		ctx := ctx';
+		nl p; indent(p, ~1); pr(p, "]"); decIndent (p, 2))
+	  in
+	    case !ctx
+	     of ARRAY ctx' => prEnd ctx'
+	      | FIRST(ARRAY ctx') => prEnd ctx'
+	      | _ => raise Fail "endArray not in array context"
+	    (* end case *)
+	  end
+
+  end

src/JSON/patch/json-stream-printer.sml.patch

@@ -0,0 +1,63 @@
+--- json-stream-printer.sml.orig	2008-05-20 20:08:00.000000000 +0200
++++ json-stream-printer.sml	2017-10-13 00:04:34.575739000 +0200
+@@ -66,7 +66,7 @@
+ 		then TextIO.output(strm, String.extract(tenSpaces, 10-n, NONE))
+ 		else (TextIO.output(strm, tenSpaces); prIndent(n-10))
+ 	  in
+-	    prIndent ((!indent+offset) * 2)
++	    prIndent (!indent+offset)
+ 	  end
+ 
+     fun incIndent (P{indent, ...}, n) = indent := !indent + n;
+@@ -98,11 +98,23 @@
+     fun integer (p, n) = prVal (p, F.format "%d" [F.LINT n])
+     fun float (p, f) = prVal (p, F.format "%g" [F.REAL f])
+ (* FIXME: need to deal with UTF-* escapes *)
+-    fun string (p, s) = prVal (p, F.format "\"%s\"" [F.STR(String.toCString s)])
+-
++    (* fun string (p, s) = prVal (p, F.format "\"%s\"" [F.STR(String.toCString s)]) *)
++    fun string (p, s) = (* RFC 7159 *)
++	let fun esc #"\"" = "\\\""
++	      | esc #"\\" = "\\\\"
++	      | esc #"\b" = "\\b"
++	      | esc #"\f" = "\\f"
++	      | esc #"\n" = "\\n"
++	      | esc #"\r" = "\\r"
++	      | esc #"\t" = "\\t"
++	      | esc c = if c < #" "
++			then "\\u" ^ (StringCvt.padLeft #"0" 4 (Int.fmt StringCvt.HEX (ord c)))
++			else str c
++	in prVal (p, "\"" ^ (String.translate esc s) ^ "\"")
++	end
+     fun beginObject (p as P{ctx, ...}) = (
+ 	  optComma p;
+-	  pr (p, "{"); incIndent(p, 2); nl p;
++	  pr (p, "{"); incIndent(p, 1); nl p;
+ 	  ctx := FIRST(OBJECT(!ctx)))
+ 
+     fun objectKey (p as P{ctx = ref(KEY _), ...}, field) =
+@@ -114,7 +126,7 @@
+     fun endObject (p as P{ctx, ...}) = let
+ 	  fun prEnd ctx' = (
+ 		ctx := ctx';
+-		indent(p, ~1); pr(p, "}"); decIndent (p, 2))
++		indent(p, 0); pr(p, "}"); decIndent (p, 1))
+ 	  in
+ 	    case !ctx
+ 	     of OBJECT ctx' => (nl p; prEnd ctx')
+@@ -125,13 +137,13 @@
+ 
+     fun beginArray (p as P{ctx, ...}) = (
+ 	  optComma p;
+-	  pr (p, "["); incIndent(p, 2); nl p;
++	  pr (p, "["); incIndent(p, 1); nl p;
+ 	  ctx := FIRST(ARRAY(!ctx)))
+ 
+     fun endArray (p as P{ctx, ...}) = let
+ 	  fun prEnd ctx' = (
+ 		ctx := ctx';
+-		nl p; indent(p, ~1); pr(p, "]"); decIndent (p, 2))
++		nl p; indent(p, 0); pr(p, "]"); decIndent (p, 1))
+ 	  in
+ 	    case !ctx
+ 	     of ARRAY ctx' => prEnd ctx'

src/JSON/patch/json-util.sml.orig

@@ -0,0 +1,273 @@
+(* json-util.sml
+ *
+ * COPYRIGHT (c) 2017 The Fellowship of SML/NJ (http://www.smlnj.org)
+ * All rights reserved.
+ *
+ * Utility functions for processing the JSON in-memory representation.
+ *)
+
+structure JSONUtil : sig
+
+  (* exceptions for conversion functions *)
+    exception NotBool of JSON.value
+    exception NotInt of JSON.value
+    exception NotNumber of JSON.value
+    exception NotString of JSON.value
+
+  (* exception that is raised when trying to process a non-object value as an object *)
+    exception NotObject of JSON.value
+
+  (* exception that is raised when the given field is not found in an object *)
+    exception FieldNotFound of JSON.value * string
+
+  (* exception that is raised when trying to process a non-array value as an array *)
+    exception NotArray of JSON.value
+
+  (* exception that is raise when access to an array value is out of bounds *)
+    exception ArrayBounds of JSON.value * int
+
+  (* map the above exceptions to a message string; we use General.exnMessage for other
+   * exceptions.
+   *)
+    val exnMessage : exn -> string
+
+  (* conversion functions for atomic values.  These raise the corresponding
+   * "NotXXX" exceptions when their argument has the wrong shape.  Also note
+   * that asNumber will accept both integers and floats and asInt may raise
+   * Overflow if the number is too large.
+   *)
+    val asBool : JSON.value -> bool
+    val asInt : JSON.value -> Int.int
+    val asIntInf : JSON.value -> IntInf.int
+    val asNumber : JSON.value -> Real.real
+    val asString : JSON.value -> string
+
+  (* find a field in an object; this function raises the NotObject exception when
+   * the supplied value is not an object.
+   *)
+    val findField : JSON.value -> string -> JSON.value option
+
+  (* lookup a field in an object; this function raises the NotObject exception when
+   * the supplied value is not an object and raises FieldNotFound if the value is
+   * an object, but does not have the specified field.
+   *)
+    val lookupField : JSON.value -> string -> JSON.value
+
+  (* convert a JSON array to an SML vector *)
+    val asArray : JSON.value -> JSON.value vector
+
+  (* map a conversion function over a JSON array to produce a list; this function
+   * raises the NotArray exception if the second argument is not an array.
+   *)
+    val arrayMap : (JSON.value -> 'a) -> JSON.value -> 'a list
+
+  (* path specification for indexing into JSON values *)
+    datatype edge
+      = SUB of int      (* index into array component *)
+      | SEL of string   (* select field of object *)
+
+    type path = edge list
+
+  (* `get (jv, path)` returns the component of `jv` named by `path`.  It raises
+   * the NotObject, NotArray, and FieldNotFound exceptions if there is an inconsistency
+   * between the path and the structure of `jv`.
+   *)
+    val get : JSON.value * path -> JSON.value
+
+  (* `replace (jv, path, v)` replaces the component of `jv` named by `path`
+   * with the value `v`.
+   *)
+    val replace : JSON.value * path * JSON.value -> JSON.value
+
+  (* `insert (jv, path, lab, v)` inserts `lab : v` into the object named by `path`
+   * in `jv`
+   *)
+    val insert : JSON.value * path * string * JSON.value -> JSON.value
+
+  (* `append (jv, path, vs)` appends the list of values `vs` onto the array named by `path`
+   * in `jv`
+   *)
+    val append : JSON.value * path * JSON.value list -> JSON.value
+
+  end = struct
+
+    structure J = JSON
+
+    exception NotBool of J.value
+    exception NotInt of J.value
+    exception NotNumber of J.value
+    exception NotString of J.value
+
+    exception NotObject of J.value
+    exception FieldNotFound of J.value * string
+
+    exception NotArray of J.value
+    exception ArrayBounds of J.value * int
+
+  (* conversion functions for atomic values *)
+    fun asBool (J.BOOL b) = b
+      | asBool v = raise NotBool v
+
+    fun asInt (J.INT n) = Int.fromLarge n
+      | asInt v = raise NotInt v
+
+    fun asIntInf (J.INT n) = n
+      | asIntInf v = raise NotInt v
+
+    fun asNumber (J.INT n) = Real.fromLargeInt n
+      | asNumber (J.FLOAT f) = f
+      | asNumber v = raise NotNumber v
+
+    fun asString (J.STRING s) = s
+      | asString v = raise NotString v
+
+    fun findField (J.OBJECT fields) = let
+	  fun find lab = (case List.find (fn (l, v) => (l = lab)) fields
+		 of NONE => NONE
+		  | SOME(_, v) => SOME v
+		(* end case *))
+	  in
+	    find
+	  end
+      | findField v = raise NotObject v
+
+    fun lookupField (v as J.OBJECT fields) = let
+	  fun find lab = (case List.find (fn (l, v) => (l = lab)) fields
+		 of NONE => raise FieldNotFound(v, concat["no definition for field \"", lab, "\""])
+		  | SOME(_, v) => v
+		(* end case *))
+	  in
+	    find
+	  end
+      | lookupField v = raise NotObject v
+
+    fun asArray (J.ARRAY vs) = Vector.fromList vs
+      | asArray v = raise NotArray v
+
+    fun arrayMap f (J.ARRAY vs) = List.map f vs
+      | arrayMap f v = raise NotArray v
+
+  (* map the above exceptions to a message string; we use General.exnMessage for other
+   * exceptions.
+   *)
+    fun exnMessage exn = let
+	  fun v2s (J.ARRAY _) = "array"
+	    | v2s (J.BOOL false) = "'false'"
+	    | v2s (J.BOOL true) = "'true'"
+	    | v2s (J.FLOAT _) = "number"
+	    | v2s (J.INT _) = "number"
+	    | v2s J.NULL = "'null'"
+	    | v2s (J.OBJECT _) = "object"
+	    | v2s (J.STRING _) = "string"
+	  in
+	    case exn
+	     of NotBool v => String.concat[
+		    "expected boolean, but found ", v2s v
+		  ]
+	      | NotInt(J.FLOAT _) => "expected integer, but found floating-point number"
+	      | NotInt v => String.concat[
+		    "expected integer, but found ", v2s v
+		  ]
+	      | NotNumber v => String.concat[
+		    "expected number, but found ", v2s v
+		  ]
+	      | NotString v => String.concat[
+		    "expected string, but found ", v2s v
+		  ]
+	      | NotObject v => String.concat[
+		    "expected object, but found ", v2s v
+		  ]
+	      | FieldNotFound(v, fld) => String.concat[
+		    "no definition for field \"", fld, "\" in object"
+		  ]
+	      | NotArray v => String.concat[
+		    "expected array, but found ", v2s v
+		  ]
+	      | _ => General.exnMessage exn
+	    (* end case *)
+	  end
+
+  (* path specification for indexing into JSON values *)
+    datatype edge
+      = SEL of string   (* select field of object *)
+      | SUB of int      (* index into array component *)
+
+    type path = edge list
+
+    fun get (v, []) = v
+      | get (v as J.OBJECT fields, SEL lab :: rest) =
+	  (case List.find (fn (l, v) => (l = lab)) fields
+	   of NONE => raise raise FieldNotFound(v, concat["no definition for field \"", lab, "\""])
+	    | SOME(_, v) => get (v, rest)
+	  (* end case *))
+      | get (v, SEL _ :: _) = raise NotObject v
+      | get (J.ARRAY vs, SUB i :: rest) = get (List.nth(vs, i), rest)
+      | get (v, SUB _ :: _) = raise (NotArray v)
+
+  (* top-down zipper to support functional editing *)
+    datatype zipper
+      = ZNIL
+      | ZOBJ of {
+            prefix : (string * J.value) list,
+            label : string,
+            child : zipper,
+            suffix : (string * J.value) list
+          }
+      | ZARR of {
+            prefix : J.value list,
+            child : zipper,
+            suffix : J.value list
+          }
+
+  (* follow a path into a JSON value while constructing a zipper *)
+    fun unzip (v, []) = (ZNIL, v)
+      | unzip (v as J.OBJECT fields, SEL lab :: rest) = let
+          fun find (_, []) = raise FieldNotFound(v, concat["no definition for field \"", lab, "\""])
+            | find (pre, (l, v)::flds) = if (l = lab)
+                then let
+		  val (zipper, v) = unzip (v, rest)
+		  in
+		    (ZOBJ{prefix=pre, label=lab, suffix=flds, child=zipper}, v)
+                  end
+                else find ((l, v)::pre, flds)
+          in
+            find ([], fields)
+          end
+      | unzip (v, SEL _ :: _) = raise NotObject v
+      | unzip (v as J.ARRAY vs, SUB i :: rest) = let
+          fun sub (_, [], _) = raise ArrayBounds(v, i)
+            | sub (prefix, v::vs, 0) = let
+		val (zipper, v) = unzip (v, rest)
+		in
+		  (ZARR{prefix = prefix, child = zipper, suffix = vs}, v)
+		end
+            | sub (prefix, v::vs, i) = sub(v::prefix, vs, i-1)
+	  in
+	    sub ([], vs, i)
+	  end
+      | unzip (v, SUB _ :: _) = raise NotArray v
+
+  (* zip up a zipper *)
+    fun zip (zipper, v) = let
+	  fun zip' ZNIL = v
+            | zip' (ZOBJ{prefix, label, suffix, child}) =
+                J.OBJECT(List.revAppend(prefix, (label, zip' child)::suffix))
+            | zip' (ZARR{prefix, child, suffix}) =
+                J.ARRAY(List.revAppend(prefix, zip' child :: suffix))
+          in
+	    zip' zipper
+	  end
+
+    fun replace (jv, path, v) = zip (#1 (unzip (jv, path)), v)
+
+    fun insert (jv, path, label, v) = (case unzip (jv, path)
+	   of (zipper, J.OBJECT fields) => zip (zipper, J.OBJECT((label, v)::fields))
+	    | (_, v) => raise NotObject v
+	  (* end case *))
+
+    fun append (jv, path, vs) = (case unzip (jv, path)
+	   of (zipper, J.ARRAY jvs) => zip (zipper, J.ARRAY(jvs @ vs))
+	    | (_, v) => raise NotArray v
+	  (* end case *))
+
+  end

src/JSON/patch/json-util.sml.patch

@@ -0,0 +1,29 @@
+--- json-util.sml.orig	2017-04-29 17:39:27.000000000 +0200
++++ json-util.sml	2017-10-04 00:40:39.574909000 +0200
+@@ -133,7 +133,7 @@
+ 
+     fun lookupField (v as J.OBJECT fields) = let
+ 	  fun find lab = (case List.find (fn (l, v) => (l = lab)) fields
+-		 of NONE => raise FieldNotFound(v, concat["no definition for field \"", lab, "\""])
++		 of NONE => raise FieldNotFound(v, lab)
+ 		  | SOME(_, v) => v
+ 		(* end case *))
+ 	  in
+@@ -197,7 +197,7 @@
+     fun get (v, []) = v
+       | get (v as J.OBJECT fields, SEL lab :: rest) =
+ 	  (case List.find (fn (l, v) => (l = lab)) fields
+-	   of NONE => raise raise FieldNotFound(v, concat["no definition for field \"", lab, "\""])
++	   of NONE => raise FieldNotFound(v, lab)
+ 	    | SOME(_, v) => get (v, rest)
+ 	  (* end case *))
+       | get (v, SEL _ :: _) = raise NotObject v
+@@ -222,7 +222,7 @@
+   (* follow a path into a JSON value while constructing a zipper *)
+     fun unzip (v, []) = (ZNIL, v)
+       | unzip (v as J.OBJECT fields, SEL lab :: rest) = let
+-          fun find (_, []) = raise FieldNotFound(v, concat["no definition for field \"", lab, "\""])
++          fun find (_, []) = raise FieldNotFound(v, lab)
+             | find (pre, (l, v)::flds) = if (l = lab)
+                 then let
+ 		  val (zipper, v) = unzip (v, rest)

src/Makefile.in

@@ -0,0 +1,39 @@
+BINFILES=
+BINFILES+=	nodes2prom nodes2prom.%%HEAP_SUFFIX%%
+BINFILES+=	json-pp json-pp.%%HEAP_SUFFIX%%
+
+CLEANFILES=	promconfig.sml .cm JSON/.cm
+
+all:	promconfig.sml nodes2prom json-pp
+
+promconfig.sml: promconfig.sml.in
+	../conf/substitute.sh $> $@
+
+nodes2prom: nodes2prom.%%HEAP_SUFFIX%%
+	heap2exec nodes2prom.%%HEAP_SUFFIX%% nodes2prom
+
+nodes2prom.%%HEAP_SUFFIX%%: promconfig.sml nodes2prom.cm nodes2prom.sml json_lib
+	ml-build nodes2prom.cm Main.main nodes2prom
+
+json-pp: json-pp.%%HEAP_SUFFIX%%
+	heap2exec json-pp.%%HEAP_SUFFIX%% json-pp
+
+json-pp.%%HEAP_SUFFIX%%: json-pp.cm json-pp.sml json_lib
+	ml-build json-pp.cm Main.main json-pp
+
+clean:
+	rm -rf ${BINFILES}
+	rm -rf ${CLEANFILES}
+
+# START: ml-makedepend (JSON/json-lib.cm:json_lib); DO NOT DELETE!
+json_lib: \
+    JSON/json.sml \
+    JSON/json.lex \
+    JSON/json-util.sml \
+    JSON/json-tokens.sml \
+    JSON/json-stream-printer.sml \
+    JSON/json-stream-parser.sml \
+    JSON/json-printer.sml \
+    JSON/json-parser.sml \
+    JSON/json-lib.cm
+# END  : ml-makedepend (JSON/json-lib.cm:json_lib); DO NOT DELETE!

src/json-pp.cm

@@ -0,0 +1,6 @@
+library
+	structure Main
+is
+	$/basis.cm
+	JSON/json-lib.cm
+	json-pp.sml

src/json-pp.sml

@@ -0,0 +1,16 @@
+structure Main :
+sig
+	val main: string * string list -> OS.Process.status
+end =
+struct
+	fun complain (p, s) =
+		(TextIO.output (TextIO.stdErr, concat [p, ": ", s, "\n"]);
+		 OS.Process.failure)
+
+	fun main (p, [inf, outf]) =
+		((JSONPrinter.print' { strm = TextIO.openOut outf, pretty = true }
+				  (JSONParser.parseFile inf);
+		  OS.Process.success)
+		 handle e => complain (p, "exception: " ^ General.exnMessage e))
+	  | main (p, _) = complain (p, "usage: " ^ p ^ " infile.json outfile.json")
+end

src/nodes2prom.cm

@@ -0,0 +1,8 @@
+library
+	structure Main
+is
+	$/basis.cm
+	$/smlnj-lib.cm
+	JSON/json-lib.cm
+	promconfig.sml
+	nodes2prom.sml

src/nodes2prom.sml

@@ -0,0 +1,299 @@
+structure Main :
+sig
+	val main: string * string list -> OS.Process.status
+end =
+struct
+	structure J = JSON
+	structure JP = JSONParser
+	structure JU = JSONUtil
+
+	structure PC = PromConfig
+	val prom_prefix = PC.prom_prefix
+	val summary_prefix = PC.summary_prefix
+	val info_prefix = PC.info_prefix
+	val stats_prefix = PC.stats_prefix
+
+	val timestamp = ref (LargeInt.toString (Time.toMilliseconds (Time.now ())))
+
+	val newline = String.str #"\n"
+	val summary_header = [
+		"# HELP " ^ summary_prefix ^ " sum of nodes and of some attributes" ^ newline ^
+		"# TYPE " ^ summary_prefix ^ " gauge" ^ newline ]
+	val info_header = [
+		"# HELP " ^ info_prefix ^ " static attributes of a node" ^ newline ^
+		"# TYPE " ^ info_prefix ^ " counter" ^ newline,
+		"# HELP " ^ info_prefix ^ "_fw_version firmware version as an integer value" ^ newline ^
+		"# TYPE " ^ info_prefix ^ "_fw_version gauge" ^ newline,
+		"# HELP " ^ info_prefix ^ "_lastseen metric for the lastseen attribute of a node" ^ newline ^
+		"# TYPE " ^ info_prefix ^ "_lastseen gauge" ^ newline,
+		"# HELP " ^ info_prefix ^ "_firstseen metric for the firtseen attribute of a node" ^ newline ^
+		"# TYPE " ^ info_prefix ^ "_firstseen gauge" ^ newline ]
+
+	fun stats_header key =
+		"# HELP " ^ stats_prefix ^ key ^ " metric for the " ^ key ^ " attribute of a node" ^ newline ^
+		"# TYPE " ^ stats_prefix ^ key ^  " gauge" ^ newline
+
+	fun prom2string (metric, labels, scalar) =
+		let fun esc #"\"" = "\\\""
+		      | esc #"\\" = "\\\\"
+		      | esc #"\n" = "\\n"
+		      | esc c = str c
+		in metric ^
+		   (ListFormat.fmt {init = "{", sep= ",", final = "}",
+				    fmt = fn (label, value) => label ^ "=\"" ^ (String.translate esc value) ^ "\""}
+				   labels) ^ " " ^
+		   scalar ^ " " ^
+		   (!timestamp) ^ newline
+		end
+
+	(* exnMessage from JSONUtil - slightly extended *)
+
+	fun v2bs' (J.ARRAY []) = "[]"
+	  | v2bs' (J.ARRAY _) = "[...]"
+	  | v2bs' (J.BOOL v) = Bool.toString v
+	  | v2bs' (J.FLOAT v) = Real.toString v
+	  | v2bs' (J.INT v) = IntInf.toString v
+	  | v2bs' J.NULL = "null"
+	  | v2bs' (J.OBJECT []) = "{}"
+	  | v2bs' (J.OBJECT _) = "{...}"
+	  | v2bs' (J.STRING v) = v
+
+	fun v2bs (J.ARRAY []) = "[]"
+	  | v2bs (J.ARRAY vl) =
+		ListFormat.fmt { init = "[", sep = ",", final = "]", fmt = v2bs' } vl
+	  | v2bs (J.OBJECT []) = "{}"
+	  | v2bs (J.OBJECT fl) =
+		ListFormat.fmt { init = "{", sep = ",", final = "}",
+				 fmt = fn (n, v) => n ^ ":" ^ (v2bs' v) } fl
+	  | v2bs v = v2bs' v
+
+	fun json_handler logstring exn =
+		(TextIO.output (TextIO.stdErr, 
+		 "json_handler(" ^ logstring ^ "): " ^ (JU.exnMessage exn) ^ ": " ^
+		 (v2bs (case exn
+			 of JU.NotBool v => v
+			  | JU.NotInt v => v
+			  | JU.NotNumber v => v
+		 	  | JU.NotString v => v
+		 	  | JU.NotObject v => v
+		 	  | JU.FieldNotFound(v, fld) => v
+		 	  | JU.NotArray v => v
+			  | _ => raise exn)) ^
+		 "\n") ; ())
+
+	fun firmware2int firmware = 
+		foldl (fn (s, i) => 100 * i + valOf (Int.fromString s))
+		      0
+		      (String.tokens (fn c => c = #".") firmware)
+
+	fun timestring2time ts = (* "timestamp" : "2017-10-01T18:49:11+02:00" *)
+		let val tsfields = String.tokens (fn c => c = #"-" orelse c = #"T" orelse c = #":" orelse c = #"+") ts
+		    val tsints = map (valOf o Int.fromString) tsfields
+		    fun int2month i =
+			let open Date
+			    val months = [ Jan, Feb, Mar, Apr, May, Jun, Jul, Aug, Sep, Oct, Nov, Dec ]
+			in List.nth (months, i - 1)
+			end
+		    val tsdate =
+			Date.date {
+				year = List.nth (tsints, 0),
+				month = int2month (List.nth (tsints, 1)),
+				day = List.nth (tsints, 2),
+				hour = List.nth (tsints, 3),
+				minute = List.nth (tsints, 4),
+				second = List.nth (tsints, 5),
+				(* Basis/date.html:
+				   ... offset reports time zone information as the amount of time west [sic!] of UTC. *)
+				offset = SOME (Time.fromSeconds (~1 * 60 * Int.toLarge ((60 * List.nth (tsints, 6) + List.nth (tsints, 7))))) }
+		in Date.toTime tsdate
+		end
+
+	fun get_timestamp obj =
+		let val tsstring = JU.asString (JU.lookupField obj "timestamp")
+		    val tstime = timestring2time tsstring
+		in timestamp := LargeInt.toString (Time.toMilliseconds tstime)
+		end
+		handle exn => json_handler ("get_timestamp") exn
+
+	fun get_fields (J.OBJECT flds) = flds
+	  | get_fields v = raise Fail ("value is not an object (" ^ (v2bs v) ^ ")")
+
+	fun get_list (J.OBJECT flds) = map #2 flds
+	  | get_list (J.ARRAY nds) = nds
+	  | get_list v = raise Fail ("value does not contain a list (" ^ (v2bs v) ^ ")")
+
+	fun get_nodes obj = get_list (JU.lookupField obj "nodes")
+
+	fun extract node =
+		let val nodeinfo = JU.lookupField node "nodeinfo"
+		    val hostname = JU.asString (JU.lookupField nodeinfo "hostname")
+		    val node_id = JU.asString (JU.lookupField nodeinfo "node_id")
+		    local val interfaces' = get_fields (JU.lookupField (JU.lookupField (JU.lookupField (JU.lookupField nodeinfo "network") "mesh") "bat0") "interfaces")
+			  val interfaces'' = map (fn i => (#1 i) ^ ":" ^ (Int.toString (length (get_list (#2 i))))) interfaces'
+			  val interfaces''' = ListMergeSort.sort String.> interfaces''
+		    in val interfaces = ListFormat.fmt { init = "", sep = ",", final = "", fmt = (fn s => s) } interfaces'''
+		    end
+		    val location = JU.findField nodeinfo "location"
+		    val (longitude, latitude) =
+			case location
+			  of SOME l => (SOME (JU.asNumber (JU.lookupField l "longitude")),
+					SOME (JU.asNumber (JU.lookupField l "latitude")))
+			   | NONE => (NONE, NONE)
+		    val software = JU.lookupField nodeinfo "software"
+		    val autoupdater = JU.asBool (JU.lookupField (JU.lookupField software "autoupdater") "enabled")
+		    val fastd = JU.asBool (JU.lookupField (JU.lookupField software "fastd") "enabled")
+		    val firmware = JU.asString (JU.lookupField (JU.lookupField software "firmware") "release")
+		    val base = JU.asString (JU.lookupField (JU.lookupField software "firmware") "base")
+		    val model = JU.asString (JU.lookupField (JU.lookupField nodeinfo "hardware") "model")
+
+		    val statistics = JU.lookupField node "statistics"
+		    val clients = JU.asInt (JU.lookupField statistics "clients")
+		    val gateway = JU.asString (JU.lookupField statistics "gateway")
+		    val loadavg = JU.asNumber (JU.lookupField statistics "loadavg")
+		    val memory_usage = JU.asNumber (JU.lookupField statistics "memory_usage")
+		    val rootfs_usage = JU.asNumber (JU.lookupField statistics "rootfs_usage")
+		    val uptime = JU.asNumber (JU.lookupField statistics "uptime")
+		    val traffic = JU.lookupField statistics "traffic"
+		    val tx = SOME (JU.asNumber (JU.lookupField (JU.lookupField traffic "tx") "bytes"))
+				 handle exn => NONE
+		    val rx = SOME (JU.asNumber (JU.lookupField (JU.lookupField traffic "rx") "bytes"))
+				 handle exn => NONE
+		    val forward = SOME (JU.asNumber (JU.lookupField (JU.lookupField traffic "forward") "bytes"))
+				 handle exn => NONE
+		    val mgmt_tx = SOME (JU.asNumber (JU.lookupField (JU.lookupField traffic "mgmt_tx") "bytes"))
+				 handle exn => NONE
+		    val mgmt_rx = SOME (JU.asNumber (JU.lookupField (JU.lookupField traffic "mgmt_rx") "bytes"))
+				 handle exn => NONE
+		    val flags = JU.lookupField node "flags"
+		    val online = JU.asBool (JU.lookupField flags "online")
+		    val uplink = JU.asBool (JU.lookupField flags "uplink")
+		    val lastseen = timestring2time (JU.asString (JU.lookupField node "lastseen"))
+		    val firstseen = timestring2time (JU.asString (JU.lookupField node "firstseen"))
+		in SOME
+		   ({	clients = clients,
+			online = online,
+			uplink = uplink },
+		    {	hostname = hostname,
+			online = online,
+			node_id = node_id,
+			interfaces = interfaces,
+			longitude = longitude,
+			latitude = latitude,
+			autoupdater = autoupdater,
+			gateway = gateway,
+			fastd = fastd,
+			firmware = firmware,
+			base = base,
+			model = model,
+			lastseen = lastseen,
+			firstseen = firstseen },
+		    {	hostname = hostname,
+			node_id = node_id,
+			clients = clients,
+			online = online,
+			uplink = uplink,
+			loadavg = loadavg,
+			memory_usage = memory_usage,
+			rootfs_usage = rootfs_usage,
+			uptime = uptime,
+			tx = tx,
+			rx = rx,
+			forward = forward,
+			mgmt_tx = mgmt_tx,
+			mgmt_rx = mgmt_rx }
+		   )
+		end
+		handle exn => (json_handler "extract" exn ; NONE)
+
+	fun nodes_summary node_summaries =
+		let fun summate (node_summary, (hcount, ccount, ocount, ucount)) =
+			let val { clients, online, uplink } = node_summary
+			in (hcount + 1,
+			    ccount + clients,
+			    if online then ocount + 1 else ocount,
+			    if uplink then ucount + 1 else ucount)
+			end
+		     val (hc, cc, oc, uc) = foldl summate (0, 0, 0, 0) node_summaries
+		     val scalars = map Int.toString [hc, cc, oc, uc]
+		     val labelvalues = ["nodes", "clients", "online", "uplink"]
+		     val items = ListPair.zip (labelvalues, scalars)
+		in foldr (fn ((count, scalar), result) =>
+				(prom2string (summary_prefix, [("count", count)], scalar)) ^
+				result)
+			 ""
+			 items
+		end
+
+	fun node_info {	hostname, online, node_id, interfaces, longitude, latitude, autoupdater, fastd, gateway, firmware, base, model, lastseen, firstseen } =
+		let val minitems = [
+				("hostname", hostname),
+				("node_id", node_id)]
+		    val allitems = minitems @ [
+				("interfaces", interfaces),
+				("longitude", case longitude
+						of NONE => "NaN"
+						 | SOME l => Real.toString l),
+				("latitude", case latitude
+						of NONE => "NaN"
+						 | SOME l => Real.toString l),
+				("autoupdater", Bool.toString autoupdater),
+				("fastd", Bool.toString fastd),
+				("gateway", gateway),
+				("firmware", firmware),
+				("base", base),
+				("model", model)]
+		in [("!info", prom2string (info_prefix, allitems, "1")),
+		    ("fw_version", prom2string (info_prefix ^ "_fw_version", minitems, Int.toString (firmware2int firmware))),
+		    ("lastseen", prom2string (info_prefix ^ "_lastseen", minitems, LargeInt.toString (Time.toSeconds lastseen))),
+		    ("firstseen", prom2string (info_prefix ^ "_firstseen", minitems, LargeInt.toString (Time.toSeconds firstseen)))]
+		end
+
+	fun node_stats { hostname, node_id, clients, online, uplink, loadavg, memory_usage, uptime, rootfs_usage, tx, rx, forward, mgmt_tx, mgmt_rx } =
+		let val items =
+			[SOME ("clients", Int.toString clients),
+			 SOME ("online", if online then "1" else "0"),
+			 SOME ("uplink", if uplink then "1" else "0"),
+			 SOME ("loadavg", Real.toString loadavg),
+			 SOME ("memory_usage", Real.toString memory_usage),
+			 SOME ("rootfs_usage", Real.toString rootfs_usage),
+			 SOME ("uptime", Real.toString(uptime)),
+			 case tx of SOME tx' => SOME ("tx", Real.toString(tx')) | NONE => NONE,
+			 case rx of SOME rx' => SOME ("rx", Real.toString(rx')) | NONE => NONE,
+			 case forward of SOME forward' => SOME ("forward", Real.toString(forward')) | NONE => NONE,
+			 case mgmt_tx of SOME mgmt_tx' => SOME ("mgmt_tx", Real.toString(mgmt_tx')) | NONE => NONE,
+			 case mgmt_rx of SOME mgmt_rx' => SOME ("mgmt_rx", Real.toString(mgmt_rx')) | NONE => NONE]
+		    fun item2prom (key, value) = (key, stats_prefix ^ key ^ "{hostname=\"" ^ hostname ^ "\",node_id=\"" ^ node_id ^ "\"} " ^ value ^ " " ^ !timestamp ^ "\n")
+		in List.mapPartial (fn (SOME i) => SOME (item2prom i) | NONE => NONE) items
+		end
+
+	fun complain (p, s) =
+		(TextIO.output (TextIO.stdErr, concat [p, ": ", s, "\n"]);
+		 OS.Process.failure)
+
+	fun main (p, [inf]) =
+		(let val json = JP.parseFile inf
+		     val _ = get_timestamp json
+		     val nodes_json = get_nodes json
+				      handle exn => (json_handler "get_nodes" exn ; raise Fail "get_nodes")
+		     val nodes_extract = List.mapPartial extract nodes_json
+		     val summaries = map #1 nodes_extract
+		     val infos = map #2 nodes_extract
+		     val (infokeys', infos) =
+			ListPair.unzip (ListMergeSort.sort
+					(fn ((k1,_), (k2,_)) => String.> (k1, k2))
+					(List.concat (List.map node_info infos)))
+		     val infokeys = ListMergeSort.uniqueSort String.compare infokeys'
+		     val stats' = List.filter (fn stts => #online stts) (map #3 nodes_extract)
+		     val (statskeys', stats) =
+			ListPair.unzip (ListMergeSort.sort
+					(fn ((k1,_), (k2,_)) => String.> (k1, k2))
+					(List.concat (List.map node_stats stats')))
+		     val statskeys = ListMergeSort.uniqueSort String.compare statskeys'
+		 in (app print (List.concat [summary_header, info_header, map stats_header statskeys]) ;
+		     print (nodes_summary summaries) ;
+		     app print infos ;
+		     app print stats ;
+		     OS.Process.success)
+		 end handle e => complain (p, exnMessage e))
+	  | main (p, _) = complain (p, "usage: " ^ p ^ " nodes.json")
+end

src/promconfig.sml.in

@@ -0,0 +1,8 @@
+structure PromConfig =
+struct
+	val seperator = "%%PROM_SEPERATOR%%"
+	val prom_prefix = "%%PROM_PREFIX%%" ^ seperator
+	val summary_prefix = prom_prefix ^ "%%SUMMARY_PREFIX%%"
+	val info_prefix = prom_prefix ^ "%%INFO_PREFIX%%"
+	val stats_prefix = prom_prefix ^ "%%STATS_PREFIX%%" ^ seperator
+end

test/Makefile.in

@@ -0,0 +1,20 @@
+all:	test
+
+test:	tmp tmp/%%PROM_PREFIX%%.prom tmp/nodes.json.pp
+
+tmp:
+	mkdir $@
+
+tmp/%%PROM_PREFIX%%.prom: ../src/nodes2prom tmp/nodes.json
+	$> > $@.new && \
+	mv $@.new $@
+
+tmp/nodes.json.pp: ../src/json-pp tmp/nodes.json
+	$> $@
+
+tmp/nodes.json:
+	fetch -q --no-verify-peer -o $@.tmp "%%NODES_URL%%" && \
+	mv $@.tmp $@
+
+clean:
+	rm -rf tmp