[MLton-commit] r6307
Vesa Karvonen
vesak at mlton.org
Wed Jan 9 09:46:24 PST 2008
Preliminary partial implementation of generic read and some minor changes.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/Generate-combination.sh
U mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/sigs.cm
U mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
U mltonlib/trunk/com/ssh/generic/unstable/detail/util/ops.sml
A mltonlib/trunk/com/ssh/generic/unstable/detail/value/read.sml
U mltonlib/trunk/com/ssh/generic/unstable/lib-with-default.mlb
U mltonlib/trunk/com/ssh/generic/unstable/lib-with-default.use
U mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
U mltonlib/trunk/com/ssh/generic/unstable/lib.use
U mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
U mltonlib/trunk/com/ssh/generic/unstable/public/value/arbitrary.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/value/pickle.sig
A mltonlib/trunk/com/ssh/generic/unstable/public/value/read.sig
U mltonlib/trunk/com/ssh/generic/unstable/test/generic.sml
U mltonlib/trunk/com/ssh/generic/unstable/test/pickle.sml
A mltonlib/trunk/com/ssh/generic/unstable/test/read.sml
U mltonlib/trunk/com/ssh/generic/unstable/test.mlb
U mltonlib/trunk/com/ssh/generic/unstable/test.use
A mltonlib/trunk/com/ssh/generic/unstable/with/read.sml
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/Generate-combination.sh
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/Generate-combination.sh 2008-01-09 17:36:04 UTC (rev 6306)
+++ mltonlib/trunk/com/ssh/generic/unstable/Generate-combination.sh 2008-01-09 17:46:22 UTC (rev 6307)
@@ -19,7 +19,7 @@
*> $(basename $0) $source $target
*)" > "$target"
-grep -e '[ /]with/.*\.sml' "$source" \
+grep -e 'with/.*\.sml' "$source" \
| xargs cat \
| grep -v -e '^[( ]\*' \
>> "$target"
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml 2008-01-09 17:36:04 UTC (rev 6306)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml 2008-01-09 17:46:22 UTC (rev 6307)
@@ -4,7 +4,7 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
-(* WARNING: This file was generated by running 'Generate-combination.sh' script as:
+(* WARNING: This file was generated by running:
*
*> Generate-combination.sh lib-with-default.mlb detail/generic.sml
*)
@@ -15,6 +15,7 @@
structure Generic = RootGeneric
+
signature Generic = sig
include Generic EQ
end
@@ -29,6 +30,7 @@
MkGeneric (structure Open = WithEq (Generic)
open Generic Open)
+
signature Generic = sig
include Generic TYPE_HASH
end
@@ -43,6 +45,7 @@
MkGeneric (structure Open = WithTypeHash (Generic)
open Generic Open)
+
signature Generic = sig
include Generic TYPE_INFO
end
@@ -57,6 +60,7 @@
MkGeneric (structure Open = WithTypeInfo (Generic)
open Generic Open)
+
signature Generic = sig
include Generic HASH
end
@@ -71,6 +75,7 @@
MkGeneric (structure Open = WithHash (Generic)
open Generic Open)
+
signature Generic = sig
include Generic ORD
end
@@ -85,6 +90,7 @@
MkGeneric (structure Open = WithOrd (Generic)
open Generic Open)
+
signature Generic = sig
include Generic PRETTY
end
@@ -99,6 +105,21 @@
MkGeneric (structure Open = WithPretty (Generic)
open Generic Open)
+
+signature Generic = sig
+ include Generic READ
+end
+
+functor MkGeneric (Arg : Generic) = struct
+ structure Open = MkGeneric (Arg)
+ open Arg Open
+ structure ReadRep = Open.Rep
+end
+
+structure Generic =
+ MkGeneric (structure Open = WithRead (Generic)
+ open Generic Open)
+
structure Generic = struct
structure Rep = ClosePrettyWithExtra (Generic)
open Generic Rep
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/sigs.cm
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/sigs.cm 2008-01-09 17:36:04 UTC (rev 6306)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/sigs.cm 2008-01-09 17:46:22 UTC (rev 6307)
@@ -31,6 +31,7 @@
../../../public/value/ord.sig
../../../public/value/pickle.sig
../../../public/value/pretty.sig
+ ../../../public/value/read.sig
../../../public/value/reduce.sig
../../../public/value/seq.sig
../../../public/value/shrink.sig
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2008-01-09 17:36:04 UTC (rev 6306)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2008-01-09 17:46:22 UTC (rev 6307)
@@ -33,6 +33,7 @@
../../value/ord.sml
../../value/pickle.sml
../../value/pretty.sml
+ ../../value/read.sml
../../value/reduce.sml
../../value/seq.sml
../../value/shrink.sml
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/util/ops.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/util/ops.sml 2008-01-09 17:36:04 UTC (rev 6306)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/util/ops.sml 2008-01-09 17:46:22 UTC (rev 6307)
@@ -40,6 +40,8 @@
R of {bitsOps : ('word, 'stream) w,
bytesPerElem : Int.t,
isoBits : ('real, 'word) Iso.t Option.t,
+ scan : (Char.t, 'stream) Reader.t
+ -> ('real, 'stream) Reader.t,
subArr : Word8Array.t * Int.t -> 'real,
toBytes : 'real -> Word8Vector.t}
@@ -79,16 +81,20 @@
structure IntOps = MkIntOps (Int)
structure LargeIntOps = MkIntOps (LargeInt)
-functor MkRealOps (include CAST_REAL PACK_REAL
- val ops : (Bits.t, 'stream) Ops.w
- sharing type t = real) = struct
+functor MkRealOps (structure Real : REAL
+ include CAST_REAL where type t = Real.t
+ include PACK_REAL where type real = Real.t
+ val ops : (Bits.t, 'stream) Ops.w) = struct
val ops = Ops.R {bitsOps = ops, bytesPerElem = bytesPerElem,
- isoBits = isoBits, subArr = subArr, toBytes = toBytes}
+ isoBits = isoBits, scan = Real.scan, subArr = subArr,
+ toBytes = toBytes}
end
-structure RealOps = MkRealOps (open CastReal PackRealLittle RealWordOps)
+structure RealOps = MkRealOps (open CastReal PackRealLittle RealWordOps
+ structure Real = Real)
structure LargeRealOps =
- MkRealOps (open CastLargeReal PackLargeRealLittle LargeRealWordOps)
+ MkRealOps (open CastLargeReal PackLargeRealLittle LargeRealWordOps
+ structure Real = LargeReal)
functor MkSeqOps (structure Seq : sig
type 'a t
Added: mltonlib/trunk/com/ssh/generic/unstable/detail/value/read.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/read.sml 2008-01-09 17:36:04 UTC (rev 6306)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/read.sml 2008-01-09 17:46:22 UTC (rev 6307)
@@ -0,0 +1,485 @@
+(* Copyright (C) 2008 Vesa Karvonen
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+signature SEQUENCE = sig
+ type t
+ structure Elem : T
+ structure Pos : T
+ val pos : t -> Pos.t
+ val get : (Elem.t, t) Reader.t
+end
+
+signature MK_PARSEC_DOM = sig
+ structure Sequence : SEQUENCE
+end
+
+signature PARSEC = sig
+ include MK_PARSEC_DOM
+
+ include ETAEXP'
+ include MONADP where type 'a monad = 'a etaexp
+
+ type 'a t = 'a etaexp
+
+ val parse : 'a t -> Sequence.t -> (Sequence.Pos.t, 'a * Sequence.t) Sum.t
+ val fromScan :
+ ((Sequence.Elem.t, Sequence.t) Reader.t -> ('a, Sequence.t) Reader.t) -> 'a t
+ val fromReader : ('a, Sequence.t) Reader.t -> 'a t
+ val guess : 'a t UnOp.t
+ val elem : Sequence.Elem.t t
+ val drop : Sequence.Elem.t UnPr.t -> Unit.t t
+ val sat : Sequence.Elem.t UnPr.t -> Sequence.Elem.t t
+ val take : Sequence.Elem.t UnPr.t -> Sequence.Elem.t List.t t
+ val peek : 'a t UnOp.t
+ val ^* : 'a t -> 'a List.t t
+end
+
+functor MkParsec (Arg : MK_PARSEC_DOM) :> PARSEC
+ where type Sequence.t = Arg.Sequence.t
+ where type Sequence.Elem.t = Arg.Sequence.Elem.t
+ where type Sequence.Pos.t = Arg.Sequence.Pos.t =
+struct
+ (* <-- SML/NJ workaround *)
+ open TopLevel
+ infix 7 *`
+ infix 6 +`
+ infixr 6 <^> <+>
+ infixr 5 <$> <$$> </> <//>
+ infix 4 <\ \>
+ infixr 4 </ />
+ infix 2 >| andAlso
+ infixr 2 |<
+ infix 1 orElse >>=
+ infix 0 & <|>
+ infixr 0 -->
+ (* SML/NJ workaround --> *)
+
+ open Arg
+ type 'a etaexp_dom = Sequence.t
+ type msg = Sequence.Pos.t
+ datatype 'a reply =
+ OK of 'a * 'a etaexp_dom * msg
+ | FAIL of msg
+ datatype 'a etaexp_cod =
+ EATEN of 'a reply
+ | TASTE of 'a reply Thunk.t
+ | EMPTY of 'a reply
+ type 'a etaexp = 'a etaexp_dom -> 'a etaexp_cod
+ type 'a t = 'a etaexp
+
+ val get = Sequence.get
+ val pos = Sequence.pos
+
+ fun parse p s =
+ case case p s
+ of EMPTY r => r
+ | EATEN r => r
+ | TASTE th => th ()
+ of FAIL p => INL p
+ | OK (x, s, _) => INR (x, s)
+
+ fun fromReader reader s =
+ case reader s
+ of SOME (x, s) => EATEN (OK (x, s, pos s))
+ | NONE => EMPTY (FAIL (pos s))
+
+ fun fromScan scan = fromReader (scan Sequence.get)
+
+ fun merge m =
+ fn OK (x, s, _) => OK (x, s, m)
+ | FAIL _ => FAIL m
+
+ fun bindSome m =
+ fn EMPTY r => merge m r
+ | EATEN r => r
+ | TASTE th => th ()
+
+ fun replyNone m =
+ fn EMPTY r => EMPTY (merge m r)
+ | other => other
+
+ fun return x s = EMPTY (OK (x, s, pos s))
+
+ fun (xM >>= x2yM) s =
+ case xM s
+ of EATEN (FAIL m) => EATEN (FAIL m)
+ | EATEN (OK (x, s, m)) => TASTE (fn () => bindSome m (x2yM x s))
+ | TASTE th => TASTE (fn () =>
+ case th ()
+ of FAIL e => FAIL e
+ | OK (x, s, m) => bindSome m (x2yM x s))
+ | EMPTY (FAIL m) => EMPTY (FAIL m)
+ | EMPTY (OK (x, s, m)) => replyNone m (x2yM x s)
+
+ fun zero s = EMPTY (FAIL (pos s))
+
+ fun (p <|> q) s =
+ case p s
+ of EMPTY (FAIL m) => replyNone m (q s)
+ | other => other
+
+ fun guess p s =
+ case p s
+ of EMPTY r => EMPTY r
+ | EATEN (FAIL _) => EMPTY (FAIL (pos s))
+ | EATEN (OK r) => EATEN (OK r)
+ | TASTE th => case th ()
+ of FAIL _ => EMPTY (FAIL (pos s))
+ | result => EATEN result
+
+ fun elem s =
+ case get s
+ of NONE => EMPTY (FAIL (pos s))
+ | SOME (c, s) => EATEN (OK (c, s, pos s))
+
+ fun drop p s = let
+ fun done f s = f (OK ((), s, pos s))
+ fun some (c, s') s = if p c then lp s' else done EATEN s
+ and body f s =
+ case get s
+ of NONE => done f s
+ | SOME cs => some cs s
+ and lp s = body EATEN s
+ in
+ body EMPTY s
+ end
+
+ fun sat p s =
+ case get s
+ of NONE => EMPTY (FAIL (pos s))
+ | SOME (c, s') =>
+ EATEN (if p c then OK (c, s', pos s') else FAIL (pos s))
+
+ fun take p = let
+ fun done s =
+ fn [] => EMPTY (OK ([], s, pos s))
+ | cs => EATEN (OK (rev cs, s, pos s))
+ fun lp cs s =
+ case get s
+ of NONE => done s cs
+ | SOME (c, s') =>
+ if p c
+ then lp (c::cs) s'
+ else done s cs
+ in
+ lp []
+ end
+
+ fun peek p s =
+ case p s
+ of EATEN (OK (x, _, m)) => EATEN (OK (x, s, m))
+ | EATEN (FAIL m) => EATEN (FAIL m)
+ | EMPTY (OK (x, _, m)) => EMPTY (OK (x, s, m))
+ | EMPTY (FAIL m) => EMPTY (FAIL m)
+ | TASTE th => case th ()
+ of OK (x, _, m) => EATEN (OK (x, s, m))
+ | FAIL m => EATEN (FAIL m)
+
+ fun ^* p = p >>= (fn x => ^* p >>= (fn xs => return (x::xs))) <|> return []
+
+ structure Monad = MkMonadP
+ (type 'a monad = 'a t
+ val return = return
+ val op >>= = op >>=
+ val zero = zero
+ val op <|> = op <|>)
+
+ open Monad
+end
+
+functor WithRead (Arg : WITH_READ_DOM) : READ_CASES = struct
+ (* <-- SML/NJ workaround *)
+ open TopLevel
+ infix 7 *`
+ infix 6 +`
+ infixr 6 <^> <+>
+ infixr 5 <$> <$$> </> <//>
+ infix 4 <\ \>
+ infixr 4 </ />
+ infix 2 >| andAlso
+ infixr 2 |<
+ infix 1 orElse >>= >>& >>*
+ infix 0 & <|>
+ infixr 0 -->
+ (* SML/NJ workaround --> *)
+
+ infix 1 >> >>>
+
+ structure Parsec = MkParsec
+ (structure Sequence = struct
+ structure Pos = Univ
+ structure Elem = Char
+ type t = (Elem.t, Pos.t) Reader.t * Pos.t
+ val pos = Pair.snd
+ fun get (r, s) =
+ case r s
+ of NONE => NONE
+ | SOME (c, s) => SOME (c, (r, s))
+ end)
+ open Parsec
+
+ fun L l = fromReader let
+ fun lp i s =
+ if i = size l
+ then SOME ((), s)
+ else case Sequence.get s
+ of NONE => NONE
+ | SOME (c, s') =>
+ if c = String.sub (l, i)
+ then lp (i+1) s'
+ else NONE
+ in
+ lp 0
+ end
+
+ val spaces = drop Char.isSpace
+
+ fun l >>> r = l >> spaces >> r
+
+ fun wrap p =
+ L"(" >>> eta wrap p >>= (fn x => L")" >>> return x) <|>
+ p >>= (fn x => spaces >> return x)
+
+ datatype radix = datatype StringCvt.radix
+
+ val alphaId =
+ map (implode o op ::)
+ (guess (sat Char.isAlpha) >>*
+ take (fn c => Char.isAlpha c
+ orelse Char.isDigit c
+ orelse #"'" = c orelse #"_" = c))
+ val symbolicId =
+ take (Char.contains "!#$%&*+-/:<=>?@\\^`|~") >>=
+ (fn [] => zero | cs => return (implode cs))
+
+ val shortId = alphaId <|> symbolicId
+ val longId = map op :: (shortId >>* ^* (L"." >> shortId))
+
+ val numLabel =
+ map (implode o op ::)
+ (guess (sat (Char.inRange (#"1", #"9"))) >>* take Char.isDigit)
+ val label = numLabel <|> shortId
+
+ fun mkSequ pre suf (Ops.S {fromList, ...}) p = let
+ val pre = L pre val suf = L suf val sep = L","
+ fun aft xs = suf >>= (fn () => return (fromList (rev xs))) <|>
+ sep >>> eta bef xs
+ and bef xs = p >>= (fn x => aft (x::xs))
+ in
+ wrap (pre >>> (suf >>= (fn () => return (fromList [])) <|> bef []))
+ end
+
+ fun mkReal (Ops.R {scan, ...} : ('r, 'w, Sequence.t) Ops.r) : 'r t =
+ wrap (fromScan scan)
+
+ fun mkScalar scan mk = wrap (mk (fromScan o scan))
+
+ fun mkWord (Ops.W {scan, ...} : ('w, Sequence.t) Ops.w) : 'w t =
+ mkScalar scan (fn p => L"0w" >> (L"x" >> p HEX <|>
+ L"o" >> p OCT <|>
+ L"b" >> p BIN <|>
+ p DEC))
+
+ fun mkInt (Ops.I {scan, ...} : ('i, Sequence.t) Ops.i) : 'i t =
+ mkScalar scan (fn p => peek (L"~0x" <|> L"0x") >> p HEX <|>
+ peek (L"~0o" <|> L"0o") >> p OCT <|>
+ peek (L"~0b" <|> L"0b") >> p BIN <|>
+ p DEC)
+
+ datatype 'a p =
+ INP of (String.t * Univ.t t) List.t *
+ (Univ.t Option.t ArraySlice.t -> 'a * Univ.t Option.t ArraySlice.t)
+
+ structure ReadRep = LayerRep
+ (open Arg
+ structure Rep = struct
+ type 'a t = 'a t
+ type 'a s = String.t -> 'a t Option.t
+ type ('a, 'k) p = 'a p
+ end)
+
+ 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, id)
+ (parse (spaces >> pA)
+ (Reader.mapState (from, to) rC, to s))
+
+ fun read t =
+ (fn INR (x, _) => x
+ | INL s => let
+ val (str, pos, len) = Substring.base s
+ val size = len + pos
+ 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 Substring.getc o
+ Substring.full
+
+ structure Open = LayerCases
+ (fun iso bP (_, b2a) = map b2a bP
+ fun isoProduct (INP (lps, fromSlice)) (_, b2a) =
+ INP (lps, Pair.map (b2a, id) o fromSlice)
+ fun isoSum bS (_, b2a) s = Option.map (map b2a) (bS s)
+
+ fun op *` (INP (ls, la), INP (rs, ra)) =
+ INP (ls @ rs,
+ fn ars =>
+ case la ars
+ of (l, ars) =>
+ case ra ars
+ of (r, ars) => (l & r, ars))
+ fun T t =
+ case Univ.Iso.new ()
+ of (to, from) =>
+ INP ([("", map to t)],
+ fn ars => case ArraySlice.getItem ars
+ of SOME (SOME u, ars) => (from u, ars)
+ | _ => fail "impossible")
+ fun R l t =
+ case Univ.Iso.new ()
+ of (to, from) =>
+ INP ([(Generics.Label.toString l, map to t)],
+ fn ars => case ArraySlice.getItem ars
+ of SOME (SOME u, ars) => (from u, ars)
+ | _ => fail "impossible")
+ fun tuple (INP (lps, fromSlice)) = let
+ val ps = List.map #2 lps
+ val n = length ps
+ fun lp a i =
+ fn [] => L")" >> return (#1 (fromSlice (ArraySlice.full a)))
+ | p::ps => p >>= (fn x =>
+ (Array.update (a, i, SOME x)
+ ; (if null ps
+ then return ()
+ else L",") >>> lp a (i+1) ps))
+ in
+ L"(" >>> wrap (lp (Array.array (n, NONE)) 0 ps)
+ end
+ fun record (INP (lps, fromSlice)) = let
+ val n = length lps
+ fun lp a =
+ fn 0 => L"}" >> return (#1 (fromSlice (ArraySlice.full a)))
+ | n => label >>= (fn l =>
+ case List.findi (l <\ op = o #1 o #2) lps
+ of NONE => zero
+ | SOME (i, (_, p)) =>
+ if isSome (Array.sub (a, i))
+ then zero
+ else spaces >> L"=" >>> p >>= (fn x =>
+ (Array.update (a, i, SOME x)
+ ; if n <= 1
+ then lp a 0
+ else L"," >>> lp a (n-1))))
+ in
+ wrap (L"{" >>> (fn ? => lp (Array.array (n, NONE)) n ?))
+ end
+
+ fun op +` (l, r) s =
+ case l s
+ of SOME l => SOME (map INL l)
+ | NONE => Option.map (map INR) (r s)
+ val unit = L"(" >>> wrap (L")")
+ fun C0 c s = if s = Generics.Con.toString c then SOME spaces else NONE
+ fun C1 c t s =
+ if s = Generics.Con.toString c then SOME (spaces >> t) else NONE
+ fun data t =
+ wrap (longId >>= (fn s => case t (String.concatWith "." s)
+ of NONE => zero
+ | SOME p => p))
+
+ val Y = Tie.function
+
+ fun op --> _ = failing "Read.--> unsupported"
+
+ val exn : Exn.t t = failing "Read.exn not yet implemented"
+ fun regExn0 _ _ = ()
+ fun regExn1 _ _ _ = ()
+
+ fun list t = mkSequ "[" "]" ListOps.ops t
+ fun vector t = mkSequ "#[" "]" VectorOps.ops t
+
+ fun array _ = failing "Read.array not yet implemented"
+ fun refc _ = failing "Read.refc not yet implemented"
+
+ val fixedInt = mkInt FixedIntOps.ops
+ val largeInt = mkInt LargeIntOps.ops
+ val largeWord = mkWord LargeWordOps.ops
+
+ val bool =
+ wrap (alphaId >>= (fn "true" => return true
+ | "false" => return false
+ | _ => zero))
+ val char =
+ wrap (L"#\"" >> fromScan Char.scan >>= (fn c => L"\"" >> return c))
+ val int = mkInt IntOps.ops
+ val string = let
+ fun finish cs stm =
+ case String.scan List.getItem cs
+ of NONE => NONE
+ | SOME (str, []) => SOME (str, stm)
+ | SOME _ => NONE
+ fun ord cs s =
+ case Sequence.get s
+ of NONE => NONE
+ | SOME (#"\"", _) => finish (rev cs) s
+ | SOME (#"\\", s) => esc (#"\\"::cs) s
+ | SOME (c, s) => ord (c::cs) s
+ and esc cs s =
+ case Sequence.get s
+ of NONE => NONE
+ | SOME (#"^", s) => hat (#"^"::cs) s
+ | SOME (c, s) =>
+ if Char.isSpace c then fmt (c::cs) s
+ else if Char.isDigit c then dec 2 (c::cs) s
+ else ord (c::cs) s
+ and fmt cs s =
+ case Sequence.get s
+ of NONE => NONE
+ | SOME (#"\\", s) => ord (#"\\"::cs) s
+ | SOME (c, s) =>
+ if Char.isSpace c then fmt (c::cs) s else NONE
+ and dec n cs s =
+ if 0 = n
+ then ord cs s
+ else case Sequence.get s
+ of NONE => NONE
+ | SOME (c, s) =>
+ if Char.isDigit c then dec (n-1) (c::cs) s else NONE
+ and hat cs s =
+ case Sequence.get s
+ of NONE => NONE
+ | SOME (c, s) => ord (c::cs) s
+ in
+ wrap (L"\"" >> fromReader (ord []) >>= (fn s => L"\"" >> return s))
+ end
+ val word = mkWord WordOps.ops
+
+ val largeReal = mkReal LargeRealOps.ops
+ val real = mkReal RealOps.ops
+
+ val word8 = mkWord Word8Ops.ops
+ val word32 = mkWord Word32Ops.ops
+(*
+ val word64 = mkWord Word64Ops.ops
+*)
+
+ fun hole () = undefined
+
+ open Arg ReadRep)
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/detail/value/read.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Modified: mltonlib/trunk/com/ssh/generic/unstable/lib-with-default.mlb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/lib-with-default.mlb 2008-01-09 17:36:04 UTC (rev 6306)
+++ mltonlib/trunk/com/ssh/generic/unstable/lib-with-default.mlb 2008-01-09 17:46:22 UTC (rev 6307)
@@ -14,4 +14,5 @@
with/hash.sml
with/ord.sml
with/pretty.sml
+with/read.sml
with/close-pretty-with-extra.sml
Modified: mltonlib/trunk/com/ssh/generic/unstable/lib-with-default.use
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/lib-with-default.use 2008-01-09 17:36:04 UTC (rev 6306)
+++ mltonlib/trunk/com/ssh/generic/unstable/lib-with-default.use 2008-01-09 17:46:22 UTC (rev 6307)
@@ -12,4 +12,5 @@
"with/hash.sml",
"with/ord.sml",
"with/pretty.sml",
+ "with/read.sml",
"with/close-pretty-with-extra.sml"] ;
Modified: mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2008-01-09 17:36:04 UTC (rev 6306)
+++ mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2008-01-09 17:46:22 UTC (rev 6307)
@@ -99,6 +99,9 @@
public/value/pretty.sig
detail/value/pretty.sml
+ public/value/read.sig
+ detail/value/read.sml
+
public/value/reduce.sig
detail/value/reduce.sml
Modified: mltonlib/trunk/com/ssh/generic/unstable/lib.use
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/lib.use 2008-01-09 17:36:04 UTC (rev 6306)
+++ mltonlib/trunk/com/ssh/generic/unstable/lib.use 2008-01-09 17:46:22 UTC (rev 6307)
@@ -59,6 +59,8 @@
"detail/value/pickle.sml",
"public/value/pretty.sig",
"detail/value/pretty.sml",
+ "public/value/read.sig",
+ "detail/value/read.sml",
"public/value/reduce.sig",
"detail/value/reduce.sml",
"public/value/seq.sig",
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2008-01-09 17:36:04 UTC (rev 6306)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2008-01-09 17:46:22 UTC (rev 6307)
@@ -170,6 +170,10 @@
and WITH_PRETTY_DOM = WITH_PRETTY_DOM
functor WithPretty (Arg : WITH_PRETTY_DOM) : PRETTY_CASES = WithPretty (Arg)
+signature READ = READ and READ_CASES = READ_CASES
+ and WITH_READ_DOM = WITH_READ_DOM
+functor WithRead (Arg : WITH_READ_DOM) : READ_CASES = WithRead (Arg)
+
signature REDUCE = REDUCE and REDUCE_CASES = REDUCE_CASES
and WITH_REDUCE_DOM = WITH_REDUCE_DOM
functor WithReduce (Arg : WITH_REDUCE_DOM) : REDUCE_CASES = WithReduce (Arg)
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/arbitrary.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/arbitrary.sig 2008-01-09 17:36:04 UTC (rev 6306)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/arbitrary.sig 2008-01-09 17:46:22 UTC (rev 6307)
@@ -31,5 +31,5 @@
signature WITH_ARBITRARY_DOM = sig
include CASES HASH TYPE_INFO
sharing Open.Rep = HashRep = TypeInfoRep
- structure RandomGen : RANDOM_GEN
+ structure RandomGen : RANDOM_GEN (* = RanQD1Gen *)
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/pickle.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/pickle.sig 2008-01-09 17:36:04 UTC (rev 6306)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/pickle.sig 2008-01-09 17:46:22 UTC (rev 6307)
@@ -11,14 +11,12 @@
*
*> - val t = tuple2 (largeInt, list order) ;
*> val t = - : (IntInf.t * Order.t List.t) Rep.t
- *> - val p = pickle t (3141592653589793238, [LESS, EQUAL, GREATER]) ;
- *> val p = "\183\^N\1873\^@\b\214I2\162\223-\153+\^@\^C\^@\^A\^B"
- *> : String.t
+ *> - val p = pickle t (31415926535897, [LESS, EQUAL, GREATER]) ;
+ *> val p = "\^@\^F\2176$\151\146\^\\^@\^C\^@\^A\^B" : String.t
*> - size p ;
- *> val it = 19 : Int.t
+ *> val it = 13 : Int.t
*> - val x = unpickle t p ;
- *> val x = (3141592653589793238, [LESS, EQUAL, GREATER])
- *> : IntInf.t * Order.t List.t
+ *> val x = (31415926535897, [LESS, EQUAL, GREATER]) : IntInf.t * Order.t List.t
*
* == About the Design and Implementation ==
*
Added: mltonlib/trunk/com/ssh/generic/unstable/public/value/read.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/read.sig 2008-01-09 17:36:04 UTC (rev 6306)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/read.sig 2008-01-09 17:46:22 UTC (rev 6307)
@@ -0,0 +1,21 @@
+(* Copyright (C) 2008 Vesa Karvonen
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+(**
+ * Signature for a generic read function.
+ *)
+signature READ = sig
+ structure ReadRep : OPEN_REP
+
+ val read : ('a, 'x) ReadRep.t -> String.t -> 'a
+end
+
+signature READ_CASES = sig
+ include CASES READ
+ sharing Open.Rep = ReadRep
+end
+
+signature WITH_READ_DOM = CASES
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/public/value/read.sig
___________________________________________________________________
Name: svn:eol-style
+ native
Modified: mltonlib/trunk/com/ssh/generic/unstable/test/generic.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test/generic.sml 2008-01-09 17:36:04 UTC (rev 6306)
+++ mltonlib/trunk/com/ssh/generic/unstable/test/generic.sml 2008-01-09 17:46:22 UTC (rev 6307)
@@ -4,7 +4,7 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
-(* WARNING: This file was generated by running 'Generate-combination.sh' script as:
+(* WARNING: This file was generated by running:
*
*> Generate-combination.sh test.mlb test/generic.sml
*)
@@ -15,6 +15,7 @@
structure Generic = RootGeneric
+
signature Generic = sig
include Generic TYPE_INFO
end
@@ -29,6 +30,7 @@
MkGeneric (structure Open = WithTypeInfo (Generic)
open Generic Open)
+
signature Generic = sig
include Generic TYPE_HASH
end
@@ -43,6 +45,7 @@
MkGeneric (structure Open = WithTypeHash (Generic)
open Generic Open)
+
signature Generic = sig
include Generic HASH
end
@@ -57,6 +60,7 @@
MkGeneric (structure Open = WithHash (Generic)
open Generic Open)
+
signature Generic = sig
include Generic PRETTY
end
@@ -71,6 +75,7 @@
MkGeneric (structure Open = WithPretty (Generic)
open Generic Open)
+
signature Generic = sig
include Generic EQ
end
@@ -85,6 +90,7 @@
MkGeneric (structure Open = WithEq (Generic)
open Generic Open)
+
signature Generic = sig
include Generic DATA_REC_INFO
end
@@ -99,6 +105,7 @@
MkGeneric (structure Open = WithDataRecInfo (Generic)
open Generic Open)
+
signature Generic = sig
include Generic SOME
end
@@ -113,6 +120,7 @@
MkGeneric (structure Open = WithSome (Generic)
open Generic Open)
+
signature Generic = sig
include Generic PICKLE
end
@@ -127,6 +135,7 @@
MkGeneric (structure Open = WithPickle (Generic)
open Generic Open)
+
signature Generic = sig
include Generic SEQ
end
@@ -141,7 +150,23 @@
MkGeneric (structure Open = WithSeq (Generic)
open Generic Open)
+
signature Generic = sig
+ include Generic READ
+end
+
+functor MkGeneric (Arg : Generic) = struct
+ structure Open = MkGeneric (Arg)
+ open Arg Open
+ structure ReadRep = Open.Rep
+end
+
+structure Generic =
+ MkGeneric (structure Open = WithRead (Generic)
+ open Generic Open)
+
+
+signature Generic = sig
include Generic REDUCE
end
@@ -155,6 +180,7 @@
MkGeneric (structure Open = WithReduce (Generic)
open Generic Open)
+
signature Generic = sig
include Generic TRANSFORM
end
@@ -169,6 +195,7 @@
MkGeneric (structure Open = WithTransform (Generic)
open Generic Open)
+
signature Generic = sig
include Generic FMAP
end
@@ -199,6 +226,7 @@
structure RandomGen = RanQD1Gen)
open Generic Open)
+
signature Generic = sig
include Generic SIZE
end
@@ -213,6 +241,7 @@
MkGeneric (structure Open = WithSize (Generic)
open Generic Open)
+
signature Generic = sig
include Generic ORD
end
@@ -227,6 +256,7 @@
MkGeneric (structure Open = WithOrd (Generic)
open Generic Open)
+
signature Generic = sig
include Generic SHRINK
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/test/pickle.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test/pickle.sml 2008-01-09 17:36:04 UTC (rev 6306)
+++ mltonlib/trunk/com/ssh/generic/unstable/test/pickle.sml 2008-01-09 17:46:22 UTC (rev 6307)
@@ -13,11 +13,9 @@
fun thatSeq t args =
if seq t (#actual args, #expect args) then () else thatEq t args
- fun thatPU t x = let
- val p = pickle t x
- in
- thatSeq t {expect = x, actual = unpickle t p}
- end
+ fun thatPU t x =
+ case pickle t x
+ of p => thatSeq t {expect = x, actual = unpickle t p}
fun testAllSeq t =
testAll t (thatPU t)
Added: mltonlib/trunk/com/ssh/generic/unstable/test/read.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test/read.sml 2008-01-09 17:36:04 UTC (rev 6306)
+++ mltonlib/trunk/com/ssh/generic/unstable/test/read.sml 2008-01-09 17:46:22 UTC (rev 6307)
@@ -0,0 +1,62 @@
+(* Copyright (C) 2008 Vesa Karvonen
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+local
+ open Generic UnitTest
+
+ fun testSR t formats =
+ testAll t (fn x =>
+ app (fn format => let
+ val fmt = Prettier.render (SOME 5) o fmt t format
+ val expect = fmt x
+ in
+ thatEq string {expect = expect,
+ actual = fmt (read t expect)}
+ ; thatEq string {expect = expect,
+ actual = fmt (read t ("( ("^expect^" )) "))}
+ end)
+ formats)
+
+ fun testRs t ss =
+ test (fn () =>
+ app (fn (s, v) =>
+ (thatEq t {expect = v, actual = read t s}
+ ; thatEq t {expect = v, actual = read t (" (( "^s^" ) )")}))
+ ss)
+
+ fun fmts f = map (fn v => let open Fmt in default & f := v end)
+
+ local
+ open StringCvt
+ in
+ val radices = [HEX, OCT, BIN, DEC]
+ val realFmts = [EXACT, SCI NONE, FIX NONE, GEN NONE]
+ end
+
+ val foobar =
+ iso (record (R' "foo" int *` R' "+" real *` R' "bar" char))
+ (fn {foo = a, + = b, bar = c} => a & b & c,
+ fn a & b & c => {foo = a, + = b, bar = c})
+in
+ val () =
+ unitTests
+ (title "Generic.Read")
+
+ (testSR (vector (tuple2 (option char, list string))) [Fmt.default])
+ (testSR word (fmts Fmt.wordRadix radices))
+ (testSR int (fmts Fmt.intRadix radices))
+ (testSR real (fmts Fmt.realFmt realFmts))
+
+ (testSR foobar [Fmt.default])
+
+ (testRs foobar [("{+ = 2, bar = #\"3\", foo = 1}",
+ {foo = 1, + = 2.0, bar = #"3"})])
+
+ (testRs unit [("()", ()), ("( )", ())])
+ (testRs bool [("true", true), ("false", false)])
+
+ $
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/test/read.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Modified: mltonlib/trunk/com/ssh/generic/unstable/test.mlb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test.mlb 2008-01-09 17:36:04 UTC (rev 6306)
+++ mltonlib/trunk/com/ssh/generic/unstable/test.mlb 2008-01-09 17:46:22 UTC (rev 6307)
@@ -4,52 +4,49 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
-local
- $(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
- $(MLTON_LIB)/com/ssh/unit-test/unstable/lib.mlb
- lib.mlb
+$(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
+$(MLTON_LIB)/com/ssh/unit-test/unstable/lib.mlb
+$(MLTON_LIB)/com/ssh/prettier/unstable/lib.mlb
+$(MLTON_LIB)/com/ssh/random/unstable/lib.mlb
+lib.mlb
- ann
- "nonexhaustiveExnMatch ignore"
- "sequenceNonUnit warn"
- "warnUnused true"
- in
- local
- with/generic.sml
- with/type-info.sml
- with/type-hash.sml
- with/hash.sml
- with/pretty.sml
- with/eq.sml
- with/data-rec-info.sml
- with/some.sml
- with/pickle.sml
- with/seq.sml
- with/reduce.sml
- with/transform.sml
- with/fmap.sml
- local $(MLTON_LIB)/com/ssh/random/unstable/lib.mlb in
- with/arbitrary.sml
- end
- with/size.sml
- with/ord.sml
- with/shrink.sml
- with/close-pretty-with-extra.sml
- with/reg-basis-exns.sml
+ann
+ "nonexhaustiveExnMatch ignore"
+ "sequenceNonUnit warn"
+ "warnUnused true"
+in
+ local
+ with/generic.sml
+ with/type-info.sml
+ with/type-hash.sml
+ with/hash.sml
+ with/pretty.sml
+ with/eq.sml
+ with/data-rec-info.sml
+ with/some.sml
+ with/pickle.sml
+ with/seq.sml
+ with/read.sml
+ with/reduce.sml
+ with/transform.sml
+ with/fmap.sml
+ with/arbitrary.sml
+ with/size.sml
+ with/ord.sml
+ with/shrink.sml
+ with/close-pretty-with-extra.sml
+ with/reg-basis-exns.sml
- ../../unit-test/unstable/with/unit-test.sml
+ ../../unit-test/unstable/with/unit-test.sml
- test/utils.fun
- in
- test/fmap.sml
- test/pickle.sml
- local $(MLTON_LIB)/com/ssh/prettier/unstable/lib.mlb in
- test/pretty.sml
- end
- test/reduce.sml
- test/some.sml
- test/transform.sml
- end
+ test/utils.fun
+ in
+ test/fmap.sml
+ test/pickle.sml
+ test/pretty.sml
+ test/read.sml
+ test/reduce.sml
+ test/some.sml
+ test/transform.sml
end
-in
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/test.use
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test.use 2008-01-09 17:36:04 UTC (rev 6306)
+++ mltonlib/trunk/com/ssh/generic/unstable/test.use 2008-01-09 17:46:22 UTC (rev 6307)
@@ -19,6 +19,7 @@
"with/some.sml",
"with/pickle.sml",
"with/seq.sml",
+ "with/read.sml",
"with/reduce.sml",
"with/transform.sml",
"with/fmap.sml",
@@ -33,6 +34,7 @@
"test/fmap.sml",
"test/pickle.sml",
"test/pretty.sml",
+ "test/read.sml",
"test/reduce.sml",
"test/some.sml",
"test/transform.sml"] ;
Added: mltonlib/trunk/com/ssh/generic/unstable/with/read.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/with/read.sml 2008-01-09 17:36:04 UTC (rev 6306)
+++ mltonlib/trunk/com/ssh/generic/unstable/with/read.sml 2008-01-09 17:46:22 UTC (rev 6307)
@@ -0,0 +1,21 @@
+(* Copyright (C) 2007 Vesa Karvonen
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+(* WARNING: This file is generated! *)
+
+signature Generic = sig
+ include Generic READ
+end
+
+functor MkGeneric (Arg : Generic) = struct
+ structure Open = MkGeneric (Arg)
+ open Arg Open
+ structure ReadRep = Open.Rep
+end
+
+structure Generic =
+ MkGeneric (structure Open = WithRead (Generic)
+ open Generic Open)
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/with/read.sml
___________________________________________________________________
Name: svn:eol-style
+ native
More information about the MLton-commit
mailing list