1 people like it.

Generic map

A generic map using TypeShape

  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: 
100: 
101: 
102: 
103: 
104: 
105: 
106: 
107: 
108: 
109: 
110: 
open System
open TypeShape
open TypeShape_Utils

// Generic map implementation that updates all occurences
// of a given type inside a value

type GMapper<'E, 'T> = ('E -> 'E) -> ('T -> 'T)

let rec gmap<'E, 'T> (mapper : 'E -> 'E) : 'T -> 'T =
    match cache.TryFind<GMapper<'E, 'T>> () with
    | Some m -> m mapper
    | None ->
        use ctx = cache.CreateRecTypeManager()
        gmapCached<'E, 'T> ctx mapper

and private gmapCached<'E, 'T> (ctx : RecTypeManager) : GMapper<'E, 'T> =
    match ctx.TryFind<GMapper<'E, 'T>> () with
    | Some m -> m
    | None ->
        let _ = ctx.CreateUninitialized<GMapper<'E, 'T>> (fun c f -> c.Value f)
        let m = gmapAux<'E, 'T> ctx
        ctx.Complete m

and private gmapAux<'E, 'T> (ctx : RecTypeManager) : GMapper<'E, 'T> =
    let EQ (input : GMapper<'E, 'a>) : GMapper<'E, 'T> = unbox input

    let gmapMember (shape : IShapeWriteMember<'Class>) =
        shape.Accept { new IWriteMemberVisitor<'Class, ('E -> 'E) -> 'Class -> 'Class -> 'Class> with
            member __.Visit (shape : ShapeWriteMember<'Class, 'Field>) =
                let fMapper = gmapCached<'E, 'Field> ctx
                fun mapper source target ->
                    let field = shape.Project source
                    let field' = fMapper mapper field
                    shape.Inject target field'
        }

    match shapeof<'T> :> TypeShape with
    | :? TypeShape<'E> -> EQ id<'E -> 'E>
    | Shape.Primitive
    | Shape.String
    | Shape.Guid
    | Shape.Decimal
    | Shape.DateTime
    | Shape.DateTimeOffset -> EQ (fun _ -> id<'T>)
    | Shape.FSharpOption s ->
        s.Accept { new IFSharpOptionVisitor<GMapper<'E, 'T>> with
            member __.Visit<'t> () = // 't option = 'T
                let em = gmapCached<'E, 't> ctx
                EQ(fun f -> Option.map (em f))
        }

    | Shape.Array s when s.Rank = 1 ->
        s.Accept { new IArrayVisitor<GMapper<'E, 'T>> with
            member __.Visit<'t> _ = // 't [] = 'T
                let em = gmapCached<'E, 't> ctx
                EQ(fun f -> Array.map (em f))
        }

    | Shape.FSharpList s ->
        s.Accept { new IFSharpListVisitor<GMapper<'E, 'T>> with
            member __.Visit<'t> () = // 't list = 'T
                let em = gmapCached<'E, 't> ctx
                EQ(fun f -> List.map (em f))
        }

    | Shape.Tuple (:? ShapeTuple<'T> as shape) ->
        let ems = shape.Elements |> Array.map gmapMember
        fun mapper source ->
            let mutable target = shape.CreateUninitialized()
            for em in ems do target <- em mapper source target
            target

    | Shape.FSharpRecord (:? ShapeFSharpRecord<'T> as shape) ->
        let fms = shape.Fields |> Array.map gmapMember
        fun mapper source ->
            let mutable target = shape.CreateUninitialized()
            for fm in fms do target <- fm mapper source target
            target

    | Shape.FSharpUnion (:? ShapeFSharpUnion<'T> as shape) ->
        let caseMappers = 
            shape.UnionCases 
            |> Array.map (fun case -> case, case.Fields |> Array.map gmapMember)

        fun mapper source ->
            let tag = shape.GetTag source
            let case, mappers = caseMappers.[tag]
            let mutable target = case.CreateUninitialized()
            for fm in mappers do target <- fm mapper source target
            target
        
    | _ -> failwithf "Unsupported type '%O'" typeof<'T>

and private cache : TypeCache = new TypeCache()


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

gmap ((+) 1) (Some [| [1 .. 10] |], 1, ("foo", 3, (5,Some 6)))

type Person = { Name : string ; Age : int ; Address : string }

let value =
    [ { Name = "george" ; Age = 31 ; Address = "Dublin" } ;
      { Name = "john" ; Age = 40; Address = "8th Avenue" } ;
      { Name = "Paul" ; Age = 74; Address = "England" } ]

gmap (fun (s:string) -> s.ToUpper()) value
namespace System
module TypeShape
module TypeShape_Utils
type GMapper<'E,'T> = ('E -> 'E) -> 'T -> 'T

Full name: Script.GMapper<_,_>
val gmap : mapper:('E -> 'E) -> ('T -> 'T)

Full name: Script.gmap
val mapper : ('E -> 'E)
val private cache : TypeCache

Full name: Script.cache
member TypeCache.TryFind : unit -> 'T option
union case Option.Some: Value: 'T -> Option<'T>
val m : GMapper<'E,'T>
union case Option.None: Option<'T>
val ctx : RecTypeManager
member TypeCache.CreateRecTypeManager : unit -> RecTypeManager
val private gmapCached : ctx:RecTypeManager -> GMapper<'E,'T>

Full name: Script.gmapCached
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 private ParentCache : TypeCache option

Full name: TypeShape_Utils.RecTypeManager

--------------------
new : unit -> RecTypeManager
member RecTypeManager.TryFind : unit -> 'T option
member RecTypeManager.CreateUninitialized : delay:(Cell<'T> -> 'T) -> 'T
val c : Cell<GMapper<'E,'T>>
val f : ('E -> 'E)
property Cell.Value: GMapper<'E,'T>
val m : (('E -> 'E) -> 'T -> 'T)
val private gmapAux : ctx:RecTypeManager -> GMapper<'E,'T>

Full name: Script.gmapAux
member RecTypeManager.Complete : value:'T -> 'T
val EQ : (GMapper<'E,'a> -> GMapper<'E,'T>)
val input : GMapper<'E,'a>
val unbox : value:obj -> 'T

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

Full name: TypeShape.IShapeWriteMember<_>
Multiple items
type ClassAttribute =
  inherit Attribute
  new : unit -> ClassAttribute

Full name: Microsoft.FSharp.Core.ClassAttribute

--------------------
new : unit -> ClassAttribute
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<'Class,'a>
type ShapeWriteMember<'DeclaringType,'MemberType> =
  interface IShapeWriteMember<'DeclaringType>
  interface IShapeMember<'DeclaringType>
  private new : label:string * memberInfo:MemberInfo * path:MemberInfo [] * readOnly:ShapeMember<'DeclaringType,'MemberType> -> ShapeWriteMember<'DeclaringType,'MemberType>
  member Inject : instance:'DeclaringType -> field:'MemberType -> 'DeclaringType
  member InjectExpr : instance:Expr<'DeclaringType> -> field:Expr<'MemberType> -> Expr<'DeclaringType>
  member Project : instance:'DeclaringType -> 'MemberType
  member ProjectExpr : instance:Expr<'DeclaringType> -> Expr<'MemberType>
  member IsPublic : bool
  member IsStructMember : bool
  member Label : string
  ...

Full name: TypeShape.ShapeWriteMember<_,_>
val fMapper : (('E -> 'E) -> 'a -> 'a)
val source : 'Class
val target : 'Class
val field : 'a
member ShapeWriteMember.Project : instance:'DeclaringType -> 'MemberType
val field' : 'a
member ShapeWriteMember.Inject : instance:'DeclaringType -> field:'MemberType -> 'DeclaringType
val shapeof<'T> : TypeShape<'T>

Full name: TypeShape.shapeof
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

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>
val id : x:'T -> 'T

Full name: Microsoft.FSharp.Core.Operators.id
module Shape

from TypeShape
active recognizer Primitive: TypeShape -> unit option

Full name: TypeShape.Shape.( |Primitive|_| )
active recognizer String: TypeShape -> unit option

Full name: TypeShape.Shape.( |String|_| )
active recognizer Guid: TypeShape -> unit option

Full name: TypeShape.Shape.( |Guid|_| )
active recognizer Decimal: TypeShape -> unit option

Full name: TypeShape.Shape.( |Decimal|_| )
active recognizer DateTime: TypeShape -> unit option

Full name: TypeShape.Shape.( |DateTime|_| )
active recognizer DateTimeOffset: TypeShape -> unit option

Full name: TypeShape.Shape.( |DateTimeOffset|_| )
active recognizer FSharpOption: TypeShape -> IShapeFSharpOption option

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

Full name: TypeShape.IFSharpOptionVisitor<_>
val em : (('E -> 'E) -> 't -> 't)
module Option

from Microsoft.FSharp.Core
val map : mapping:('T -> 'U) -> option:'T option -> 'U option

Full name: Microsoft.FSharp.Core.Option.map
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<_>
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
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<_>
Multiple items
module List

from Microsoft.FSharp.Collections

--------------------
type List<'T> =
  | ( [] )
  | ( :: ) of Head: 'T * Tail: 'T list
  interface IEnumerable
  interface IEnumerable<'T>
  member GetSlice : startIndex:int option * endIndex:int option -> 'T list
  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 map : mapping:('T -> 'U) -> list:'T list -> 'U list

Full name: Microsoft.FSharp.Collections.List.map
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> []

Full name: TypeShape.ShapeTuple<_>
val shape : ShapeTuple<'T>
val ems : (('E -> 'E) -> 'T -> 'T -> 'T) []
property ShapeTuple.Elements: IShapeWriteMember<'T> []
val source : 'T
val mutable target : 'T
member ShapeTuple.CreateUninitialized : unit -> 'Tuple
val em : (('E -> 'E) -> 'T -> 'T -> 'T)
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> []

Full name: TypeShape.ShapeFSharpRecord<_>
val shape : ShapeFSharpRecord<'T>
val fms : (('E -> 'E) -> 'T -> 'T -> 'T) []
property ShapeFSharpRecord.Fields: IShapeWriteMember<'T> []
member ShapeFSharpRecord.CreateUninitialized : unit -> 'Record
val fm : (('E -> 'E) -> 'T -> 'T -> '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 UnionCases : ShapeFSharpUnionCase<'U> []

Full name: TypeShape.ShapeFSharpUnion<_>
val shape : ShapeFSharpUnion<'T>
val caseMappers : (ShapeFSharpUnionCase<'T> * (('E -> 'E) -> 'T -> 'T -> 'T) []) []
property ShapeFSharpUnion.UnionCases: ShapeFSharpUnionCase<'T> []
val case : ShapeFSharpUnionCase<'T>
property ShapeFSharpUnionCase.Fields: IShapeWriteMember<'T> []
val tag : int
member ShapeFSharpUnion.GetTag : caseName:string -> int
member ShapeFSharpUnion.GetTag : union:'U -> int
val mappers : (('E -> 'E) -> 'T -> 'T -> 'T) []
member ShapeFSharpUnionCase.CreateUninitialized : unit -> 'Union
val failwithf : format:Printf.StringFormat<'T,'Result> -> 'T

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.failwithf
val typeof<'T> : Type

Full name: Microsoft.FSharp.Core.Operators.typeof
Multiple items
type TypeCache =
  new : unit -> TypeCache
  member Commit : manager:RecTypeManager -> unit
  member CreateRecTypeManager : unit -> RecTypeManager
  member TryAdd : value:'T -> bool
  member TryFind : unit -> 'T option
  member TryGetValue : result:byref<'T> -> bool

Full name: TypeShape_Utils.TypeCache

--------------------
new : unit -> TypeCache
type Person =
  {Name: string;
   Age: int;
   Address: string;}

Full name: Script.Person
Person.Name: string
Multiple items
val string : value:'T -> string

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

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

Full name: Microsoft.FSharp.Core.string
Person.Age: int
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<_>
Person.Address: string
val value : Person list

Full name: Script.value
val s : string
String.ToUpper() : string
String.ToUpper(culture: Globalization.CultureInfo) : string
Raw view Test code New version

More information

Link:http://fssnip.net/7RL
Posted:7 years ago
Author:Eirik Tsarpalis
Tags: generic programming