Functional IoC Container Example

open System

type StateMonad() =

    member this.ReturnFrom x = x

    member this.Return x s = (x, s)

    member this.Bind (m, f) s = let (x, s1) = m s

                                in (f x) s1

let state = new StateMonad()

type IEnvironment =

    abstract member UserName : string with get

type ILogger =

    abstract member Log : string -> unit

type Container = { Environment : IEnvironment

                   Logger : ILogger }

let getContainer = fun f -> (f(), f)

let run ctx m = m (fun () -> ctx) |> fst

let rec fac n acc  = state { let! container = getContainer

                             container.Logger.Log (sprintf "%d" acc)

                             if (n = 0) then return acc

                             else return! fac (n - 1) (n * acc) }

let compute n = state { let! container = getContainer                       

                        container.Logger.Log (sprintf "Begin fac %d" n)

                        let! result = fac n 1                                      

                        container.Logger.Log (sprintf "End fac %d" n)

                        let userName = container.Environment.UserName

                        container.Logger.Log (sprintf "Computed by %s" userName)

                        return result }

let prodContainer =

    { Environment = { new IEnvironment with                         

                          member this.UserName

                                  with get () =

                                       Environment.UserName }

      Logger = { new ILogger with

                    member this.Log s =

                        Console.WriteLine ("{0} : {1}", (DateTime.Now), s) } }

let testContainer =

    { Environment = { new IEnvironment with                         

                          member this.UserName

                                  with get () =

                                       "John Doe" }

      Logger = { new ILogger with

                    member this.Log s = Console.WriteLine (" {0} ",  s) } }

printfn "Result %A" (run prodContainer (compute 10))

printfn "Result %A" (run testContainer (compute 10))

Functional WPF Part Five (Simple example of how to use it)

// Example using the Functional WPF DSL

// View Model

type Person (firstName, lastName, age) =

    static member New (firstName, lastName, age) =

            new Person(firstName, lastName, age)

    member this.LastName

                with get () = lastName

                and set (value : string) = ()

    member this.FirstName

                with get () = firstName

                and set (value : string) = ()

    member this.Age

                with get () = age

                and set (value : int) = ()

let dataContext = [("Homer", "Simpson", 46)

                   ("Marge", "Simpson", 42)

                   ("Lisa", "Simpson", 9)

                   ("Bart", "Simpson", 12) ] |> List.map (Person.New)

// Header

let header = [ label [width 100] "First Name"

               label [width 100] "Last Name"

               label [width 50] "Age" ] |> stackpanel [] Horizontal

// Row

let row = [ textbox [width 100] <@@ fun (x:Person) -> x.FirstName @@>

            textbox [width 100] <@@ fun (x:Person) -> x.LastName @@>

            textbox [width 50] <@@ fun (x:Person) -> x.Age @@> ]

            |> stackpanel [] Horizontal

// Data Template

let sampleTemplate = datatemplate row

// Final composition

let sampleGrid = [ header

                   itemscontrol sampleTemplate

                   button "submit" ] |> stackpanel [width 250] Vertical

                                     |> border Blue

// Main Window

let mainWindow = window [width 400; height 200] sampleGrid

             

// Application                                

let sampleApplication = application mainWindow

// Run the app with the given dataContext                                                               

[<STAThread()>]

do run sampleApplication dataContext

Functional WPF Part Four

// Functional WPF Part Four              
// Running the WPF Application

#if INTERACTIVE

#r @"WindowsBase.dll"

#r @"PresentationCore.dll"

#r @"PresentationFramework.dll"

#endif

open System.Windows

open System.Windows.Controls

open System.Windows.Markup

let run app data = app |> parseApplication                    

                       |> XamlReader.Parse

                       |> fun x -> (x :?> System.Windows.Application)

                       |> fun x -> x.MainWindow.DataContext <- data

                                   x.MainWindow.Show()

                                   x.Run()

                       |> ignore

Functional WPF Part Three

// Functional WPF Part Three

// Parsing to Xaml

let parseColor o =

            match o with

            | Red -> "Red"

            | Green -> "Green"

            | Blue -> "Blue"

