20200802 src/JSON (update auf SML/NJ 110.98)

src/JSON/json-lib.cm

@@ -31,6 +31,7 @@ is
   json.sml
   json-parser.sml
   json-printer.sml
+  json-source.sml
   json-stream-parser.sml
   json-stream-printer.sml
   json-tokens.sml

src/JSON/json-parser.sml

@@ -4,9 +4,24 @@
  * All rights reserved.
  *)
 
-structure JSONParser : sig
+structure JSONParser :> sig
 
-    val parse : TextIO.instream -> JSON.value
+  (* abstract type of JSON input *)
+    type source = JSONSource.source
+
+  (* open a text input stream as a source *)
+    val openStream : TextIO.instream -> source
+
+  (* open a text file as a source *)
+    val openFile : string -> source
+
+  (* open a string as a source *)
+    val openString : string -> source
+
+  (* close a source *)
+    val close : source -> unit
+
+    val parse : source -> JSON.value
 
     val parseFile : string -> JSON.value
 
@@ -16,34 +31,20 @@ structure JSONParser : sig
     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, "'"
-		])
+    datatype source = datatype JSONSource.source
+
+    val openStream = JSONSource.openStream
+    val openFile = JSONSource.openFile
+    val openString = JSONSource.openString
+    val close = JSONSource.close
+
+    fun parse (Src{closed = ref true, ...}) = raise Fail "closed JSON source"
+      | parse (src as Src{srcMap, strm, ...}) = let
+	  val errorMsg = JSONSource.errorMsg src
+	  fun error arg = raise Fail(errorMsg arg)
 	  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
+		val (tok, span, strm) = lexer strm
 		in
 		  case tok
 		   of T.LB => parseArray strm
@@ -54,47 +55,62 @@ structure JSONParser : sig
 		    | 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)
+		    | _ => error (span, "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 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, span, strm) = lexer strm
+			    in
+			      case tok
+			       of T.RB => (strm, v::items)
+				| T.COMMA => loop (strm, v::items)
+				| _ => error (span, "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 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))
+		fun parseField ((T.STRING s, _, strm), flds) = (case lexer strm
+		       of (T.COLON, _, strm) => let
+			    val (strm, v) = parseValue strm
+			    in
+			      parseFields (strm, (s, v)::flds)
+			    end
+			| (tok, span, _) => error (span, "parsing field", tok)
+		      (* end case *))
+		  | parseField ((tok, span, _), _) = error (span, "parsing field", tok)
+		and parseFields (strm, flds) = (case lexer strm
+		       of (T.RCB, span, strm) => (strm, J.OBJECT(List.rev flds))
+			| (T.COMMA, span, strm) => parseField (lexer strm, flds)
+			| (tok, span, _) => error (span, "parsing object", tok)
+		      (* end case *))
+		in
+		  case lexer strm
+		   of (T.RCB, span, strm) => (strm, J.OBJECT[])
+		    | tokEtc => parseField (tokEtc, [])
+		  (* end case *)
 		end
+	  val (inStrm, value) = parseValue (!strm)
 	  in
-	    #2 (parseValue (Lex.streamifyInstream inStrm))
+	    strm := inStrm;
+	    value
 	  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)
+	  val inStrm = openFile fileName
+	  val v = parse inStrm
+		handle ex => (close inStrm; raise ex)
 	  in
-	    TextIO.closeIn inStrm;
+	    close inStrm;
 	    v
 	  end
 
   end
-

src/JSON/json-source.sml

@@ -0,0 +1,93 @@
+(* json-source.sml
+ *
+ * COPYRIGHT (c) 2020 The Fellowship of SML/NJ (http://www.smlnj.org)
+ * All rights reserved.
+ *
+ * JSON input sources.  Note that this module is internal the the library.
+ *)
+
+structure JSONSource : sig
+
+    datatype source = Src of {
+	srcMap : AntlrStreamPos.sourcemap,
+	strm : JSONLexer.strm ref,
+	closeFn : unit -> unit,
+	closed : bool ref
+      }
+
+  (* open a text input stream as a source *)
+    val openStream : TextIO.instream -> source
+
+  (* open a text file as a source *)
+    val openFile : string -> source
+
+  (* open a string as a source *)
+    val openString : string -> source
+
+  (* close a source *)
+    val close : source -> unit
+
+    val errorMsg : source -> AntlrStreamPos.span * string * JSONTokens.token -> string
+
+  end = struct
+
+    structure Lex = JSONLexer
+    structure T = JSONTokens
+
+    datatype source = Src of {
+	srcMap : AntlrStreamPos.sourcemap,
+	strm : Lex.strm ref,
+	closeFn : unit -> unit,
+	closed : bool ref
+      }
+
+    fun openStream inS = let
+	  val closed = ref false
+	  in
+	    Src{
+		srcMap = AntlrStreamPos.mkSourcemap (),
+		strm = ref(Lex.streamifyInstream inS),
+		closeFn = fn () => (),
+		closed = closed
+	      }
+	  end
+
+    fun openFile file = let
+	  val closed = ref false
+	  val inStrm = TextIO.openIn file
+	  in
+	    Src{
+		srcMap = AntlrStreamPos.mkSourcemap (),
+		strm = ref(Lex.streamifyInstream inStrm),
+		closeFn = fn () => TextIO.closeIn inStrm,
+		closed = closed
+	      }
+	  end
+
+    fun openString s = let
+	  val closed = ref false
+	  val data = ref s
+	  fun input () = (!data before data := "")
+	  in
+	    Src{
+		srcMap = AntlrStreamPos.mkSourcemap (),
+		strm = ref(Lex.streamify input),
+		closeFn = fn () => (),
+		closed = closed
+	      }
+	  end
+
+    fun close (Src{closed = ref true, ...}) = ()
+      | close (Src{closed, closeFn, ...}) = (
+	  closed := true;
+	  closeFn())
+
+    fun errorMsg (Src{srcMap, ...}) (span, _, T.ERROR msg) = concat(
+	  "error " :: AntlrStreamPos.spanToString srcMap span :: ": " ::
+	    msg)
+      | errorMsg (Src{srcMap, ...}) (span, msg, tok) = concat[
+	    "error ", AntlrStreamPos.spanToString srcMap span, ": ",
+	    msg, ", found '", T.toString tok, "'"
+	  ]
+
+  end

src/JSON/json-stream-parser.sml

@@ -2,9 +2,27 @@
  *
  * COPYRIGHT (c) 2020 The Fellowship of SML/NJ (http://www.smlnj.org)
  * All rights reserved.
+ *
+ * TODO: use the same "source" abstraction supported by the `JSONParser`
+ * structure.
  *)
 
-structure JSONStreamParser : sig
+structure JSONStreamParser :> sig
+
+  (* abstract type of JSON input *)
+    type source = JSONSource.source
+
+  (* open a text input stream as a source *)
+    val openStream : TextIO.instream -> source
+
+  (* open a text file as a source *)
+    val openFile : string -> source
+
+  (* open a string as a source *)
+    val openString : string -> source
+
+  (* close a source *)
+    val close : source -> unit
 
   (* callback functions for the different parsing events *)
     type 'ctx callbacks = {
@@ -21,7 +39,7 @@ structure JSONStreamParser : sig
 	error : 'ctx * string -> unit
       }
 
-    val parse : 'ctx callbacks -> (TextIO.instream * 'ctx) -> 'ctx
+    val parse : 'ctx callbacks -> (source * 'ctx) -> 'ctx
 
     val parseFile : 'ctx callbacks -> (string * 'ctx) -> 'ctx
 
@@ -30,6 +48,13 @@ structure JSONStreamParser : sig
     structure Lex = JSONLexer
     structure T = JSONTokens
 
+    datatype source = datatype JSONSource.source
+
+    val openStream = JSONSource.openStream
+    val openFile = JSONSource.openFile
+    val openString = JSONSource.openString
+    val close = JSONSource.close
+
   (* callback functions for the different parsing events *)
     type 'ctx callbacks = {
 	null : 'ctx -> 'ctx,
@@ -49,10 +74,12 @@ structure JSONStreamParser : sig
 	  #error cb (ctx, msg);
 	  raise Fail "error")
 
