A monadic interpreter

MyInterpreter.fs

type Value =
    | NoValue
    | Bool   of bool
    | Int    of int
    | String of string
    | Double of double
    | Void

// With interpreters it's often good to have a stack of variables
//  For instance when the interpreter calls a function typically a stackframe is pushed
//  and when the function returns the stackframe is popped.
type InterpreterStack =
    | Empty
    | StackFrame of Map<string, Value>*InterpreterStack


let inline OrElse (f : unit->'T option) (ov : 'T option) =
    match ov with 
    | Some _    -> ov
    | _         -> f ()

let rec LookupValue (nm : string) (stack : InterpreterStack) : Value option =
    match stack with
    | StackFrame (m,p)      -> 
        m.TryFind nm
        |> OrElse (fun ()   -> LookupValue nm p)
    | _                     -> None

let rec SetValue (nm : string) (v : Value) (stack : InterpreterStack) : InterpreterStack =
    match stack with
    | StackFrame (m,p)      -> 
        let mm = m |> Map.remove nm |> Map.add nm v
        StackFrame (mm,p)
    | _                     -> 
        let mm = Map.empty |> Map.add nm v
        StackFrame (mm,Empty)

// This Context can of course be expanded for more interpret utility state
type InterpreterContext =
    {
        Stack   : InterpreterStack
    }
    static member New (s : InterpreterStack) = { Stack = s }
       
type InterpreterError =
    | UndefinedError    of string
    | ValueNotFound     of string

// Interpreter takes a context and 
// 1. Returns a value if successful, if no value is returned interpretation should be aborted
// 2. Returns discovered errors, may be more than one. The presence of an error doesn't abort
// 3. Returns updated context
type Interpreter<'T> = InterpreterContext -> 'T option * InterpreterError list * InterpreterContext

module Interpreter =

    // Delay is an important function to have in order to get correct behavior
    let Delay (d : unit -> Interpreter<'T>) = d ()

    let Return (v : 'T) : Interpreter<'T> = 
        fun ctx ->
            (Some v), [], ctx

    // Bind is where the magic happens as usual
    let Bind (t : Interpreter<'T>) (fu : 'T -> Interpreter<'U>) : Interpreter<'U> =
        fun ctx ->
            let otv, terrors, tctx = t ctx
            match otv with
            // If the first interpreter is successful then we shall execute the second one
            // with the first result as input
            | Some tv   -> 
                let u                   = fu tv
                let ouv, uerrors, uctx  = u tctx

                ouv, uerrors@terrors, uctx
            // If the first interpreter has failed then we return None
            //  this will according to railway oriented programming causes
            //  all subsequent binds to fail as well
            | _         ->
                None, terrors, tctx

    let inline Zero () : Interpreter<unit> = Return ()

    type InterpreterBuilder() =
            member b.Bind(t, fu)    = Bind t fu
            member b.Delay(d)       = Delay (d)
            member b.Return(v)      = Return v
            member b.ReturnFrom(t)  = t
            member b.Zero()         = Zero ()

    let interpreter = InterpreterBuilder()

    let GetContext : Interpreter<InterpreterContext> = 
        fun ctx -> Some ctx, [], ctx

    let SetContext ctx : Interpreter<unit> = 
        fun _ -> Some (), [], ctx

    // This raises an error that will abort the interpreter
    let RaiseCriticalError (e : InterpreterError) : Interpreter<_> = 
        fun ctx -> None, [e], ctx

    // This raises an warning that will not abort the interpreter
    //  a value has to be specified
    let RaiseNonCriticalError (v : 'T) (e : InterpreterError) : Interpreter<'T> = 
        fun ctx -> Some v, [e], ctx

    // GetValue looks for a value
    //  If not found an error will be raised that will abort the interpreter
    let GetValue nm : Interpreter<_> =
        interpreter {
            let! ctx    = GetContext

            let ov      = LookupValue nm ctx.Stack

            let result  =
                match ov with
                | Some v    -> Return v
                | _         -> RaiseCriticalError (ValueNotFound nm)

            return! result
        }

    // FindValue looks for a value
    //  If not found an error will be raised that will NOT abort the interpreter
    let FindValue nm =
        interpreter {
            let! ctx    = GetContext

            let ov      = LookupValue nm ctx.Stack

            let result  =
                match ov with
                | Some v    -> Return v
                | _         -> RaiseNonCriticalError NoValue (ValueNotFound nm)

            return! result
        }

    let SetValue nm v =
        interpreter {
            let! ctx    = GetContext

            let stack   = SetValue nm v ctx.Stack
            let nctx    = InterpreterContext.New stack

            do! SetContext nctx

            return ()
        }

open Interpreter

[<EntryPoint>]
let main argv = 

    let ctx = InterpreterContext.New Empty

    let first = 
        interpreter {
            printfn "First is starting..."

            do! SetValue "Test1" <| String "Testing"

            let! v1 = GetValue "Test1"
            printfn "Test1 = %A" v1

            let! v2 = GetValue "Test2"
            printfn "Test2 = %A" v2

            let! v3 = GetValue "Test3"
            printfn "Test3 = %A" v3

            printfn "First is done"
        }
    
    let second = 
        interpreter {
            printfn "Second is starting..."

            do! SetValue "Test1" <| String "Testing"

            let! v1 = FindValue "Test1"
            printfn "Test1 = %A" v1

            let! v2 = FindValue "Test2"
            printfn "Test2 = %A" v2

            let! v3 = FindValue "Test3"
            printfn "Test3 = %A" v3

            printfn "Second is done"

        }

    let fv, ferrors, fctx = first ctx

    printfn "First: Value = %A, Errors = %A, Context = %A" fv ferrors fctx

    let sv, serrors, sctx = second ctx

    printfn "Second: Value = %A, Errors = %A, Context = %A" sv serrors sctx

    0