воскресенье, 7 ноября 2010 г.

(null : string).GetEnumerator() ?

Little quiz, guess what will be the result of the code below:

((string)null).GetEnumerator(); //C#

Obvious, isn’t it? And what about this?

(null : string).GetEnumerator() //F#

Expecting NullReferenceException? Well, time for little dissapointment, because this code will be compiled and executed without any errors. How can this happen, we expicitly invoke method with null instance and haven’t received any complains? Does it mean that this  will be null inside the instance method? Prepare to be astonished – yes.

[<AllowNullLiteral>]
type MyClass() =
member this.IsThisNull() = (box this) = null

let b : MyClass = null
printfn "%b" (b.IsThisNull())
(*
true
*)

To find out the reason, let’s decompile result assembly and have a look to its internals:

// C# representation
public static void main@()
{
fp@1 = new PrintfFormat<FSharpFunc<bool, Unit>, TextWriter, Unit, Unit, bool>("%b");
PrintfModule.PrintFormatLineToTextWriter<FSharpFunc<bool, Unit>>(Console.Out, Program.fp@1).Invoke(null.IsThisNull());
}

Haven’’t got new clues, maybe IL representation will be more descriptive:

.method public static void main@() cil managed
{
.entrypoint
.maxstack 4
L_0000: nop
L_0001: nop
L_0002: ldstr "%b"
L_0007: newobj instance void [FSharp.Core]Microsoft.FSharp.Core.PrintfFormat`5<class [FSharp.Core]Microsoft.FSharp.Core.FSharpFunc`2<bool, class [FSharp.Core]Microsoft.FSharp.Core.Unit>, class [mscorlib]System.IO.TextWriter, class [FSharp.Core]Microsoft.FSharp.Core.Unit, class [FSharp.Core]Microsoft.FSharp.Core.Unit, bool>::.ctor(string)
L_000c: stsfld class [FSharp.Core]Microsoft.FSharp.Core.PrintfFormat`4<class [FSharp.Core]Microsoft.FSharp.Core.FSharpFunc`2<bool, class [FSharp.Core]Microsoft.FSharp.Core.Unit>, class [mscorlib]System.IO.TextWriter, class [FSharp.Core]Microsoft.FSharp.Core.Unit, class [FSharp.Core]Microsoft.FSharp.Core.Unit> <StartupCode$ConsoleApplication4>.$Program::fp@1
L_0011: call class [mscorlib]System.IO.TextWriter [mscorlib]System.Console::get_Out()
L_0016: call class [FSharp.Core]Microsoft.FSharp.Core.PrintfFormat`4<class [FSharp.Core]Microsoft.FSharp.Core.FSharpFunc`2<bool, class [FSharp.Core]Microsoft.FSharp.Core.Unit>, class [mscorlib]System.IO.TextWriter, class [FSharp.Core]Microsoft.FSharp.Core.Unit, class [FSharp.Core]Microsoft.FSharp.Core.Unit> Program::get_fp@1()
L_001b: call !!0 [FSharp.Core]Microsoft.FSharp.Core.PrintfModule::PrintFormatLineToTextWriter<class [FSharp.Core]Microsoft.FSharp.Core.FSharpFunc`2<bool, class [FSharp.Core]Microsoft.FSharp.Core.Unit>>(class [mscorlib]System.IO.TextWriter, class [FSharp.Core]Microsoft.FSharp.Core.PrintfFormat`4<!!0, class [mscorlib]System.IO.TextWriter, class [FSharp.Core]Microsoft.FSharp.Core.Unit, class [FSharp.Core]Microsoft.FSharp.Core.Unit>)
L_0020: ldnull
L_0021: call instance bool Program/MyClass::IsThisNull()
L_0026: callvirt instance !1 [FSharp.Core]Microsoft.FSharp.Core.FSharpFunc`2<bool, class [FSharp.Core]Microsoft.FSharp.Core.Unit>::Invoke(!0)
L_002b: pop
L_002c: ret
}

Aha, IsThisNull() is invoked with call instruction that doesn’t perform null checks for this argument. C# in many cases uses callvirt instead of call to get cheap null check. For more details please refer to the post by Eric Gunnerson (Why does C# always use callvirt). or to Eric Lippert’s comment here: Summing up: Case (1) invoke virtual method: generate callvirt. Case (2) invoke instance method on nullable receiver: generate callvirt to get cheap null check -- yes, this is typesafe. Case (3) invoke instance method on known non-nullable receiver: generate call to avoid null check. Your first example falls into category (2), your second example falls into category (3). (The compiler knows that new never returns null and therefore need not check again.).

You may think: nulls are rare in F#, we need to explicitly mark nullable types so maybe this error wouldn’t appear in my code. However F# is part of .NET platform so interoperability with other languages is mandatory feature. Lets imagine we have created (or used existing) C# library that returns some object to F# code. Factory method reports about internal errors via returning null.

    public static class Factory
{
public static SomeObject Create()
{
return null;
}
}

public class SomeObject
{
public void Do(int a)
{
Console.WriteLine(a);
}

public SomeAnotherObject Create()
{
return new SomeAnotherObject(this);
}
}

public class SomeAnotherObject
{
private readonly SomeObject o;

public SomeAnotherObject(SomeObject o)
{
this.o = o;
}

public void Start()
{
o.Do(10);
}
}
// F# part
let x = Factory.Create()
let y = x.Create()
y.Start()

Compile and run our sample – it fails with NullReferenceException inside Start. Ok, in our synthetic example it is obvious – o field is null. It is initialized in constructor – find every usage of constructor. The only found case passes this as the argument and we expect this cannot be null. So what else can be the reason? Creating instance via reflection…we can spend hours searching for the real answer. Real life code can be more complex, so such corner cases look like timebomb – you can never predict when it will explode.

четверг, 7 октября 2010 г.

Solving Zebra puzzle + few announcements and ads

For today I have 2 news and 1 announcement:

  1. Bad (news): My F# related activities on Blogger are frozen. Here I'll publish only general .NET/C# programming stuff, so do not remove me from your RSS feeds :).
  2. Good (news): I didn’t give up F# blogging, moreover I’ll try to increase quality of posts. Please meet my new blog on IntelliFactory website together with the first post: Solving Zebra Puzzle. Subscribe to feeds and stay tuned!
  3. Neutral (announcement): The company I work for is looking for senior .NET developers to work on site at Goldman Sachs and Bank of America Merrill Lynch in New York City (downtown location). The job involves developing trading and risk management applications and integrating them with bank systems. Only .NET experience is required, the company will provide training in financial software. If anyone is interested in this position visit http://compatibl.com, contact me or send email to jobs@compatibl.com.

вторник, 5 октября 2010 г.

Introducing UStatic: check Unity injection statically

A few months ago I’ve made post about wrapper over Unity container that allows to verify object structure during compilation. At that time this wrapper supports only one type of injection – through properties (setter injection). Today it evolve into more evil and aggressive creature that besides property injection can initialize objects through calling specified constructors (constructor injection) and invoking methods.

Basically idea remains the same: we use lambdas for collecting user-defined configuration and describe dependencies as expression trees (amazing stuff, BTW! it can be applied to solve dozens of problems, from describing queries to being source for automatic generation of WPF ViewModels). With properties everything is pretty trivial:

using System;
using Microsoft.Practices.Unity;
using UStatic;

namespace UStaticTest
{
class Program
{
static void Main()
{
var container = new UnityContainer();

container.RegisterType<AnotherTestObject>(
c => c
.SetName("Test1")
.SetValueProperty(_ => _.Name, "The one you need")
);

container.RegisterType<AnotherTestObject>(
c => c
.SetValueProperty(_ => _.Name, "How did you get it??")
);

container.RegisterType<TestObject>(
c => c
.SetResolvedProperty(_ => _.A, "Test1")
.SetValueProperty(_ => _.B, "String value")
);

var testObject = container.Resolve<TestObject>();
Console.WriteLine(testObject.A.Name); // The one you need
Console.WriteLine(testObject.B); // String value
}
}

class TestObject
{
public AnotherTestObject A { get; set; }
public string B { get; set; }
}

public class AnotherTestObject
{
public string Name { get; set; }
}
}

We register AnotherTestObject twice: first time with name and  second – anonymous. For both registrations we specify value being set into property Name. After that we register TestObject with resolved property A. Our extension translates expression trees into various subtypes of InjectionMember but preserving type related information. This is funny but not new, we have already seen it in the previous post. What is really interesting is how can we use expression trees to describe constructor and method call. If we want to pass constant values everything is straightforward – just make another method in the interface, name it SetInitMethod and analyze expression in the similar way with SetResolvedProperty. But was if we want method arguments to be resolved from container during instance initialization? This is usual and widely used scenario. We need some auxiliary types to denote holes in our source expression so later this holes can be filled using values from container.

    /// <summary>
/// This type is used to make typed placeholders in expression trees that will be filled with actual values during resolution.
/// </summary>
public static class Param
{
internal static readonly MethodInfo ResolvedMethod = new Func<ResolvedParameterPlaceholder<int>>(Resolved<int>).Method.GetGenericMethodDefinition();
internal static readonly MethodInfo ResolvedWithNameMethod = new Func<string, ResolvedParameterPlaceholder<int>>(Resolved<int>).Method.GetGenericMethodDefinition();

public sealed class ResolvedParameterPlaceholder<T>
{
private ResolvedParameterPlaceholder() { }

public static implicit operator T(ResolvedParameterPlaceholder<T> p)
{
throw NoDynamicInvokation();
}
}

/// <summary>
/// Denotes placeholder for resolved value with specified type.
/// </summary>
/// <typeparam name="T">Type of target object</typeparam>
/// <returns>Resolution placeholder</returns>
public static ResolvedParameterPlaceholder<T> Resolved<T>()
{
throw NoDynamicInvokation();
}

/// <summary>
/// Denotes placeholder for resolved value with specified type and name.
/// </summary>
/// <typeparam name="T">Type of target object</typeparam>
/// <param name="name">Name of target object</param>
/// <returns>Resolution placeholder</returns>
public static ResolvedParameterPlaceholder<T> Resolved<T>(string name)
{
throw NoDynamicInvokation();
}

private static Exception NoDynamicInvokation()
{
return new InvalidOperationException("This operation is intended to be used in expression trees only");
}
}

ResolvedParameterPlaceholder type will act as placeholder (that’s why he has such weird name). It shouldn’t ever be created, we intended to use it only as marker in expression trees. Implicit conversion operator allows to use this type instead of any other actual types. Our analyzer will process usages of Param.Resolved separately and use ResolvedParameter instead of value. Nice and simple idea and it should also work for constructors. To select constructor we will use new expression + direct values and Param.Resolved.

using System;
using Microsoft.Practices.Unity;
using UStatic;

namespace UStaticTest
{
class Program
{
static void Main()
{
var container = new UnityContainer();

container.RegisterType<AnotherTestObject>(
c => c
.SetValueProperty(_ => _.Name, "AnotherTestObject")
);
container.RegisterType<YetAnotherTestObject>(
c => c
.SetValueProperty(_ => _.Name, "YetAnotherTestObject")
);

container.RegisterType<TestObject>(
c => c
.SetConstructor(() => new TestObject(Param.Resolved<YetAnotherTestObject>()))
.SetInitMethod(_ => _.Initialize(Param.Resolved<AnotherTestObject>()))
);

container.Resolve<TestObject>(); // Initialize: testObject.Name = AnotherTestObject, B = YetAnotherTestObject
}
}

class TestObject
{
public TestObject(YetAnotherTestObject obj)
{
B = obj;
}

public TestObject(YetAnotherTestObject obj, string text)
{
throw new InvalidOperationException("What's happen??");
}

public YetAnotherTestObject B { get; set; }

public void Initialize(AnotherTestObject testObject)
{
Console.WriteLine("Initialize: testObject.Name = {0}, B = {1}", testObject.Name, B.Name);
}
}

public class AnotherTestObject
{
public string Name { get; set; }
}

public class YetAnotherTestObject
{
public string Name { get; set; }
}
}

Complete source code of this project(I’ve named it UStatic) is avaiable here. As always any suggestions, constructive critisicm (and especially huge money donations :) ) are welcomed and appreciated.

вторник, 14 сентября 2010 г.

Slides And Samples

Presentation and code samples from my recent talk on FSUG meeting.

понедельник, 30 августа 2010 г.

F#: Building compiler from sources.

I think every curious person couldn’t resist from peeking when he met folder named Source inside F# installation directory. And what can be funnier that browsing through the source code of real-world compiler? Of course, compiling them sources and observing all internal compiler activities, so to say “in action’.

You need F# 2.0 and F#PowerPack to be installed. Additionaly we’ll build a few necessary utilities from PowerPack sources (in fact we can build entire PowerPack from scratch, but to save time we’ll take prepared binaries).

Initial ingredients:

So, let’s start:

  1. Create new folder (denoted below as $ROOT)
  2. Copy F# sources into $ROOT\source
  3. Copy PowerPack sources into $ROOT\powerpack
  4. Create auxiliary directory $ROOT\lkg\FSharp-2.0.50726.900\bin\. Copy files listed below to newly created folder
    • From PowerPack installation folder
      • FSharp.PowerPack.targets
      • FSharp.PowerPack.Build.Tasks.dll
      • Fslex.exe
      • Fsyacc.exe
    • From F# installation folder
      • Fsc.exe
      • FSharp.Core.dll
      • FSharp.Core.optdata
      • FSharpCore.sigdata
  5. Briefly about remaining steps: build FsSrGen utility from PowerPack, build proto compiler and finally build result compiler with proto (obtained on step 2). To automate the build process you can use script given below (copy it to $ROOT folder)
    set MSB35="c:\WINDOWS\Microsoft.NET\Framework\v3.5\MSBuild.exe"

    SET ROOT=%cd%

    @rem Delete previous build results
    rmdir %ROOT%\powerpack\head\Debug /S /Q

    @rem Build FsResGen
    cd %ROOT%\powerpack\head\workyard\FsSrGen\FsSrGen
    %MSB35% FsSrGen.fsproj

    @rem Build FsResGen task
    cd %ROOT%\powerpack\head\workyard\FsSrGen\FSharp.SRGen.Build.Tasks
    %MSB35% FSharp.SRGen.Build.Tasks.fsproj

    @rem Copy build results
    copy %ROOT%\powerpack\head\Debug\bin\*.* %ROOT%\lkg\FSharp-2.0.50726.900\bin\ /Y

    rem proto
    cd %ROOT%\source
    %MSB35% /p:TargetFrameworkVersion=v3.5 fsharp-proto-build.proj
    %MSB35% /p:TargetFrameworkVersion=v3.5 fsharp-compiler-build.proj

    cd %ROOT%\source\Debug\bin\

Overall compilation time will be something about 20 min.

Testing the result

For the test we’'ll take well-known sample with async downloading of web pages, but this time it will be examined from the inside.

open System.IO
open System.Net

let downloadPage (uri : string) = async {
let request = WebRequest.Create(uri)
let! response = request.AsyncGetResponse()
use stream = response.GetResponseStream()
use reader = new StreamReader(stream)
return reader.ReadLine()
}

let content = Async.RunSynchronously <| downloadPage "http://microsoft.com"
printfn "%d" content.Length

 

Create new C# ConsoleApplication project in VS, open Project Properties –> Debug page and select Start external program.

1. set path

External program here: out freshly built fsc.

Save settings, press F10 and behold… you are debugging the compiler

debugging the compiler  parsing in progress

After compiler finish its job modify Project Properties and replace external program file from  fsc.exe to the name of new executable file.

main

Start debugging and set breakpoint inside downloadPage function.

debug 3

Press F11 several times and you step into source code of FSharp.Core

debug 4

Having your own tamed version of the compiler is pretty convinient, you can not only browse static source code but also inspect behavior dynamically. Imagination is the only limitation, enjoy :).

суббота, 14 августа 2010 г.

INotifyPropertyChanged strikes back

This short post was inspired by this question on StackOverflow. Questioner asks for some language-specific features that can simplify tracking of changes in objects. This task can be perfectly solved by language that supports compile-time metaprogramming, unfortunately F# doesn’t have such features… maybe only in some distant future. Let’s demonstrate the solution using language that already has such capabilities – Nemerle.

Macros in Nemerle are programs that are executed in compile-time, consumes and produces AST.

Macro code

using Nemerle;
using Nemerle.Assertions;
using Nemerle.Collections;
using Nemerle.Compiler;
using Nemerle.Compiler.Parsetree;
using Nemerle.Compiler.Typedtree;
using Nemerle.Text;
using Nemerle.Utility;

using System;
using SCG = System.Collections.Generic;
using System.Linq;
using System.ComponentModel;

namespace ComponentModelHelpers
{
[MacroUsage(MacroPhase.BeforeInheritance, MacroTargets.Class, Inherited = false, AllowMultiple = false)]
public macro ImplementsNotifyPropertyChanged(tb : TypeBuilder)
{
NPCHelper.ImplementInterface(tb);
}

[MacroUsage(MacroPhase.WithTypedMembers, MacroTargets.Class, Inherited = false, AllowMultiple = false)]
public macro ImplementsNotifyPropertyChanged(tb : TypeBuilder)
{
NPCHelper.FixProperties(tb)
}

[MacroUsage(MacroPhase.BeforeInheritance, MacroTargets.Property, Inherited = false, AllowMultiple = false)]
public macro IgnoreProperty(tb : TypeBuilder, property : ParsedProperty)
{
NPCHelper.RegisterIgnored(tb, property)
}

module NPCHelper
{
private ignoredProperties : SCG.HashSet[TypeBuilder * string] = SCG.HashSet();

public RegisterIgnored(tb : TypeBuilder, property : ClassMember.Property) : void
{
ignore(ignoredProperties.Add(tb, property.Name));
}

public FixProperties(tb : TypeBuilder) : void
{
def properties = tb
.GetProperties()
.Filter(p => !ignoredProperties.Contains(tb, p.Name));

foreach(p is PropertyBuilder in properties)
{
def setter = (p.GetSetter() :> MethodBuilder);
when (setter != null)
{
setter.Body = <[
$(setter.Body);
RaisePropertyChanged($(p.Name : string));
]>;
}
}
}

public ImplementInterface(tb : TypeBuilder) : void
{
def handlerFieldName = Macros.NewSymbol("PropertyChanged");
def fieldDecl = <[ decl:
private mutable $(handlerFieldName.Id : usesite) : PropertyChangedEventHandler;
]>;

def modifyEvent(modifier)
{
<[
mutable tmp;
mutable h = $(handlerFieldName.Id : usesite);
do
{
tmp = h;
def newHandler = $(modifier)(tmp, value) :> PropertyChangedEventHandler;
h = System.Threading.Interlocked.CompareExchange(ref $(handlerFieldName.Id : usesite), newHandler, tmp);
} while(h != tmp);
]>
}
def eventDecl = <[decl:
public event PropertyChanged : PropertyChangedEventHandler
{
add { $(modifyEvent(<[ Delegate.Combine ]>)); }
remove { $(modifyEvent(<[ Delegate.Remove ]>)); }
}
]>;

def raisePropertyChangedMethodDecl = <[ decl:
protected RaisePropertyChanged(propertyName: string) : void
{
def h = $(handlerFieldName.Id : usesite);
when (h != null)
h(this, PropertyChangedEventArgs(propertyName));
}
]>;

tb.Define(fieldDecl);
tb.Define(eventDecl);
tb.Define(raisePropertyChangedMethodDecl);
tb.AddImplementedInterface(<[INotifyPropertyChanged]>);
}
}
}

Notes:

  • ImplementsNotifyPropertyChanged macro adds implementation of INotifiedPropertyChanged and patches properties so RaisePropertyChanged will be called in every setter
  • IgnoreProperty registers ignored property.
  • <[ ]> – denotes a quotation. Basically quotation produces PExpr (expression), so we need to mark explicitly if quotation contains declaration with decl: prefix
  • $(…) – splice in quotation
  • Macros in Nemerle are hygienic, so x variable introduced in macros won’t clash with the variable of the same name. If we need to suppress hygiene – this is done with :usesite directive.

Client code

using Nemerle.Collections;
using Nemerle.Text;
using Nemerle.Utility;

using System;
using System.Collections.Generic;
using System.Console;
using System.Linq;
using System.ComponentModel;

using ComponentModelHelpers;

module Program
{
Main() : void
{
def c = MegaComponent();
Test(c);
c.X = 100;
c.Y = "123";
}

Test(npc : INotifyPropertyChanged) : void
{
npc.PropertyChanged += (_, e) => WriteLine($"$(e.PropertyName) changed")
}
}

[ImplementsNotifyPropertyChanged]
class MegaComponent
{
private mutable y : string;

public X : int {get;set;};

[IgnoreProperty]
public Y : string
{
get { y }
set
{
y = value;
RaisePropertyChanged("Y");
}
}
}

/*
X changed
Y changed
*/

Notes:

  • Macro is made accessible in source code by opening containing namespace: ComponentModelHelpers
  • RaisePropertyChanged method is generated by macro so source code can use it

Decompiled class

internal class MegaComponent : INotifyPropertyChanged
{
// Fields
private PropertyChangedEventHandler _N_PropertyChanged_2784;
[CompilerGenerated, DebuggerBrowsable(DebuggerBrowsableState.Never)]
private int _N_X_3169;
private string y;

// Events
public event PropertyChangedEventHandler PropertyChanged
{
add
{
PropertyChangedEventHandler a = null;
PropertyChangedEventHandler handler2 = this._N_PropertyChanged_2784;
do
{
a = handler2;
PropertyChangedEventHandler handler3 = (PropertyChangedEventHandler) Delegate.Combine(a, value);
handler2 = Interlocked.CompareExchange<PropertyChangedEventHandler>(ref this._N_PropertyChanged_2784, handler3, a);
}
while (handler2 != a);
}
remove
{
PropertyChangedEventHandler source = null;
PropertyChangedEventHandler handler2 = this._N_PropertyChanged_2784;
do
{
source = handler2;
PropertyChangedEventHandler handler3 = (PropertyChangedEventHandler) Delegate.Remove(source, value);
handler2 = Interlocked.CompareExchange<PropertyChangedEventHandler>(ref this._N_PropertyChanged_2784, handler3, source);
}
while (handler2 != source);
}
}

// Methods
protected void RaisePropertyChanged(string propertyName)
{
PropertyChangedEventHandler handler = this._N_PropertyChanged_2784;
if (handler != null)
{
handler(this, new PropertyChangedEventArgs(propertyName));
}
}

// Properties
public int X
{
[CompilerGenerated]
get
{
return this._N_X_3169;
}
[CompilerGenerated]
set
{
this._N_X_3169 = value;
this.RaisePropertyChanged("X");
}
}

public string Y
{
get
{
return this.y;
}
set
{
this.y = value;
this.RaisePropertyChanged("Y");
}
}
}

понедельник, 9 августа 2010 г.

WebSharper, part 2: WebExcel

Well, after the long pause, I came back to blogging and today out test pet once again will be WebSharper. However now we’ll make pure client-side application so it can reveal all (or mostly all) positive sides of WS.

Today’s demo project will be modestly codenamed WebExcel – simple spreadsheet with support of formulae.

All major components of our system and relations between them are shown on the diagram below:

diagram

  • EvalResult – in fact it is discriminated union that represents current runtime cell value: it can be either Ok of obj – value, or Error of string – failure with description.
  • Presenter – This component handles all user input, invokes some functions from Model part and updates UI – MVP presenter.
  • CellDataStorage – simple container for cell values.
  • CellFormulaStorage – facade for formulae related functionality. Stores mapping from cell reference to parsed formula.
  • Parser – converts text representation for formula to parsed expression – instance of Expr type.
  • Expr – represents parsed formulae. Contains the following case constructors:
    • Value – literal value
    • Ref – reference to another cell
    • Operation – function that accepts list of Expr and produces EvalResult. Operation function accepts context argument that is used during expression evaluation to resolve Ref into value.
  • TopoSort – helps to build formula evaluation order according to dependencies between them.

Common workflow of handling UI events is roughly following:

workflow

Now, enough pictures, lets turn to the code.

EvalResult type

[<JavaScriptType>]
type EvalResult = Ok of obj | Error of string

Ast module

module Ast =
open System.Collections.Generic

[<JavaScriptType>]
type Context = string -> EvalResult option

[<JavaScriptType>]
type Expr =
| Value of obj
| Ref of string
| Operation of (Context -> list<Expr> -> EvalResult) * list<Expr>

[<JavaScript>]
let eval (ctx : Context) = function
| Value o -> Ok o
| Ref name ->
match ctx name with
| Some r -> r
| None -> Error("Name " + name + " not found")
| Operation (f, args) -> f ctx args

[<JavaScript>]
let bind ctx f e =
match eval ctx e with
| Ok v -> f v
| e -> e

[<JavaScript>]
let bindList ctx f args =
let rec impl l acc =
match l with
| [] -> f (List.rev acc)
| x::xs -> x |> bind ctx (fun o -> impl xs (o::acc))
impl args []

[<JavaScript>]
let getReferences e =
let rec impl (acc : Set<_>) = function
| Value _ -> acc
| Ref v -> acc.Add v
| Operation(_, l) -> (acc, l) ||> Seq.fold impl
impl Set.empty e

Ast contains definition of Expr type and some auxiliary functions:

  • eval – name is self descriptive – evaluates expression in a given context
  • bind – helper for chaining subsequent evaluations, returns on first occurance of Error
  • bindList – similar to bind but works for the list of expressions
  • getReferences – traverses given Expr and collects references to other cells

Operations module

module Operations = 

open Ast

[<JavaScript>]
let adapt f ctx args =
try
match args with
| [e1; e2] ->
e1 |> bind ctx (fun v1 ->
e2 |> bind ctx (fun v2 ->
Ok(f (unbox<double> v1) (unbox<double> v2))
)
)
| _ -> Error("Incorrect number of arguments")
with
e -> e.Message |> Error

[<JavaScript>]
let add = adapt (+)

[<JavaScript>]
let sub = adapt (-)

[<JavaScript>]
let mul = adapt (*)

[<JavaScript>]
let div = adapt (/)

[<JavaScript>]
let gt = adapt (>)

[<JavaScript>]
let ge = adapt (>=)

[<JavaScript>]
let lt = adapt (<)

[<JavaScript>]
let le = adapt (<=)

[<JavaScript>]
let eq = adapt (=)

[<JavaScript>]
let neq = adapt (<>)

[<JavaScript>]
let iif ctx args =
try
match args with
| [c; ifTrue; ifFalse] ->
c |> bind ctx (fun cond ->
if (unbox<bool> cond) then eval ctx ifTrue
else eval ctx ifFalse
)
| _ -> Error "Invalid number of arguments"
with
e -> Error e.Message

[<JavaScript>]
let average ctx args =
try
args |> bindList ctx (fun objs ->
objs
|> List.map unbox<double>
|> List.average
|> (box >> Ok)
)
with
e -> Error e.Message

[<JavaScript>]
let operations =
[
"IF", iif
"AVERAGE", average
] |> Map.ofSeq

Operations module stores all functions that will be accessible from formulae: common infix operators and external ones. Our definitions of Expr.Operation as function that accepts not values but thunks gives us capability to define functions like IF: evaluate first argument and after that evaluate second or third.

Parser module

module Parser = 

open Ast

[<JavaScript>]
let some v (rest : string) = Some(v, rest)

[<JavaScript>]
let capture pattern text =
let regex = JRegExp("^(" + pattern + ")(.*)")
if regex.Test(text)
then regex.Exec(text) |> Option.bind (fun v -> some v.[1] v.[2])
else None

[<JavaScript>]
let matchValue pattern = (capture @"\s*") >> (Option.bind (snd >> capture pattern))
[<JavaScript>]
let matchSymbol pattern = (matchValue pattern) >> (Option.bind (snd >> Some))

[<JavaScript>]
let (|NUMBER|_|) = matchValue @"-?\d+\.?\d*"
[<JavaScript>]
let (|IDENTIFIER|_|) = matchValue @"[A-Za-z]\w*"
[<JavaScript>]
let (|LPAREN|_|) = matchSymbol @"\("
[<JavaScript>]
let (|RPAREN|_|) = matchSymbol @"\)"
[<JavaScript>]
let (|PLUS|_|) = matchSymbol @"\+"
[<JavaScript>]
let (|MINUS|_|) = matchSymbol @"-"

[<JavaScript>]
let (|GT|_|) = matchSymbol @">"
[<JavaScript>]
let (|GE|_|) = matchSymbol @">="
[<JavaScript>]
let (|LT|_|) = matchSymbol @"<"
[<JavaScript>]
let (|LE|_|) = matchSymbol @"<="
[<JavaScript>]
let (|EQ|_|) = matchSymbol @"="
[<JavaScript>]
let (|NEQ|_|) = matchSymbol @"<>"

[<JavaScript>]
let (|MUL|_|) = matchSymbol @"\*"
[<JavaScript>]
let (|DIV|_|) = matchSymbol @"/"
[<JavaScript>]
let (|COMMA|_|) = matchSymbol @","

[<JavaScript>]
let operation op args rest = some (Operation(op, args)) rest

// error handling in case of unknown operation is omitted
let rec [<JavaScript>] (|Factor|_|) = function
| IDENTIFIER(id, r) ->
match r with
| LPAREN (ArgList (args, RPAREN r)) -> operation (Operations.operations.[id]) args r
| _ -> some(Ref id) r
| NUMBER (v, r) -> some (Value (System.Double.Parse v)) r
| LPAREN(Logical (e, RPAREN r)) -> some e r
| _ -> None

and [<JavaScript>] (|ArgList|_|) = function
| Logical(e, r) ->
match r with
| COMMA (ArgList(t, r1)) -> some (e::t) r1
| _ -> some [e] r
| rest -> some [] rest

and [<JavaScript>] (|Term|_|) = function
| Factor(e, r) ->
match r with
| MUL (Term(r, rest)) -> operation Operations.mul [e; r] rest
| DIV (Term(r, rest)) -> operation Operations.div [e; r] rest
| _ -> some e r
| _ -> None

and [<JavaScript>] (|Expr|_|) = function
| Term(e, r) ->
match r with
| PLUS (Expr(r, rest)) -> operation Operations.add [e; r] rest
| MINUS (Expr(r, rest)) -> operation Operations.sub [e; r] rest
| _ -> some e r
| _ -> None

and [<JavaScript>] (|Logical|_|) = function
| Expr(l, r) ->
match r with
| GE (Logical(r, rest)) -> operation Operations.ge [l; r] rest
| GT (Logical(r, rest)) -> operation Operations.gt [l; r] rest
| LE (Logical(r, rest)) -> operation Operations.le [l; r] rest
| LT (Logical(r, rest)) -> operation Operations.lt [l; r] rest
| EQ (Logical(r, rest)) -> operation Operations.eq [l; r] rest
| NEQ (Logical(r, rest)) -> operation Operations.neq [l; r] rest
| _ -> some l r
| _ -> None

and [<JavaScript>] (|Formula|_|) (s : string) =
if s.StartsWith("=") then
match s.Substring(1) with
| Logical(l, t) when System.String.IsNullOrEmpty(t) -> Some l
| _ -> None
else None

Concept of implementing parser using active patterns I've shamelessly stolen from excellent article by Adam Granicz.

Model module

module Model = 

open System
open System.Collections.Generic

[<JavaScript>]
let private toString o = o.ToString()

[<JavaScript>]
let private concat lines =
let delimiter = ", "
if Seq.isEmpty lines
then ""
else lines |> Seq.reduce(fun a b -> a + delimiter + b)

[<JavaScript>]
let rows = [1..20] |> List.map toString
[<JavaScript>]
let private rowsSet = Set.ofSeq rows

[<JavaScript>]
let cols = [int 'A'..int 'H'] |> List.map (char >> toString)
[<JavaScript>]
let colSet = Set.ofSeq cols


[<JavaScript>]
let private isReference (s : string) =
if System.String.IsNullOrEmpty s || s.Length < 2 then false
else
let col = toString s.[0]
let row = s.Substring(1)
rowsSet.Contains row && colSet.Contains col

[<JavaScriptType>]
type ICellDataStorage =
abstract member GetValue : string -> EvalResult option
abstract member SetValue : cell : string * value : EvalResult -> unit

[<JavaScriptType>]
type CellDataStorage [<JavaScript>] () =
let results = new System.Collections.Generic.Dictionary<string, EvalResult>()

[<JavaScript>]
let setValue cell value = results.[cell] <- value

[<JavaScript>]
member this.SetValue(cell, value) =
if System.String.IsNullOrEmpty value
then
this.DeleteValue(cell)
true
else
let (v, ok) = try Ok (box (float value)), true with _ -> Error "Not a number", false
setValue cell v
ok

[<JavaScript>]
member this.DeleteValue(cell) =
if results.ContainsKey cell then
results.Remove cell |> ignore

[<JavaScript>]
member this.GetValue(cell) =
if results.ContainsKey cell
then results.[cell] |> Some
else None

interface ICellDataStorage with
[<JavaScript>]
member this.GetValue(cell) = this.GetValue(cell)
[<JavaScript>]
member this.SetValue(cell, value) = setValue cell value

[<JavaScriptType>]
type TopoSort [<JavaScript>] () =
let map = new System.Collections.Generic.Dictionary<string, Set<_>>()

[<JavaScript>]
member this.Insert(cell, parents) =
for p in parents do
let s = if map.ContainsKey(p) then map.[p] else Set.empty
map.[p] <- s.Add cell
try
this.GetDependents(cell) |> ignore
with
_ ->
this.Delete(cell, parents)
reraise()

[<JavaScript>]
member this.Delete(cell, parents) =
for p in parents do
let s = map.[p]
map.[p] <- s.Remove cell

[<JavaScript>]
member this.GetDependents(s) =
let visited = ref Set.empty
let rec impl ((order, cycles) as state) s =
if Set.contains s cycles then failwith ("Cycle detected:" + (concat cycles))
if Set.contains s !visited
then state
else
visited := Set.add s !visited
if map.ContainsKey s
then
let children = map.[s]
((order, Set.add s cycles), children)
||> Seq.fold impl
|> (fun (l, cycle) -> List.Cons(s, l), Set.remove s cycles)
else
s::order, cycles

impl ([], Set.empty) s |> fst

[<JavaScriptType>]
type CellFormulaStorage [<JavaScript>](dataStorage : ICellDataStorage) =
let map = new System.Collections.Generic.Dictionary<string, Ast.Expr>()
let toposort = new TopoSort()

[<JavaScript>]
let getValue cell =
match dataStorage.GetValue cell with
| None -> Some(Ok 0.0)
| x -> x

[<JavaScript>]
member this.HasFormula(cell) = map.ContainsKey cell

[<JavaScript>]
member this.DeleteFormula(cell) =
if map.ContainsKey cell then
let oldExpr = map.[cell]
let parents = Ast.getReferences oldExpr
toposort.Delete(cell, parents)
map.Remove(cell) |> ignore


[<JavaScript>]
member this.SetFormula(cell, text) =
match text with
| Parser.Formula(f) ->
let invalidReferences =
Ast.getReferences f
|> Seq.filter (not << isReference)
|> Seq.toList
if List.isEmpty invalidReferences
then
let parents = Ast.getReferences f

try
toposort.Insert(cell, parents)
map.[cell] <- f

this.Evaluate(cell)
with
e -> dataStorage.SetValue(cell, Error(e.ToString()))
[cell]
else
dataStorage.SetValue(cell, Error ("Formula contains invalid references: " + (concat invalidReferences)))
[cell]
| _ ->
dataStorage.SetValue(cell, Error ("Invalid formula text:" + text))
[cell]


[<JavaScript>]
member this.Evaluate(cell) =
let dependencies = toposort.GetDependents(cell)
for d in dependencies do
if map.ContainsKey(d) then
let e = map.[d]
let res = Ast.eval getValue e
dataStorage.SetValue (d, res)
dependencies

ICellDataStorage interface is used only during formula evaluation: for the simplicity we make assumption that values obtained as evaluation results are correct and do not require validation.

UI module

open IntelliFactory.WebSharper.Html

[<Require(typeof<Styles.Table>)>]
module UI =

open System
open System.Collections.Generic

[<JavaScriptType>]
type Presenter [<JavaScript>] () =

let dataStorage = new Model.CellDataStorage()
let formulaStorage = new Model.CellFormulaStorage(dataStorage)

let userInput = new Dictionary<_, _>()

let map = new Dictionary<_, _>()

[<JavaScript>]
let onFocus (cell : Element) =
cell.AddClass("editing")
cell.Value <- if userInput.ContainsKey cell.Id then userInput.[cell.Id] else ""

[<JavaScript>]
let onBlur (cell : Element) =
cell.RemoveClass("editing")
userInput.[cell.Id] <- cell.Value
formulaStorage.DeleteFormula(cell.Id)

cell.RemoveClass("error")
cell.RemoveClass("formula")
try
let dependencies =
if cell.Value.StartsWith("=")
then
formulaStorage.SetFormula(cell.Id, cell.Value)
else
let ok = dataStorage.SetValue(cell.Id, cell.Value)
if ok
then formulaStorage.Evaluate(cell.Id)
else [cell.Id]

for dep in dependencies do
let el : Element = map.[dep]
match dataStorage.GetValue(el.Id) with
| Some (Ok v) ->
el.RemoveAttribute("title")
if formulaStorage.HasFormula el.Id then
el.AddClass("formula")
el.SetAttribute("title", userInput.[el.Id])
el.Value <- v.ToString()
| Some (Error msg) ->
el.SetAttribute("title", msg)
el.AddClass("error")
el.Value <- "#ERROR"
| None ->
el.RemoveAttribute("title")
el.Value <- ""
with
e ->
Window.Alert(e.ToString())

[<JavaScript>]
member this.CreateCell(name) =
let cell =
Input [Id name]
|>! OnFocus(fun e _ -> onFocus e)
|>! OnBlur(fun e _ -> onBlur e)
map.Add(name, cell)
cell

[<JavaScript>]
let main =

let presenter = new Presenter()

Table [] -< [
yield TR [
yield TD [Class "specialCell firstColumn"];
for col in Model.cols do yield TD [Class "specialCell"] -< [Text col]]
for row in Model.rows do
yield TR [
yield TD [Class "specialCell firstColumn"] -< [ Text row ];
for col in Model.cols do yield TD [presenter.CreateCell (col + row)]
]
]

[<JavaScriptType>]
type ExcelControl() =
inherit Web.Control()

[<JavaScript>]
override this.Body = UI.main

Presenter stores all values (even incorrect) so user can resume editing from the same point in case of incorrect input.

Final result with some CSS tweaks.

Let’s make some tests…

Create formula with incorrect reference

1_incorrect input

and behold… error notification.

2_tooltip

Fix formula: =A1 * 10 + 2

3_formulatooltip

Implicitly absence of value = 0

Create 3 linked formulae: A1 <- =A2 * 2, A2 <- =A1 + 10, A3 <- =B1 * 3

4_formulachain

Change value in A2 and observe chain reevaluation

5_reevaluation

Create formula cycle: A2 <- C1

6_cycle

Use IF and AVERAGE formulae: A2 <- AVERAGE(A1, B1, C1), A3 <- IF (A2 > B2, 10, -10)

7_if

Project source code can be downloaded here.

 
GeekySpeaky: Submit Your Site!