17 people like it.

Traits, Mixins and Aspect-Oriented Programming in F#

A compositional type system built using generics and monads in F#. It is only a very limited, _toy_ project exploring traits, mixins and aspect-oriented programming.

  1: 
  2: 
  3: 
  4: 
  5: 
  6: 
  7: 
  8: 
  9: 
 10: 
 11: 
 12: 
 13: 
 14: 
 15: 
 16: 
 17: 
 18: 
 19: 
 20: 
 21: 
 22: 
 23: 
 24: 
 25: 
 26: 
 27: 
 28: 
 29: 
 30: 
 31: 
 32: 
 33: 
 34: 
 35: 
 36: 
 37: 
 38: 
 39: 
 40: 
 41: 
 42: 
 43: 
 44: 
 45: 
 46: 
 47: 
 48: 
 49: 
 50: 
 51: 
 52: 
 53: 
 54: 
 55: 
 56: 
 57: 
 58: 
 59: 
 60: 
 61: 
 62: 
 63: 
 64: 
 65: 
 66: 
 67: 
 68: 
 69: 
 70: 
 71: 
 72: 
 73: 
 74: 
 75: 
 76: 
 77: 
 78: 
 79: 
 80: 
 81: 
 82: 
 83: 
 84: 
 85: 
 86: 
 87: 
 88: 
 89: 
 90: 
 91: 
 92: 
 93: 
 94: 
 95: 
 96: 
 97: 
 98: 
 99: 
100: 
101: 
102: 
103: 
104: 
105: 
106: 
107: 
108: 
109: 
110: 
111: 
112: 
113: 
114: 
115: 
116: 
117: 
118: 
119: 
120: 
121: 
122: 
123: 
124: 
125: 
126: 
127: 
128: 
129: 
130: 
131: 
132: 
133: 
134: 
135: 
136: 
137: 
138: 
139: 
140: 
141: 
142: 
143: 
144: 
145: 
146: 
147: 
148: 
149: 
150: 
151: 
152: 
153: 
154: 
155: 
156: 
157: 
158: 
159: 
160: 
161: 
162: 
163: 
164: 
165: 
166: 
167: 
168: 
169: 
170: 
171: 
172: 
173: 
174: 
175: 
176: 
177: 
178: 
179: 
180: 
181: 
182: 
183: 
184: 
185: 
186: 
187: 
188: 
189: 
190: 
191: 
192: 
193: 
194: 
195: 
196: 
197: 
198: 
199: 
200: 
201: 
202: 
203: 
204: 
205: 
206: 
207: 
208: 
209: 
210: 
211: 
212: 
213: 
//////////////////////////////////////////////////////////////////
// A compositional type system using generics and monads in F#. //
//////////////////////////////////////////////////////////////////
// A very limited, _toy_ project exploring traits, mixins       //
// and aspect oriented programming                              //
// by Zach Bray (http://www.zbray.com).                         //
//////////////////////////////////////////////////////////////////

(Class monad omitted.)


open System
open TypeSystem

//////////////////////////////////////////////////////////////////
// BASICS                                                       //
//////////////////////////////////////////////////////////////////

// Member symbols are defined as single cases.
type FirstName = |FirstName
type LastName = |LastName
type Name = |Name

// Class constructors are created using the Class monad.
// In this example only 5 members are supported.
let person firstName lastName = Class {
   // Each member function is yielded
   yield function FirstName -> firstName
   yield function LastName -> lastName
   yield function Name -> firstName + " " + lastName
}

// Members symbols can have arguments (and these arguments can be generic).
type 'a AddManager = |AddManager of 'a
type Managers = |Managers

// Class constructors can be generic
let worker<'a>() = Class {
   // Mutable state can be kept inside reference cells.
   let managers = ref List.empty<'a>
   yield function Managers -> !managers
   // A member that takes a parameter
   yield function AddManager newManager -> 
                  managers := newManager :: !managers
}

// Class constructors can be composed
let employee<'a> firstName secondName = Class {
   // We can yield the members of one class...
   yield! person firstName secondName
   // ... then another
   yield! worker<'a>()
}

// We construct instances by passing the parameters into
// the constuctor
let testConstruction =
   let rupert = employee<unit> "Rupert" "Maddog"
   let becca = employee "Becca" "Brooked"
   let dave = employee "Dave" "Kameroon"

   // We access members by using the (/) operator
   becca / AddManager(rupert)
   dave / AddManager(becca)

   for manager in dave / Managers do
      printfn "%s" (manager / Name)


//////////////////////////////////////////////////////////////////
// MIXINS & ADAPTORS                                            //
//////////////////////////////////////////////////////////////////

// Class constructors can also be composed using 
// the (+) operator which allows us to use mixins a la Scala
// http://www.scala-lang.org/node/117

// Iterator members
type HasNext = |HasNext
type Next = |Next

// Rich iterator members
type 'a ForEach = |ForEach of ('a -> unit)

// A rich iterator provides a foreach wrapper
// around the HasNext and Next members
let inline richIterator x = 
   Class {
      yield function ForEach f ->
                     while x / HasNext do
                        f (x / Next)
   }

// Here we construct a basic string iterator
let stringIterator (str:string) = Class {
   let i = ref 0
   yield function HasNext -> !i < str.Length
   yield function Next ->
                  let c = str.[!i]
                  incr i
                  c
}

// Here we construct a mixin of the string iterator
// and the rich iterator
let richStringIterator str =
   let iter = stringIterator str
   // We combine the rich iterator interface with
   // the existing interface here using the (+) operator
   richIterator iter + iter

// We can also choose to use the rich iterator constructor
// as an adaptor rather than a mixin by omitting the
// composition with the original iter
let onlyRichStringIterator str =
   richIterator (stringIterator str)

// We can use either the ForEach member or the HasNext and
// Next members of a richStringIterator to print a string
let testRSI =
   // Using rich interface
   let iter = richStringIterator "Ordered generic parameters suck!"
   iter / ForEach (printf "%c")
   printfn ""

   // Using basic interface
   let iter2 = richStringIterator "Arbitrary metrics suck!"
   while iter2 / HasNext do
      printf "%c" (iter2 / Next)
   printfn ""

// If we use the adapter method we can only use the rich interface
let testORSI =
   // Using rich interface still works!
   let iter = onlyRichStringIterator "Type safety rules!"
   iter / ForEach (printf "%c")
   printfn ""

   // Using basic interface will _not_ compile!
   (*
   let iter2 = onlyRichStringIterator "Type safety rules!"
   while iter2 / HasNext do
      printf "%c" (iter2 / Next)
   printfn ""
   *)

//////////////////////////////////////////////////////////////////
// ASPECT-ORIENTED                                              //
//////////////////////////////////////////////////////////////////

// In addition to adding new members using the (+) operator we
// can also hide members using the (-) operator.

// This means we can do some simple aspect oriented programming
// http://en.wikipedia.org/wiki/Aspect-oriented_programming


// Here we create the interface to a bank account...
type Balance = |Balance
type Deposit = |Deposit of decimal
type Withdraw = |Withdraw of decimal

// ... and its constructor
let account name = Class {
   let balance = ref 0m
   yield function Name -> name
   yield function Balance -> !balance
   yield function Deposit x -> balance := !balance + x
   yield function Withdraw x -> balance := !balance - x
}

