A Continuation monad with stacktrace support in F# 4.1

cont.fsx

open System
open System.Runtime.CompilerServices

type SymbolicException =
    {
        Source : Exception
        Stacktrace : string list
    }

module SymbolicException =
 
    open System.Reflection
 
    /// clones an exception to avoid mutation issues related to the stacktrace
    let clone (e : exn) =
        let bf = new System.Runtime.Serialization.Formatters.Binary.BinaryFormatter()
        use m = new System.IO.MemoryStream()
        bf.Serialize(m, e)
        m.Position <- 0L
        bf.Deserialize m :?> exn
 
    let remoteStackTraceField =
        let getField name = typeof<System.Exception>.GetField(name, BindingFlags.Instance ||| BindingFlags.NonPublic)
        match getField "remote_stack_trace" with
        | null -> getField "_remoteStackTraceString"
        | f -> f
 
    /// appens a line to the symbolic stacktrace
    let append (line : string) (se : SymbolicException) =
        { se with Stacktrace = line :: se.Stacktrace }
 
    /// Raises exception with its appended symboic stacktrace
    let inline raise (se : SymbolicException) =
        let e' = clone se.Source
        let stacktrace =
            seq { yield e'.StackTrace ; yield! List.rev se.Stacktrace }
            |> String.concat Environment.NewLine
 
        remoteStackTraceField.SetValue(e', stacktrace + Environment.NewLine)
        raise e'
 
    /// Captures an exception into a SymbolicException instance
    let capture (e : exn) = { Source = clone e ; Stacktrace = [] }


type Cont<'T> = ('T -> unit) -> (SymbolicException -> unit) -> unit

type ContBuilder() =
    member __.Return(t : 'T) : Cont<'T> = fun sc _ -> sc t
    member __.Zero() = __.Return()
    member __.Delay(f : unit -> Cont<'T>) : Cont<'T> =
        fun sc ec ->
            let sc' t =
                match (try Ok(f ()) with e -> Error e) with
                | Ok g -> g sc ec
                | Error e -> ec (SymbolicException.capture e)
 
            __.Zero() sc' ec

    member __.Bind(f : Cont<'T>, g : 'T -> Cont<'S>,
                    [<CallerMemberName>]?callerName : string,
                    [<CallerFilePath>]?callerFilePath : string,
                    [<CallerLineNumber>]?callerLineNumber : int) : Cont<'S> =

        fun sc ec ->
            let sc' (t : 'T) =
                match (try Ok(g t) with e -> Error e) with
                | Ok g -> g sc ec
                | Error e -> ec (SymbolicException.capture e)
 
            let ec' (se : SymbolicException) =
                let stackMsg =
                    sprintf "   at %s in %s:line %d" 
                        callerName.Value 
                        callerFilePath.Value
                        callerLineNumber.Value

                ec (SymbolicException.append stackMsg se)

            f sc' ec'

    member __.ReturnFrom(f : Cont<'T>,
                            [<CallerMemberName>]?callerName : string,
                            [<CallerFilePath>]?callerFilePath : string,
                            [<CallerLineNumber>]?callerLineNumber : int) : Cont<'T> =
        fun sc ec ->
            let ec' (se : SymbolicException) =
                let stackMsg =
                    sprintf "   at %s in %s:line %d" 
                        callerName.Value 
                        callerFilePath.Value
                        callerLineNumber.Value

                ec (SymbolicException.append stackMsg se)

            f sc ec'

module Cont =
    let run (cont : Cont<'T>) =
        let result = ref Unchecked.defaultof<'T>
        let sc (t : 'T) = result := t
        let ec se = SymbolicException.raise se
        cont sc ec
        !result

let cont = new ContBuilder()

///

let rec odd (n : int) = 
    cont {
        if n = 0 then return false
        else
            return! even (n - 1)
    }
 
and even (n : int) =
    cont {
        if n = 0 then return failwith "bug!"
        else
            return! odd (n - 1)
    }


odd 5 |> Cont.run
//System.Exception: bug!
//   at [email protected](Unit unitVar) in C:\Users\eirik\devel\public\cont\Program.fs:line 119
//   at Program.sc'@54-1.Invoke(a t) in C:\Users\eirik\devel\public\cont\Program.fs:line 54
//   at odd in C:\Users\eirik\devel\public\cont\Program.fs:line 114
//   at even in C:\Users\eirik\devel\public\cont\Program.fs:line 121
//   at odd in C:\Users\eirik\devel\public\cont\Program.fs:line 114
//   at even in C:\Users\eirik\devel\public\cont\Program.fs:line 121
//   at odd in C:\Users\eirik\devel\public\cont\Program.fs:line 114
//   at [email protected](SymbolicException se) in C:\Users\eirik\devel\public\cont\Program.fs:line 102
//   at Program.ContModule.run[T](FSharpFunc`2 cont) in C:\Users\eirik\devel\public\cont\Program.fs:line 103
//   at <StartupCode$ConsoleApplication3>.$Program.main@() in C:\Users\eirik\devel\public\cont\Program.fs:line 106