let parseOrientation o =

            match o with

            | Horizontal -> "Horizontal"

            | Vertical -> "Vertical"

let parseAttribute attr =

            match attr with

            | Width x -> sprintf @"Width = ""%i""" x

            | Height x -> sprintf @"Height = ""%i""" x

let parseAttributes =

            List.fold (fun acc x -> sprintf "%s %s" acc (parseAttribute x)) ""

let rec parseBinding (b:Expr) =

            match b with

            | Lambda (_, e) -> parseBinding e

            | PropertyGet (_, info, _) -> sprintf @"{Binding Path=%s}" (info.Name)

let rec parseDataTemplate (DataTemplate x) =

            sprintf @"<DataTemplate>%s</DataTemplate>" 
                    (parseFrameworkElement x)                               

and parseFrameworkElement x =

            match x with

            | Label (s, attrs) -> sprintf @"<Label Content=""%s"" %s/>" s

                                          (parseAttributes attrs)

            | Button s -> sprintf @"<Button Content=""%s""/>" s

            | TextBox (attrs, b) -> sprintf @"<TextBox %s Text=""%s""/>"

                                            (parseAttributes attrs)

                                            (parseBinding b)

            | StackPanel (xs, attrs, orient) ->

                     let (+) x y = sprintf "%s\n%s" x y

                     sprintf @"<StackPanel Orientation = ""%s"" %s>%s
                               </StackPanel>"                                                                             

                             (parseOrientation orient)

                             (parseAttributes attrs)

                             (List.fold (fun acc x -> acc + (parseFrameworkElement x)) "" xs)

            | Border (c, x) -> sprintf @"<Border BorderBrush=""%s""

                                                 BorderThickness=""2"">%s</Border>"

                                       (parseColor c)

                                       (parseFrameworkElement x)

            | ItemsControl t -> 

                     sprintf @"<ItemsControl ItemsSource=""{Binding .}""> 

                               <ItemsControl.ItemTemplate>%s</ItemsControl.ItemTemplate>

                               </ItemsControl>" (parseDataTemplate t)

let parseWindow (Window (c, attrs)) =

            sprintf @"<Window %s>%s</Window>"

                    (parseAttributes attrs)

                    (parseFrameworkElement c)

let parseApplication (Application c) =

        sprintf @"<Application

                   xmlns=""http://schemas.microsoft.com/winfx/2006/xaml/presentation""

                   xmlns:x=""http://schemas.microsoft.com/winfx/2006/xaml"">

                   <Application.MainWindow>%s</Application.MainWindow></Application>"

                (parseWindow c)

Functional WPF Part Two

// Functional WPF Part Two

// Helper functions

let width = Width

let height = Height

let stackpanel attrs orient xs = StackPanel (xs, attrs, orient)

let border c x = Border(c, x)

let label attrs s = Label(s, attrs)

let button = Button

let textbox attrs b = TextBox(attrs, b)

let itemscontrol = ItemsControl

let datatemplate = DataTemplate

let application = Application

let window attrs c = Window (c, attrs)

Functional WPF Part One

// Functional WPF (An Experiment in F# DSL to Xaml)

open System

open Microsoft.FSharp.Quotations

open Microsoft.FSharp.Quotations.Patterns

// Type Definitions

type Color = Red | Green | Blue

type Orientation = Horizontal | Vertical

type Attribute = Width of int

               | Height of int

type DataTemplate = DataTemplate of FrameworkElement

and FrameworkElement

        = Label of string * Attribute list

        | Button of string

        | TextBox of Attribute list * Expr

        | StackPanel of FrameworkElement list * Attribute list * Orientation

        | Border of Color * FrameworkElement

        | ItemsControl of DataTemplate

type Window = Window of FrameworkElement * Attribute list

type Application = Application of Window

Reactive Extensions v1.0.10425 Computation Expression Builder

// Reactive Extensions v1.0.10425 Computation Expression Builder
// http://msdn.microsoft.com/en-us/data/gg577609

open System

open System.Linq

open System.Reactive.Linq

