Undo Redo in F#

Code…

#light

#r "FSharp.Core"
#r "PresentationCore"
#r "PresentationFramework"
#r "WindowsBase"
#r "System.Xaml"

open System
open System.Linq
open System.Windows
open System.Windows.Input
open System.Windows.Controls
open System.Windows.Data
open System.ComponentModel
open System.Windows.Shapes
open System.Windows.Media
open System.Xaml
open System.IO
open System.Text
open System.Windows.Markup
open System.Threading

type Command = string * (unit -> unit) * (unit -> unit)

type MementoMessage =
    | UndoList of string seq AsyncReplyChannel
    | RedoList of string seq AsyncReplyChannel
    | UndoCommand
    | RedoCommand
    | Clear
    | NewCommand of Command
    | CanUndo of bool AsyncReplyChannel
    | CanRedo of bool AsyncReplyChannel

type Memento() as this =

    let (<--) (m:'msg MailboxProcessor) x = m.Post x
    let (<->) (m:_ MailboxProcessor) msg = m.PostAndReply(fun replyChannel -> msg replyChannel)

    let emptyStack = List<string * (unit -> unit) * (unit -> unit)>.Empty

    let memento = new MailboxProcessor<MementoMessage>(fun inbox ->
        let rec loop undoStack redoStack =
            async { let! msgOption = inbox.TryReceive(timeout=0)
                    match msgOption with
                    | None ->
                        do! Async.Sleep(20)
                        return! loop undoStack redoStack
                    | Some(msg) ->
                       match msg with
                       | CanUndo replyChannel  ->
                            replyChannel.Reply (undoStack |> List.isEmpty |> not)
                            return! loop undoStack redoStack
                       | CanRedo replyChannel  ->
                            replyChannel.Reply (redoStack |> List.isEmpty |> not)
                            return! loop undoStack redoStack
                       | UndoList replyChannel ->
                            replyChannel.Reply (undoStack |> List.map (fun (name,_,_) -> name))
                            return! loop undoStack redoStack
                       | RedoList replyChannel ->
                            replyChannel.Reply (redoStack |> List.map (fun (name,_,_) -> name))
                            return! loop undoStack redoStack
                       | UndoCommand ->
                            if (undoStack |> List.isEmpty) then return! loop undoStack redoStack // ignore
                                else
                                    let (_, undo, _) = List.head undoStack
                                    undo()
                                    return! loop (List.tail undoStack) ((List.head undoStack)::redoStack)
                       | RedoCommand ->
                            if (redoStack |> List.isEmpty) then return! loop undoStack redoStack
                                else
                                   let (_, _, redo) = List.head redoStack
                                   redo()
                                   return! loop ((List.head redoStack)::undoStack) (List.tail redoStack)
                       | NewCommand command   ->
                           return! loop (command::undoStack) emptyStack
                       | Clear ->
                           return! loop emptyStack emptyStack
                }

        loop emptyStack emptyStack
        )

    do
        memento.Start()

    let propertyChanged = Event<_,_>()
    let notify obj s = propertyChanged.Trigger(obj, PropertyChangedEventArgs(s))

    let notifyAll() = [|"CanUndo";"CanRedo";"UndoList";"RedoList"|] |> Array.iter (fun s -> notify this s)

    interface INotifyPropertyChanged with
       [<CLIEvent>]
       member this.PropertyChanged = propertyChanged.Publish

    member this.NewCommand(command:Command) = memento <-- NewCommand(command); notifyAll()
    member this.Undo() = memento <-- UndoCommand; notifyAll()
    member this.Redo() = memento <-- RedoCommand; notifyAll()
    member this.Clear() = memento <-- Clear
    member this.CanUndo with get()  = memento <-> CanUndo
    member this.CanRedo with get()  = memento <-> CanRedo
    member this.UndoList with get() = memento <-> UndoList
    member this.RedoList with get() = memento <-> RedoList

let window = "<Window
        xmlns=\"http://schemas.microsoft.com/winfx/2006/xaml/presentation\"
        xmlns:x=\"http://schemas.microsoft.com/winfx/2006/xaml\"
        Title=\"MainWindow\" Height=\"400\" Width=\"525\">
    <DockPanel>
        <StackPanel DockPanel.Dock=\"Left\" Width=\"150\">
            <Button x:Name=\"redButton\">Red</Button>
            <Button x:Name=\"greenButton\">Green</Button>
            <Button x:Name=\"blueButton\">Blue</Button>
            <Button IsEnabled=\"{Binding CanUndo}\" x:Name=\"undoButton\">Undo</Button>
            <Button IsEnabled=\"{Binding CanRedo}\" x:Name=\"redoButton\">Redo</Button>
            <Label>Undo List:</Label>
            <ListBox x:Name=\"undoListBox\" MinHeight=\"100\" ItemsSource=\"{Binding UndoList}\"></ListBox>
            <Label>Redo List:</Label>
            <ListBox x:Name=\"redoListBox\" MinHeight=\"100\" ItemsSource=\"{Binding RedoList}\"></ListBox>
        </StackPanel>
        <Grid x:Name=\"grid\" Background=\"Red\" />
    </DockPanel>
</Window>" |> XamlReader.Parse :?> Window

let memento = new Memento()
window.DataContext <- memento

let redButton = window.FindName("redButton") :?> Button
let greenButton = window.FindName("greenButton") :?> Button
let blueButton = window.FindName("blueButton") :?> Button
let undoButton = window.FindName("undoButton") :?> Button
let redoButton = window.FindName("redoButton") :?> Button

let grid = window.FindName("grid") :?> Grid

let context = AsyncOperationManager.SynchronizationContext
let runInGuiContext f =
    context.Post(new SendOrPostCallback(fun _ -> f()),null)

let changeBackground(name:string, brush:Brush) =
    let old = grid.Background
    memento.NewCommand((name, (fun _ -> runInGuiContext(fun _ -> grid.Background <- old)), (fun _ -> runInGuiContext(fun _ -> grid.Background <- brush))))
    grid.Background <- brush

redButton.Click.Add(fun _ ->  changeBackground("-> Red", Brushes.Red))
greenButton.Click.Add(fun _ -> changeBackground("-> Green", Brushes.Green))
blueButton.Click.Add(fun _ -> changeBackground("-> Blue", Brushes.Blue))

undoButton.Click.Add(fun _ -> memento.Undo())
redoButton.Click.Add(fun _ -> memento.Redo())

window.Show()

I wrote this little applet to see what the combination of MEF and the F# CodeDom would look like, and for the record it looks really really good.

This combination opens a whole lot of doors. By using the F# CodeDom the plugin source code can brought in from anywhere;

• A server,
• A blog,
• Code generated from a DSL, or even
• Entered by the user directly.

See below for the implementation.

Basic MEF Code originally from Jomo Fisher

open System.Reflection
open System.IO
open System.ComponentModel.Composition
open System.ComponentModel.Composition.Hosting
open Microsoft.FSharp.Compiler.CodeDom
open System.CodeDom.Compiler
open System.Linq
open System.Collections

open MEF_Interface
// Set up catalog
let catalog = new AggregateCatalog()
let directoryCatalog = new DirectoryCatalog(@"c:\Extensions","*.dll")

let container = new CompositionContainer(catalog)
catalog.Catalogs.Add(directoryCatalog)

// Jar that will contain tasty treats
type TreatJar() =
    [<ImportMany(typeof<ITastyTreat>)>]
    let cookies : seq<ITastyTreat> = null

    member this.EatTreats() =
        cookies |> Seq.iter (fun tt -> printfn "Yum, it was a %s" tt.Description)

let jar = TreatJar()

// Build plugin from string
let fs = new FSharpCodeProvider()
let parameters = new CompilerParameters([|@"C:\Users\moloneymb\Documents\Visual Studio 2010\Projects\MEF\MEF Interface\bin\Debug\MEF_Interface.dll";"System.ComponentModel.Composition.dll";"System.Core.dll"|], "test.dll", true)
parameters.GenerateExecutable <- false
let m = "
namespace ChocolateCookie
open System.ComponentModel.Composition
open MEF_Interface

[<Export(typeof<ITastyTreat>)>]
type ChocolateCookie() =
    interface ITastyTreat with
        member this.Description = \"a delicious chocolate cookie\""

let result = fs.CompileAssemblyFromSource(parameters,m)
for e in result.Errors do System.Console.WriteLine(e.ToString())
for o in result.Output do System.Console.WriteLine(o)

// Copy plug-in to container path
File.Copy(@"C:\Users\moloneymb\Documents\Visual Studio 2010\Projects\MEF\MEF\bin\Debug\test.dll",@"c:\Extensions\test.dll")

// Wait for transfer
System.Console.ReadKey() |> ignore

// Refresh directory catalog to pick up the new plug-in
directoryCatalog.Refresh()

// Run plug-ins
container.ComposeParts(jar)
jar.EatTreats()

// Wait to close
System.Console.ReadKey() |> ignore

// Delete file so we can re-run this program later
File.Delete(@"c:\Extensions\test.dll")

I have recently been experimenting with combining Reactive X, WPF, and F# and have found the combination to be very palatable. I chose drag and drop as the test case because it is both non trivial and generally deeply stateful. The resulting Rx turns out to be one fifth the code of my original C#, much easier to read and has fewer errors.

Drag and Drop code:

    leftDown
        |> map (fun e1 -> (e1, mouseMove |> takeUntil leftUp |> takeUntil mouseLeave))
        |> filter (fun (e1, e2s) -> e1.Source.Equals(canvas) |> not)
        |> map (fun (e1, e2s) ->
                        let control = e1.Source :?> UIElement
                        let leftTop = (Canvas.GetLeft(control), Canvas.GetTop(control))
                        let pt1 = e1.GetPosition(canvas)
                        e2s |> map (fun e2 ->
                                        let pt2 = e2.GetPosition(canvas)
                                        (control, leftTop, pt2 - pt1)))
        |> mergeAll
        |> subscribe (fun (control, (left,top), delta) -> Canvas.SetLeft(control, left + delta.X); Canvas.SetTop(control, top + delta.Y))

As always, I am interested in feedback.

Cheers,

Matt

Full Code:

open System
open System.Linq
open System.Windows
open System.Windows.Input
open System.Windows.Controls
open System.Windows.Shapes
open System.Windows.Media
open System.Xaml
open System.IO
open System.Text
open System.Windows.Markup

let parseXAML (xaml : string) =
    use ms = new MemoryStream(Encoding.ASCII.GetBytes(xaml))
    ms.Position <- int64 0
    XamlReader.Load(ms)

// helper functions from Steffen Forkmann (http://www.navision-blog.de)
let asAction f = new System.Action(f)

let doNothing = asAction (fun () -> ())

let create f =
    Observable.Create<_>(fun x ->
        f x
        doNothing)

let fromEvent (event:IEvent<_,_>) = create (fun x -> event.Add x.OnNext)

let mergeAll (observables:IObservable<IObservable<'a>>) = Observable.Merge observables

let map f observable = Observable.Select(observable, Func<_,_>(f))

let takeUntil other source = Observable.TakeUntil(source,other)

let filter f observable = Observable.Where(observable, Func<_,_>(f))

let subscribeComplete next error completed (obs: IObservable<'a>) =
    obs.Subscribe(
        (fun x -> next x),
        (fun e -> error e),
        (fun () -> completed()))

let subscribeWithError next error obs =
    subscribeComplete next error (fun () -> ()) obs

let subscribe next obs =
    subscribeWithError next ignore obs

let window =
    let window =
        "<Window
            xmlns=\"http://schemas.microsoft.com/winfx/2006/xaml/presentation\"
            xmlns:x=\"http://schemas.microsoft.com/winfx/2006/xaml\"
            Title=\"Event Sample\" Height=\"200\" Width=\"200\">
        <Canvas x:Name=\"canvas\" Background=\"LightBlue\">
            <Rectangle Canvas.Left=\"50\" Canvas.Top=\"50\"  Fill=\"Red\" Height=\"50\" Width=\"50\" />
            <TextBlock Canvas.Left=\"50\" Canvas.Top=\"120\"   Text=\"Hello World!\" />
        </Canvas>
    </Window>" |> parseXAML :?> Window
    let canvas = window.FindName("canvas") :?> Canvas

    let leftDown = canvas.MouseLeftButtonDown  |> fromEvent
    let leftUp   = canvas.MouseLeftButtonUp    |> fromEvent
    let mouseMove = canvas.MouseMove           |> fromEvent
    let mouseLeave = canvas.MouseLeave         |> fromEvent

    leftDown
        |> map (fun e1 -> (e1, mouseMove |> takeUntil leftUp |> takeUntil mouseLeave))
        |> filter (fun (e1, e2s) -> e1.Source.Equals(canvas) |> not)
        |> map (fun (e1, e2s) ->
                        let control = e1.Source :?> UIElement
                        let leftTop = (Canvas.GetLeft(control), Canvas.GetTop(control))
                        let pt1 = e1.GetPosition(canvas)
                        e2s |> map (fun e2 ->
                                        let pt2 = e2.GetPosition(canvas)
                                        (control, leftTop, pt2 - pt1)))
        |> mergeAll
        |> subscribe (fun (control, (left,top), delta) -> Canvas.SetLeft(control, left + delta.X); Canvas.SetTop(control, top + delta.Y))
        |> ignore

    window

let main() =
    let app = new Application()
    app.Run(window) |> ignore

[<STAThread>]
    do main()

Quick test of the Azure WCF service

Azure now has support for input endpoints on Worker Roles! (Azure Tools Nov 2009) This is awesome as it greatly simplifies building WCF services in the cloud. David Aiken has written an excellent Channel 9 post on exactly how to do this (here).

As per usual, I’ve gone ahead and ported the most important components to F# and I have included a short list of some of the difficulties I had while doing so.

Lessons Learned;

1. In Azure, you cannot just specify the input endpoints in code, you have to specify the endpoints in the properties for the role. It will work in the Dev fabric but will not initialize in the cloud. (thanks to Daniel C Wang)

Wrong:

 let baseAddress = Uri("http://kapow.cloudapp.net:8080/service")
 let myServiceHost = new ServiceHost((typeof<GreetingService>), [|baseAddress|])

Right:

using Microsoft.WindowsAzure.SerivceRuntime;

var listenAddress = RoleEnvironment
    .CurrentInstance
    .InstanceEndpoint["<name of your input endpoint >"]
    .IPEndpoint;

string uri = String.Format("http://{0}" ,listenAddress)

2. TryGetValue can return the value in a 2-tuple instead of by ref – this makes it a lot more F# friendly. (from here)

This:

SessionInformation session;
bool exists = sessions.TryGetValue(sessionId, out session)

Becomes this:

let (exists,session) = sessions.TryGetValue(sessionId)

3. KnownTypes – By default, you cannot use a subclass of a data contract class instead of its base class. This took me a while to figure out. (From Programming WCF Services – O’Reilly)

In C#:

[DataContract]
[KnownType(typeof(Custoemr))]
class Contact
{..}

[DataContract]
Class Customer : Contact
{..}

4. You have to take down an Azure deployment in order to change the input endpoints, so no in place upgrades with new endpoints. The Dr. Watson error for this wasn’t very clear.

Things I still can’t figure out;

I am assuming that the ICommunicationObject interface is added by an attribute, I just can’t cast to it. I get an invalid cast error at runtime. I need to do this, so if anyone knows how, please let me know.

In C#:

((ICommunicationObject)client).Abort();

In F#: (from here)

(box client :?> ICommunicationObject).Abort()

The Code:

The contract:

namespace AzureTalk.Contract

open System
open System.Collections.Generic
open System.ServiceModel
open System.Runtime.Serialization

[<DataContract(Namespace = "urn:WindowsAzurePlatformKit:Labs:AzureTalk:2009:10:schemas")>]
[<KnownType(typeof<SessionInformation>)>]
type ClientInformation =
        [<DataMember>]
        val mutable SessionId : string

        [<DataMember>]
        val mutable UserName : string

        [<DataMember>]
        val mutable RoleId : string

        [<DataMember>]
        val mutable IsActive : bool

        new(sessionId, userName, roleId) =
            {
                SessionId = sessionId
                UserName = userName
                RoleId = roleId
                IsActive = true
            }

and [<DataContract(Namespace = "urn:WindowsAzurePlatformKit:Labs:AzureTalk:2009:10")>]
    SessionInformation =
    inherit ClientInformation

        [<IgnoreDataMember>]
        val mutable Callback : IClientNotification option

    new(sessionId, userName, roleId, isActive, callback) =
            {   inherit ClientInformation(sessionId, userName, roleId)
                Callback = callback
            }

and [<ServiceContract(Namespace = "urn:WindowsAzurePlatformKit:Labs:AzureTalk:2009:10" )>]
     IClientNotification =

    [<OperationContract(IsOneWay = true)>]
    abstract DeliverMessage : message:string -> fromSessionId:string -> toSessionId:string -> Unit

    [<OperationContract(IsOneWay = true)>]
    abstract UpdateClientList : clientInfo:ClientInformation -> Unit

[<ServiceContract(
    Namespace = "urn:WindowsAzurePlatformKit:Labs:AzureTalk:2009:10",
    CallbackContract = typeof<IClientNotification>,
    SessionMode = SessionMode.Required)>]
type IChatService =

    [<OperationContract(IsInitiating = true)>]
    abstract Register : userName:string -> ClientInformation

    [<OperationContract(IsInitiating = false)>]
    abstract SendMessage : message:string -> sessionId:string -> Unit

    [<OperationContract(IsInitiating = false)>]
    abstract GetConnectedClients : Unit -> IEnumerable<ClientInformation>

The server:

namespace WorkerRole1

open System
open System.Diagnostics
open System.Linq;
open System.Net;
open System.Threading
open Microsoft.WindowsAzure.Diagnostics
open Microsoft.WindowsAzure.ServiceRuntime
open System.Runtime.Serialization
open System.Collections.Generic
open System.ServiceModel
open AzureTalk.Contract

type internal SessionManager() =
    static let sessionLock = new ReaderWriterLockSlim()
    static let read (f:Unit->'a) =
        sessionLock.EnterReadLock()
        try
            f()
        finally
            sessionLock.ExitReadLock()
    static let write (f:Unit->'a) =
        sessionLock.EnterWriteLock()
        try
            f()
        finally
            sessionLock.ExitWriteLock()
    static let sessions = new Dictionary<string, SessionInformation>()

    static member TryGetSession(sessionId:string) =  read (fun() -> sessions.TryGetValue(sessionId))

    static member CreateOrUpdateSession (sessionId:string) (userName:string) (roleId:string) (callback:IClientNotification option) =
        write (fun() ->

                let (existingSession, session) = sessions.TryGetValue(sessionId)
                if (not existingSession) then
                    let session = SessionInformation(sessionId, userName, roleId, true, callback)
                    sessions.Add(sessionId, session)
                    (existingSession, session)
                else
                    session.SessionId <- sessionId
                    session.UserName  <- userName
                    session.RoleId    <- roleId
                    session.Callback  <- callback
                    session.IsActive  <- true
                    (existingSession, session))

    static member RemoveSession (sessionId:string) =
        write (fun() ->
                    let (exists,session) = sessions.TryGetValue(sessionId)
                    if (exists) then session.IsActive <- false; sessions.Remove(sessionId) |> ignore)

    static member GetActiveSessions() = (read (fun() -> sessions.Values |> Seq.filter (fun s -> s.IsActive))).ToArray()

///Implementation of the WCF chat service
[<ServiceBehavior(
    InstanceContextMode = InstanceContextMode.Single,
    ConcurrencyMode = ConcurrencyMode.Multiple,
#if DEBUG
    IncludeExceptionDetailInFaults = true,
#else
    IncludeExceptionDetailInFaults = false,
#endif
    AddressFilterMode = AddressFilterMode.Any)>]
type ChatService() =
    let log message kind = Trace.WriteLine(message, kind)

    member this.NotifyConnectedClients (clientInfo:ClientInformation) =
        SessionManager.GetActiveSessions()
        |> Array.iter (fun client ->
            try
                match client.Callback with
                | Some(callback)-> callback.UpdateClientList(clientInfo)
                | None -> ()

            with
            | :? TimeoutException as e ->
                log (sprintf "Unable to notify client '%s'. The service operation timed out. '%s'" client.UserName e.Message) "Error"
                //(box client :?> ICommunicationObject).Abort()
                client.Callback <- None

            | :? CommunicationException as e ->
                log (sprintf "Unable to notify client '%s'. There was a communication problem. '%s' - '%s'" client.UserName e.Message e.StackTrace) "Error"
                //(box client :?> ICommunicationObject).Abort()
                client.Callback <- None)

    interface IClientNotification with

        member this.DeliverMessage message fromSessionId toSessionId =
            let (fromExists,fromSession)= SessionManager.TryGetSession(fromSessionId)
            let (toExists, toSession) = SessionManager.TryGetSession(toSessionId)
            if (fromExists && toExists) then
                match toSession.Callback with
                | Some(callback) ->
                    callback.DeliverMessage message fromSessionId toSessionId
                    log (sprintf "Message '%s' send from '%s' to '%s'." message fromSession.UserName toSession.UserName) "Information"
                |  None -> ()

        member this.UpdateClientList clientInfo =
            if clientInfo.IsActive
            then
                let (created, session) = SessionManager.CreateOrUpdateSession clientInfo.SessionId clientInfo.UserName clientInfo.RoleId None
                if created then log (sprintf "Remote session '%s' by user '%s' has been opened in role '%s'." session.SessionId session.UserName session.RoleId) "Information"
            else
                SessionManager.RemoveSession(clientInfo.SessionId)
                log (sprintf "Remote session '%s' by user '%s' has been opened in role '%s'." clientInfo.SessionId clientInfo.UserName clientInfo.RoleId) "Information"
            this.NotifyConnectedClients clientInfo

    interface IChatService with
        member this.Register userName =
            let roleId = RoleEnvironment.CurrentRoleInstance.Id
            let sessionId = OperationContext.Current.SessionId
            let callback = OperationContext.Current.GetCallbackChannel<IClientNotification>()

            let (existing, session) = SessionManager.CreateOrUpdateSession sessionId userName roleId (Some(callback))
            if (not existing)
                then
                    OperationContext.Current.Channel.Closed.Add(fun e ->
                        SessionManager.RemoveSession sessionId
                        this.NotifyConnectedClients session
                        log  (sprintf "Session '%s' by user '%s' has been closed in role '%s'." sessionId userName roleId)  "Information")
                    log (sprintf "Session '%s' by user '%s' has been opened in role '%s'." sessionId userName roleId) "Information"

            this.NotifyConnectedClients session
            ClientInformation(sessionId, userName, roleId)

        member this.SendMessage message sessionId =
            let fromSessionId = OperationContext.Current.SessionId
            (this :> IClientNotification).DeliverMessage message fromSessionId sessionId

        member this.GetConnectedClients() =
            (SessionManager.GetActiveSessions()
            |> Seq.map (fun session -> ClientInformation(session.SessionId, session.UserName, session.RoleId)))

type WorkerRole() =
    inherit RoleEntryPoint()

    let log message kind = Trace.WriteLine(message, kind)

    let rec startChatService (retries:int) =
        if (retries = 0)
            then
                RoleEnvironment.RequestRecycle();
            else
                log "Start chat service host..." "Information"

                let serviceHost = new ServiceHost(typeof<ChatService>)

                serviceHost.Faulted.Add(fun e ->
                    log (String.Format("Host fault occured. Aborting and restartign the host. Retry count: {0}", retries)) "Error"
                    serviceHost.Abort()
                    startChatService(retries - 1))

                let binding = new NetTcpBinding(SecurityMode.None)

                let externalEndPoint = RoleEnvironment.CurrentRoleInstance.InstanceEndpoints.["ChatService"]

                serviceHost.AddServiceEndpoint(typeof<IChatService>, binding, (String.Format("net.tcp://{0}/ChatService", externalEndPoint.IPEndpoint))) |> ignore

                try
                    serviceHost.Open()
                    log "Chat service host started successfully." "Information"
                with
                | :? TimeoutException as timeoutException -> log (sprintf "The service operation timed out. %s" timeoutException.Message) "Error"
                | :? CommunicationException as communicationException -> log (sprintf "The service operation timed out.  %s" communicationException.Message) "Error"

    override wr.Run() =

        log "Worker Process entry point called" "Information"

        startChatService 3

        while(true) do
            Thread.Sleep(300000)
            log "Working" "Information"

    override wr.OnStart() =

        // Set the maximum number of concurrent connections
        ServicePointManager.DefaultConnectionLimit <- 12

        DiagnosticMonitor.Start("DiagnosticsConnectionString") |> ignore

        // For information on handling configuration changes
        // see the MSDN topic at http://go.microsoft.com/fwlink/?LinkId=166357.
        RoleEnvironment.Changing.Add(fun e ->
            // If a configuration setting is changing
            if e.Changes |> Seq.exists (fun change -> change :? RoleEnvironmentConfigurationSettingChange) then
                // Set e.Cancel to true to restart this role instance
                e.Cancel <- true)

        base.OnStart()

The client:

module AzureClient.Client

open System
open System.Collections.Generic
open System.ServiceModel
open System.Runtime.Serialization
open System.Windows
open System.Threading
open AzureTalk.Contract

type IChatServiceChannel =
    interface IChatService
    interface IClientChannel

type ClientErrorEventArgs() =
    inherit EventArgs()

    let mutable message = ""
    let mutable cancel = false

    member this.Message with get() = message and set(x:string) = message <- x
    member this.Cancel with get() = cancel and set(x:bool) = cancel <- cancel

type ChatClient(callbackObject:IClientNotification,endpoint:string) as this =
    let binding = new NetTcpBinding(SecurityMode.None, false)
    let factory = new DuplexChannelFactory<IChatServiceChannel>(callbackObject, binding, endpoint)
    let error = new Event<ChatClient*ClientErrorEventArgs>()
    let onError message = error.Trigger(this, new ClientErrorEventArgs(Message = message, Cancel = false))

    let mutable _channel = None

    member this.Error = error.Publish

    member this.Channel
        with get() =
            let getChannel() =
                let channel = factory.CreateChannel()
                channel.Faulted.AddHandler(EventHandler(fun sender e ->
                    channel.Abort()
                    _channel <- None
                    System.Windows.MessageBox.Show("Channel Faulted") |> ignore
                ))
                channel
            let channel =
                match _channel with
                | None -> getChannel()
                | Some(x:IChatServiceChannel) when x.State = CommunicationState.Faulted -> getChannel()
                | Some(x:IChatServiceChannel) -> x
            _channel <- Some(channel)
            channel

    member this.Close() =
        try
            match _channel with | None -> () | Some(x:IChatServiceChannel) -> x.Close()
        with
        | :? TimeoutException as e -> this.Channel.Abort()
        | :? CommunicationException as e -> this.Channel.Abort()

    interface IChatService with
        member this.Register userName = this.Channel.Register(userName)
        member this.SendMessage message toUserName = this.Channel.SendMessage message toUserName
        member this.GetConnectedClients() = this.Channel.GetConnectedClients()

type Client() as this =
    let mutable userList = Seq.empty<ClientInformation>
    let endpoint = "net.tcp://localhost:3030/ChatService"
    let chatClient = new ChatClient(this,endpoint)
    let context = SynchronizationContext()
    let sync(f:obj->unit) = context.Post(SendOrPostCallback(f), null)
    let showMsg msg = System.Windows.MessageBox.Show(msg) |> ignore
    let showErr err = System.Windows.MessageBox.Show(err) |> ignore
    do
        chatClient.Error.AddHandler(fun _ (_,ea) ->  showMsg ea.Message)

    interface IClientNotification with
        member this.DeliverMessage message fromSessionId toSessionId =
            sync(fun state ->
                match (userList |> Seq.tryFind(fun userInfo -> userInfo.SessionId = fromSessionId)) with
                | Some(fromSession) -> showMsg (sprintf @"Message: %s \n From: %s" message fromSession.UserName)
                | None -> showErr (sprintf "A message was received from an unknown sender. The session ID '%s' is not registered." fromSessionId)
                )

        member this.UpdateClientList(session) =
            sync(fun state ->
                match (userList |> Seq.tryFind(fun userInfo -> userInfo.SessionId = session.SessionId)) with
                | Some(client) ->

                    if session.IsActive
                    then
                        client.UserName <- session.UserName
                        client.RoleId <- session.RoleId
                    else
                        userList <- userList |>  Seq.filter(fun u -> u = client)
                        showMsg (sprintf "User '%s' has left the chat." client.UserName)
                | None ->
                    if session.IsActive
                    then
                        userList <- Seq.append ([session] |> List.toSeq) userList
                        showMsg (sprintf "User '%s' has joined the chat." session.UserName)
                )
    member this.Register userName = chatClient.Channel.Register(userName)

    member this.SendMessage message toSessionId = chatClient.Channel.SendMessage message toSessionId

    member this.GetConnectedClients() = chatClient.Channel.GetConnectedClients()

let client = new Client()
let clientInformation = client.Register "Matt"

client.GetConnectedClients() |> Seq.iter(fun c -> client.SendMessage "Hello from Matt" c.SessionId)

Console.Read() |> ignore

The video demonstrates a server and two clients collaborating on the same machine.

The way it works is that there are two different roles, the server (EchoServer) and the client (EchoClient). The role of the server is to act as repeater between the clients. When one client inputs source code the code is automatically sent to all the other clients. The server stores the code so when a new client joins it can be brought up to speed with all of the other clients.

This has the following advantages;

• Everyone is on the same page with the latest version of the software
• All developers work with the very latest source code
• The source code is continuously integrated in real time
• ‘Build’ breaks are noticed (and fixed) immediately

There are also a number of disadvantages;

• Cannot undo certain operations with side effects
• Code from the network is being downloaded and run on your machine
• The entire source code is a stored as single string

The reason I am playing with this is prepare for my next move into Domain Specific Modeling tools.

I’ve included the source code below. It is prototype code, so there are probably a few bugs in it, and as always feedback is greatly appreciated.

EchoServer

#light

open System
open System.IO
open System.Text
open System.Net
open System.Net.Sockets
open System.Threading
open System.Diagnostics
open System.Runtime.Serialization;
open System.Runtime.Serialization.Formatters.Binary;

// Connection settings
// Arguments IP address, and Port number
// e.g. 127.0.0.1 9050
let IPaddr = IPAddress.Loopback
let PortNo = 9050
let mutable filename = "log.txt"

// Helper functions
let wrapEvent (fBlock:unit->'a) =
    let event = new Event<'a>()
    let eventThread = new Thread(fun () ->  while true do event.Trigger((fBlock())))
    do eventThread.Start()
    event.Publish

let write s = printf "%s\n" s
let read() = System.Console.ReadLine()

// Networking functions
// types of messages, message error / disconnect = -1, connect = 0, command = 1
type Message = int * obj
type Client = string*(Message->unit)*(unit->Message)*NetworkStream

let mutable code = ""

let clients = new ResizeArray<Client>()

let getByteArray (o:obj) =
    use ms = new MemoryStream()
    let bf = new BinaryFormatter()
    bf.Serialize(ms,o)
    ms.ToArray()

let getObject (ba:byte array) =
    use ms = new MemoryStream(ba)
    let bf = new BinaryFormatter()
    ms.Position <- int64 0;
    bf.Deserialize(ms)

let sendVarData (stream:NetworkStream) (data:byte array) =
    let datasize = BitConverter.GetBytes(int32 data.Length)
    stream.Write(datasize, 0, 4)
    stream.Write(data, 0, data.Length)
    stream.Flush()

// There has to be a much better way? :)
let receiveVarData (stream:NetworkStream) =
    let mutable total = 0
    let mutable recv = 0
    let datasize = [|for n in 0..4 -> byte 0 |] // anyone have a better idea on how to do this?
    stream.Read(datasize, 0, 4) |> ignore
    let size = BitConverter.ToInt32(datasize,0)
    let mutable dataleft = size;
    let mutable data = [|for n in 0..size -> byte 0 |] // anyone have a better idea on how to do this?
    let mutable flag = false
    while total < size && not flag do
        recv <- stream.Read(data, total, dataleft)
        if (recv = 0) then
            data <- Encoding.ASCII.GetBytes("exit ")
            flag <- true
        total <- total + recv
        dataleft <- dataleft - recv
    data

let tcpListen ip portNo =
    try
        let tcp = new TcpListener(IPaddr, PortNo)
        tcp.Start()
        let conRecv = wrapEvent(fun () -> tcp.AcceptTcpClient())
        write "Awaiting connections"
        conRecv
    with
    | e -> write ("Unable to create TcpListener " + e.Message)
           exit 1

let server = tcpListen IPaddr PortNo

let clientHandler (client:TcpClient) =
    let ipaddr = client.Client.RemoteEndPoint.ToString()
    let ns = client.GetStream()
    let send(msg:Message) = try (sendVarData ns (getByteArray msg)) with | _ -> ()
    let recv()  =  try (getObject (receiveVarData ns)) :?> Message with | _ -> (-1,null)
    clients.Add(ipaddr, send, recv, ns)
    write ("New Connection from: " + ipaddr)
    let recvMsg = wrapEvent (fun () ->
        let (i,o) = recv()
        if i = -1 then
            clients.Remove(ipaddr,send,recv,ns) |> ignore
            write (ipaddr.ToString() + " has disconnected")
            Thread.CurrentThread.Abort()
        (i,o))
    recvMsg.Add(fun (msg) ->
        let (i,o) = msg
        match i with
        | 0 -> send(1,code + "\n;;") // start msg received - send everything
        | 1 ->
            write ((string o) + "\n")
            let str = "\n\n" + string o
            code <- code + str
            for (_,send,_,_)  in clients do send(1,o)  // echo command to all clients
        | _ -> write "Unhandled message received")

server.Add(fun (client) -> clientHandler client)

let readUrl (url:string) =
    try
        use sr = new StreamReader(WebRequest.Create(url).GetResponse().GetResponseStream())
        code <- sr.ReadToEnd()
        write ("Loaded " + url)
        // send uploaded code to clients
        for (_,send,_,_)  in clients do send(1,code)
    with
    | e -> write (sprintf "Unable to open url %s Error: %s" url e.Message )
let readFile filename =
    if File.Exists filename then
        try
           code <- File.ReadAllText(filename)
           write ("Loaded " + filename)
           // send uploaded code to clients
           for (_,send,_,_)  in clients do send(1,code)
        with
        | e -> write (sprintf "Unable to open file %s Error: %s" filename e.Message )
    else write ("File not found:" + filename)
let writeFile filename =
    try
        File.WriteAllText(filename, code)
        write ("Loading " + filename)
    with
    | e -> write (sprintf "Unable to write to file %s Error: %s"  filename  e.Message)
// Console
let inHandler cmd =
    match cmd with
    | "reset" ->  code <- ""; write "Reseting code"
    | (s:string) when (s.Split [|' '|]).[0] = "load" ->
        let ss = s.Split [|' '|]
        match ss.Length with
        | 1 -> readFile filename
        | 2 -> readFile ss.[1]
        | _ -> write "Incorrect usage of the load command"
    | (s:string) when (s.Split [|' '|]).[0] = "loadUrl" ->
        let ss = s.Split [|' '|]
        match ss.Length with
        | 2 -> readUrl ss.[1]
        | _ -> write "Incorrect usage of the loadUrl command"
    | (s:string) when (s.Split [|' '|]).[0] = "save" ->
        let ss = s.Split [|' '|]
        match ss.Length with
        | 1 -> writeFile filename
        | 2 -> writeFile ss.[1]
        | _ -> write "Incorrect usage of the save command"
    | "quit" -> exit 0
    | _ -> write "Command Not Found"

let cnslReadLine = wrapEvent(fun () -> System.Console.ReadLine())
cnslReadLine.Add(inHandler)

// Load up the space scene program
//readUrl "http://www.mattssoftwareblog.com/software/3DWPF/SpaceScene.txt"

EchoClient

#light

open System
open System.IO
open System.Text
open System.Net
open System.Net.Sockets
open System.Threading
open System.Diagnostics
open System.Runtime.Serialization;
open System.Runtime.Serialization.Formatters.Binary;
open System.Windows
open System.Windows.Markup
open System.Windows.Controls
open System.Xaml
open System.Xml

// Connection settings
// Arguments IP address, and Port number
// e.g. 127.0.0.1 9050
let IPaddr = IPAddress.Loopback
let PortNo = 9050
let FSharpDir = @"C:\Program Files (x86)\Microsoft F#\v4.0\"

// Helper functions
let wrapEvent (fBlock:unit->'a) =
    let event = new Event<'a>()
    let eventThread = new Thread(fun () ->  while true do event.Trigger((fBlock())))
    do eventThread.Start()
    event.Publish

let dispatch<'T when 'T :> Control> (f:'T -> Unit) (control:'T) =
    if (control.CheckAccess()) then f control
    else control.Dispatcher.Invoke(System.Windows.Threading.DispatcherPriority.Background, Action (fun () -> f(control))) |> ignore

type ProcessShell(psi:ProcessStartInfo)  =
    let proc = Process.Start(psi)
    let outEvent = wrapEvent (fun () -> proc.StandardOutput.ReadLine() + "\n")
    let errEvent = wrapEvent (fun () -> proc.StandardError.ReadLine() + "\n")
    member this.Output = outEvent
    member this.Error = errEvent
    member this.Input(s:string) =
        proc.StandardInput.WriteLine(s)
        proc.StandardInput.Flush()

let psi() file wd args =
    let tmp = new ProcessStartInfo()
    tmp.UseShellExecute <- false
    tmp.FileName <- file
    tmp.WorkingDirectory <- wd
    tmp.CreateNoWindow <- true
    tmp.RedirectStandardError <- true
    tmp.RedirectStandardInput <- true
    tmp.RedirectStandardOutput <- true
    tmp.Arguments <- args
    tmp

// types of messages, message error / disconnect = -1, connect = 0, command = 1
type Message = int * obj

let write (s:string) = System.Console.WriteLine(s)
let read() = System.Console.ReadLine()

let connect(ip:IPAddress, p:int) =
    let getByteArray (o:obj) =
        use ms = new MemoryStream()
        let bf = new BinaryFormatter()
        bf.Serialize(ms,o)
        ms.ToArray()

    let getObject (ba:byte array) =
        use ms = new MemoryStream(ba)
        let bf = new BinaryFormatter()
        ms.Position <- int64 0;
        bf.Deserialize(ms)

    let sendVarData (stream:NetworkStream) (data:byte array) =
        let datasize = BitConverter.GetBytes(int32 data.Length)
        stream.Write(datasize, 0, 4)
        stream.Write(data, 0, data.Length)
        stream.Flush()

    let receiveVarData (stream:NetworkStream) =
        let mutable total = 0
        let mutable recv = 0
        let datasize = [|for n in 0..4 -> byte 0 |]
        stream.Read(datasize, 0, 4) |> ignore
        let size = BitConverter.ToInt32(datasize,0)
        let mutable dataleft = size;
        let mutable data = [|for n in 0..size -> byte 0 |]
        let mutable flag = false
        while total < size && not flag do
            recv <- stream.Read(data, total, dataleft)
            if (recv = 0) then
                data <- Encoding.ASCII.GetBytes("exit ")
                flag <- true
            total <- total + recv
            dataleft <- dataleft - recv
        data

    let tc = new TcpClient()
    tc.Connect(ip,p)
    let ns = tc.GetStream()
    let send(msg:Message) = try (sendVarData ns (getByteArray msg)) with | _ -> ()
    let recv()  =  try (getObject (receiveVarData ns)) :?> Message with | _ -> (-1,null)
    (send, recv, ns)

// attempt connection
let (send:int*obj->unit , recv, stream) =
    try
        let tmp = connect(IPaddr, PortNo)
        tmp
    with
    | e ->  write (sprintf "Unable to connect to server %s, %i : %s" (IPaddr.ToString()) PortNo  e.Message)
            exit 1

let parseXAML (xaml : string) =
    use ms = new MemoryStream(Encoding.ASCII.GetBytes(xaml))
    ms.Position <- int64 0
    XamlReader.Load(ms)

let windowXaml =
    "<Window
        xmlns=\"http://schemas.microsoft.com/winfx/2006/xaml/presentation\"
        xmlns:x=\"http://schemas.microsoft.com/winfx/2006/xaml\"
        Title=\"EchoClient\" Height=\"400\" Width=\"512\">
    <Window.Resources>
        <Style x:Key=\"ConsoleTextBoxStyle\" TargetType=\"{x:Type TextBox}\">
            <Setter Property=\"TextBox.Background\" Value=\"Black\" />
            <Setter Property=\"TextBox.Foreground\" Value=\"White\" />
            <Setter Property=\"TextBox.VerticalScrollBarVisibility\" Value=\"Auto\" />
            <Setter Property=\"TextBox.TextWrapping\" Value=\"Wrap\" />
            <Setter Property=\"TextBox.FontFamily\" Value=\"Lucida Console\" />
            <Setter Property=\"TextBox.FontSize\" Value=\"10\" />
        </Style>
    </Window.Resources>
    <Grid>
        <Grid.RowDefinitions>
            <RowDefinition />
            <RowDefinition Height=\"4\"/>
            <RowDefinition Height=\"50\"/>
        </Grid.RowDefinitions>
        <TabControl Grid.Row=\"0\">
            <TabItem Header=\"Code\">
                <ScrollViewer>
                    <TextBox x:Name=\"code_TextBox\" IsReadOnly=\"True\" Style=\"{StaticResource ConsoleTextBoxStyle}\" />
                </ScrollViewer>
            </TabItem>
            <TabItem Header=\"Output\">
                <ScrollViewer>
                    <TextBox x:Name=\"output_TextBox\" IsReadOnly=\"True\" Style=\"{StaticResource ConsoleTextBoxStyle}\" />
                </ScrollViewer>
            </TabItem>
            <TabItem Header=\"Error\">
                <ScrollViewer>
                    <TextBox x:Name=\"error_TextBox\" IsReadOnly=\"True\" Style=\"{StaticResource ConsoleTextBoxStyle}\" />
                </ScrollViewer>
            </TabItem>
        </TabControl>
        <GridSplitter Grid.Row=\"1\" HorizontalAlignment=\"Stretch\" />
        <DockPanel Grid.Row=\"2\">
            <Button DockPanel.Dock=\"Right\" Name=\"send_Button\">_Send</Button>
            <ScrollViewer DockPanel.Dock=\"Left\" HorizontalScrollBarVisibility=\"Auto\" VerticalScrollBarVisibility=\"Auto\">
                <TextBox x:Name=\"inputCode_TextBox\" Style=\"{StaticResource ConsoleTextBoxStyle}\" AcceptsReturn=\"True\"/>
            </ScrollViewer>
        </DockPanel>
    </Grid>
</Window>"

let window = windowXaml |> parseXAML :?> Window
let send_Button = window.FindName("send_Button") :?> Button
let inputCode_TextBox = window.FindName("inputCode_TextBox") :?> TextBox
let code_TextBox = window.FindName("code_TextBox") :?> TextBox
let output_TextBox = window.FindName("output_TextBox") :?> TextBox
let error_TextBox = window.FindName("error_TextBox") :?> TextBox
send_Button.Click.Add(fun re -> send(1,inputCode_TextBox.Text + "\n;;"))

// Close stream and console when window is closed
window.Closed.Add(fun _ -> stream.Close(); exit 0)

// start up fsi
let fsi = ProcessShell((psi() (FSharpDir + "fsi.exe") FSharpDir ""))
// Console out
fsi.Output.Add(fun (s) -> write s)
fsi.Error.Add(fun (s) -> write s)
// GUI out
fsi.Output.Add(fun (s) -> output_TextBox |> dispatch (fun output_TextBox -> output_TextBox.Text <- output_TextBox.Text + s))
fsi.Error.Add(fun (s) -> error_TextBox |> dispatch (fun error_TextBox -> error_TextBox.Text <- error_TextBox.Text + s))

// Callback incomming messages
let msgRecvEvnt = wrapEvent(fun () ->
        let (i,o) = recv()
        if i = -1 then
            write "Disconnected from server"
            Thread.CurrentThread.Abort()
        (i,o))

// Console out, FSI in
msgRecvEvnt.Add(fun (i,o) -> match i with | 1 ->  fsi.Input (string o); write (string o) | _ -> write "Unrecognised message received")
// Gui out
msgRecvEvnt.Add(fun (i,o) ->
                    match i with
                    | 1 -> code_TextBox |> dispatch (fun code_TextBox -> code_TextBox.Text <- code_TextBox.Text + (string o))
                    | _ -> ())

// connect, and send IP address
send(0,IPaddr)

// run the application
let main() =
    let app = new Application()
    app.Run(window) |> ignore

[<STAThread>]
do main()

#r "System.Core"

open System
open System.Collections.Generic
open System.Linq
open System.Text
open System.Data.SqlClient
open System.Data

// Provide the following information
let userName = "<ProvideUserName>"
let password = "<ProvidePassword>"
let dataSource= "<ProvideServerName>"
let sampleDatabaseName = "<ProvideDatabaseName>"

let sendToCommand() (command:SqlCommand) query =
    command.CommandText <- query
    command.ExecuteNonQuery()

// create the sample database
let createDatabase (command:SqlCommand) =
    (String.Format("CREATE DATABASE {0}", sampleDatabaseName)) |> sendToCommand() command |> ignore

// perform various operations
let modifyDatabase (command:SqlCommand) =
    let send() = sendToCommand() command
    // Create a table
    "CREATE TABLE T1(Col1 int primary key, Col2 varchar(20))" |> send() |> ignore

    // Insert sample records
    let rowsAdded = "INSERT INTO T1 (col1, col2) values (1, 'string 1'), (2, 'string 2'), (3, 'string 3')" |> send()

    // Query the table and print the results
    let readCols() =
        command.CommandText <- "SELECT * FROM T1"
        use reader = command.ExecuteReader()
        // Loop over the results
        while reader.Read() do
            Console.WriteLine("Col1: {0}, Col2: {1}", reader.["Col1"].ToString().Trim(), reader.["Col2"].ToString().Trim())

    // Query the table and print the results
    readCols()

    // Update a record
    "UPDATE T1 SET Col2='string 1111' WHERE Col1=1" |> send() |> ignore

    //Delete a record
    "DELETE FROM T1 WHERE Col1=2" |> send() |> ignore

    Console.WriteLine("\nAfter update/delete the table has these records...")

    // Query the table and print the results
    readCols()

let sqlBuild initialCatalog =
    new SqlConnectionStringBuilder(
         DataSource = dataSource,
         InitialCatalog = initialCatalog,
         Encrypt = true,
         TrustServerCertificate = false,
         UserID = userName,
         Password = password
    )

let runQuery stringBuilder func =
    use conn = new SqlConnection(stringBuilder.ToString())
    use command = conn.CreateCommand()
    conn.Open()
    func(command)
    conn.Close()

// Create a connection string for the master database, connect to the master database and create the sample database
createDatabase |> ("master" |> sqlBuild |> runQuery)
// Create a connection string for the sample database, connect to the sample database and perform various operations
modifyDatabase |> (sampleDatabaseName |> sqlBuild |> runQuery)

I have done my best to attribute sources, and as always feedback is very much appreciated. Also, I will be updating my code viewer as soon as possible to stop it from embedding html smiley faces.

1. Data Templates

Unfortunately the only way to build Data Templates in code is being deprecated, which means we have to resort to writing Data Templates in XAML as a string. This string is then loaded using XamlReader as per the following code.

let loadFromString xaml =
    use sr = new StringReader(xaml)
    use xr = XmlReader.Create(sr)
    XamlReader.Load xr

Steve Horsfeild has a good write up on this here

2. Attached Dependency Properties

For ages I tried to  figure out why my attached properties were not showing up in the XAML intellisense. It turns out that I was missing the Get and Set functions for the property, as per below;

    static let useHoverProperty =
                    DependencyProperty.RegisterAttached(
                     "UseHover", typeof<bool>, typeof<HoverInteractor>)

    static member public SetUseHover(d:DependencyObject, _use:bool) = d.SetValue(useHoverProperty, _use)
    static member public GetUseHover(d:DependencyObject) = d.GetValue(useHoverProperty) :?> bool

3. Using options instead of Null

I use this when a attribute is begin set at runtime and I know that no function will call the attribute until after it has been set. (from here)

“Nullable” member

    static let mutable draggedElt = None

    static member private DraggedElt
        with get() = match draggedElt with | Some(v) -> v | _ -> failwith "initialization fail"
        and set(x:UIElement) = draggedElt <- Some(x)

Check for “null”:

match scrollOwner with
| Some(v) -> v.InvalidateScrollInfo()
| None -> ()

From here

4. Removing event handlers

let rec eventHandler = EventHandler(fun o e ->

    // Hide the Viewport
    this.viewport.Visibility <- Visibility.Hidden
    Panel.SetZIndex(this.backChildContainer, 0)

    // Show the FrontChild
    this.frontChildContainer.Visibility <- Visibility.Visible
    dockAnim.Completed.RemoveHandler(eventHandler)
    )

However, sometimes you can’t keep a reference to the delegate instance. Fortunately you don’t have to. The following code works as the object passed into Remove() must match the associated signature, but not necessarily the actual delegate instance you wish to remove. (Apress: Pro C# 2008 and the .Net 3.5 Platform)

    override this.StartListening(source:obj) =
        let evtSource = source :?> DataSource
        evtSource.DataChanged.AddHandler(Handler<EventArgs>(this.PrivateOnDataChanged))

    override this.StopListening(source:obj) =
        let evtSource = source :?> DataSource
        evtSource.DataChanged.RemoveHandler(Handler<EventArgs>(this.PrivateOnDataChanged))

4. Property changed events

This is pretty straight forward (from here)

let propertyChanged = Event<_,_>()
let notify obj s = propertyChanged.Trigger(obj, PropertyChangedEventArgs(s))

interface INotifyPropertyChanged with
    [<CLIEvent>]
    member this.PropertyChanged = propertyChanged.Publish

6. Runtime casting:

The following is the equivilent for using as (C# keyword), and then checking for Null. (from here)

   match b1 with
   | :? Derived1 as derived1 -> derived1.F()
   | _ -> ()

Other bits and pieces;

• Accessing members in interfaces. It is a little odd but you have to cast the object to the interface type before you can call on the interface member: “(mark :> CouchDBDocument).DocType” (from here)

• Pass ‘by ref’ into a function can be done by using the prefix ‘&” operator on a mutable (from here)

let mutable x = 1
if d.TryGetValue("foo", &x) then...
 

• PropertyPath wouldn’t work with a string, it requires the actual property “PropertyPath(UIElement.OpacityProperty)”  (from here)

Screen Shot

It is a translation of SAMS WPF Control Development Unleashed: Building Advanced User Interfaces written by Pavan Podila, and Kevin Hoffman to F#. I picked this book for translation as it covers many advanced topics that other books shy away from. I have been a reader of Pavan Podila’s blog Pixel in Gene for some time, and I have also been waiting for a book dedicated advanced UIs, so when I heard that he was coming out with such a book I knew it was going to be exactly what I needed.

WPF Control Development

The aim behind this project is to serve as an extensive collection non trivial examples of WPF/F# UI. As I introduce people to F#, one thing I am constantly  asked is; can it do GUI. Now I can say yes, … well sort of. So far I have only translated 3,500 lines of F# code, and I am still not finished.

I’m doing this primarily as a learning experience and as a forcing function. I have already learned a lot about WPF and F#, and I plan on continuously improving the code as I learn more. Other contributions to the project would be very welcome, and if you spot mistakes or know of any better implementations please don’t hesitate to let me know.

I hope that you find this code to be useful to your WPF and F# projects , and happy coding.

-Matt

Read on for a list of known bugs;

A recent upgrade from VSTS 2010 Beta 1 to VSTS 2010 Beta 2 has unfortunately caused a whole lot of new  bugs (on top of the ones that were already there).

List of known bugs:

• Chapter 2 – Media element doesn’t play
• Chapter 9  - TransitionContainer (delegate blocked off from TransitionTester_Loaded)
• Chapter 10 – ComponentResourceKey ?? Not sure what is happening here
• Chapter 10 – Custom Chrome Window, no skin on window
• Chapter 11 – GardenViewPanel3D and Interactive GardenViewPanel3D both register the same names (they work individually)
• Chapter 12 – Issues with enums for 3D mesh
• Chapter 13 – Dependency properties for SqueezeEffect and DisplacementEffect overlap? “Input’ property was already registered by ‘DisplacementEffect’”
• Chapter 14 – WeekEvent / Command Source (Property SpikeControl.Command not found)
• Chapter 15 – Media element doesn’t play
• Chapter 17 – Cannot find the static member ‘WatermakrTextProperty’ on the type ‘TextBoxWatermarkHelper’
• Chapter 18 – ComputedStartOffsetProperty on type RangeSelector

1. XML documents are printed out as a sequence of sequences
2. Printing out XML as text leaves it unformatted, i.e. the whole document is spread out on a single line

To fix this I put together the following function;

#r "System.Xml"

open System.IO
open System.Xml
open System.Text

fsi.AddPrinter(fun (xml : System.Xml.XmlNode) ->
    use ms = new MemoryStream()
    use w = new XmlTextWriter(ms, Encoding.Unicode)
    w.Formatting <- Formatting.Indented
    xml.WriteContentTo(w)
    w.Flush()
    ms.Flush()
    ms.Position <- int64 0
    use sr = new StreamReader(ms)
    sr.ReadToEnd())

My initial expectation was that there would be a library function for nicely formatting XML. If there is and I haven’t found it, or if anyone knows of a better way to do this, please let me know.

Cheers,

Matt