// Here we create a helper that will run some code before a given
// member is accessed.
let inline beforeAccess f (property:'a) x =
   Class {
      yield fun (_:'a) ->
         f()
         x / property
   } + (x - property)

// Here we create a function that logs before a property is accessed
let inline logAccess property x =
   x |> beforeAccess (fun () -> printfn "%A Accessed!" property) property

// Here we create a new constructor for an account that logs balance
// requests.
let loggingAccount name =
   account name |> logAccess Balance

let testLoggingAccount =
   let acc = loggingAccount "Zach's current account"
   let illicitFunds = 1000000m
   acc / Deposit illicitFunds
   printfn "Zach's account balance is: %f" (acc / Balance)
   // prints:
   // > Balance Accessed!
   // > Zach's account balance is: 1000000.000000

// We can re-use the same block of code to log when a persons name is accessed.

// Here we create a new constructor for a person that logs when their name
// is accessed
let loggingPerson fName sName =
   person fName sName |> logAccess Name

let testLoggingPerson =
   let zach = loggingPerson "Zach" "Bray"
   printf "My name is: %s" (zach / Name)
   // prints:
   // > Name Accessed!
   // > My name is: Zach Bray

Console.ReadLine() |> ignore<string>
module TypeSystem =

   type Class0() =
      do ()

   type Class1<'m1>(m1) =
      member c.Member1:'m1 = m1
      static member ( / ) (c:Class1<_>, m:'m) =
         c.Member1 m

   type Class2<'m1,'m2>(m1, m2) =
      member c.Member1:'m1 = m1
      member c.Member2:'m2 = m2
      static member ( / ) (c:Class2<_,_>, m:'m) =
         c.Member1 m
      static member ( / ) (c:Class2<_,_>, m:'m) =
         c.Member2 m

   type Class3<'m1,'m2,'m3>(m1, m2, m3) =
      member c.Member1:'m1 = m1
      member c.Member2:'m2 = m2
      member c.Member3:'m3 = m3
      static member ( / ) (c:Class3<_,_,_>, m:'m) =
         c.Member1 m
      static member ( / ) (c:Class3<_,_,_>, m:'m) =
         c.Member2 m
      static member ( / ) (c:Class3<_,_,_>, m:'m) =
         c.Member3 m

   type Class4<'m1,'m2,'m3,'m4>(m1, m2, m3, m4) =
      member c.Member1:'m1 = m1
      member c.Member2:'m2 = m2
      member c.Member3:'m3 = m3
      member c.Member4:'m4 = m4
      static member ( / ) (c:Class4<_,_,_,_>, m:'m) =
         c.Member1 m
      static member ( / ) (c:Class4<_,_,_,_>, m:'m) =
         c.Member2 m
      static member ( / ) (c:Class4<_,_,_,_>, m:'m) =
         c.Member3 m
      static member ( / ) (c:Class4<_,_,_,_>, m:'m) =
         c.Member4 m

   type Class5<'m1,'m2,'m3,'m4,'m5>(m1, m2, m3, m4, m5) =
      member c.Member1:'m1 = m1
      member c.Member2:'m2 = m2
      member c.Member3:'m3 = m3
      member c.Member4:'m4 = m4
      member c.Member5:'m5 = m5
      static member ( / ) (c:Class5<_,_,_,_,_>, m:'m) =
         c.Member1 m
      static member ( / ) (c:Class5<_,_,_,_,_>, m:'m) =
         c.Member2 m
      static member ( / ) (c:Class5<_,_,_,_,_>, m:'m) =
         c.Member3 m
      static member ( / ) (c:Class5<_,_,_,_,_>, m:'m) =
         c.Member4 m
      static member ( / ) (c:Class5<_,_,_,_,_>, m:'m) =
         c.Member5 m

   type Class5 with
      static member ( - ) (x:Class5< ('m -> 'a) , _, _, _, _>, m:'m) =
         Class4(x.Member2, x.Member3, x.Member4, x.Member5)
      static member ( - ) (x:Class5<_, ('m -> 'a), _, _, _>, m:'m) =
         Class4(x.Member1, x.Member3, x.Member4, x.Member5)
      static member ( - ) (x:Class5<_, _, ('m -> 'a), _, _>, m:'m) =
         Class4(x.Member1, x.Member2, x.Member4, x.Member5)
      static member ( - ) (x:Class5<_, _, _, ('m -> 'a), _>, m:'m) =
         Class4(x.Member1, x.Member2, x.Member3, x.Member5)
      static member ( - ) (x:Class5<_, _, _, _, ('m -> 'a)>, m:'m) =
         Class4(x.Member1, x.Member2, x.Member3, x.Member4)

   type Class4 with
      static member ( + ) (x:Class4<_,_,_,_>, y:Class1<_>) =
         Class5(x.Member1, x.Member2, x.Member3, x.Member4, y.Member1)

      static member ( - ) (x:Class4< ('m -> 'a) , _, _, _>, m:'m) =
         Class3(x.Member2, x.Member3, x.Member4)
      static member ( - ) (x:Class4<_, ('m -> 'a), _, _>, m:'m) =
         Class3(x.Member1, x.Member3, x.Member4)
      static member ( - ) (x:Class4<_, _, ('m -> 'a), _>, m:'m) =
         Class3(x.Member1, x.Member2, x.Member4)
      static member ( - ) (x:Class4<_, _, _, ('m -> 'a)>, m:'m) =
         Class3(x.Member1, x.Member2, x.Member3)

   type Class3 with
      static member ( + ) (x:Class3<_,_,_>, y:Class1<_>) =
         Class4(x.Member1, x.Member2, x.Member3, y.Member1)
      static member ( + ) (x:Class3<_,_,_>, y:Class2<_,_>) =
         Class5(x.Member1, x.Member2, x.Member3, y.Member1, y.Member2)

      static member ( - ) (x:Class3< ('m -> 'a) , _, _>, m:'m) =
         Class2(x.Member2, x.Member3)
      static member ( - ) (x:Class3<_, ('m -> 'a), _>, m:'m) =
         Class2(x.Member1, x.Member3)
      static member ( - ) (x:Class3<_, _, ('m -> 'a)>, m:'m) =
         Class2(x.Member1, x.Member2)

   type Class2 with
      static member ( + ) (x:Class2<_,_>, y:Class1<_>) =
         Class3(x.Member1, x.Member2, y.Member1)
      static member ( + ) (x:Class2<_,_>, y:Class2<_,_>) =
         Class4(x.Member1, x.Member2, y.Member1, y.Member2)
      static member ( + ) (y:Class2<_,_>, x:Class3<_,_,_>) =
         Class5(x.Member1, x.Member2, x.Member3, y.Member1, y.Member2)

      static member ( - ) (x:Class2< ('m -> 'a) , _>, m:'m) =
         Class1(x.Member2)
      static member ( - ) (x:Class2<_, ('m -> 'a) >, m:'m) =
         Class1(x.Member1)

   type Class1 with
      static member ( + ) (x:Class1<_>, y:Class1<_>) =
         Class2(x.Member1, y.Member1)
      static member ( + ) (y:Class1<_>, x:Class2<_,_>) =
         Class3(x.Member1, x.Member2, y.Member1)
      static member ( + ) (y:Class1<_>, x:Class3<_,_,_>) =
         Class4(x.Member1, x.Member2, x.Member3, y.Member1)
      static member ( + ) (y:Class1<_>, x:Class4<_,_,_,_>) =
         Class5(x.Member1, x.Member2, x.Member3, x.Member4, y.Member1)

      static member ( - ) (x:Class1< ('m -> 'a) >, m:'m) = Class0()

   type Class0 with
      static member ( + ) (x:Class0, y:Class1<_>) = y
      static member ( + ) (x:Class0, y:Class2<_,_>) = y
      static member ( + ) (x:Class0, y:Class3<_,_,_>) = y
      static member ( + ) (x:Class0, y:Class4<_,_,_,_>) = y
      static member ( + ) (x:Class0, y:Class5<_,_,_,_,_>) = y

   type ClassBuilder() =
      member inline b.Yield f = Class1(f)
      member inline b.YieldFrom x = x
      member inline b.Combine(x, y) = x + y
      member inline b.Delay f = f()
   
   let Class = ClassBuilder()
namespace System
module TypeSystem

from Script
Multiple items
union case FirstName.FirstName: FirstName

--------------------
type FirstName = | FirstName

Full name: Script.FirstName
Multiple items
union case LastName.LastName: LastName

--------------------
type LastName = | LastName

Full name: Script.LastName
Multiple items
union case Name.Name: Name

--------------------
type Name = | Name

Full name: Script.Name
val person : firstName:string -> lastName:string -> Class3<(LastName -> string),(Name -> string),(FirstName -> string)>

Full name: Script.person
val firstName : string
val lastName : string
Multiple items
val Class : ClassBuilder

Full name: Script.TypeSystem.Class

--------------------
type ClassAttribute =
  inherit Attribute
  new : unit -> ClassAttribute

Full name: Microsoft.FSharp.Core.ClassAttribute

--------------------
new : unit -> ClassAttribute
Multiple items
union case AddManager.AddManager: 'a -> 'a AddManager

--------------------
type 'a AddManager = | AddManager of 'a

Full name: Script.AddManager<_>
Multiple items
union case Managers.Managers: Managers

--------------------
type Managers = | Managers

Full name: Script.Managers
val worker : unit -> Class2<(Managers -> 'a list),('a AddManager -> unit)>

Full name: Script.worker
val managers : 'a list ref
Multiple items
val ref : value:'T -> 'T ref

Full name: Microsoft.FSharp.Core.Operators.ref

--------------------
type 'T ref = Ref<'T>

Full name: Microsoft.FSharp.Core.ref<_>
Multiple items
module List

from Microsoft.FSharp.Collections

--------------------
type List<'T> =
  | ( [] )
  | ( :: ) of Head: 'T * Tail: 'T list
  interface IEnumerable
  interface IEnumerable<'T>
  member Head : 'T
  member IsEmpty : bool
  member Item : index:int -> 'T with get
  member Length : int
  member Tail : 'T list
  static member Cons : head:'T * tail:'T list -> 'T list
  static member Empty : 'T list

Full name: Microsoft.FSharp.Collections.List<_>
val empty<'T> : 'T list

Full name: Microsoft.FSharp.Collections.List.empty
val newManager : 'a
val employee : firstName:string -> secondName:string -> Class5<(LastName -> string),(Name -> string),(FirstName -> string),(Managers -> 'a list),('a AddManager -> unit)>

Full name: Script.employee
val secondName : string
val testConstruction : unit

Full name: Script.testConstruction
val rupert : Class5<(LastName -> string),(Name -> string),(FirstName -> string),(Managers -> unit list),(unit AddManager -> unit)>
type unit = Unit

Full name: Microsoft.FSharp.Core.unit
val becca : Class5<(LastName -> string),(Name -> string),(FirstName -> string),(Managers -> Class5<(LastName -> string),(Name -> string),(FirstName -> string),(Managers -> unit list),(unit AddManager -> unit)> list),(Class5<(LastName -> string),(Name -> string),(FirstName -> string),(Managers -> unit list),(unit AddManager -> unit)> AddManager -> unit)>
val dave : Class5<(LastName -> string),(Name -> string),(FirstName -> string),(Managers -> Class5<(LastName -> string),(Name -> string),(FirstName -> string),(Managers -> Class5<(LastName -> string),(Name -> string),(FirstName -> string),(Managers -> unit list),(unit AddManager -> unit)> list),(Class5<(LastName -> string),(Name -> string),(FirstName -> string),(Managers -> unit list),(unit AddManager -> unit)> AddManager -> unit)> list),(Class5<(LastName -> string),(Name -> string),(FirstName -> string),(Managers -> Class5<(LastName -> string),(Name -> string),(FirstName -> string),(Managers -> unit list),(unit AddManager -> unit)> list),(Class5<(LastName -> string),(Name -> string),(FirstName -> string),(Managers -> unit list),(unit AddManager -> unit)> AddManager -> unit)> AddManager -> unit)>
val manager : Class5<(LastName -> string),(Name -> string),(FirstName -> string),(Managers -> Class5<(LastName -> string),(Name -> string),(FirstName -> string),(Managers -> unit list),(unit AddManager -> unit)> list),(Class5<(LastName -> string),(Name -> string),(FirstName -> string),(Managers -> unit list),(unit AddManager -> unit)> AddManager -> unit)>
val printfn : format:Printf.TextWriterFormat<'T> -> 'T

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.printfn
Multiple items
union case HasNext.HasNext: HasNext

--------------------
type HasNext = | HasNext

Full name: Script.HasNext
Multiple items
union case Next.Next: Next

--------------------
type Next = | Next

Full name: Script.Next
Multiple items
union case ForEach.ForEach: ('a -> unit) -> 'a ForEach

--------------------
type 'a ForEach = | ForEach of ('a -> unit)

Full name: Script.ForEach<_>
val richIterator : x:'a -> Class1<('b ForEach -> unit)> (requires member ( / ) and member ( / ))

Full name: Script.richIterator
val x : 'a (requires member ( / ) and member ( / ))
val f : ('b -> unit) (requires member ( / ) and member ( / ))
val stringIterator : str:string -> Class2<(HasNext -> bool),(Next -> char)>

Full name: Script.stringIterator
val str : string
Multiple items
val string : value:'T -> string

Full name: Microsoft.FSharp.Core.Operators.string

--------------------
type string = String

Full name: Microsoft.FSharp.Core.string
val i : int ref
property String.Length: int
val c : char
val incr : cell:int ref -> unit

Full name: Microsoft.FSharp.Core.Operators.incr
val richStringIterator : str:string -> Class3<(HasNext -> bool),(Next -> char),(char ForEach -> unit)>

Full name: Script.richStringIterator
val iter : Class2<(HasNext -> bool),(Next -> char)>
val onlyRichStringIterator : str:string -> Class1<(char ForEach -> unit)>

Full name: Script.onlyRichStringIterator
val testRSI : unit

Full name: Script.testRSI
val iter : Class3<(HasNext -> bool),(Next -> char),(char ForEach -> unit)>
val printf : format:Printf.TextWriterFormat<'T> -> 'T

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.printf
val iter2 : Class3<(HasNext -> bool),(Next -> char),(char ForEach -> unit)>
val testORSI : unit

Full name: Script.testORSI
val iter : Class1<(char ForEach -> unit)>
Multiple items
union case Balance.Balance: Balance

--------------------
type Balance = | Balance

Full name: Script.Balance
Multiple items
union case Deposit.Deposit: decimal -> Deposit

--------------------
type Deposit = | Deposit of decimal

Full name: Script.Deposit
Multiple items
val decimal : value:'T -> decimal (requires member op_Explicit)

Full name: Microsoft.FSharp.Core.Operators.decimal

--------------------
type decimal = Decimal

Full name: Microsoft.FSharp.Core.decimal

--------------------
type decimal<'Measure> = decimal

Full name: Microsoft.FSharp.Core.decimal<_>
Multiple items
union case Withdraw.Withdraw: decimal -> Withdraw

--------------------
type Withdraw = | Withdraw of decimal

Full name: Script.Withdraw
val account : name:'a -> Class4<(Deposit -> unit),(Withdraw -> unit),(Balance -> decimal),(Name -> 'a)>

Full name: Script.account
val name : 'a
val balance : decimal ref
val x : decimal
val beforeAccess : f:(unit -> unit) -> property:'a -> x:'a0 -> 'd (requires member ( / ) and member ( - ) and member ( + ))

Full name: Script.beforeAccess
val f : (unit -> unit)
val property : 'a (requires member ( / ) and member ( - ) and member ( + ))
val x : 'a (requires member ( / ) and member ( - ) and member ( + ))
val logAccess : property:'a -> x:'b -> 'e (requires member ( / ) and member ( - ) and member ( + ))

Full name: Script.logAccess
val x : 'b (requires member ( / ) and member ( - ) and member ( + ))
val loggingAccount : name:'a -> Class4<(Deposit -> unit),(Withdraw -> unit),(Name -> 'a),(Balance -> decimal)>

Full name: Script.loggingAccount
val testLoggingAccount : unit

Full name: Script.testLoggingAccount
val acc : Class4<(Deposit -> unit),(Withdraw -> unit),(Name -> string),(Balance -> decimal)>
val illicitFunds : decimal
val loggingPerson : fName:string -> sName:string -> Class3<(LastName -> string),(FirstName -> string),(Name -> string)>

Full name: Script.loggingPerson
val fName : string
val sName : string
val testLoggingPerson : unit

Full name: Script.testLoggingPerson
val zach : Class3<(LastName -> string),(FirstName -> string),(Name -> string)>
type Console =
  static member BackgroundColor : ConsoleColor with get, set
  static member Beep : unit -> unit + 1 overload
  static member BufferHeight : int with get, set
  static member BufferWidth : int with get, set
  static member CapsLock : bool
  static member Clear : unit -> unit
  static member CursorLeft : int with get, set
  static member CursorSize : int with get, set
  static member CursorTop : int with get, set
  static member CursorVisible : bool with get, set
  ...

Full name: System.Console
Console.ReadLine() : string
val ignore : value:'T -> unit

Full name: Microsoft.FSharp.Core.Operators.ignore
Raw view Test code New version

More information

Link:http://fssnip.net/bZ
Posted:12 years ago
Author:Zach Bray
Tags: monad , mixin , generic , types , aspect-oriented