Sunday 28 August 2011

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))

Sunday 17 July 2011

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

Saturday 28 May 2011

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

Friday 29 April 2011

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')