4 people like it.

A Continuation monad with Symbolic Stacktraces

A first attempt at implementing symbolic exception stacktraces in computation expressions using reflection.

Symbolic Stacktraces

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19: 
20: 
21: 
22: 
23: 
24: 
25: 
26: 
27: 
28: 
29: 
30: 
31: 
32: 
33: 
34: 
35: 
36: 
37: 
38: 
39: 
40: 
41: 
42: 
43: 
44: 
45: 
46: 
open System

/// An exception with appended symbolic stacktrace entries
type SymbolicException =
    {
        Source : Exception
        Stacktrace : string list
    }

[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module SymbolicException =

    // See also http://fssnip.net/k1

    open System.Reflection

    /// clones an exception to avoid mutation issues related to the stacktrace
    let private 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 private remoteStackTraceField =
        let getField name = typeof<System.Exception>.GetField(name, BindingFlags.Instance ||| BindingFlags.NonPublic)
        match getField "remote_stack_trace" with
        | null -> getField "_remoteStackTraceString"
        | f -> f

    /// Captures an exception into a SymbolicException instance
    let capture (e : exn) = { Source = clone e ; Stacktrace = [] }

    /// 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 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'

Monad Implementation

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19: 
20: 
21: 
22: 
23: 
24: 
25: 
26: 
27: 
28: 
29: 
30: 
31: 
32: 
33: 
34: 
35: 
36: 
37: 
38: 
39: 
40: 
41: 
42: 
43: 
44: 
45: 
46: 
47: 
48: 
49: 
50: 
51: 
52: 
53: 
54: 
55: 
56: 
57: 
58: 
59: 
60: 
61: 
62: 
63: 
64: 
65: 
66: 
67: 
68: 
type Cont<'T> = 
    {
        /// Workflow body
        Body : ('T -> unit) -> (SymbolicException -> unit) -> unit
        /// Workflow definition type, if applicable
        Definition : Type option
    }

type ContBuilder() =
    let protect f x = try Choice1Of2 (f x) with e -> Choice2Of2 e
    let mkCont def bd = { Body = bd ; Definition = def }

    member __.Return t = mkCont None (fun sc _ -> sc t)
    member __.Zero() = __.Return()

    member __.Delay(f : unit -> Cont<'T>) : Cont<'T> =
        let def = f.GetType()
        mkCont (Some def) (fun sc ec ->
            let sc' t =
                match protect f () with
                | Choice1Of2 g -> g.Body sc ec
                | Choice2Of2 e -> ec (SymbolicException.capture e)

            __.Zero().Body sc' ec)

    member __.Bind(f : Cont<'T>, g : 'T -> Cont<'S>) : Cont<'S> =
        mkCont None (fun sc ec ->
            let sc' (t : 'T) =
                match protect g t with
                | Choice1Of2 g -> g.Body sc ec
                | Choice2Of2 e -> ec (SymbolicException.capture e)

            let ec' (se : SymbolicException) =
                match f.Definition with
                | None -> ec se
                | Some def ->
                    let callSite = g.GetType()
                    let stackMsg = sprintf "   at %O in %O" def callSite
                    ec (SymbolicException.append stackMsg se)

            f.Body sc' ec')

    member __.ReturnFrom (f : Cont<'T>) = 
        match f.Definition with
        | None -> f
        | Some df ->
            { f with Body = fun sc ec ->
                    let ec' (se : SymbolicException) =
                        let stackMsg = sprintf "   at %O" df
                        ec (SymbolicException.append stackMsg se)

                    f.Body sc ec' }

module Cont =
    let run (cont : Cont<'T>) =
        let result = ref Unchecked.defaultof<'T>
        let sc (t : 'T) = result := t
        let ec se =
            match cont.Definition with
            | None -> SymbolicException.raise se
            | Some def ->
                let stackMsg = sprintf "   at %O in Cont.run" def
                se |> SymbolicException.append stackMsg |> SymbolicException.raise

        cont.Body sc ec
        !result

let cont = new ContBuilder()

Example A

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19: 
20: 
21: 
22: 
let rec factorial n = cont {
    if n = 0 then return failwith "bug!"
    else
        let! pd = factorial (n - 1)
        return n * pd
}

Cont.run (factorial 5)

///// Stacktace:
//System.Exception: bug!
//   at FSI_0009.factorial@132.Invoke(Unit unitVar) in C:\Users\eirik\Desktop\meta2.fsx:line 132
//   at FSI_0002.ContBuilder.protect[a,b](FSharpFunc`2 f, a x) in C:\Users\eirik\Desktop\meta2.fsx:line 54
//   at FSI_0009+factorial@132 in FSI_0009+factorial@135-1
//   at FSI_0009+factorial@132 in FSI_0009+factorial@135-1
//   at FSI_0009+factorial@132 in FSI_0009+factorial@135-1
//   at FSI_0009+factorial@132 in FSI_0009+factorial@135-1
//   at FSI_0009+factorial@132 in FSI_0009+factorial@135-1
//   at FSI_0009+factorial@132 in Cont.run
//   at FSI_0002.SymbolicExceptionModule.raise[a](SymbolicException se) in C:\Users\eirik\Desktop\meta2.fsx:line 40
//   at FSI_0002.Cont.run[T](Cont`1 cont) in C:\Users\eirik\Desktop\meta2.fsx:line 111
//   at <StartupCode$FSI_0010>.$FSI_0010.main@()

Example B

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19: 
20: 
21: 
22: 
23: 
24: 
25: 
26: 
27: 
28: 
29: 
30: 
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

///// Stacktrace:
//System.Exception: bug!
//   at FSI_0011.even@149-3.Invoke(Unit unitVar) in C:\Users\eirik\Desktop\meta2.fsx:line 149
//   at FSI_0002.ContBuilder.protect[a,b](FSharpFunc`2 f, a x) in C:\Users\eirik\Desktop\meta2.fsx:line 54
//   at FSI_0011+even@149-3
//   at FSI_0011+odd@142-3
//   at FSI_0011+even@149-3
//   at FSI_0011+odd@142-3
//   at FSI_0011+even@149-3
//   at FSI_0011+odd@142-3 in Cont.run
//   at FSI_0002.SymbolicExceptionModule.raise[a](SymbolicException se) in C:\Users\eirik\Desktop\meta2.fsx:line 40
//   at FSI_0002.Cont.run[T](Cont`1 cont) in C:\Users\eirik\Desktop\meta2.fsx:line 111
//   at <StartupCode$FSI_0011>.$FSI_0011.main@()
//Stopped due to error
namespace System
type SymbolicException =
  {Source: Exception;
   Stacktrace: string list;}

Full name: Script.SymbolicException


 An exception with appended symbolic stacktrace entries
SymbolicException.Source: Exception
Multiple items
type Exception =
  new : unit -> Exception + 2 overloads
  member Data : IDictionary
  member GetBaseException : unit -> Exception
  member GetObjectData : info:SerializationInfo * context:StreamingContext -> unit
  member GetType : unit -> Type
  member HelpLink : string with get, set
  member InnerException : Exception
  member Message : string
  member Source : string with get, set
  member StackTrace : string
  ...

Full name: System.Exception

--------------------
Exception() : unit
Exception(message: string) : unit
Exception(message: string, innerException: exn) : unit
SymbolicException.Stacktrace: string list
Multiple items
val string : value:'T -> string

Full name: Microsoft.FSharp.Core.Operators.string

--------------------
type string = String

Full name: Microsoft.FSharp.Core.string
type 'T list = List<'T>

Full name: Microsoft.FSharp.Collections.list<_>
Multiple items
type CompilationRepresentationAttribute =
  inherit Attribute
  new : flags:CompilationRepresentationFlags -> CompilationRepresentationAttribute
  member Flags : CompilationRepresentationFlags

Full name: Microsoft.FSharp.Core.CompilationRepresentationAttribute

--------------------
new : flags:CompilationRepresentationFlags -> CompilationRepresentationAttribute
type CompilationRepresentationFlags =
  | None = 0
  | Static = 1
  | Instance = 2
  | ModuleSuffix = 4
  | UseNullAsTrueValue = 8
  | Event = 16

Full name: Microsoft.FSharp.Core.CompilationRepresentationFlags
CompilationRepresentationFlags.ModuleSuffix: CompilationRepresentationFlags = 4
namespace System.Reflection
val private clone : e:#exn -> exn

Full name: Script.SymbolicExceptionModule.clone


 clones an exception to avoid mutation issues related to the stacktrace
val e : #exn
type exn = Exception

Full name: Microsoft.FSharp.Core.exn
val bf : Runtime.Serialization.Formatters.Binary.BinaryFormatter
namespace System.Runtime
namespace System.Runtime.Serialization
namespace System.Runtime.Serialization.Formatters
namespace System.Runtime.Serialization.Formatters.Binary
Multiple items
type BinaryFormatter =
  new : unit -> BinaryFormatter + 1 overload
  member AssemblyFormat : FormatterAssemblyStyle with get, set
  member Binder : SerializationBinder with get, set
  member Context : StreamingContext with get, set
  member Deserialize : serializationStream:Stream -> obj + 1 overload
  member DeserializeMethodResponse : serializationStream:Stream * handler:HeaderHandler * methodCallMessage:IMethodCallMessage -> obj
  member FilterLevel : TypeFilterLevel with get, set
  member Serialize : serializationStream:Stream * graph:obj -> unit + 1 overload
  member SurrogateSelector : ISurrogateSelector with get, set
  member TypeFormat : FormatterTypeStyle with get, set
  ...

Full name: System.Runtime.Serialization.Formatters.Binary.BinaryFormatter

--------------------
Runtime.Serialization.Formatters.Binary.BinaryFormatter() : unit
Runtime.Serialization.Formatters.Binary.BinaryFormatter(selector: Runtime.Serialization.ISurrogateSelector, context: Runtime.Serialization.StreamingContext) : unit
val m : IO.MemoryStream
namespace System.IO
Multiple items
type MemoryStream =
  inherit Stream
  new : unit -> MemoryStream + 6 overloads
  member CanRead : bool
  member CanSeek : bool
  member CanWrite : bool
  member Capacity : int with get, set
  member Flush : unit -> unit
  member GetBuffer : unit -> byte[]
  member Length : int64
  member Position : int64 with get, set
  member Read : buffer:byte[] * offset:int * count:int -> int
  ...

Full name: System.IO.MemoryStream

--------------------
IO.MemoryStream() : unit
IO.MemoryStream(capacity: int) : unit
IO.MemoryStream(buffer: byte []) : unit
IO.MemoryStream(buffer: byte [], writable: bool) : unit
IO.MemoryStream(buffer: byte [], index: int, count: int) : unit
IO.MemoryStream(buffer: byte [], index: int, count: int, writable: bool) : unit
IO.MemoryStream(buffer: byte [], index: int, count: int, writable: bool, publiclyVisible: bool) : unit
Runtime.Serialization.Formatters.Binary.BinaryFormatter.Serialize(serializationStream: IO.Stream, graph: obj) : unit
Runtime.Serialization.Formatters.Binary.BinaryFormatter.Serialize(serializationStream: IO.Stream, graph: obj, headers: Runtime.Remoting.Messaging.Header []) : unit
property IO.MemoryStream.Position: int64
Runtime.Serialization.Formatters.Binary.BinaryFormatter.Deserialize(serializationStream: IO.Stream) : obj
Runtime.Serialization.Formatters.Binary.BinaryFormatter.Deserialize(serializationStream: IO.Stream, handler: Runtime.Remoting.Messaging.HeaderHandler) : obj
val private remoteStackTraceField : FieldInfo

Full name: Script.SymbolicExceptionModule.remoteStackTraceField
val getField : (string -> FieldInfo)
val name : string
val typeof<'T> : Type

Full name: Microsoft.FSharp.Core.Operators.typeof
type BindingFlags =
  | Default = 0
  | IgnoreCase = 1
  | DeclaredOnly = 2
  | Instance = 4
  | Static = 8
  | Public = 16
  | NonPublic = 32
  | FlattenHierarchy = 64
  | InvokeMethod = 256
  | CreateInstance = 512
  ...

Full name: System.Reflection.BindingFlags
field BindingFlags.Instance = 4
field BindingFlags.NonPublic = 32
val f : FieldInfo
val capture : e:exn -> SymbolicException

Full name: Script.SymbolicExceptionModule.capture


 Captures an exception into a SymbolicException instance
val e : exn
val append : line:string -> se:SymbolicException -> SymbolicException

Full name: Script.SymbolicExceptionModule.append


 appens a line to the symbolic stacktrace
val line : string
val se : SymbolicException
val raise : se:SymbolicException -> 'a

Full name: Script.SymbolicExceptionModule.raise


 Raises exception with its appended symboic stacktrace
val e' : exn
val stacktrace : string
Multiple items
val seq : sequence:seq<'T> -> seq<'T>

Full name: Microsoft.FSharp.Core.Operators.seq

--------------------
type seq<'T> = Collections.Generic.IEnumerable<'T>

Full name: Microsoft.FSharp.Collections.seq<_>
property Exception.StackTrace: string
Multiple items
module List

from Microsoft.FSharp.Collections

--------------------
type List<'T> =
  | ( [] )
  | ( :: ) of Head: 'T * Tail: 'T list
  interface IEnumerable
  interface IEnumerable<'T>
  member Head : 'T
  member IsEmpty : bool
  member Item : index:int -> 'T with get
  member Length : int
  member Tail : 'T list
  static member Cons : head:'T * tail:'T list -> 'T list
  static member Empty : 'T list

Full name: Microsoft.FSharp.Collections.List<_>
val rev : list:'T list -> 'T list

Full name: Microsoft.FSharp.Collections.List.rev
Multiple items
type String =
  new : value:char -> string + 7 overloads
  member Chars : int -> char
  member Clone : unit -> obj
  member CompareTo : value:obj -> int + 1 overload
  member Contains : value:string -> bool
  member CopyTo : sourceIndex:int * destination:char[] * destinationIndex:int * count:int -> unit
  member EndsWith : value:string -> bool + 2 overloads
  member Equals : obj:obj -> bool + 2 overloads
  member GetEnumerator : unit -> CharEnumerator
  member GetHashCode : unit -> int
  ...

Full name: System.String

--------------------
String(value: nativeptr<char>) : unit
String(value: nativeptr<sbyte>) : unit
String(value: char []) : unit
String(c: char, count: int) : unit
String(value: nativeptr<char>, startIndex: int, length: int) : unit
String(value: nativeptr<sbyte>, startIndex: int, length: int) : unit
String(value: char [], startIndex: int, length: int) : unit
String(value: nativeptr<sbyte>, startIndex: int, length: int, enc: Text.Encoding) : unit
val concat : sep:string -> strings:seq<string> -> string

Full name: Microsoft.FSharp.Core.String.concat
type Environment =
  static member CommandLine : string
  static member CurrentDirectory : string with get, set
  static member Exit : exitCode:int -> unit
  static member ExitCode : int with get, set
  static member ExpandEnvironmentVariables : name:string -> string
  static member FailFast : message:string -> unit + 1 overload
  static member GetCommandLineArgs : unit -> string[]
  static member GetEnvironmentVariable : variable:string -> string + 1 overload
  static member GetEnvironmentVariables : unit -> IDictionary + 1 overload
  static member GetFolderPath : folder:SpecialFolder -> string + 1 overload
  ...
  nested type SpecialFolder
  nested type SpecialFolderOption

Full name: System.Environment
property Environment.NewLine: string
FieldInfo.SetValue(obj: obj, value: obj) : unit
FieldInfo.SetValue(obj: obj, value: obj, invokeAttr: BindingFlags, binder: Binder, culture: Globalization.CultureInfo) : unit
val raise : exn:Exception -> 'T

Full name: Microsoft.FSharp.Core.Operators.raise
type Cont<'T> =
  {Body: ('T -> unit) -> (SymbolicException -> unit) -> unit;
   Definition: Type option;}

Full name: Script.Cont<_>
Cont.Body: ('T -> unit) -> (SymbolicException -> unit) -> unit


 Workflow body
type unit = Unit

Full name: Microsoft.FSharp.Core.unit
Multiple items
module SymbolicException

from Script

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

Full name: Script.SymbolicException


 An exception with appended symbolic stacktrace entries
Cont.Definition: Type option


 Workflow definition type, if applicable
type Type =
  inherit MemberInfo
  member Assembly : Assembly
  member AssemblyQualifiedName : string
  member Attributes : TypeAttributes
  member BaseType : Type
  member ContainsGenericParameters : bool
  member DeclaringMethod : MethodBase
  member DeclaringType : Type
  member Equals : o:obj -> bool + 1 overload
  member FindInterfaces : filter:TypeFilter * filterCriteria:obj -> Type[]
  member FindMembers : memberType:MemberTypes * bindingAttr:BindingFlags * filter:MemberFilter * filterCriteria:obj -> MemberInfo[]
  ...

Full name: System.Type
type 'T option = Option<'T>

Full name: Microsoft.FSharp.Core.option<_>
Multiple items
type ContBuilder =
  new : unit -> ContBuilder
  member Bind : f:Cont<'T> * g:('T -> Cont<'S>) -> Cont<'S>
  member Delay : f:(unit -> Cont<'T>) -> Cont<'T>
  member Return : t:'a -> Cont<'a>
  member ReturnFrom : f:Cont<'T> -> Cont<'T>
  member Zero : unit -> Cont<unit>

Full name: Script.ContBuilder

--------------------
new : unit -> ContBuilder
val protect : (('b -> 'c) -> 'b -> Choice<'c,exn>)
val f : ('b -> 'c)
val x : 'b
union case Choice.Choice1Of2: 'T1 -> Choice<'T1,'T2>
union case Choice.Choice2Of2: 'T2 -> Choice<'T1,'T2>
val mkCont : (Type option -> (('b -> unit) -> (SymbolicException -> unit) -> unit) -> Cont<'b>)
val def : Type option
val bd : (('b -> unit) -> (SymbolicException -> unit) -> unit)
member ContBuilder.Return : t:'a -> Cont<'a>

Full name: Script.ContBuilder.Return
val t : 'a
union case Option.None: Option<'T>
val sc : ('a -> unit)
val __ : ContBuilder
member ContBuilder.Zero : unit -> Cont<unit>

Full name: Script.ContBuilder.Zero
member ContBuilder.Return : t:'a -> Cont<'a>
member ContBuilder.Delay : f:(unit -> Cont<'T>) -> Cont<'T>

Full name: Script.ContBuilder.Delay
val f : (unit -> Cont<'T>)
val def : Type
Object.GetType() : Type
union case Option.Some: Value: 'T -> Option<'T>
val sc : ('T -> unit)
val ec : (SymbolicException -> unit)
val sc' : ('a -> unit)
val g : Cont<'T>
member ContBuilder.Zero : unit -> Cont<unit>
member ContBuilder.Bind : f:Cont<'T> * g:('T -> Cont<'S>) -> Cont<'S>

Full name: Script.ContBuilder.Bind
val f : Cont<'T>
val g : ('T -> Cont<'S>)
val sc : ('S -> unit)
val sc' : ('T -> unit)
val t : 'T
val g : Cont<'S>
Cont.Body: ('S -> unit) -> (SymbolicException -> unit) -> unit


 Workflow body
val ec' : (SymbolicException -> unit)
val callSite : Type
val stackMsg : string
val sprintf : format:Printf.StringFormat<'T> -> 'T

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.sprintf
member ContBuilder.ReturnFrom : f:Cont<'T> -> Cont<'T>

Full name: Script.ContBuilder.ReturnFrom
val df : Type
val run : cont:Cont<'T> -> 'T

Full name: Script.Cont.run
val cont : Cont<'T>
val result : 'T ref
Multiple items
val ref : value:'T -> 'T ref

Full name: Microsoft.FSharp.Core.Operators.ref

--------------------
type 'T ref = Ref<'T>

Full name: Microsoft.FSharp.Core.ref<_>
module Unchecked

from Microsoft.FSharp.Core.Operators
val defaultof<'T> : 'T

Full name: Microsoft.FSharp.Core.Operators.Unchecked.defaultof
val ec : (SymbolicException -> 'a)
val cont : ContBuilder

Full name: Script.cont
val factorial : n:int -> Cont<int>

Full name: Script.factorial
val n : int
val failwith : message:string -> 'T

Full name: Microsoft.FSharp.Core.Operators.failwith
val pd : int
Multiple items
module Cont

from Script

--------------------
type Cont<'T> =
  {Body: ('T -> unit) -> (SymbolicException -> unit) -> unit;
   Definition: Type option;}

Full name: Script.Cont<_>
val odd : n:int -> Cont<bool>

Full name: Script.odd
Multiple items
val int : value:'T -> int (requires member op_Explicit)

Full name: Microsoft.FSharp.Core.Operators.int

--------------------
type int = int32

Full name: Microsoft.FSharp.Core.int

--------------------
type int<'Measure> = int

Full name: Microsoft.FSharp.Core.int<_>
val even : n:int -> Cont<bool>

Full name: Script.even
Raw view New version

More information

Link:http://fssnip.net/tA
Posted:1 years ago
Author:Eirik Tsarpalis
Tags: exceptions , stacktrace , computation expressions