[MLton-commit] r6331
Vesa Karvonen
vesak at mlton.org
Wed Jan 16 05:19:05 PST 2008
More careful treatment of extra input.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/read.sml
U mltonlib/trunk/com/ssh/generic/unstable/public/value/read.sig
U mltonlib/trunk/com/ssh/generic/unstable/test/read.sml
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/read.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/read.sml 2008-01-15 19:06:28 UTC (rev 6330)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/read.sml 2008-01-16 13:19:04 UTC (rev 6331)
@@ -204,7 +204,7 @@
infixr 0 -->
(* SML/NJ workaround --> *)
- infix 1 >> >>>
+ infix 1 << >> <<< >>>
structure Parsec = MkParsec
(structure Sequence = struct
@@ -245,11 +245,11 @@
val ignored = ignored 0
+ fun l << r = l >>= (fn l => r >> return l)
fun l >>> r = l >> ignored >> r
+ fun l <<< r = l >>= (fn l => ignored >> r >> return l)
- fun parens p =
- guess (E#"(" >>> eta parens p) >>= (fn x => E#")" >>> return x) <|> p
- fun wrap p = parens (p >>= (fn x => ignored >> return x))
+ fun parens p = guess (E#"(" >>> eta parens p) <<< E#")" <|> p
datatype radix = datatype StringCvt.radix
@@ -273,17 +273,17 @@
val label = numLabel <|> shortId
fun mkSequ pre suf (Ops.S {fromList, ...}) p = let
- fun aft xs = E#"," >>> bef xs <|>
- suf >> return (fromList (rev xs))
+ fun fin xs () = return (fromList (rev xs))
+ fun aft xs = ignored >> (E#"," >>> bef xs <|> suf >>= fin xs)
and bef xs = p >>= (fn x => aft (x::xs))
in
- wrap (pre >>> (suf >>= (fn () => return (fromList [])) <|> bef []))
+ parens (pre >>> (suf >>= fin [] <|> bef []))
end
fun mkReal (Ops.R {scan, ...} : ('r, 'w, Sequence.t) Ops.r) : 'r t =
- wrap (fromScan scan)
+ parens (fromScan scan)
- fun mkScalar scan mk = wrap (mk (fromScan o scan))
+ fun mkScalar scan mk = parens (mk (fromScan o scan))
fun mkWord (Ops.W {scan, ...} : ('w, Sequence.t) Ops.w) : 'w t =
mkScalar scan (fn p => L"0w" >> (E#"x" >> p HEX <|>
@@ -321,36 +321,44 @@
open ReadRep.This
- fun reader t =
- case getT t
- of pA => fn rC => fn s =>
- case Univ.Iso.new ()
- of (to, from) =>
- Sum.map (from, fn (v, ((_, s), _)) => (v, from s))
- (parse (ignored >> pA)
- ((Reader.mapState (from, to) rC, to s),
- ()))
+ fun reader' pA rC s =
+ case Univ.Iso.new ()
+ of (to, from) =>
+ Sum.map (from, fn (v, ((_, s), _)) => (v, from s))
+ (parse (ignored >> pA)
+ ((Reader.mapState (from, to) rC, to s),
+ ()))
- fun read t =
- (fn INR (x, _) => x
- | INL s => let
- val pos = StringSequence.pos s
- val str = StringSequence.string s
- val size = String.size str
- val begin = Int.max (0, pos - 5)
- val beyond = Int.min (pos + 5, size)
- fun substr b e = String.toString (String.substring (str, b, e-b))
- fun dotsUnless b = if b then "" else "..."
- in
- fails ["parse error at ", Int.toString pos, " (\"",
- dotsUnless (0 = begin),
- substr begin pos, ".", substr pos beyond,
- dotsUnless (size = beyond),
- "\")"]
- end) o
- reader t StringSequence.get o
- StringSequence.full
+ fun reader t = reader' (getT t)
+ local
+ fun error s = let
+ val pos = StringSequence.pos s
+ val str = StringSequence.string s
+ val size = String.size str
+ val begin = Int.max (0, pos - 5)
+ val beyond = Int.min (pos + 5, size)
+ fun substr b e = String.toString (String.substring (str, b, e-b))
+ fun dotsUnless b = if b then "" else "..."
+ in
+ fails ["parse error at ", Int.toString pos, " (\"",
+ dotsUnless (0 = begin),
+ substr begin pos, ".", substr pos beyond,
+ dotsUnless (size = beyond),
+ "\")"]
+ end
+ in
+ fun read t =
+ (fn INR (x, s) =>
+ if StringSequence.pos s = size (StringSequence.string s)
+ then x
+ else error s
+ | INL s => error s) o
+ reader' (getT t << ignored)
+ StringSequence.get o
+ StringSequence.full
+ end
+
structure Open = LayerCases
(fun iso bP (_, b2a) = map b2a bP
fun isoProduct (INP (lps, fromSlice)) (_, b2a) =
@@ -370,19 +378,19 @@
val ps = List.map #2 lps
val n = length ps
fun lp a i =
- fn [] => E#")" >>> return (#1 (fromSlice (ArraySlice.full a)))
+ fn [] => E#")" >> return (#1 (fromSlice (ArraySlice.full a)))
| p::ps => p >>= (fn x =>
(Array.update (a, i, SOME x)
; (if null ps
- then return ()
- else E#",") >>> lp a (i+1) ps))
+ then ignored
+ else ignored >> E#"," >> ignored) >> lp a (i+1) ps))
in
E#"(" >>> parens (lp (Array.array (n, NONE)) 0 ps)
end
fun record (INP (lps, fromSlice)) = let
val n = length lps
fun lp a =
- fn 0 => E#"}" >>> return (#1 (fromSlice (ArraySlice.full a)))
+ fn 0 => E#"}" >> return (#1 (fromSlice (ArraySlice.full a)))
| n => label >>= (fn l =>
case List.findi (l <\ op = o #1 o #2) lps
of NONE => zero
@@ -392,8 +400,8 @@
else ignored >> I"=" >>> p >>= (fn x =>
(Array.update (a, i, SOME x)
; if n <= 1
- then lp a 0
- else E#"," >>> lp a (n-1))))
+ then ignored >> lp a 0
+ else ignored >> E#"," >>> lp a (n-1))))
in
parens (E#"{" >>> (fn ? => lp (Array.array (n, NONE)) n ?))
end
@@ -402,13 +410,12 @@
case l s
of SOME l => SOME (map INL l)
| NONE => Option.map (map INR) (r s)
- val unit = E#"(" >>> wrap (E#")")
- fun C0 c = C c ignored
+ val unit = E#"(" >>> parens (E#")")
+ fun C0 c = C c (return ())
fun C1 c t = C c (ignored >> t)
- fun data t =
- parens (longId >>= (fn s => case t (String.concatWith "." s)
- of NONE => zero
- | SOME p => p))
+ fun data t = parens (longId >>= (fn s => case t (String.concatWith "." s)
+ of NONE => zero
+ | SOME p => p))
val Y = Tie.function
@@ -428,12 +435,10 @@
val largeInt = mkInt LargeIntOps.ops
val largeWord = mkWord LargeWordOps.ops
- val bool =
- wrap (alphaId >>= (fn "true" => return true
- | "false" => return false
- | _ => zero))
- val char =
- parens (L"#\"" >> fromScan Char.scan >>= (fn c => E#"\"" >>> return c))
+ val bool = parens (alphaId >>= (fn "true" => return true
+ | "false" => return false
+ | _ => zero))
+ val char = parens (L"#\"" >> fromScan Char.scan << E#"\"")
val int = mkInt IntOps.ops
val string = let
@@ -449,7 +454,7 @@
and escape cs =
elem >>= (fn c => if #"^" = c then
sat Char.isPrint >>= (fn c =>
- chars (c:: #"^":: #"\\"::cs))
+ chars (c :: #"^" :: #"\\" :: cs))
else if Char.isSpace c then
drop Char.isSpace >> E#"\\" >> chars cs
else if Char.isPrint c then
@@ -457,7 +462,7 @@
else
zero)
in
- wrap (E#"\"" >> chars [])
+ parens (E#"\"" >> chars [])
end
val word = mkWord WordOps.ops
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/read.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/read.sig 2008-01-15 19:06:28 UTC (rev 6330)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/read.sig 2008-01-16 13:19:04 UTC (rev 6331)
@@ -6,11 +6,35 @@
(**
* Signature for a generic read function.
+ *
+ * Spaces and SML-style comments are skipped implicitly.
+ *
+ * Functions cannot be read.
*)
signature READ = sig
structure ReadRep : OPEN_REP
+ val reader :
+ ('a, 'x) ReadRep.t -> (Char.t, 'b) Reader.t -> 'b -> ('b, 'a * 'b) Sum.t
+ (**
+ * Parses a value of type {'a} from the given stream of type {'b}.
+ * Returns either the stream at a position where a parse error was
+ * detected or the parsed value and the stream at a position
+ * immediately after the parsed value. Other errors (e.g. {Overflow})
+ * cause exceptions being raised.
+ *
+ * Note that parsing stops immediately after a valid value has been
+ * parsed. Any characters, spaces or otherwise, following a valid
+ * value are ignored.
+ *)
+
val read : ('a, 'x) ReadRep.t -> String.t -> 'a
+ (**
+ * Parses a value of type {'a} from the given string. Parse and other
+ * errors (e.g. {Overflow}) cause exceptions being raised. Parsing is
+ * considered to fail unless the whole string is consumed. Spaces and
+ * SML-style comments are consumed implicitly.
+ *)
end
signature READ_CASES = sig
Modified: mltonlib/trunk/com/ssh/generic/unstable/test/read.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test/read.sml 2008-01-15 19:06:28 UTC (rev 6330)
+++ mltonlib/trunk/com/ssh/generic/unstable/test/read.sml 2008-01-16 13:19:04 UTC (rev 6331)
@@ -85,5 +85,7 @@
(testSR (tuple2 (tuple2 (string, vector (option unit)), list char))
[Fmt.default])
+ (testFails (fn () => read int "0 garbage accepted"))
+
$
end
More information about the MLton-commit
mailing list