Create a gist now

Instantly share code, notes, and snippets.

A Continuation monad with stacktrace support in F# 4.1
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 Program.even@119.Invoke(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 Program.ContModule.ec@102-1.Invoke(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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment