F# version of http://i.cs.hku.hk/~bruno/oa/ using FsControl

ExprProblemUsingOA.fsx

#r @"C:\packages\FsControl.1.0.8\lib\net40\FsControl.Core.dll"

type Eval = Eval of int
let eval (Eval x) = x

// To define a Type Method we need to add at least 2 instances
type Eval' = Eval' of int
let eval' (Eval' x) = x

module ExpAlg =

    type Lit = Lit with
        static member instance (Lit,_:Eval ) = fun x -> Eval  x
        static member instance (Lit,_:Eval') = fun x -> Eval' x

    type Add = Add with
        static member instance (Add,e1,_:Eval ) = fun e2 -> Eval  (eval  e1 + eval  e2)
        static member instance (Add,e1,_:Eval') = fun e2 -> Eval' (eval' e1 + eval' e2)

let inline lit (x:int) = Inline.instance ExpAlg.Lit x
let inline add (e1:'a) (e2:'a) :'a = Inline.instance (ExpAlg.Add, e1) e2


// Evolution 1: Adding subtraction

module SubExpAlg =

    type Sub = Sub with
        static member instance (Sub,e1,_:Eval ) = fun e2 -> Eval  (eval  e1 - eval  e2)
        static member instance (Sub,e1,_:Eval') = fun e2 -> Eval' (eval' e1 - eval' e2)

let inline sub e1 e2 = Inline.instance (SubExpAlg.Sub, e1) e2


// Evolution 2: Adding pretty printing

type Print = Print of string
let print (Print x) = x

type Print with
    static member instance (ExpAlg.Lit   ,     _:Print) = Print << string
    static member instance (ExpAlg.Add   , e1, _:Print) = fun e2 -> Print (print e1 + " + " + print e2)
    static member instance (SubExpAlg.Sub, e1, _:Print) = fun e2 -> Print (print e1 + " - " + print e2)


// Test
// Note: there are (almost) no generic constants in F#
// so a generic constant is coded as a function: unit -> 'a

let inline exp1() = add (lit 3) (lit 4)
let inline exp2() = sub (exp1()) (lit 4)

let (ev:Eval) = exp1()

let r1 = "Evaluation of exp1 \"" + print (exp1()) + "\" is: " + string (eval ev)
let r2 = "Evaluation of exp1 \"" + print (exp2()) + "\" is: " + string (eval (exp2()))

// TODO add instances for Show (In fsControl is ToString)
// let r3 = "Evaluation of exp1 \"" + (exp1()) + "\" is: " + (exp2())