type rxBuilder() =    

    member this.Bind ((xs:'a IObservable), (f:'a -> 'b IObservable)) =

        Observable.SelectMany (xs, f)

    member this.Delay f = Observable.Defer f

    member this.Return x = Observable.Return x

    member this.ReturnFrom xs = xs

    member this.Combine (xs:'a IObservable, ys: 'a IObservable) =

        Observable.Concat (xs, ys)

    member this.For (xs : 'a seq, f: 'a -> 'b IObservable) =

        Observable.For(xs, new Func<_, IObservable<_>>(f)) 

    member this.TryFinally (xs: 'a IObservable, f : unit -> unit) =

        Observable.Finally(xs, new Action(f))

    member this.TryWith (xs: 'a IObservable, f: exn -> 'a IObservable) =

        Observable.Catch (xs, new Func<exn, 'a IObservable>(f))

    member this.While (f, xs: 'a IObservable) =

        Observable.While (new Func<bool>(f), xs)

    member this.Yield x = Observable.Return x

    member this.YieldFrom xs = xs

    member this.Zero () = Observable.Empty()

              

let rx = rxBuilder()

// Rx combinators

let repeat (xs:IObservable<_>) = xs.Repeat()

// Sample usages

let xs = rx { yield 42

              yield 43 }

let ys = rx { yield 42

              yield! xs }

let zs = rx { for i = 0 to 10 do yield i }

let redTime = rx { while (DateTime.Now.Second > 30) do

                      yield ConsoleColor.Red }

let blueTime = rx { while (DateTime.Now.Second < 30) do

                      yield ConsoleColor.Green }

let coloredTime  = rx { yield! redTime

                        yield! blueTime } |> repeat

Kleisli List Arrow Combinators

// Kleisli List Arrow

// ( >>= ) : 'a list -> ('a -> 'b list) -> 'b list

let (>>=) m f = m |> List.map f |> List.concat

// unit : 'a -> 'a list

let unit x = [x]

type Arrow<'i,'o> = Arrow of('i -> 'o list)

// arr : ('a -> 'b list) -> Arrow<'a,'b>

let arr f = Arrow f

// pure' : ('a -> 'b) -> Arrow<'a,'b>

let pure' f = arr (unit << f)

// ( >>>> ) : Arrow<'a,'b> -> Arrow<'b,'c> -> Arrow<'a,'c>
let (>>>>) (Arrow f) (Arrow g) = arr ((fun m -> m >>= g) << f)

// first : Arrow<'a,'b> -> Arrow<('a * 'c),('b * 'c)>
let first (Arrow f) = arr (fun(x,y) -> (f x) >>= (fun x' -> unit (x', y)))

// second : Arrow<'a,'b> -> Arrow<('c * 'a),('c * 'b)>

let second (Arrow f) = arr (fun(x,y) -> (f y) >>= (fun y' -> unit (x, y')))


// mapA : Arrow<'a,'b> -> ('b -> 'c) -> Arrow<'a,'c>
// Not sure about this one. Is it right ?
let mapA m f = m >>>> pure' f

// toMonad : Arrow<unit,'a> -> 'a list

let toMonad (Arrow f) = f()

// map : 'a list -> ('a -> 'b) -> 'b list
let map m f = mapA (arr (fun _ -> m)) f |> toMonad

// bind : 'a list -> ('a -> 'b list) -> 'b list

let bind m f = (arr (fun _ -> m) >>>> arr f) |> toMonad

// fix : (('a -> 'b) -> 'a -> 'b) -> 'a -> 'b

let rec fix f x = f (fix f) x

// mfix : ('a -> 'a list) -> 'a list
// This one is wrong. Help!

let rec mfix f = match fix (fun x -> fun () -> f(List.head (x()))) () with

                 | [] -> []

                 | x::_ -> x :: mfix (List.tail<< f)

// liftM : ('a -> 'b) -> 'a list -> 'b list

let liftM f m = m >>= (fun a -> unit (f a))

// loop : Arrow<('a * 'b),('c * 'b)> -> Arrow<'a,'c>

let loop (Arrow f) = let f' x y = f (x, snd y)

                     arr (liftM fst << mfix << f')