Created
February 2, 2010 04:53
-
-
Save mattpodwysocki/292392 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
open System | |
open System.Collections.Generic | |
type IMonoid<'T> = | |
abstract member mempty : unit -> 'T | |
abstract member mappend : 'T * 'T -> 'T | |
type MonoidAssociations private() = | |
static let associations = new Dictionary<Type, obj>() | |
static member Add<'T>(monoid : IMonoid<'T>) = associations.Add(typeof<'T>, monoid) | |
static member Get<'T>() = | |
match associations.TryGetValue(typeof<'T>) with | |
| true, assoc -> assoc :?> IMonoid<'T> | |
| false, _ -> failwithf "Type %O does not have an implementation of IMonoid" <| typeof<'T> | |
let mempty<'T> = MonoidAssociations.Get<'T>().mempty | |
let mappend<'T> a b = MonoidAssociations.Get<'T>().mappend(a, b) | |
type ListMonoid<'T>() = | |
interface IMonoid<'T list> with | |
member this.mempty() = [] | |
member this.mappend(a, b) = a @ b | |
MonoidAssociations.Add(new ListMonoid<string>()) | |
type Writer<'W,'T> = Writer of (unit -> 'T * 'W) | |
let runWriter<'W,'T> (Writer t) : ('T * 'W) = t() | |
type WriterBuilder() = | |
member this.Return<'W,'T>(a : 'T) : Writer<'W,'T> = | |
Writer(fun () -> a, mempty()) | |
member this.ReturnFrom<'W,'T>(w : Writer<'W,'T>) = w | |
member this.Bind<'W,'T,'U>(m : Writer<'W,'T>, k : 'T -> Writer<'W,'U>) : Writer<'W,'U> = | |
Writer(fun () -> | |
let (a, w) = runWriter m | |
let (b, w') = runWriter (k a) | |
in (b, mappend<'W> w w')) | |
member this.Zero<'W>() : Writer<'W,unit> = this.Return () | |
member this.TryWith<'W,'T>(writer : Writer<'W,'T>, handler : exn -> Writer<'W,'T>) = | |
Writer(fun () -> | |
try runWriter writer | |
with e -> runWriter (handler e)) | |
member this.TryFinally<'W,'T>(writer : Writer<'W,'T>, compensation : unit -> unit) = | |
Writer(fun () -> | |
try runWriter writer | |
finally compensation()) | |
member this.Using<'D,'W,'T when 'D :> IDisposable and 'D : null>(resource : 'D, body : 'D -> Writer<'W,'T>) = | |
this.TryFinally(body resource, (fun () -> match resource with null -> () | disp -> disp.Dispose())) | |
member this.Delay<'W,'T>(f : unit -> Writer<'W,'T>) = | |
this.Bind(this.Return (), f) | |
member this.Combine<'W,'T>(comp1 : Writer<'W,unit>, comp2 : Writer<'W,'T>) = | |
this.Bind(comp1, (fun () -> comp2)) | |
member this.While<'W>(pred : unit -> bool, body : Writer<'W,unit>) = | |
match pred() with | |
| true -> this.Bind(body, (fun () -> this.While(pred,body))) | |
| _ -> this.Return () | |
member this.For<'W,'T>(items : seq<'T>, body : 'T -> Writer<'W,unit>) = | |
this.Using(items.GetEnumerator(), | |
(fun enum -> this.While((fun () -> enum.MoveNext()), this.Delay(fun () -> body enum.Current)))) | |
let writer = new WriterBuilder() | |
let tell w = Writer(fun () -> (), w) | |
let listen m = Writer(fun () -> let (a, w) = runWriter m in ((a, w), w)) | |
let pass m = Writer(fun () -> let ((a, f), w) = runWriter m in (a, f w)) | |
let listens f m = writer { | |
let! (a,w) = m | |
return (a, f w) } | |
let censor f m = | |
writer { let! a = m | |
return (a, f) | |
} |> pass | |
let logMsg (s : string) = tell [s] |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment