[MLton-commit] r6999
Vesa Karvonen
vesak at mlton.org
Sun Dec 14 04:58:33 PST 2008
Added a number of combinators and some ad hoc tests.
----------------------------------------------------------------------
U mltonlib/trunk/org/mlton/vesak/parsec/unstable/detail/mk-parsec.fun
U mltonlib/trunk/org/mlton/vesak/parsec/unstable/public/parsec.sig
A mltonlib/trunk/org/mlton/vesak/parsec/unstable/test/
A mltonlib/trunk/org/mlton/vesak/parsec/unstable/test/app/
A mltonlib/trunk/org/mlton/vesak/parsec/unstable/test/app/generic.mlb
A mltonlib/trunk/org/mlton/vesak/parsec/unstable/test/parsec.sml
A mltonlib/trunk/org/mlton/vesak/parsec/unstable/test.mlb
----------------------------------------------------------------------
Modified: mltonlib/trunk/org/mlton/vesak/parsec/unstable/detail/mk-parsec.fun
===================================================================
--- mltonlib/trunk/org/mlton/vesak/parsec/unstable/detail/mk-parsec.fun 2008-12-09 18:07:41 UTC (rev 6998)
+++ mltonlib/trunk/org/mlton/vesak/parsec/unstable/detail/mk-parsec.fun 2008-12-14 12:58:31 UTC (rev 6999)
@@ -20,7 +20,7 @@
infixr 4 </ />
infix 2 >| andAlso
infixr 2 |<
- infix 1 orElse >>=
+ infix 1 orElse >>= ->> >>-
infix 0 & <|>
infixr 0 -->
(* SML/NJ workaround --> *)
@@ -79,7 +79,7 @@
| EMPTY (OK (x, s, m)) => replyNone m (x2yM x s)
| TASTE th =>
TASTE (fn () => case th ()
- of FAIL e => FAIL e
+ of FAIL m => FAIL m
| OK (x, s, m) => bindSome m (x2yM x s))
fun zero s = EMPTY (FAIL (pos s))
@@ -89,6 +89,24 @@
of EMPTY (FAIL m) => replyNone m (q s)
| other => other
+ structure Monad = MkMonadP
+ (type 'a monad = 'a t
+ val return = return
+ val op >>= = op >>=
+ val zero = zero
+ val op <|> = op <|>)
+
+ open Monad
+
+ fun map x2y xM s =
+ case xM s
+ of EMPTY (FAIL m) => EMPTY (FAIL m)
+ | EMPTY (OK (x, s, m)) => EMPTY (OK (x2y x, s, m))
+ | TASTE th =>
+ TASTE (fn () => case th ()
+ of FAIL m => FAIL m
+ | OK (x, s, m) => OK (x2y x, s, m))
+
fun guess p s =
case p s
of EMPTY r => EMPTY r
@@ -142,27 +160,58 @@
of OK (x, _, m) => taste (OK (x, s, m))
| FAIL m => taste (FAIL m)
- fun many p = many1 p <|> return []
- and many1 p = p >>= (fn x => many p >>= (fn xs => return (x::xs)))
+ fun foldMany f s p = let
+ fun lp s = p >>= (fn x => lp (f (x, s))) <|> (fn ? => return s ?)
+ in
+ lp s
+ end
- fun between b a p = b >>= (fn _ => p >>= (fn r => a >>= (fn _ => return r)))
+ fun manyRev p = foldMany op :: [] p
+ fun many p = map rev (manyRev p)
- fun option alt p = p <|> return alt
+ fun oneMany p q = p >>= (fn x => map (fn xs => x::xs) (many q))
- fun sepBy1 p s =
- p >>= (fn x => many (s >>= (fn _ => p)) >>= (fn xs => return (x::xs)))
- fun sepBy p s = sepBy1 p s <|> return []
+ fun many1 p = oneMany p p
- fun skip p = p >>= return o ignore
+ fun p >>- s = p >>= (fn x => map (const x) s)
+ fun s ->> p = s >>= const p
+
+ fun between b a p = b ->> p >>- a
+
+ fun foldCount f s p n = let
+ fun lp s n =
+ if 0 < n
+ then p >>= (fn x => lp (f (x, s)) (n-1))
+ else return s
+ in
+ if n < 0 then raise Domain else lp s n
+ end
+
+ fun count p = map rev o foldCount op :: [] p
+
+ fun skip p = map General.ignore p
+ fun skipCount p = foldCount General.ignore () p
fun skipMany p = skipMany1 p <|> return ()
and skipMany1 p = p >>= (fn _ => skipMany p)
- structure Monad = MkMonadP
- (type 'a monad = 'a t
- val return = return
- val op >>= = op >>=
- val zero = zero
- val op <|> = op <|>)
+ fun option alt p = p <|> return alt
+ fun opt p = option NONE (map SOME p)
+ fun optional p = skip p <|> return ()
- open Monad
+ fun endBy p = many o p <\ op >>-
+ fun endBy1 p = many1 o p <\ op >>-
+
+ fun sepBy1 p s = oneMany p (s ->> p)
+ fun sepBy p s = sepBy1 p s <|> return []
+
+ fun sepEndBy p s = let
+ fun done xs ? = return (rev xs) ?
+ fun pee xs = p >>= (fn x => ess (x::xs)) <|> done xs
+ and ess xs = s >>= (fn _ => pee xs) <|> done xs
+ in
+ pee []
+ end
+
+ fun sepEndBy1 p s =
+ p >>= (fn x => s >>= (fn _ => map (fn xs => x::xs) (sepEndBy p s)))
end
Modified: mltonlib/trunk/org/mlton/vesak/parsec/unstable/public/parsec.sig
===================================================================
--- mltonlib/trunk/org/mlton/vesak/parsec/unstable/public/parsec.sig 2008-12-09 18:07:41 UTC (rev 6998)
+++ mltonlib/trunk/org/mlton/vesak/parsec/unstable/public/parsec.sig 2008-12-14 12:58:31 UTC (rev 6999)
@@ -34,19 +34,34 @@
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 * 'b t -> 'b t
+ val >>- : 'a t * 'b t -> 'a t
+ val between : 'a t -> 'b t -> 'c t UnOp.t
+
+ val count : 'a t -> Int.t -> 'a List.t t
+
+ val endBy : 'a t -> 'end t -> 'a List.t t
+ val endBy1 : 'a t -> 'end t -> 'a List.t t
+
val many : 'a t -> 'a List.t t
+ val manyRev : 'a t -> 'a List.t t
val many1 : 'a t -> 'a List.t t
+ val opt : 'a t -> 'a Option.t t
val option : 'a -> 'a t UnOp.t
+ val optional : 'a t -> Unit.t t
- val between : 'a t -> 'b t -> 'c t UnOp.t
+ val peek : 'a t UnOp.t
- val sepBy : 'a t -> 'b t -> 'a List.t t
- val sepBy1 : 'a t -> 'b t -> 'a List.t t
+ val sepBy : 'a t -> 'sep t -> 'a List.t t
+ val sepBy1 : 'a t -> 'sep t -> 'a List.t t
+ val sepEndBy : 'a t -> 'sep t -> 'a List.t t
+ val sepEndBy1 : 'a t -> 'sep t -> 'a List.t t
+
val skip : 'a t -> Unit.t t
+ val skipCount : 'a t -> Int.t -> Unit.t t
val skipMany : 'a t -> Unit.t t
val skipMany1 : 'a t -> Unit.t t
end
Added: mltonlib/trunk/org/mlton/vesak/parsec/unstable/test/app/generic.mlb
===================================================================
--- mltonlib/trunk/org/mlton/vesak/parsec/unstable/test/app/generic.mlb 2008-12-09 18:07:41 UTC (rev 6998)
+++ mltonlib/trunk/org/mlton/vesak/parsec/unstable/test/app/generic.mlb 2008-12-14 12:58:31 UTC (rev 6999)
@@ -0,0 +1,27 @@
+(* 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
+ $(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
+ $(MLTON_LIB)/com/ssh/random/unstable/lib.mlb
+
+ $(MLTON_LIB)/com/ssh/generic/unstable/lib.mlb
+in
+ $(MLTON_LIB)/com/ssh/generic/unstable/with/generic.sml
+ $(MLTON_LIB)/com/ssh/generic/unstable/with/type-info.sml
+ $(MLTON_LIB)/com/ssh/generic/unstable/with/type-hash.sml
+ $(MLTON_LIB)/com/ssh/generic/unstable/with/hash.sml
+ $(MLTON_LIB)/com/ssh/generic/unstable/with/pretty.sml
+ $(MLTON_LIB)/com/ssh/generic/unstable/with/eq.sml
+ $(MLTON_LIB)/com/ssh/generic/unstable/with/arbitrary.sml
+ $(MLTON_LIB)/com/ssh/generic/unstable/with/size.sml
+ $(MLTON_LIB)/com/ssh/generic/unstable/with/ord.sml
+ $(MLTON_LIB)/com/ssh/generic/unstable/with/shrink.sml
+ $(MLTON_LIB)/com/ssh/generic/unstable/with/close-pretty-with-extra.sml
+ $(MLTON_LIB)/com/ssh/generic/unstable/with/reg-basis-exns.sml
+ $(MLTON_LIB)/com/ssh/generic/unstable/with/types.sml
+ $(MLTON_LIB)/com/ssh/generic/unstable/with/types-$(SML_COMPILER).sml
+end
Added: mltonlib/trunk/org/mlton/vesak/parsec/unstable/test/parsec.sml
===================================================================
--- mltonlib/trunk/org/mlton/vesak/parsec/unstable/test/parsec.sml 2008-12-09 18:07:41 UTC (rev 6998)
+++ mltonlib/trunk/org/mlton/vesak/parsec/unstable/test/parsec.sml 2008-12-14 12:58:31 UTC (rev 6999)
@@ -0,0 +1,88 @@
+(* 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.
+ *)
+
+structure Parsec =
+ MkParsec (structure Sequence = StringSequence
+ structure State = Unit)
+
+val () = let
+ open UnitTest Parsec
+
+ infix |>>
+ fun p |>> f = map f p
+
+ fun parse p s =
+ Parsec.parse p (StringSequence.full s, ())
+
+ datatype 'a test =
+ SUCCESS of String.t * 'a * String.t
+ | FAILURE of String.t * Int.t
+
+ fun remaining s =
+ Substring.extract (StringSequence.vector s, StringSequence.pos s, NONE)
+ >| Substring.string
+
+ fun chk p t cs =
+ test (fn () =>
+ List.app
+ (fn SUCCESS (s, v, r) =>
+ (case parse p s
+ of INL p => fails ["Parse failed at ", Int.toString p]
+ | INR (v', (r', ())) =>
+ (thatEq t {actual = v', expect = v}
+ ; thatEq String.t {actual = remaining r', expect = r}))
+ | FAILURE (s, c) =>
+ (case parse p s
+ of INL p => thatEq Int.t {actual = p, expect = c}
+ | INR (v, (r, ())) =>
+ fails ["Parse succeed with ", Generic.show t v,
+ " at pos ", Int.toString (StringSequence.pos r),
+ " and remaining input ",
+ Generic.show String.t (remaining r)]))
+ cs)
+
+ fun S s v r = SUCCESS (s, v, r)
+ fun F s p = FAILURE (s, p)
+
+ val d = sat Char.isDigit
+ val l = sat Char.isLower
+ val u = sat Char.isUpper
+in
+ unitTests
+ (title "Parsec")
+
+ (chk (l <|> u) Char.t [F "0" 0, S "ab" #"a" "b", S "Ba" #"B" "a"])
+
+ (chk (l >>* u) (Sq.t Char.t) [F "Ul" 0, S "lU-" (#"l", #"U") "-"])
+
+ (chk (between l u d) Char.t [S "b9X-" #"9" "-", F "bX" 1])
+
+ (chk (count l 3 |>> implode) String.t [S "abcdE" "abc" "dE", F "abC" 2])
+
+ (chk (endBy l u |>> implode) String.t
+ [S "-" "" "-", S "aXbY-" "ab" "-", F "aXbYc-" 5])
+ (chk (endBy1 l u |>> implode) String.t
+ [F "-" 0, F "o-" 1, S "aXbY-" "ab" "-", F "aXbYc-" 5])
+
+ (chk (many (l >>* u |>> op ^ o Sq.map str) |>> concat) String.t
+ [S "-" "" "-", S "aBcD-" "aBcD" "-", F "abC" 1])
+ (chk (manyRev (l >>* u |>> op ^ o Sq.map str) |>> concat) String.t
+ [S "-" "" "-", S "aBcD-" "cDaB" "-", F "abC" 1])
+ (chk (many1 (l >>* u |>> op ^ o Sq.map str) |>> concat) String.t
+ [F "-" 0, S "aBcD-" "aBcD" "-", F "abC" 1])
+
+ (chk (opt (count l 2 |>> implode)) (Option.t String.t)
+ [S "xy-" (SOME "xy") "-", S "-" NONE "-", F "bA" 1])
+
+ (chk (l >>* peek u) (Sq.t Char.t) [S "lU-" (#"l", #"U") "U-", F "ab" 1])
+
+ (chk (sepBy l u |>> implode) String.t
+ [S "-" "" "-", S "aXb-" "ab" "-", F "aXbY" 4])
+ (chk (sepBy1 l u |>> implode) String.t
+ [F "-" 0, S "aXb-" "ab" "-", F "aXbY" 4])
+
+ $
+end
Property changes on: mltonlib/trunk/org/mlton/vesak/parsec/unstable/test/parsec.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/org/mlton/vesak/parsec/unstable/test.mlb
===================================================================
--- mltonlib/trunk/org/mlton/vesak/parsec/unstable/test.mlb 2008-12-09 18:07:41 UTC (rev 6998)
+++ mltonlib/trunk/org/mlton/vesak/parsec/unstable/test.mlb 2008-12-14 12:58:31 UTC (rev 6999)
@@ -0,0 +1,19 @@
+(* 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.
+ *)
+
+$(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
+$(MLTON_LIB)/com/ssh/unit-test/unstable/lib.mlb
+lib.mlb
+
+$(APPLICATION)/generic.mlb
+
+ann
+ "nonexhaustiveExnMatch ignore"
+ "sequenceNonUnit warn"
+ "warnUnused true"
+in
+ test/parsec.sml
+end
More information about the MLton-commit
mailing list