-    fun parser (cb : 'a callbacks) (srcMap, inStrm, ctx) = let
-	  val lexer = Lex.lex (AntlrStreamPos.mkSourcemap ())
+    fun parse (cb : 'a callbacks) (src as Src{srcMap, strm, ...}, ctx) = let
+	  val lexer = Lex.lex srcMap
+	  val errorMsg = JSONSource.errorMsg src
+	  fun err (ctx, span, msg, tok) = error (cb, ctx, errorMsg (span, msg, tok))
 	  fun parseValue (strm : Lex.strm, ctx) = let
-		val (tok, pos, strm) = lexer strm
+		val (tok, span, strm) = lexer strm
 		in
 		  case tok
 		   of T.LB => parseArray (strm, ctx)
@@ -63,7 +90,7 @@ structure JSONStreamParser : sig
 		    | 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")
+		    | _ => err (ctx, span, "error parsing value", tok)
 		  (* end case *)
 		end
 	  and parseArray (strm : Lex.strm, ctx) = (case lexer strm
@@ -72,12 +99,12 @@ structure JSONStreamParser : sig
 		      fun loop (strm, ctx) = let
 			    val (strm, ctx) = parseValue (strm, ctx)
 			  (* expect either a "," or a "]" *)
-			    val (tok, pos, strm) = lexer strm
+			    val (tok, span, strm) = lexer strm
 			    in
 			      case tok
 			       of T.RB => (strm, ctx)
 				| T.COMMA => loop (strm, ctx)
-				| _ => error (cb, ctx, "error parsing array")
+				| _ => err (ctx, span, "error parsing array", tok)
 			      (* end case *)
 			    end
 		      val ctx = #startArray cb ctx
@@ -88,12 +115,13 @@ structure JSONStreamParser : sig
 		(* end case *))
 	  and parseObject (strm : Lex.strm, ctx) = let
 		fun parseField (strm, ctx) = (case lexer strm
-		       of (T.STRING s, pos, strm) => let
+		       of (T.STRING s, span, 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")
+				| (tok, span, _) =>
+				    err (ctx, span, "error parsing field", tok)
 			      (* end case *)
 			    end
 			| _ => (strm, ctx)
@@ -103,9 +131,10 @@ structure JSONStreamParser : sig
 		      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")
+			 of (T.RCB, span, strm) => (strm, ctx)
+			  | (T.COMMA, span, strm) => loop (strm, ctx)
+			  | (tok, span, _) =>
+			      err (ctx, span, "error parsing object", tok)
 			(* end case *)
 		      end
 		val ctx = #startObject cb ctx
@@ -113,30 +142,24 @@ structure JSONStreamParser : sig
 		in
 		  (strm, #endObject cb ctx)
 		end
+	  val (inStrm, cxt) = parseValue (!strm, ctx)
 	  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'
+	    strm := inStrm;
+	    ctx
 	  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)
+	  val parse = parse cb
+	  fun parser (fileName, ctx) = let
+		val inStrm = openFile fileName
+		val ctx = parse (inStrm, ctx)
+		      handle ex => (close inStrm; raise ex)
 		in
-		  TextIO.closeIn inStrm;
+		  close inStrm;
 		  ctx
 		end
 	  in
-	    parse
+	    parser
 	  end
 
   end

src/JSON/json-stream-printer.sml

@@ -107,19 +107,23 @@ structure JSONStreamPrinter : sig
 	  val getWChar = UTF8.getu getChar
 	  fun tr (i, chrs) = (case getWChar i
 		 of SOME(wchr, i) => if (wchr <= 0w126)
-		      then (case UTF8.toAscii wchr
-			 of #"\"" => tr(i, "\\\"" :: chrs)
-			  | #"\\" => tr(i, "\\\\" :: chrs)
-			  | #"/" => tr(i, "\\/" :: chrs)
-			  | #"\b" => tr(i, "\\b" :: chrs)
-			  | #"\f" => tr(i, "\\f" :: chrs)
-			  | #"\n" => tr(i, "\\n" :: chrs)
-			  | #"\r" => tr(i, "\\r" :: chrs)
-			  | #"\t" => tr(i, "\\t" :: chrs)
-			  | c => if (wchr < 0w32)
-			      then tr(i, F.format "\\u%04x" [F.WORD wchr] :: chrs)
-			      else tr(i, str c :: chrs)
-			(* end case *))
+		      then let
+			val c = (case UTF8.toAscii wchr
+			       of #"\"" => "\\\""
+				| #"\\" => "\\\\"
+				| #"/" => "\\/"
+				| #"\b" => "\\b"
+				| #"\f" => "\\f"
+				| #"\n" => "\\n"
+				| #"\r" => "\\r"
+				| #"\t" => "\\t"
+				| c => if (wchr < 0w32)
+				    then F.format "\\u%04x" [F.WORD wchr]
+				    else str c
+			      (* end case *))
+			in
+			  tr (i, c :: chrs)
+			end
 		      else tr(i, F.format "\\u%04x" [F.WORD wchr] :: chrs)
 		  | NONE => String.concat(List.rev chrs)
 		(* end case *))

src/JSON/json-tokens.sml

@@ -21,6 +21,7 @@ structure JSONTokens =
       | INT of IntInf.int
       | FLOAT of real
       | STRING of string
+      | ERROR of string list
 
     fun toString EOF = "<eof>"
       | toString LB = "["
@@ -43,5 +44,6 @@ structure JSONTokens =
 	  in
 	    String.concat("\"" :: (List.foldr f ["\""] (UTF8.explode s)))
 	  end
+      | toString (ERROR msg) = "<error>" (* default behavior should be overridden *)
 
   end

src/JSON/json-util.sml

@@ -133,7 +133,7 @@ structure JSONUtil : sig
 
     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)
+		 of NONE => raise FieldNotFound(v, concat["no definition for field \"", lab, "\""])
 		  | SOME(_, v) => v
 		(* end case *))
 	  in
@@ -197,7 +197,7 @@ structure JSONUtil : sig
     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)
+	   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
@@ -222,7 +222,7 @@ structure JSONUtil : sig
   (* 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)
+          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)

