1 people like it.

Generic IDisposable

Generic, structural IDisposable generator for algebraic data types.

 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: 
69: 
70: 
71: 
72: 
73: 
74: 
75: 
76: 
77: 
78: 
79: 
80: 
81: 
82: 
83: 
84: 
85: 
86: 
87: 
88: 
89: 
90: 
91: 
92: 
93: 
94: 
95: 
96: 
97: 
98: 
open System
open TypeShape
open TypeShape_Utils
open TypeShape_SubtypeExtensions

let rec mkDisposer<'T> () : 'T -> unit =
    let mutable f = Unchecked.defaultof<'T -> unit>
    if cache.TryGetValue(&f) then f
    else
        use mgr = cache.CreateRecTypeManager()
        mkDisposerCached<'T> mgr

and private mkDisposerCached<'T> (ctx : RecTypeManager) : 'T -> unit =
    match ctx.TryFind<'T -> unit>() with
    | Some f -> f
    | None ->
        let _ = ctx.CreateUninitialized<'T -> unit>(fun c t -> c.Value t)
        let f = mkDisposerAux<'T> ctx
        ctx.Complete f

and private mkDisposerAux<'T> (ctx : RecTypeManager) : 'T -> unit =
    let EQ (f : 'a -> unit) = unbox<'T -> unit> f

    let mkMemberDisposer (shape : IShapeWriteMember<'DeclaringType>) =
        shape.Accept { new IWriteMemberVisitor<'DeclaringType, 'DeclaringType -> unit> with
            member __.Visit (shape : ShapeWriteMember<'DeclaringType, 'Field>) =
                let fd = mkDisposerCached<'Field> ctx
                fun inst -> let f = shape.Project inst in fd f }

    match shapeof<'T> with
    | Shape.IDisposable s ->
        s.Accept { new ISubtypeVisitor<IDisposable, ('T -> unit)> with
            member __.Visit<'D when 'D :> IDisposable> () =
                if typeof<'D>.IsValueType then
                    fun (d:'D) -> d.Dispose()
                else
                    fun (d:'D) -> if not(obj.ReferenceEquals(d,null)) then d.Dispose()
                |> EQ }

    | Shape.Nullable s ->
        s.Accept { new INullableVisitor<'T -> unit> with
            member __.Visit<'t when 't : struct and 't :> ValueType and 't : (new : unit -> 't)>() = // 'T = 't
                let td = mkDisposerCached<'t> ctx
                EQ (fun (t : Nullable<'t>) -> if t.HasValue then td t.Value)
        }

    | Shape.FSharpList s ->
        s.Accept { new IFSharpListVisitor<'T -> unit> with
            member __.Visit<'t>() = // 'T = 't list
                let td = mkDisposerCached<'t> ctx
                EQ (fun (ts : 't list) -> for t in ts do td t) } 

    | Shape.Array s when s.Rank = 1 ->
        s.Accept { new IArrayVisitor<'T -> unit> with
            member __.Visit<'t> _ = // 'T = 't []
                let td = mkDisposerCached<'t> ctx
                EQ (fun (ts : 't []) -> for t in ts do td t) } 

    | Shape.Tuple (:? ShapeTuple<'T> as shape) ->
        let elemDisposers = shape.Elements |> Array.map mkMemberDisposer
        fun t -> for d in elemDisposers do d t

    | Shape.FSharpRecord (:? ShapeFSharpRecord<'T> as shape) ->
        let fieldDisposers = shape.Fields |> Array.map mkMemberDisposer
        fun t -> for d in fieldDisposers do d t

    | Shape.FSharpUnion (:? ShapeFSharpUnion<'T> as shape) ->
        let fieldDisposers = shape.UnionCases |> Array.map (fun c -> Array.map mkMemberDisposer c.Fields)
        fun t ->
            let tag = shape.GetTag t
            for d in fieldDisposers.[tag] do d t

    | _ -> ignore

and private cache : TypeCache = new TypeCache()

/// Performs a structural disposal of provided type
let dispose (t : 'T) = mkDisposer<'T> () t
/// Creates an IDisposable token that structurally disposes contents
let mkDisposable (t : 'T) = { new IDisposable with member __.Dispose() = dispose t }

type Disposable() =
    static let mutable counter = 0
    let id = System.Threading.Interlocked.Increment &counter
    interface IDisposable with 
        member __.Dispose() = printfn "Disposing %d" id
    
let d() = new Disposable()

dispose [d() ; d(); d()]

let test() =
    use d = mkDisposable [Some (d())]
    ()

type Tree<'T> = Leaf | Node of 'T * Tree<'T> * Tree<'T>

dispose <| Node(d(), Leaf, Node(d(), Leaf, Leaf))
namespace System
namespace TypeShape
module TypeShape_Utils
module TypeShape_SubtypeExtensions
val mkDisposer : unit -> ('T -> unit)

Full name: Script.mkDisposer
type unit = Unit

Full name: Microsoft.FSharp.Core.unit
val mutable f : ('T -> unit)
module Unchecked

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

Full name: Microsoft.FSharp.Core.Operators.Unchecked.defaultof
val private cache : TypeCache

Full name: Script.cache
member TypeCache.TryGetValue : result:byref<'T> -> bool
member TypeCache.TryGetValue : t:Type * result:byref<obj> -> bool
val mgr : RecTypeManager
member TypeCache.CreateRecTypeManager : unit -> RecTypeManager
val private mkDisposerCached : ctx:RecTypeManager -> ('T -> unit)

Full name: Script.mkDisposerCached
val ctx : RecTypeManager
Multiple items
type RecTypeManager =
  interface IDisposable
  new : unit -> RecTypeManager
  private new : parentCache:TypeCache option -> RecTypeManager
  member Complete : value:'T -> 'T
  member CreateUninitialized : delay:(Cell<'T> -> 'T) -> 'T
  member private GetGeneratedValues : unit -> (Type * obj) []
  member TryFind : unit -> 'T option
  member TryFind : t:Type -> obj option
  member TryGetValue : result:byref<'T> -> bool
  member TryGetValue : t:Type * result:byref<obj> -> bool
  ...

Full name: TypeShape_Utils.RecTypeManager

--------------------
new : unit -> RecTypeManager
member RecTypeManager.TryFind : unit -> 'T option
member RecTypeManager.TryFind : t:Type -> obj option
union case Option.Some: Value: 'T -> Option<'T>
val f : ('T -> unit)
union case Option.None: Option<'T>
member RecTypeManager.CreateUninitialized : delay:(Cell<'T> -> 'T) -> 'T
val c : Cell<('T -> unit)>
val t : 'T
property Cell.Value: 'T -> unit
val private mkDisposerAux : ctx:RecTypeManager -> ('T -> unit)

Full name: Script.mkDisposerAux
member RecTypeManager.Complete : value:'T -> 'T
val EQ : (('a -> unit) -> 'T -> unit)
val f : ('a -> unit)
val unbox : value:obj -> 'T

Full name: Microsoft.FSharp.Core.Operators.unbox
val mkMemberDisposer : (IShapeWriteMember<'DeclaringType> -> 'DeclaringType -> unit)
val shape : IShapeWriteMember<'DeclaringType>
type IShapeWriteMember<'Record> =
  interface
    inherit IShapeMember<'Record>
    abstract member Accept : IWriteMemberVisitor<'Record,'R> -> 'R
  end

Full name: TypeShape.IShapeWriteMember<_>
abstract member IShapeMember.Accept : IMemberVisitor<'DeclaringType,'R> -> 'R
abstract member IShapeWriteMember.Accept : IWriteMemberVisitor<'Record,'R> -> 'R
type IWriteMemberVisitor<'TRecord,'R> =
  interface
    abstract member Visit : ShapeWriteMember<'TRecord,'Field> -> 'R
  end

Full name: TypeShape.IWriteMemberVisitor<_,_>
val shape : ShapeWriteMember<'DeclaringType,'a>
type ShapeWriteMember<'DeclaringType,'MemberType> =
  inherit ShapeMember<'DeclaringType,'MemberType>
  interface IShapeWriteMember<'DeclaringType>
  private new : label:string * memberInfo:MemberInfo * path:MemberInfo [] -> ShapeWriteMember<'DeclaringType,'MemberType>
  member Inject : instance:'DeclaringType -> field:'MemberType -> 'DeclaringType
  member InjectExpr : instance:Expr<'DeclaringType> -> field:Expr<'MemberType> -> Expr<'DeclaringType>

Full name: TypeShape.ShapeWriteMember<_,_>
val fd : ('a -> unit)
val inst : 'DeclaringType
val f : 'a
member ShapeMember.Project : instance:'DeclaringType -> 'MemberType
val shapeof<'T> : TypeShape

Full name: TypeShape.shapeof
Multiple items
module Shape

from TypeShape_SubtypeExtensions

--------------------
module Shape

from TypeShape
active recognizer IDisposable: TypeShape -> IShapeSubtype<IDisposable> option

Full name: TypeShape_SubtypeExtensions.Shape.( |IDisposable|_| )
val s : IShapeSubtype<IDisposable>
IShapeSubtype.Accept<'TResult>(visitor: ISubtypeVisitor<IDisposable,'TResult>) : 'TResult
type ISubtypeVisitor<'TBase,'TResult> =
  member Visit<'TSubtype> : unit -> 'TResult

Full name: TypeShape.ISubtypeVisitor<_,_>
type IDisposable =
  member Dispose : unit -> unit

Full name: System.IDisposable
val typeof<'T> : Type

Full name: Microsoft.FSharp.Core.Operators.typeof
val d : #IDisposable
IDisposable.Dispose() : unit
val not : value:bool -> bool

Full name: Microsoft.FSharp.Core.Operators.not
type obj = Object

Full name: Microsoft.FSharp.Core.obj
Object.ReferenceEquals(objA: obj, objB: obj) : bool
active recognizer Nullable: TypeShape -> IShapeNullable option

Full name: TypeShape.Shape.( |Nullable|_| )
val s : IShapeNullable
abstract member IShapeNullable.Accept : INullableVisitor<'R> -> 'R
type INullableVisitor<'R> =
  interface
    abstract member Visit : unit -> 'R
  end

Full name: TypeShape.INullableVisitor<_>
type ValueType =
  member Equals : obj:obj -> bool
  member GetHashCode : unit -> int
  member ToString : unit -> string

Full name: System.ValueType
val td : ('t -> unit) (requires value type and 't :> ValueType and default constructor)
val t : Nullable<'t> (requires value type and 't :> ValueType and default constructor)
Multiple items
type Nullable =
  static member Compare<'T> : n1:Nullable<'T> * n2:Nullable<'T> -> int
  static member Equals<'T> : n1:Nullable<'T> * n2:Nullable<'T> -> bool
  static member GetUnderlyingType : nullableType:Type -> Type

Full name: System.Nullable

--------------------
type Nullable<'T (requires default constructor and value type and 'T :> ValueType)> =
  struct
    new : value:'T -> Nullable<'T>
    member Equals : other:obj -> bool
    member GetHashCode : unit -> int
    member GetValueOrDefault : unit -> 'T + 1 overload
    member HasValue : bool
    member ToString : unit -> string
    member Value : 'T
  end

Full name: System.Nullable<_>

--------------------
Nullable()
Nullable(value: 'T) : unit
property Nullable.HasValue: bool
property Nullable.Value: 't
active recognizer FSharpList: TypeShape -> IShapeFSharpList option

Full name: TypeShape.Shape.( |FSharpList|_| )
val s : IShapeFSharpList
abstract member IShapeFSharpList.Accept : IFSharpListVisitor<'R> -> 'R
type IFSharpListVisitor<'R> =
  interface
    abstract member Visit : unit -> 'R
  end

Full name: TypeShape.IFSharpListVisitor<_>
val td : ('t -> unit)
val ts : 't list
type 'T list = List<'T>

Full name: Microsoft.FSharp.Collections.list<_>
val t : 't
active recognizer Array: TypeShape -> IShapeArray option

Full name: TypeShape.Shape.( |Array|_| )
val s : IShapeArray
property IShapeArray.Rank: int
abstract member IShapeArray.Accept : IArrayVisitor<'R> -> 'R
type IArrayVisitor<'R> =
  interface
    abstract member Visit : rank:int -> 'R
  end

Full name: TypeShape.IArrayVisitor<_>
val ts : 't []
active recognizer Tuple: TypeShape -> IShapeTuple option

Full name: TypeShape.Shape.( |Tuple|_| )
type ShapeTuple<'Tuple> =
  interface IShapeTuple
  private new : unit -> ShapeTuple<'Tuple>
  member CreateUninitialized : unit -> 'Tuple
  member CreateUninitializedExpr : unit -> Expr<'Tuple>
  member Elements : IShapeWriteMember<'Tuple> []
  member IsStructTuple : bool

Full name: TypeShape.ShapeTuple<_>
val shape : ShapeTuple<'T>
val elemDisposers : ('T -> unit) []
property ShapeTuple.Elements: IShapeWriteMember<'T> []
Multiple items
union case TypeShapeInfo.Array: element: Type * rank: int -> TypeShapeInfo

--------------------
type Array =
  member Clone : unit -> obj
  member CopyTo : array:Array * index:int -> unit + 1 overload
  member GetEnumerator : unit -> IEnumerator
  member GetLength : dimension:int -> int
  member GetLongLength : dimension:int -> int64
  member GetLowerBound : dimension:int -> int
  member GetUpperBound : dimension:int -> int
  member GetValue : [<ParamArray>] indices:int[] -> obj + 7 overloads
  member Initialize : unit -> unit
  member IsFixedSize : bool
  ...

Full name: System.Array
val map : mapping:('T -> 'U) -> array:'T [] -> 'U []

Full name: Microsoft.FSharp.Collections.Array.map
val d : ('T -> unit)
active recognizer FSharpRecord: TypeShape -> IShapeFSharpRecord option

Full name: TypeShape.Shape.( |FSharpRecord|_| )
type ShapeFSharpRecord<'Record> =
  interface IShapeFSharpRecord
  private new : unit -> ShapeFSharpRecord<'Record>
  member CreateUninitialized : unit -> 'Record
  member CreateUninitializedExpr : unit -> Expr<'Record>
  member Fields : IShapeWriteMember<'Record> []
  member IsStructRecord : bool

Full name: TypeShape.ShapeFSharpRecord<_>
val shape : ShapeFSharpRecord<'T>
val fieldDisposers : ('T -> unit) []
property ShapeFSharpRecord.Fields: IShapeWriteMember<'T> []
active recognizer FSharpUnion: TypeShape -> IShapeFSharpUnion option

Full name: TypeShape.Shape.( |FSharpUnion|_| )
type ShapeFSharpUnion<'U> =
  interface IShapeFSharpUnion
  private new : unit -> ShapeFSharpUnion<'U>
  member GetTag : caseName:string -> int
  member GetTag : union:'U -> int
  member GetTagExpr : union:Expr<'U> -> Expr<int>
  member IsStructUnion : bool
  member UnionCases : ShapeFSharpUnionCase<'U> []

Full name: TypeShape.ShapeFSharpUnion<_>
val shape : ShapeFSharpUnion<'T>
val fieldDisposers : ('T -> unit) [] []
property ShapeFSharpUnion.UnionCases: ShapeFSharpUnionCase<'T> []
val c : ShapeFSharpUnionCase<'T>
property ShapeFSharpUnionCase.Fields: IShapeWriteMember<'T> []
val tag : int
member ShapeFSharpUnion.GetTag : caseName:string -> int
member ShapeFSharpUnion.GetTag : union:'U -> int
val ignore : value:'T -> unit

Full name: Microsoft.FSharp.Core.Operators.ignore
Multiple items
type TypeCache =
  new : unit -> TypeCache
  private new : dict:ConcurrentDictionary<Type,obj> -> TypeCache
  member Clone : unit -> TypeCache
  member Commit : manager:RecTypeManager -> unit
  member ContainsKey : unit -> bool
  member ContainsKey : t:Type -> bool
  member CreateRecTypeManager : unit -> RecTypeManager
  member ForceAdd : value:'T -> unit
  member GetOrAdd : factory:(unit -> 'T) -> 'T
  member TryAdd : value:'T -> bool
  ...

Full name: TypeShape_Utils.TypeCache

--------------------
new : unit -> TypeCache
val dispose : t:'T -> unit

Full name: Script.dispose


 Performs a structural disposal of provided type
val mkDisposable : t:'T -> IDisposable

Full name: Script.mkDisposable


 Creates an IDisposable token that structurally disposes contents
Multiple items
type Disposable =
  interface IDisposable
  new : unit -> Disposable

Full name: Script.Disposable

--------------------
new : unit -> Disposable
val mutable counter : int
val id : int
namespace System.Threading
type Interlocked =
  static member Add : location1:int * value:int -> int + 1 overload
  static member CompareExchange : location1:int * value:int * comparand:int -> int + 6 overloads
  static member Decrement : location:int -> int + 1 overload
  static member Exchange : location1:int * value:int -> int + 6 overloads
  static member Increment : location:int -> int + 1 overload
  static member Read : location:int64 -> int64

Full name: System.Threading.Interlocked
Threading.Interlocked.Increment(location: byref<int64>) : int64
Threading.Interlocked.Increment(location: byref<int>) : int
override Disposable.Dispose : unit -> unit

Full name: Script.Disposable.Dispose
val printfn : format:Printf.TextWriterFormat<'T> -> 'T

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.printfn
val d : unit -> Disposable

Full name: Script.d
val test : unit -> unit

Full name: Script.test
val d : IDisposable
type Tree<'T> =
  | Leaf
  | Node of 'T * Tree<'T> * Tree<'T>

Full name: Script.Tree<_>
union case Tree.Leaf: Tree<'T>
union case Tree.Node: 'T * Tree<'T> * Tree<'T> -> Tree<'T>
Raw view New version

More information

Link:http://fssnip.net/7TL
Posted:2 months ago
Author:Eirik Tsarpalis
Tags: generic programming