[MLton-commit] r5326
Vesa Karvonen
vesak at mlton.org
Sun Feb 25 23:18:26 PST 2007
Preliminary Functor and Monad concepts. These are open for improvements.
----------------------------------------------------------------------
A mltonlib/trunk/com/ssh/extended-basis/unstable/detail/mk-monad.fun
U mltonlib/trunk/com/ssh/extended-basis/unstable/detail/reader.sml
U mltonlib/trunk/com/ssh/extended-basis/unstable/detail/smlnj/sigs.cm
U mltonlib/trunk/com/ssh/extended-basis/unstable/detail/smlnj/unsealed.cm
U mltonlib/trunk/com/ssh/extended-basis/unstable/detail/writer.sml
U mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.mlb
U mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.use
A mltonlib/trunk/com/ssh/extended-basis/unstable/public/concept/func.sig
A mltonlib/trunk/com/ssh/extended-basis/unstable/public/concept/monad.sig
U mltonlib/trunk/com/ssh/extended-basis/unstable/public/export/common.sml
U mltonlib/trunk/com/ssh/extended-basis/unstable/public/reader.sig
U mltonlib/trunk/com/ssh/extended-basis/unstable/public/writer.sig
----------------------------------------------------------------------
Added: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/mk-monad.fun
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/mk-monad.fun 2007-02-26 01:32:04 UTC (rev 5325)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/mk-monad.fun 2007-02-26 07:18:06 UTC (rev 5326)
@@ -0,0 +1,41 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+functor MkMonad' (MonadCore : MONAD_CORE') : MONAD' = struct
+ infix >> >>& >>* >>= >>@
+ open MonadCore
+ type ('a, 'x1) func = ('a, 'x1) monad
+ fun map f aM = aM >>= return o f
+ type ('a, 'x1) monad_ex = ('a, 'x1) monad
+ fun aM >>* bM = aM >>= (fn a => bM >>= Fn.<\ (a, return))
+ fun fM >>@ aM = map Fn.\> (fM >>* aM)
+ fun aM >>& bM = map Product.& (aM >>* bM)
+ fun aM >> bM = map #2 (aM >>* bM)
+ fun seq [] = return []
+ | seq (xM::xMs) = map op :: (xM >>* seq xMs)
+end
+
+functor MkMonad (MonadCore : MONAD_CORE) : MONAD = struct
+ structure Monad = MkMonad' (open MonadCore type ('a, 'b) monad = 'a monad)
+ open Monad MonadCore
+ type 'a func = 'a monad
+ type 'a monad_ex = 'a monad
+end
+
+functor MkMonadP' (MonadPCore : MONADP_CORE') : MONADP' = struct
+ structure Monad = MkMonad' (MonadPCore)
+ open Monad MonadPCore
+ type ('a, 'x) monadp_ex = ('a, 'x) monad
+ fun sum [] = zero | sum [x] = x | sum (x::xs) = plus (x, sum xs)
+end
+
+functor MkMonadP (MonadPCore : MONADP_CORE) : MONADP = struct
+ structure MonadP = MkMonadP' (open MonadPCore type ('a, 'b) monad = 'a monad)
+ open MonadP MonadPCore
+ type 'a func = 'a monad
+ type 'a monad_ex = 'a monad
+ type 'a monadp_ex = 'a monad
+end
Property changes on: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/mk-monad.fun
___________________________________________________________________
Name: svn:eol-style
+ native
Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/reader.sml
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/reader.sml 2007-02-26 01:32:04 UTC (rev 5325)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/reader.sml 2007-02-26 07:18:06 UTC (rev 5326)
@@ -1,20 +1,20 @@
-(* Copyright (C) 2006 SSH Communications Security, Helsinki, Finland
+(* Copyright (C) 2006-2007 SSH Communications Security, Helsinki, Finland
*
* This code is released under the MLton license, a BSD-style license.
* See the LICENSE file or http://mlton.org/License for details.
*)
structure Reader :> READER = struct
- open Reader
+ infix >>=
- infix >>= >>&
+ structure Monad =
+ MkMonad'
+ (type ('a, 's) monad = ('a, 's) Reader.t
+ fun return a s = SOME (a, s)
+ fun rA >>= a2rB = Option.mapPartial (Fn.uncurry a2rB) o rA)
- fun return a s = SOME (a, s)
- fun rA >>= a2rB = Option.mapPartial (Fn.uncurry a2rB) o rA
+ open Reader Monad
- fun map a2b rA = rA >>= return o a2b
- fun rA >>& rB = rA >>= (fn a => rB >>= (fn b => return (Product.& (a, b))))
-
type univ = Univ.t
type 'a u = ('a, univ) t
Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/smlnj/sigs.cm
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/smlnj/sigs.cm 2007-02-26 01:32:04 UTC (rev 5325)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/smlnj/sigs.cm 2007-02-26 07:18:06 UTC (rev 5326)
@@ -11,6 +11,8 @@
../../public/concept/bitwise.sig
../../public/concept/cstringable.sig
../../public/concept/flags.sig
+ ../../public/concept/func.sig
+ ../../public/concept/monad.sig
../../public/concept/ordered.sig
../../public/concept/signed.sig
../../public/concept/stringable.sig
Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/smlnj/unsealed.cm
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/smlnj/unsealed.cm 2007-02-26 01:32:04 UTC (rev 5325)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/smlnj/unsealed.cm 2007-02-26 07:18:06 UTC (rev 5326)
@@ -29,6 +29,7 @@
../fn.sml
../iso.sml
../list.sml
+ ../mk-monad.fun
../mk-word-flags.fun
../option.sml
../order.sml
Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/writer.sml
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/writer.sml 2007-02-26 01:32:04 UTC (rev 5325)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/writer.sml 2007-02-26 07:18:06 UTC (rev 5326)
@@ -7,6 +7,7 @@
structure Writer :> WRITER = struct
open Writer
+ type ('a, 's) func = ('a, 's) t
fun map b2a wA = wA o Pair.map (b2a, Fn.id)
type univ = Univ.t
Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.mlb
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.mlb 2007-02-26 01:32:04 UTC (rev 5325)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.mlb 2007-02-26 07:18:06 UTC (rev 5326)
@@ -39,6 +39,8 @@
public/concept/bitwise.sig
public/concept/cstringable.sig
public/concept/flags.sig
+ public/concept/func.sig
+ public/concept/monad.sig
public/concept/ordered.sig
public/concept/signed.sig
public/concept/stringable.sig
@@ -158,8 +160,13 @@
in
bas public/sequence/buffer.sig detail/buffer.sml end
end
+ basis MkMonad = let
+ open Fn Products
+ in
+ bas detail/mk-monad.fun end
+ end
basis Reader = let
- open Fn Products Univ
+ open Fn MkMonad Products Univ
in
bas public/reader.sig detail/reader.sml end
end
@@ -229,7 +236,7 @@
open Fix Fn
open Iso
open List
- open MkWordFlags MonoSeqs
+ open MkMonad MkWordFlags MonoSeqs
open Option Order
open Products Promise
open Reader Ref
Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.use
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.use 2007-02-26 01:32:04 UTC (rev 5325)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.use 2007-02-26 07:18:06 UTC (rev 5326)
@@ -16,6 +16,8 @@
"public/concept/bitwise.sig",
"public/concept/cstringable.sig",
"public/concept/flags.sig",
+ "public/concept/func.sig",
+ "public/concept/monad.sig",
"public/concept/ordered.sig",
"public/concept/signed.sig",
"public/concept/stringable.sig",
@@ -59,6 +61,7 @@
"public/data/option.sig", "detail/option.sml",
"public/sequence/list.sig", "detail/list.sml",
"public/sequence/buffer.sig", "detail/buffer.sml",
+ "detail/mk-monad.fun",
"public/reader.sig", "detail/reader.sml",
"public/writer.sig", "detail/writer.sml",
"public/exit.sig", "detail/exit.sml",
Added: mltonlib/trunk/com/ssh/extended-basis/unstable/public/concept/func.sig
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/public/concept/func.sig 2007-02-26 01:32:04 UTC (rev 5325)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/public/concept/func.sig 2007-02-26 07:18:06 UTC (rev 5326)
@@ -0,0 +1,27 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+signature FUNC = sig
+ type 'a func
+ val map : ('a -> 'b) -> 'a func -> 'b func
+end
+
+signature CFUNC = sig
+ type 'a func
+ val map : ('b -> 'a) -> 'a func -> 'b func
+end
+
+(************************************************************************)
+
+signature FUNC' = sig
+ type ('a, 'x1) func
+ val map : ('a -> 'b) -> ('a, 'x1) func -> ('b, 'x1) func
+end
+
+signature CFUNC' = sig
+ type ('a, 'x1) func
+ val map : ('b -> 'a) -> ('a, 'x1) func -> ('b, 'x1) func
+end
Property changes on: mltonlib/trunk/com/ssh/extended-basis/unstable/public/concept/func.sig
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/extended-basis/unstable/public/concept/monad.sig
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/public/concept/monad.sig 2007-02-26 01:32:04 UTC (rev 5325)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/public/concept/monad.sig 2007-02-26 07:18:06 UTC (rev 5326)
@@ -0,0 +1,84 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+signature MONAD_CORE = sig
+ type 'a monad
+ val return : 'a -> 'a monad
+ val >>= : 'a monad * ('a -> 'b monad) -> 'b monad
+end
+
+signature MONAD_EX = sig
+ type 'a monad_ex
+ include FUNC where type 'a func = 'a monad_ex
+ val >> : 'a monad_ex * 'b monad_ex -> 'b monad_ex
+ val >>& : 'a monad_ex * 'b monad_ex -> ('a, 'b) Product.t monad_ex
+ val >>* : 'a monad_ex * 'b monad_ex -> ('a * 'b) monad_ex
+ val >>@ : ('a -> 'b) monad_ex * 'a monad_ex -> 'b monad_ex
+ val seq : 'a monad_ex List.t -> 'a List.t monad_ex
+end
+
+signature MONAD = sig
+ include MONAD_CORE
+ include MONAD_EX where type 'a monad_ex = 'a monad
+end
+
+signature MONADP_CORE = sig
+ include MONAD_CORE
+ val zero : 'a monad
+ val plus : 'a monad BinOp.t
+end
+
+signature MONADP_EX = sig
+ type 'a monadp_ex
+ val sum : 'a monadp_ex List.t -> 'a monadp_ex
+end
+
+signature MONADP = sig
+ include MONADP_CORE
+ include MONAD_EX where type 'a monad_ex = 'a monad
+ include MONADP_EX where type 'a monadp_ex = 'a monad
+end
+
+(************************************************************************)
+
+signature MONAD_CORE' = sig
+ type ('a, 'x) monad
+ val return : 'a -> ('a, 'x) monad
+ val >>= : ('a, 'x) monad * ('a -> ('b, 'x) monad) -> ('b, 'x) monad
+end
+
+signature MONAD_EX' = sig
+ type ('a, 'x) monad_ex
+ include FUNC' where type ('a, 'x) func = ('a, 'x) monad_ex
+ val >> : ('a, 'x) monad_ex * ('b, 'x) monad_ex -> ('b, 'x) monad_ex
+ val >>* : ('a, 'x) monad_ex * ('b, 'x) monad_ex -> ('a * 'b, 'x) monad_ex
+ val >>& : ('a, 'x) monad_ex * ('b, 'x) monad_ex
+ -> (('a, 'b) Product.t, 'x) monad_ex
+ val >>@ : ('a -> 'b, 'x) monad_ex * ('a, 'x) monad_ex -> ('b, 'x) monad_ex
+ val seq : ('a, 'x) monad_ex List.t -> ('a List.t, 'x) monad_ex
+end
+
+signature MONAD' = sig
+ include MONAD_CORE'
+ include MONAD_EX' where type ('a, 'x) monad_ex = ('a, 'x) monad
+end
+
+signature MONADP_CORE' = sig
+ include MONAD_CORE'
+ val zero : ('a, 'x) monad
+ val plus : ('a, 'x) monad BinOp.t
+end
+
+signature MONADP_EX' = sig
+ type ('a, 'x) monadp_ex
+ val sum : ('a, 'x) monadp_ex List.t -> ('a, 'x) monadp_ex
+end
+
+signature MONADP' = sig
+ include MONADP_CORE'
+ include MONAD_EX' where type ('a, 'x) monad_ex = ('a, 'x) monad
+ include MONADP_EX' where type ('a, 'x) monadp_ex = ('a, 'x) monad
+end
Property changes on: mltonlib/trunk/com/ssh/extended-basis/unstable/public/concept/monad.sig
___________________________________________________________________
Name: svn:eol-style
+ native
Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/public/export/common.sml
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/public/export/common.sml 2007-02-26 01:32:04 UTC (rev 5325)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/public/export/common.sml 2007-02-26 07:18:06 UTC (rev 5326)
@@ -9,8 +9,20 @@
(** === Concept Signatures === *)
signature BITWISE = BITWISE
+signature CFUNC = CFUNC
+signature CFUNC' = CFUNC'
signature CSTRINGABLE = CSTRINGABLE
signature FLAGS = FLAGS
+signature FUNC = FUNC
+signature FUNC' = FUNC'
+signature MONAD = MONAD
+signature MONAD' = MONAD'
+signature MONADP = MONADP
+signature MONADP' = MONADP'
+signature MONADP_CORE = MONADP_CORE
+signature MONADP_CORE' = MONADP_CORE'
+signature MONAD_CORE = MONAD_CORE
+signature MONAD_CORE' = MONAD_CORE'
signature ORDERED = ORDERED
signature SIGNED = SIGNED
signature STRINGABLE = STRINGABLE
@@ -132,4 +144,8 @@
(** === Functors === *)
+functor MkMonad (Arg : MONAD_CORE) : MONAD = MkMonad (Arg)
+functor MkMonad' (Arg : MONAD_CORE') : MONAD' = MkMonad' (Arg)
+functor MkMonadP (Arg : MONADP_CORE) : MONADP = MkMonadP (Arg)
+functor MkMonadP' (Arg : MONADP_CORE') : MONADP' = MkMonadP' (Arg)
functor MkWordFlags (Arg : WORD) : FLAGS = MkWordFlags (Arg)
Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/public/reader.sig
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/public/reader.sig 2007-02-26 01:32:04 UTC (rev 5325)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/public/reader.sig 2007-02-26 07:18:06 UTC (rev 5326)
@@ -6,21 +6,10 @@
(** Utilities for dealing with readers. *)
signature READER = sig
- type ('a, 'b) t = 'b -> ('a * 'b) Option.t
+ type ('a, 's) t = 's -> ('a * 's) Option.t
- (** == Monad Interface == *)
+ include MONAD' where type ('a, 's) monad = ('a, 's) t
- val return : 'a -> ('a, 's) t
- val >>= : ('a, 's) t * ('a -> ('b, 's) t) -> ('b, 's) t
-
- (** == Functor Interface == *)
-
- val map : ('a -> 'b) -> ('a, 's) t -> ('b, 's) t
-
- (** == Useful Combinators == *)
-
- val >>& : ('a, 's) t * ('b, 's) t -> (('a, 'b) Product.t, 's) t
-
(** == Typing == *)
type univ
Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/public/writer.sig
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/public/writer.sig 2007-02-26 01:32:04 UTC (rev 5325)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/public/writer.sig 2007-02-26 07:18:06 UTC (rev 5326)
@@ -8,10 +8,8 @@
signature WRITER = sig
type ('a, 's) t = 'a * 's -> 's
- (** == Functor Interface == *)
+ include CFUNC' where type ('a, 's) func = ('a, 's) t
- val map : ('b -> 'a) -> ('a, 's) t -> ('b, 's) t
-
(** == Typing == *)
type univ
More information about the MLton-commit
mailing list