src/JSON/json.lex

@@ -75,5 +75,4 @@
 
 <INITIAL>"/*"(~(.*"*/".*))"*/"	=> ( skip() );
 
-(* FIXME: add some error reporting *)
-<INITIAL>.			=> ( skip() );
+<INITIAL>. => ( T.ERROR["bad character '", String.toString yytext, "'"]);

src/JSON/json.lex.sml

@@ -2,6 +2,8 @@ structure JSONLexer  = struct
 
     datatype yystart_state = 
 S | INITIAL
+    local
+
     structure UserDeclarations = 
       struct
 
@@ -23,10 +25,8 @@ S | INITIAL
 	end
   fun finishString () = (T.STRING(String.concat(List.rev(!sbuf))) before sbuf := [])
 
-
       end
 
-    local
     datatype yymatch 
       = yyNO_MATCH
       | yyMATCH of ULexBuffer.stream * action * yymatch
@@ -70,7 +70,7 @@ Vector.fromList []
         (* 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
+	  fun yygetc strm = (case ULexBuffer.getu strm
                 of (SOME (0w10, s')) => 
 		     (AntlrStreamPos.markNewLine yysm (ULexBuffer.getpos strm);
 		      SOME (0w10, s'))
@@ -104,7 +104,7 @@ Vector.fromList []
 		(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'
+		      val finals = List.map (fn i => Vector.sub (actTable, i)) finals'
 		      fun tryfinal() = 
 		            yystuck (yyactsToMatches (strm, finals, oldMatches))
 		      fun find (c, []) = NONE
@@ -185,7 +185,12 @@ fun yyAction24 (strm, lastMatch : yymatch) = let
 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 yyAction27 (strm, lastMatch : yymatch) = let
+      val yytext = yymktext(strm)
+      in
+        yystrm := strm;
+          T.ERROR["bad character '", String.toString yytext, "'"]
+      end
 fun yyQ33 (strm, lastMatch : yymatch) = (case (yygetc(strm))
        of NONE => yyAction2(strm, yyNO_MATCH)
         | SOME(inp, strm') => yyAction2(strm, yyNO_MATCH)

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

@@ -1,101 +0,0 @@
-(* 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

@@ -1,102 +0,0 @@
---- 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

@@ -107,19 +107,23 @@ structure JSONStreamPrinter : sig
 	  val getWChar = UTF8.getu getChar
 	  fun tr (i, chrs) = (case getWChar i
 		 of SOME(wchr, i) => if (wchr <= 0w126)
-		      then (case UTF8.toAscii wchr
-			 of #"\"" => "\\\""
-			  | #"\\" => "\\\\"
-			  | #"/" => "\\/"
-			  | #"\b" => "\\b"
-			  | #"\f" => "\\f"
-			  | #"\n" => "\\n"
-			  | #"\r" => "\\r"
-			  | #"\t" => "\\t"
-			  | c => if (wchr < 0w32)
-			      then tr(i, F.format "\\u%04x" [F.WORD wchr] :: chrs)
-			      else tr(i, str c :: chrs)
-			(* end case *))
+		      then let
+			val c = (case UTF8.toAscii wchr
+			       of #"\"" => "\\\""
+				| #"\\" => "\\\\"
+				| #"/" => "\\/"
+				| #"\b" => "\\b"
+				| #"\f" => "\\f"
+				| #"\n" => "\\n"
+				| #"\r" => "\\r"
+				| #"\t" => "\\t"
+				| c => if (wchr < 0w32)
+				    then F.format "\\u%04x" [F.WORD wchr]
+				    else str c
+			      (* end case *))
+			in
+			  tr (i, c :: chrs)
+			end
 		      else tr(i, F.format "\\u%04x" [F.WORD wchr] :: chrs)
 		  | NONE => String.concat(List.rev chrs)
 		(* end case *))

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

@@ -1,5 +1,5 @@
---- json-stream-printer.sml.orig	2020-04-08 19:00:10.000000000 +0200
-+++ json-stream-printer.sml	2020-07-03 15:23:14.218708000 +0200
+--- json-stream-printer.sml.orig	2020-05-20 19:13:04.000000000 +0200
++++ json-stream-printer.sml	2020-07-29 14:26:23.965874000 +0200
 @@ -70,7 +70,7 @@
  		then TextIO.output(strm, String.extract(tenSpaces, 10-n, NONE))
  		else (TextIO.output(strm, tenSpaces); prIndent(n-10))
@@ -9,30 +9,7 @@
  	  end
  
      fun incIndent (P{indent, ...}, n) = indent := !indent + n;
-@@ -108,14 +108,14 @@
- 	  fun tr (i, chrs) = (case getWChar i
- 		 of SOME(wchr, i) => if (wchr <= 0w126)
- 		      then (case UTF8.toAscii wchr
--			 of #"\"" => "\\\""
--			  | #"\\" => "\\\\"
--			  | #"/" => "\\/"
--			  | #"\b" => "\\b"
--			  | #"\f" => "\\f"
--			  | #"\n" => "\\n"
--			  | #"\r" => "\\r"
--			  | #"\t" => "\\t"
-+			 of #"\"" => tr(i, "\\\"" :: chrs)
-+			  | #"\\" => tr(i, "\\\\" :: chrs)
-+			  | #"/" => tr(i, "\\/" :: chrs)
-+			  | #"\b" => tr(i, "\\b" :: chrs)
-+			  | #"\f" => tr(i, "\\f" :: chrs)
-+			  | #"\n" => tr(i, "\\n" :: chrs)
-+			  | #"\r" => tr(i, "\\r" :: chrs)
-+			  | #"\t" => tr(i, "\\t" :: chrs)
- 			  | c => if (wchr < 0w32)
- 			      then tr(i, F.format "\\u%04x" [F.WORD wchr] :: chrs)
- 			      else tr(i, str c :: chrs)
-@@ -131,7 +131,7 @@
+@@ -135,7 +135,7 @@
  	   of CLOSED => raise Fail "closed printer"
  	    | _ => (
  		optComma p;
@@ -41,7 +18,7 @@
  		ctx := FIRST(OBJECT(!ctx)))
  	  (* end case *))
  
-@@ -148,7 +148,7 @@
+@@ -152,7 +152,7 @@
      fun endObject (p as P{ctx, ...}) = let
  	  fun prEnd ctx' = (
  		ctx := ctx';
@@ -50,7 +27,7 @@
  	  in
  	    case !ctx
  	     of CLOSED => raise Fail "closed printer"
-@@ -163,14 +163,14 @@
+@@ -167,14 +167,14 @@
  	   of CLOSED => raise Fail "closed printer"
  	    | _ => (
  		optComma p;