3 people like it.

Universal Mutator

Defines a generic `mutate : 'T -> 'T` function that structurally mutates every value in the object graph, without performing new allocations. Needless to say, this is intended for educational purposes only.

 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: 
99: 
// I can haz F# 4.1?

open System
open TypeShape
open TypeShape_Utils
open FSharp.NativeInterop

// The Universal Mutator

type Mutator<'T> = 'T -> 'T

let rec mutate<'T> (t : 'T) : 'T =
    match cache.TryFind<Mutator<'T>> () with
    | Some m -> m t
    | None ->
        use ctx = cache.CreateRecTypeManager()
        mkMutatorCached<'T> ctx t

and private mkMutatorCached<'T> (ctx : RecTypeManager) : Mutator<'T> =
    match ctx.TryFind<Mutator<'T>> () with
    | Some m -> m
    | None ->
        let _ = ctx.CreateUninitialized<Mutator<'T>> (fun c f -> c.Value f)
        let m = mkMutator<'T> ctx
        ctx.Complete m

and private mkMutator<'T> (ctx : RecTypeManager) : Mutator<'T> =
    let EQ (input : Mutator<'a>) : Mutator<'T> = unbox input

    let mkMemberMutator (shape : IShapeWriteMember<'T>) =
        shape.Accept { new IWriteMemberVisitor<'T, Mutator<'T>> with
            member __.Visit (shape : ShapeWriteMember<'T, 'Field>) =
                let fmutator = mkMutatorCached<'Field> ctx
                fun input ->
                    let field = shape.Project input
                    let field' = fmutator field
                    shape.Inject input field' }

    match shapeof<'T> with
    | Shape.Bool -> EQ not
    | Shape.Byte -> EQ (fun x -> x + 1uy)
    | Shape.Int32 -> EQ (fun x -> x + 1)
    | Shape.Int64 -> EQ (fun x -> x + 1L)
    | Shape.Decimal -> EQ (fun x -> x + 1M)
    | Shape.String -> 
        fun (x:string) ->
            if isNull x then x else
            use fp = fixed x
            for i = 0 to x.Length - 1 do
                let c = NativePtr.get fp i
                NativePtr.set fp i (int c + 1 |> char)
            x
        |> EQ

    | Shape.Array s when s.Rank = 1 ->
        s.Accept { new IArrayVisitor<Mutator<'T>> with
            member __.Visit<'t> _ = // 't [] = 'T
                let em = mkMutatorCached<'t> ctx
                fun ts -> 
                    if isNull ts then ts else
                    for i = 0 to Array.length ts - 1 do ts.[i] <- em ts.[i]
                    ts
                |> EQ
        }

    | Shape.Poco (:? ShapePoco<'T> as shape) ->
        let isOpen = not typeof<'T>.IsSealed
        let fms = shape.Fields |> Array.map mkMemberMutator
        fun t ->
            if obj.ReferenceEquals(t,null) then t 
            elif isOpen && t.GetType() <> typeof<'T> then
                let sub = TypeShape.Create(t.GetType())
                sub.Accept 
                  { new ITypeShapeVisitor<'T> with 
                    member __.Visit<'t>() = mutate (unbox<'t> t) |> unbox }
            else
                let mutable t = t
                for fm in fms do t <- fm t
                t

    | _ -> id

and private cache : TypeCache = new TypeCache()


//-------------------------------
// Examples

let test<'T when 'T : not struct> (x : 'T) =
    let y = mutate x
    obj.ReferenceEquals(x,y), y

test "Hello, World"
test [1 .. 10]
test ([|1uy;5uy|], [Choice1Of2 true ; Choice2Of2 42])
test [|(1, [2;3], Some false)|]
test (Some ("1", 42, true))
test (set [1;2;3])
test (ref (42, struct(0, Some "test")))
namespace System
module TypeShape
module TypeShape_Utils
namespace Microsoft.FSharp
namespace Microsoft.FSharp.NativeInterop
type Mutator<'T> = 'T -> 'T

Full name: Script.Mutator<_>
val mutate : t:'T -> 'T

Full name: Script.mutate
val t : 'T
val private cache : TypeCache

Full name: Script.cache
member TypeCache.TryFind : unit -> 'T option
member TypeCache.TryFind : t:Type -> obj option
union case Option.Some: Value: 'T -> Option<'T>
val m : Mutator<'T>
union case Option.None: Option<'T>
val ctx : RecTypeManager
member TypeCache.CreateRecTypeManager : unit -> RecTypeManager
val private mkMutatorCached : ctx:RecTypeManager -> Mutator<'T>

Full name: Script.mkMutatorCached
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
member RecTypeManager.CreateUninitialized : delay:(Cell<'T> -> 'T) -> 'T
val c : Cell<Mutator<'T>>
val f : 'T
property Cell.Value: Mutator<'T>
val m : ('T -> 'T)
val private mkMutator : ctx:RecTypeManager -> Mutator<'T>

Full name: Script.mkMutator
member RecTypeManager.Complete : value:'T -> 'T
val EQ : (Mutator<'a> -> Mutator<'T>)
val input : Mutator<'a>
val unbox : value:obj -> 'T

Full name: Microsoft.FSharp.Core.Operators.unbox
val mkMemberMutator : (IShapeWriteMember<'T> -> Mutator<'T>)
val shape : IShapeWriteMember<'T>
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<'T,'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 fmutator : ('a -> 'a)
val input : 'T
val field : 'a
member ShapeMember.Project : instance:'DeclaringType -> 'MemberType
val field' : 'a
member ShapeWriteMember.Inject : instance:'DeclaringType -> field:'MemberType -> 'DeclaringType
val shapeof<'T> : TypeShape

Full name: TypeShape.shapeof
module Shape

from TypeShape
active recognizer Bool: TypeShape -> unit option

Full name: TypeShape.Shape.( |Bool|_| )
val not : value:bool -> bool

Full name: Microsoft.FSharp.Core.Operators.not
active recognizer Byte: TypeShape -> unit option

Full name: TypeShape.Shape.( |Byte|_| )
val x : byte
active recognizer Int32: TypeShape -> unit option

Full name: TypeShape.Shape.( |Int32|_| )
val x : int
active recognizer Int64: TypeShape -> unit option

Full name: TypeShape.Shape.( |Int64|_| )
val x : int64
active recognizer Decimal: TypeShape -> unit option

Full name: TypeShape.Shape.( |Decimal|_| )
val x : decimal
active recognizer String: TypeShape -> unit option

Full name: TypeShape.Shape.( |String|_| )
val x : string
Multiple items
val string : value:'T -> string

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

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

Full name: Microsoft.FSharp.Core.string
val isNull : value:'T -> bool (requires 'T : null)

Full name: Microsoft.FSharp.Core.Operators.isNull
val fp : nativeptr<char>
val i : int
property String.Length: int
val c : char
module NativePtr

from Microsoft.FSharp.NativeInterop
val get : address:nativeptr<'T> -> index:int -> 'T (requires unmanaged)

Full name: Microsoft.FSharp.NativeInterop.NativePtr.get
val set : address:nativeptr<'T> -> index:int -> value:'T -> unit (requires unmanaged)

Full name: Microsoft.FSharp.NativeInterop.NativePtr.set
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<_>
Multiple items
val char : value:'T -> char (requires member op_Explicit)

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

--------------------
type char = Char

Full name: Microsoft.FSharp.Core.char
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 em : ('t -> 't)
val ts : '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 length : array:'T [] -> int

Full name: Microsoft.FSharp.Collections.Array.length
active recognizer Poco: TypeShape -> IShapePoco option

Full name: TypeShape.Shape.( |Poco|_| )
type ShapePoco<'Poco> =
  interface IShapePoco
  private new : unit -> ShapePoco<'Poco>
  member CreateUninitialized : unit -> 'Poco
  member CreateUninitializedExpr : unit -> Expr<'Poco>
  member Constructors : IShapeConstructor<'Poco> []
  member Fields : IShapeWriteMember<'Poco> []
  member IsStruct : bool
  member Properties : IShapeMember<'Poco> []

Full name: TypeShape.ShapePoco<_>
val shape : ShapePoco<'T>
val isOpen : bool
val typeof<'T> : Type

Full name: Microsoft.FSharp.Core.Operators.typeof
val fms : ('T -> 'T) []
property ShapePoco.Fields: IShapeWriteMember<'T> []
val map : mapping:('T -> 'U) -> array:'T [] -> 'U []

Full name: Microsoft.FSharp.Collections.Array.map
type obj = Object

Full name: Microsoft.FSharp.Core.obj
Object.ReferenceEquals(objA: obj, objB: obj) : bool
Object.GetType() : Type
val sub : TypeShape
Multiple items
module TypeShape

--------------------
type TypeShape =
  private new : unit -> TypeShape
  abstract member Accept : ITypeShapeVisitor<'R> -> 'R
  abstract member ShapeInfo : TypeShapeInfo
  abstract member Type : Type
  override ToString : unit -> string
  static member Create : unit -> TypeShape<'T>
  static member Create : typ:Type -> TypeShape
  static member FromValue : obj:obj -> TypeShape

Full name: TypeShape.TypeShape

--------------------
type TypeShape<'T> =
  inherit TypeShape
  new : unit -> TypeShape<'T>
  override Accept : v:ITypeShapeVisitor<'a1> -> 'a1
  override Equals : o:obj -> bool
  override GetHashCode : unit -> int
  override ShapeInfo : TypeShapeInfo
  override Type : Type

Full name: TypeShape.TypeShape<_>

--------------------
new : unit -> TypeShape<'T>
static member TypeShape.Create : unit -> TypeShape<'T>
static member TypeShape.Create : typ:Type -> TypeShape
abstract member TypeShape.Accept : ITypeShapeVisitor<'R> -> 'R
type ITypeShapeVisitor<'R> =
  interface
    abstract member Visit : unit -> 'R
  end

Full name: TypeShape.ITypeShapeVisitor<_>
val mutable t : 'T
val fm : ('T -> 'T)
val id : x:'T -> 'T

Full name: Microsoft.FSharp.Core.Operators.id
Multiple items
type TypeCache =
  new : unit -> TypeCache
  member Commit : manager:RecTypeManager -> unit
  member CreateRecTypeManager : unit -> RecTypeManager
  member GetOrAdd : factory:(unit -> 'T) -> 'T
  member TryAdd : value:'T -> bool
  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.TypeCache

--------------------
new : unit -> TypeCache
val test : x:'T -> bool * 'T (requires reference type)

Full name: Script.test
val x : 'T (requires reference type)
val y : 'T (requires reference type)
union case Choice.Choice1Of2: 'T1 -> Choice<'T1,'T2>
union case Choice.Choice2Of2: 'T2 -> Choice<'T1,'T2>
val set : elements:seq<'T> -> Set<'T> (requires comparison)

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.set
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<_>
Raw view Test code New version

More information

Link:http://fssnip.net/7Tu
Posted:6 years ago
Author:Eirik Tsarpalis
Tags: counterexample , generic programming