[MLton-commit] r5809
Vesa Karvonen
vesak at mlton.org
Mon Jul 30 02:10:34 PDT 2007
Yet another generic programming approach in SML'97.
----------------------------------------------------------------------
A mltonlib/trunk/org/mlton/vesak/tech/generics/syb.sml
----------------------------------------------------------------------
Added: mltonlib/trunk/org/mlton/vesak/tech/generics/syb.sml
===================================================================
--- mltonlib/trunk/org/mlton/vesak/tech/generics/syb.sml 2007-07-30 06:40:01 UTC (rev 5808)
+++ mltonlib/trunk/org/mlton/vesak/tech/generics/syb.sml 2007-07-30 09:10:33 UTC (rev 5809)
@@ -0,0 +1,179 @@
+(* 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.
+ *)
+
+(*
+ * This program note explores yet another approach to generic programming
+ * in SML'97. This is one is based on Lämmel and Jones' ``Scrap Your
+ * Boilerplate'' (SYB) approach [1]. The SYB approach makes use of rank-2
+ * types, a cast primitive, type classes, and boilerplate code generation.
+ *
+ * At the moment, only the {gmapT} functionality from the SYB paper is
+ * implemented.
+ *
+ * [1] Scrap Your Boilerplate: A Practical Design Pattern for Generic
+ * Programming.
+ * Ralf Lämmel and Simon Peyton Jones.
+ * ACM SIGPLAN Notices, 38(3):26-37, March 2003.
+ *)
+
+
+(*
+ The following code uses the Extended Basis Library. To try the code
+ with SML/NJ, run the following prefix before evaluating the rest:
+
+ val mltonLib = "../../../../.." ;
+ val extBasisLib = mltonLib ^ "/com/ssh/extended-basis/unstable" ;
+ CM.make (extBasisLib ^ "/basis.cm") ;
+ use (extBasisLib ^ "/public/export/infixes.sml") ;
+ open TopLevel ;
+ *)
+
+
+val op <--> = Iso.<-->
+
+val arrow = Fn.map
+fun worra iso = arrow (Iso.swap iso)
+
+
+structure G :> sig
+ structure Void : sig
+ type t
+ structure Iso : sig
+ type 'a t = ('a, t) Iso.t
+ end
+ end
+
+ structure Type : sig
+ type methods
+ type 'a t
+
+ val tyConA : 'a t Thunk.t
+ val tyCon1 : 'a Void.Iso.t * (methods -> methods)
+ -> ('b Void.Iso.t -> ('c, 'a) Iso.t) -> 'b t -> 'c t
+ val tyCon2 : 'a Void.Iso.t * (methods * methods -> methods)
+ -> ('b Void.Iso.t * 'c Void.Iso.t -> ('d, 'a) Iso.t)
+ -> 'b t * 'c t -> 'd t
+ val pM : ('a -> {map : (methods -> Void.t UnOp.t) -> 'b -> 'b})
+ -> 'b Void.Iso.t * ('a -> methods)
+ val rM : ('a * methods * 'b Void.Iso.t
+ -> {map:(methods -> Void.t UnOp.t) -> 'b -> 'b})
+ -> 'b Void.Iso.t * ('a -> methods)
+ end
+
+ structure Map : sig
+ val lift : 'a Type.t -> 'a UnOp.t -> Void.t Type.t -> Void.t UnOp.t
+ val children : 'a Type.t -> (Void.t Type.t -> Void.t UnOp.t) -> 'a UnOp.t
+ val bottomUp : (Void.t Type.t -> Void.t UnOp.t) -> 'a Type.t -> 'a UnOp.t
+ val topDown : (Void.t Type.t -> Void.t UnOp.t) -> 'a Type.t -> 'a UnOp.t
+ end
+end = struct
+ structure Void = Univ
+
+ structure Type = struct
+ datatype methods = M of {map : (methods -> Void.t UnOp.t) -> Void.t UnOp.t}
+ datatype 'a t = T of 'a Void.Iso.t * methods
+
+ fun tyConA () = T (Void.Iso.new (), M {map = const id})
+
+ fun tyCon1 (tIu, t) iso (T (aIu, a)) =
+ T (tIu <--> iso aIu, t a)
+ fun tyCon2 (tIu, t) iso (T (aIu, a), T (bIu, b)) =
+ T (tIu <--> iso (aIu, bIu), t (a, b))
+
+ fun pM m = let
+ val iso = Void.Iso.new ()
+ in
+ (iso, (fn {map} => M {map = worra iso o map}) o m)
+ end
+
+ fun rM m = let
+ val iso = Void.Iso.new ()
+ in
+ (iso,
+ fn a =>
+ let open Tie in fix o iso function end
+ (fn M {map} => map, fn map => M {map = map})
+ (fn t => let
+ val {map} = m (a, t, iso)
+ in
+ M {map = worra iso o map}
+ end))
+ end
+ end
+
+ open Type
+
+ fun toVoid aM = T (Iso.id, aM)
+
+ structure Map : sig
+ val children : methods -> (methods -> Void.t UnOp.t) -> Void.t UnOp.t
+ val bottomUp : (methods -> Void.t UnOp.t) -> methods -> Void.t UnOp.t
+ val topDown : (methods -> Void.t UnOp.t) -> methods -> Void.t UnOp.t
+ end = struct
+ fun children (M r) f = #map r f
+ fun bottomUp f aM = f aM o children aM (bottomUp f)
+ fun topDown f aM = children aM (topDown f) o f aM
+ end
+
+ structure Map = struct
+ fun lift (T ((a2u, u2a), _)) f _ u =
+ try (fn () => u2a u,
+ fn a => a2u (f a),
+ fn Void.Univ => u | e => raise e)
+ fun children (T (aIu, aM)) f =
+ arrow aIu (Map.children aM (f o toVoid))
+ fun bottomUp f (T (aIu, aM)) =
+ arrow aIu (Map.bottomUp (f o toVoid) aM)
+ fun topDown f (T (aIu, aM)) =
+ arrow aIu (Map.topDown (f o toVoid) aM)
+ end
+end
+
+
+structure G = struct
+ open G
+
+ structure Type = struct
+ open Type
+
+ val bool : Bool.t t = tyConA ()
+ val char : Char.t t = tyConA ()
+ val int : Int.t t = tyConA ()
+ val real : Real.t t = tyConA ()
+ val unit : Unit.t t = tyConA ()
+ val word : Word.t t = tyConA ()
+
+ val list = rM (fn (a, t, i) =>
+ {map = fn f => fn [] => []
+ | x::r => f a x::arrow i (f t) r})
+ val list = fn ? => tyCon1 list List.iso ?
+
+ val pair = pM (fn (a, b) => {map = fn f => Pair.map (f a, f b)})
+ val pair = fn ? => tyCon2 pair Pair.iso ?
+
+ val option = pM (fn a => {map = fn f => Option.map (f a)})
+ val option = fn ? => tyCon1 option Option.iso ?
+
+ val vector = pM (fn a => {map = fn f => Vector.map (f a)})
+ val vector = fn ? => tyCon1 vector Vector.iso ?
+ end
+end
+
+
+local
+ open G.Map G.Type
+in
+ val [SOME [~5]] =
+ bottomUp (lift int ~) (list (option (list int))) [SOME [5]] ;
+
+ val [NONE, SOME [2, 4, 3, 1]] =
+ bottomUp (lift (list int) rev)
+ (list (option (list int)))
+ [NONE, SOME [1,2,3,4]] ;
+
+ val (SOME ~1, [~2, ~3]) =
+ bottomUp (lift int ~) (pair (option int, list int)) (SOME 1, [2, 3]) ;
+end
Property changes on: mltonlib/trunk/org/mlton/vesak/tech/generics/syb.sml
___________________________________________________________________
Name: svn:eol-style
+ native
More information about the MLton-commit
mailing list