[MLton-commit] r6174
Vesa Karvonen
vesak at mlton.org
Sun Nov 18 15:21:15 PST 2007
OO Shapes Example
----------------------------------------------------------------------
A mltonlib/trunk/org/mlton/vesak/tech/oo/
A mltonlib/trunk/org/mlton/vesak/tech/oo/framework/
A mltonlib/trunk/org/mlton/vesak/tech/oo/framework/any.sig
A mltonlib/trunk/org/mlton/vesak/tech/oo/framework/any.sml
A mltonlib/trunk/org/mlton/vesak/tech/oo/framework/lib.use
A mltonlib/trunk/org/mlton/vesak/tech/oo/framework/sub.fun
A mltonlib/trunk/org/mlton/vesak/tech/oo/framework/var.sml
A mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/
A mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/README
A mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/circle.sig
A mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/circle.sml
A mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/main.sml
A mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/main.use
A mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/rectangle.sig
A mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/rectangle.sml
A mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/shape.sig
A mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/shape.sml
----------------------------------------------------------------------
Added: mltonlib/trunk/org/mlton/vesak/tech/oo/framework/any.sig
===================================================================
--- mltonlib/trunk/org/mlton/vesak/tech/oo/framework/any.sig 2007-11-17 17:25:55 UTC (rev 6173)
+++ mltonlib/trunk/org/mlton/vesak/tech/oo/framework/any.sig 2007-11-18 23:21:13 UTC (rev 6174)
@@ -0,0 +1,12 @@
+(* 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.
+ *)
+
+signature ANY = sig
+ type 'a t
+ val part : 'a t -> Unit.t t
+ val getSub : 'a t -> 'a
+ val mapSub : ('a -> 'b) -> 'a t -> 'b t
+end
Property changes on: mltonlib/trunk/org/mlton/vesak/tech/oo/framework/any.sig
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/org/mlton/vesak/tech/oo/framework/any.sml
===================================================================
--- mltonlib/trunk/org/mlton/vesak/tech/oo/framework/any.sml 2007-11-17 17:25:55 UTC (rev 6173)
+++ mltonlib/trunk/org/mlton/vesak/tech/oo/framework/any.sml 2007-11-18 23:21:13 UTC (rev 6174)
@@ -0,0 +1,12 @@
+(* 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.
+ *)
+
+structure Any : ANY = struct
+ type 'a t = 'a
+ fun part _ = ()
+ val getSub = id
+ val mapSub = id
+end
Property changes on: mltonlib/trunk/org/mlton/vesak/tech/oo/framework/any.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/org/mlton/vesak/tech/oo/framework/lib.use
===================================================================
--- mltonlib/trunk/org/mlton/vesak/tech/oo/framework/lib.use 2007-11-17 17:25:55 UTC (rev 6173)
+++ mltonlib/trunk/org/mlton/vesak/tech/oo/framework/lib.use 2007-11-18 23:21:13 UTC (rev 6174)
@@ -0,0 +1,11 @@
+(* 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.
+ *)
+
+lib ["../../../../../../com/ssh/extended-basis/unstable/basis.use",
+ "any.sig",
+ "any.sml",
+ "sub.fun",
+ "var.sml"] ;
Property changes on: mltonlib/trunk/org/mlton/vesak/tech/oo/framework/lib.use
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/org/mlton/vesak/tech/oo/framework/sub.fun
===================================================================
--- mltonlib/trunk/org/mlton/vesak/tech/oo/framework/sub.fun 2007-11-17 17:25:55 UTC (rev 6173)
+++ mltonlib/trunk/org/mlton/vesak/tech/oo/framework/sub.fun 2007-11-18 23:21:13 UTC (rev 6174)
@@ -0,0 +1,16 @@
+(* 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.
+ *)
+
+functor Sub (include ANY type x) : sig
+ include ANY
+ val its : (x -> 'r) -> 'a t -> 'r
+end = struct
+ type 'a t = ('a, x) Product.t t
+ fun part d = mapSub (Product.mapFst ignore) d
+ fun its f d = f (Product.snd (getSub d))
+ val getSub = fn d => Product.fst (getSub d)
+ val mapSub = fn f => mapSub (Product.mapFst f)
+end
Property changes on: mltonlib/trunk/org/mlton/vesak/tech/oo/framework/sub.fun
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/org/mlton/vesak/tech/oo/framework/var.sml
===================================================================
--- mltonlib/trunk/org/mlton/vesak/tech/oo/framework/var.sml 2007-11-17 17:25:55 UTC (rev 6173)
+++ mltonlib/trunk/org/mlton/vesak/tech/oo/framework/var.sml 2007-11-18 23:21:13 UTC (rev 6174)
@@ -0,0 +1,15 @@
+(* 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.
+ *)
+
+structure Var = struct
+ type 'a t = {get : 'a Thunk.t, set : 'a Effect.t}
+ fun new v = let
+ val r = ref v
+ in
+ {get = fn () => !r,
+ set = fn v => r := v}
+ end
+end
Property changes on: mltonlib/trunk/org/mlton/vesak/tech/oo/framework/var.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/README
===================================================================
--- mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/README 2007-11-17 17:25:55 UTC (rev 6173)
+++ mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/README 2007-11-18 23:21:13 UTC (rev 6174)
@@ -0,0 +1,48 @@
+OO Shapes Example
+=================
+
+ The code in this directory along with the minimal OO framework in a
+ separate directory implements the "OO Shapes Example" described on the
+ following pages:
+
+ http://onestepback.org/articles/poly/
+ http://www.angelfire.com/tx4/cus/shapes/
+
+ I might write a more thorough explanation of this code at some point,
+ but below are some random notes for starters.
+
+ Standard ML does not provide subtyping or inheritance. The example
+ encodes subtyping using parametric polymorphism. This is an old trick.
+ See [http://mlton.org/References#Berthomieu00] for a thorough treatment.
+
+ More precisely, subtyping is encoded using open products. The infix
+ product type is just for convenience to avoid having to write nested
+ parentheses.
+
+ The main purpose of the OO framework is to provide the Sub functor for
+ creating subtypes more mechanically.
+
+ The way to think about the code is that types define interfaces and the
+ "new" functions define classes. A class can encapsulate arbitrary state
+ or data.
+
+ No implementation inheritance is used in the example.
+
+ The "part" function specified in the ANY signature is for coercing an
+ object to one of its supertypes. I would have preferred to call it
+ "from", so a call could be read naturally as in
+
+ Shape.from rectangle
+
+ but "from" is a reserved word in Alice ML. Feel free to suggest a
+ better name.
+
+ All signatures in this example are strictly unnecessary. That includes
+ separate signature definitions and signatures given for particular
+ structures. The reason why the signatures are unnecessary is that all
+ implementation hiding is already done by the interface and class
+ definitions. The signatures are provided mostly for readability.
+
+ The Var structure is also just for convenience to avoid some code
+ duplication. Note that specifying a 'a Var.t field does not restrict
+ the way in which the get and set methods for that field are implemented.
Added: mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/circle.sig
===================================================================
--- mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/circle.sig 2007-11-17 17:25:55 UTC (rev 6173)
+++ mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/circle.sig 2007-11-18 23:21:13 UTC (rev 6174)
@@ -0,0 +1,11 @@
+(* 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.
+ *)
+
+signature CIRCLE = sig
+ include SHAPE
+ val getR : 'a t -> Int.t
+ val setR : 'a t -> Int.t Effect.t
+end
Property changes on: mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/circle.sig
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/circle.sml
===================================================================
--- mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/circle.sml 2007-11-17 17:25:55 UTC (rev 6173)
+++ mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/circle.sml 2007-11-18 23:21:13 UTC (rev 6174)
@@ -0,0 +1,25 @@
+(* 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.
+ *)
+
+structure Circle : sig
+ include CIRCLE
+ val new : {x : Int.t, y : Int.t, r : Int.t} -> Unit.t t
+end = struct
+ structure D = Sub (open Shape type x = {r : Int.t Var.t})
+ open Shape D
+ fun getR c = #get (its#r c) ()
+ fun setR c = #set (its#r c)
+ fun new {x, y, r} = let
+ val x = Var.new x and y = Var.new y
+ val r = Var.new r
+ fun draw () =
+ print (concat ["Drawing a Circle at:(", Int.toString (#get x ()), ",",
+ Int.toString (#get y ()), "), Radius ",
+ Int.toString (#get r ()), "\n"])
+ in
+ () & {r = r} & {x = x, y = y, draw = draw}
+ end
+end
Property changes on: mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/circle.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/main.sml
===================================================================
--- mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/main.sml 2007-11-17 17:25:55 UTC (rev 6173)
+++ mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/main.sml 2007-11-18 23:21:13 UTC (rev 6174)
@@ -0,0 +1,27 @@
+(* 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.
+ *)
+
+(* A subtype polymorphic function on shapes: *)
+fun drawAndMove s =
+ (Shape.draw s
+ ; Shape.rMoveTo s (100, 100)
+ ; Shape.draw s)
+
+(* Create some shapes: *)
+val scribble = [Shape.part (Rectangle.new {x=10, y=20, w=5, h=6}),
+ Shape.part (Circle.new {x=15, y=25, r=8})]
+
+(* Handle shapes polymorphically: *)
+val () = app drawAndMove scribble
+
+(* Create a rectangle: *)
+val rect = Rectangle.new {x=0, y=0, w=15, h=15}
+
+(* Call a rectangle specific function: *)
+val () = Rectangle.setW rect 30
+
+(* Uses a Rectangle as a subtype of Shape: *)
+val () = Shape.draw rect
Property changes on: mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/main.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/main.use
===================================================================
--- mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/main.use 2007-11-17 17:25:55 UTC (rev 6173)
+++ mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/main.use 2007-11-18 23:21:13 UTC (rev 6174)
@@ -0,0 +1,14 @@
+(* 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.
+ *)
+
+lib ["../framework/lib.use",
+ "shape.sig",
+ "shape.sml",
+ "circle.sig",
+ "circle.sml",
+ "rectangle.sig",
+ "rectangle.sml",
+ "main.sml"] ;
Property changes on: mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/main.use
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/rectangle.sig
===================================================================
--- mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/rectangle.sig 2007-11-17 17:25:55 UTC (rev 6173)
+++ mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/rectangle.sig 2007-11-18 23:21:13 UTC (rev 6174)
@@ -0,0 +1,13 @@
+(* 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.
+ *)
+
+signature RECTANGLE = sig
+ include SHAPE
+ val getH : 'a t -> Int.t
+ val getW : 'a t -> Int.t
+ val setH : 'a t -> Int.t Effect.t
+ val setW : 'a t -> Int.t Effect.t
+end
Property changes on: mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/rectangle.sig
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/rectangle.sml
===================================================================
--- mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/rectangle.sml 2007-11-17 17:25:55 UTC (rev 6173)
+++ mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/rectangle.sml 2007-11-18 23:21:13 UTC (rev 6174)
@@ -0,0 +1,28 @@
+(* 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.
+ *)
+
+structure Rectangle : sig
+ include RECTANGLE
+ val new : {x : Int.t, y : Int.t, w : Int.t, h : Int.t} -> Unit.t t
+end = struct
+ structure D = Sub (open Shape type x = {w : Int.t Var.t, h : Int.t Var.t})
+ open Shape D
+ fun getW r = #get (its#w r) ()
+ fun getH r = #get (its#h r) ()
+ fun setW r = #set (its#w r)
+ fun setH r = #set (its#h r)
+ fun new {x, y, w, h} = let
+ val x = Var.new x and y = Var.new y
+ val w = Var.new w and h = Var.new h
+ fun draw () =
+ print (concat ["Drawing a Rectangle at:(", Int.toString (#get x ()),
+ ",", Int.toString (#get y ()), "), Width ",
+ Int.toString (#get w ()), ", Height ",
+ Int.toString (#get h ()), "\n"])
+ in
+ () & {w = w, h = h} & {x = x, y = y, draw = draw}
+ end
+end
Property changes on: mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/rectangle.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/shape.sig
===================================================================
--- mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/shape.sig 2007-11-17 17:25:55 UTC (rev 6173)
+++ mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/shape.sig 2007-11-18 23:21:13 UTC (rev 6174)
@@ -0,0 +1,16 @@
+(* 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.
+ *)
+
+signature SHAPE = sig
+ include ANY
+ val getX : 'a t -> Int.t
+ val getY : 'a t -> Int.t
+ val setX : 'a t -> Int.t Effect.t
+ val setY : 'a t -> Int.t Effect.t
+ val draw : 'a t Effect.t
+ val moveTo : 'a t -> Int.t Sq.t Effect.t
+ val rMoveTo : 'a t -> Int.t Sq.t Effect.t
+end
Property changes on: mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/shape.sig
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/shape.sml
===================================================================
--- mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/shape.sml 2007-11-17 17:25:55 UTC (rev 6173)
+++ mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/shape.sml 2007-11-18 23:21:13 UTC (rev 6174)
@@ -0,0 +1,20 @@
+(* 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.
+ *)
+
+structure Shape : SHAPE = struct
+ structure D = Sub (open Any
+ type x = {x : Int.t Var.t,
+ y : Int.t Var.t,
+ draw : Unit.t Effect.t})
+ open Any D
+ fun getX s = #get (its#x s) ()
+ fun getY s = #get (its#y s) ()
+ fun setX s = #set (its#x s)
+ fun setY s = #set (its#y s)
+ fun draw s = its#draw s ()
+ fun moveTo s (x, y) = (setX s x ; setY s y)
+ fun rMoveTo s (dx, dy) = moveTo s (getX s + dx, getY s + dy)
+end
Property changes on: mltonlib/trunk/org/mlton/vesak/tech/oo/imperative-shapes/shape.sml
___________________________________________________________________
Name: svn:eol-style
+ native
More information about the MLton-commit
mailing list