Using delegate/DLR Lambdas to override instance methods? - f#

In an effort to learn F# and .Net, I've been playing around with the to-be-released DLR.
To that end, I've been playing around with reflection, in an effort to implement a basic type system that integrates nicely with the clr. While I'm able to instantiate a simple type that extends Object, I get an error when calling the method it defines.
Because at the end of the day DLR LambdaExpressions compile down to delegates, what I do is take generated MethodInfo off the generated delegate and call it, populating the stack with the args of the generated method. Then return it. It's at this point I get my error.
Here's my code:
open System
open System.Reflection
open System.Reflection.Emit
type ConstructorInformation=
{Types:System.Type array}
type MethodInformation=
{ParamTypes:System.Type array;
Name:string
Impl:System.Delegate}
let rec addConstructors (t:TypeBuilder) (baseType:System.Type) constructorInfos =
match constructorInfos with
|ci::rest ->
let cb = t.DefineConstructor(MethodAttributes.Public, CallingConventions.Standard,ci.Types)
let ilGen = cb.GetILGenerator()
ilGen.Emit(OpCodes.Ldarg_0)
Array.iteri (fun (index:int) _-> ilGen.Emit(OpCodes.Ldarg, index+1)) ci.Types
ilGen.Emit( OpCodes.Call, baseType.GetConstructor(ci.Types) )
addConstructors t baseType rest
|[] -> ()
let rec addMethods (tb:TypeBuilder) baseType methodInfos =
match methodInfos with
|mi::rest ->
let mb = tb.DefineMethod(mi.Name, MethodAttributes.Public, typeof<obj>, mi.ParamTypes)
let ilGen = mb.GetILGenerator()
ilGen.Emit(OpCodes.Ldarg_0)
Array.iteri (fun index _ -> ilGen.Emit(OpCodes.Ldarg, index+1)) mi.ParamTypes
ilGen.EmitCall(OpCodes.Call, mi.Impl.Method, mi.ParamTypes)
ilGen.Emit(OpCodes.Ret)
addMethods tb baseType rest
|[] -> ()
let defineType (baseType:System.Type) constructorInfos methodInfos=
let ab = AppDomain.CurrentDomain.DefineDynamicAssembly( AssemblyName("test"), AssemblyBuilderAccess.Run)
let mb = ab.DefineDynamicModule("test")
let typeBuilder = mb.DefineType("testType", TypeAttributes.Public, baseType)// | TypeAttributes.Class
addConstructors typeBuilder baseType constructorInfos
addMethods typeBuilder baseType methodInfos
typeBuilder.CreateType()
type Delegate1 = delegate of obj -> obj
let echo y:#obj= (y :> obj)
let del1 : Delegate1 = new Delegate1(echo)
let mis:MethodInformation list=[{Impl=del1; Name="Echo"; ParamTypes=[|(typeof<obj>)|]}]
let cis:ConstructorInformation list=[]
let t= defineType (typeof<obj>) cis mis
let cinfo = t.GetConstructor([||])
let instance =cinfo.Invoke([||])
instance.GetType()
(t.GetMethod("Echo")).Invoke(instance, [| (1:>obj)|])
Here's my error, from fsi:
System.Reflection.TargetInvocationException: Exception has been thrown by the target of an invocation. ---> System.MethodAccessException: clo#51.Invoke(System.Object)
at testType.Echo(Object )
--- End of inner exception stack trace ---
at System.RuntimeMethodHandle._InvokeMethodFast(Object target, Object[] arguments, SignatureStruct& sig, MethodAttributes methodAttributes, RuntimeTypeHandle typeOwner)
at System.RuntimeMethodHandle.InvokeMethodFast(Object target, Object[] arguments, Signature sig, MethodAttributes methodAttributes, RuntimeTypeHandle typeOwner)
at System.Reflection.RuntimeMethodInfo.Invoke(Object obj, BindingFlags invokeAttr, Binder binder, Object[] parameters, CultureInfo culture, Boolean skipVisibilityChecks)
at System.Reflection.RuntimeMethodInfo.Invoke(Object obj, BindingFlags invokeAttr, Binder binder, Object[] parameters, CultureInfo culture)
at <StartupCode$FSI_0002>.$FSI_0002._main()
stopped due to error
Any help or suggestions would be appreciated-I'm a bit of a .Net newb so my mistake may be simple.
Mike Kohout

Well, I solved it. The generated cil was bad. Also, I had to dynamicinvoke on the delegate, not the function it was fronting.
#light
open System
open System.Reflection
open System.Reflection.Emit
type ConstructorInformation=
{Types:System.Type array}
type MethodInformation=
{ParamTypes:System.Type array;
Name:string;
Impl:System.Delegate;
mutable Field:FieldBuilder option}
let rec addConstructors (t:TypeBuilder) (baseType:System.Type) constructorInfos =
match constructorInfos with
|ci::rest ->
let cb = t.DefineConstructor(MethodAttributes.Public, CallingConventions.Standard,ci.Types)
let ilGen = cb.GetILGenerator()
ilGen.Emit(OpCodes.Ldarg_0)
Array.iteri (fun (index:int) _-> ilGen.Emit(OpCodes.Ldarg, index+1)) ci.Types
ilGen.Emit( OpCodes.Call, baseType.GetConstructor(ci.Types) )
addConstructors t baseType rest
|[] -> ()
let rec addMethods (tb:TypeBuilder) baseType methodInfos =
match methodInfos with
|mi::rest ->
let fb = tb.DefineField(mi.Name+"_field", typeof<Delegate>, FieldAttributes.Public);
mi.Field <- Some(fb)
let mb = tb.DefineMethod(mi.Name, MethodAttributes.Public, typeof<obj>, mi.ParamTypes)
let ilGen = mb.GetILGenerator()
let arrayLocal = ilGen.DeclareLocal((typeof<obj[]>))
ilGen.Emit(OpCodes.Ldarg_0)
ilGen.Emit(OpCodes.Ldfld, fb)
ilGen.Emit(OpCodes.Ldc_I4, Array.length mi.ParamTypes)
ilGen.Emit(OpCodes.Newarr, typeof<obj>)
ilGen.Emit(OpCodes.Stloc, arrayLocal)
ilGen.Emit(OpCodes.Ldloc, arrayLocal)
Array.iteri (fun index _ -> ilGen.Emit(OpCodes.Ldc_I4, index)
ilGen.Emit(OpCodes.Ldarg, index+1)
ilGen.Emit(OpCodes.Stelem_Ref)
ilGen.Emit(OpCodes.Ldloc, arrayLocal)) mi.ParamTypes
ilGen.EmitCall(OpCodes.Callvirt, (mi.Impl.GetType()).GetMethod("DynamicInvoke", [|(typeof<obj[]>)|]), mi.ParamTypes)
ilGen.Emit(OpCodes.Ret)
addMethods tb baseType rest
|[] -> ()
let defineType (baseType:System.Type) constructorInfos methodInfos=
let ab = AppDomain.CurrentDomain.DefineDynamicAssembly( AssemblyName("test"), AssemblyBuilderAccess.Run)
let mb = ab.DefineDynamicModule("test")
let typeBuilder = mb.DefineType("testType", TypeAttributes.Public, baseType)// | TypeAttributes.Class
addConstructors typeBuilder baseType constructorInfos
addMethods typeBuilder baseType methodInfos
typeBuilder.CreateType()
type Delegate1 = delegate of obj -> obj
let echo y:#obj= (y :> obj)
let del1 : Delegate1 = new Delegate1(echo)
type Delegate2 = delegate of obj * obj -> obj
let echoFirst (x:#obj) (y:#obj)=(x:>obj)
let echoFirstDelegate:Delegate2 = new Delegate2(echoFirst)
echoFirstDelegate.DynamicInvoke( [|(1:>obj);(2:>obj)|])
//let mis:MethodInformation list=[{Impl=del1; Name="Echo"; ParamTypes=[|(typeof<obj>)|];Field=None}]
//let cis:ConstructorInformation list=[]
//let t= defineType (typeof<obj>) cis mis
//let cinfo = t.GetConstructor([||])
//let instance =cinfo.Invoke([||])
//instance.GetType()
//(t.GetField("Echo_field")).SetValue(instance, del1)
//let fieldDelegate = (t.GetField("Echo_field")).GetValue(instance) :?> Delegate
//(t.GetMethod("Echo")).Invoke(instance, [| (1:>obj)|])
//del1.DynamicInvoke( [|(1:>obj)|])
let mis:MethodInformation list=[{Impl=del1; Name="Echo"; ParamTypes=[|(typeof<obj>)|];Field=None};
{Impl=echoFirstDelegate; Name="EchoFirst"; ParamTypes=[| (typeof<obj>);(typeof<obj>)|]; Field=None}]
let cis:ConstructorInformation list=[]
let t= defineType (typeof<obj>) cis mis
let cinfo = t.GetConstructor([||])
let instance =cinfo.Invoke([||])
instance.GetType()
(t.GetField("Echo_field")).SetValue(instance, del1)
let fieldDelegate = (t.GetField("Echo_field")).GetValue(instance) :?> Delegate
(t.GetMethod("Echo")).Invoke(instance, [| (1:>obj)|])
(t.GetField("EchoFirst_field")).SetValue(instance, echoFirstDelegate)
(t.GetMethod("EchoFirst")).Invoke(instance, [| (1:>obj);(2:>obj)|])

Related

Implementing Tagless Final Encoding in F# with SRTP

I'd like to transform my F# OOP version of Tagless Final into a typical FP approach and I'm thinking to use Statically Resolved Type Parameters of Type Classes from OO.
What I've done is
open System
open FSharpPlus
type UserName = string
type DataResult<'t> = DataResult of 't with
static member Map ( x:DataResult<'t> , f) =
match x with
| DataResult t -> DataResult (f t)
creating the SRTP I need
type Cache =
static member inline getOfCache cacheImpl data =
( ^T : (member getFromCache : 't -> DataResult<'t> option) (cacheImpl, data))
static member inline storeOfCache cacheImpl data =
( ^T : (member storeToCache : 't -> unit) (cacheImpl, data))
type DataSource() =
static member inline getOfSource dataSourceImpl data =
( ^T : (member getFromSource : 't -> DataResult<'t>) (dataSourceImpl, data))
static member inline storeOfSource dataSourceImpl data =
( ^T : (member storeToSource : 't -> unit) (dataSourceImpl, data))
and their concrete implementations
type CacheNotInCache() =
member this.getFromCache _ = None
member this.storeCache _ = ()
type CacheInCache() =
member this.getFromCache user = monad {
return! DataResult user |> Some}
member this.storeCache _ = ()
type DataSourceNotInCache() =
member this.getFromSource user = monad {
return! DataResult user }
type DataSourceInCache() =
member this.getFromSource _ =
raise (NotImplementedException())
by which I can define a tagless final DSL
let requestData (cacheImpl: ^Cache) (dataSourceImpl: ^DataSource) (userName:UserName) = monad {
match Cache.getOfCache cacheImpl userName with
| Some dataResult ->
return! map ((+) "cache: ") dataResult
| None ->
return! map ((+) "source: ") (DataSource.getOfSource dataSourceImpl userName) }
and that kind of works as follows
[<EntryPoint>]
let main argv =
let cacheImpl1 = CacheInCache()
let dataSourceImpl1 = DataSourceInCache()
let cacheImpl2 = CacheNotInCache()
let dataSourceImpl2 = DataSourceNotInCache()
requestData cacheImpl1 dataSourceImpl1 "john" |> printfn "%A"
//requestData (cacheImpl2 ) dataSourceImpl2 "john" |> printfn "%A"
0
The problem is that I'm getting the warning
construct causes code to be less generic than indicated by the type
annotations
for both cacheImpl1 and dataSourceImpl1 and so I can't reuse requestData for the other case.
Is there a way to detour this issue?
I'm not familiar with the abstraction you're trying to implement, but looking at your code it seems you're missing an inline modifier here:
let inline requestData (cacheImpl: ^Cache) (dataSourceImpl: ^DataSource) (userName:UserName) = monad {
match Cache.getOfCache cacheImpl userName with
| Some dataResult ->
return! map ((+) "cache: ") dataResult
| None ->
return! map ((+) "source: ") (DataSource.getOfSource dataSourceImpl userName) }
As a side note, you can simplify your map function like this:
type DataResult<'t> = DataResult of 't with
static member Map (DataResult t, f) = DataResult (f t)
I am familiar with final tagless, but I'm not sure why you would use SRTPs.
Final tagless uses type classes, and these can be emulated with interfaces (see the way scala emulates typeclasses).
The approach is similar to (basically the same) as "object algebra", which can be implemented using standard OO constructs.

How to convert a sequence of Task<MyType> to a sequence of MyType

So I currently have a sequence of type seq<System.Threading.Tasks.Task<Restaurant>> and I want to turn it into a sequence of type seq<Restaurant>.
I'm currently using TaskBuilder.fs library and from my research, I need to use either let! or do! for this situation but they require task {} which when used with Seq.map bring back the same Task type.
let joinWithReviews (r : Restaurant) =
task {
let! reviewResult = Reviews.Database.getByLocationId cnf.connectionString r.Restaurant_Id
match reviewResult with
| Ok reviewResult ->
let restaurant = { r with Reviews = (List.ofSeq reviewResult)}
return restaurant
| Error ex ->
return raise ex
}
let indexAction (ctx : HttpContext) =
task {
let (cnf:Config) = Controller.getConfig ctx
let! result = Restaurants.Database.getAll cnf.connectionString
match result with
| Ok result ->
let restaurantWithReviews = (Seq.map joinWithReviews result)
return index ctx (List.ofSeq restaurantWithReviews)
| Error ex ->
return raise ex
}
So my result is of type Seq<Restaurant> and I need to add reviews to each restaurant so I use Seq.map to get restaurantWithReviews which is type seq<System.Threading.Tasks.Task<Restaurant>> which I won't be able to use.
The .NET method System.Threading.Tasks.Task.WhenAll will convert seq<Task<'a>> to Task<'a[]>. You can get the result with let! if you're inside a task { } block.
let restaurants: seq<Restaurant>
let! withReviews: Restaurant[] =
restaurants
|> Seq.map joinWithReviews
|> Task.WhenAll

Reflecting let bindings in a module by attribute and type

I am trying to find let bindings with a specific attribute and type, throughout a given assembly.
For instance, the following type and attribute:
type TargetType = { somedata: string }
type MarkingAttribute() = inherit System.Attribute()
Then I would like to find the value in the following module:
module SomeModule =
[<Marking>]
let valueIWantToFind = {somedata = "yoyo"}
So what I am looking for is a function with the following signature (assuming it is suitable for a generic function signature):
let valuesOfTypeWithAttribute<'t,'attr> (assembly: Assembly) : 't list = ...
My futile attempts seem to be blocked by my lack of understanding how F# modules are translated to CLR (CLI?) classes.
I have the following FSI snippet which unfortunately finds nothing:
open System.Reflection
let types = Assembly.GetExecutingAssembly().GetTypes()
let fiWithAttribute (attributeType: System.Type) (fi: FieldInfo) =
fi.CustomAttributes
|> Seq.exists (fun attr -> attr.AttributeType = attributeType)
let fields =
types
|> Array.collect (fun t -> t.GetFields())
|> Array.filter (fiWithAttribute typeof<MarkingAttribute>)
Any help or pointers will be greatly appreciated.
Modules are compiled as classes with static members. Load your assembly into a value called assembly, and start to investigate:
> let publicTypes = assembly.GetExportedTypes ();;
val publicTypes : System.Type [] =
[|Ploeh.StackOverflow.Q36245870.TargetType;
Ploeh.StackOverflow.Q36245870.MarkingAttribute;
Ploeh.StackOverflow.Q36245870.SomeModule|]
As you can tell, SomeModule is one of those types:
> let someModule =
publicTypes |> Array.find (fun t -> t.Name.EndsWith "SomeModule");;
val someModule : System.Type = Ploeh.StackOverflow.Q36245870.SomeModule
You can now get all members of the type:
> let members = someModule.GetMembers ();;
val members : MemberInfo [] =
[|Ploeh.StackOverflow.Q36245870.TargetType get_valueIWantToFind();
System.String ToString(); Boolean Equals(System.Object);
Int32 GetHashCode(); System.Type GetType();
Ploeh.StackOverflow.Q36245870.TargetType valueIWantToFind|]
This array includes the let-bound function valueIWantToFind, and it has the desired attribute:
> let attrs = members.[5].GetCustomAttributes ();;
val attrs : System.Collections.Generic.IEnumerable<System.Attribute> =
[|Ploeh.StackOverflow.Q36245870.MarkingAttribute;
Microsoft.FSharp.Core.CompilationMappingAttribute|]
Mark's response led me onto the path of success. The reflection does not work for modules defined entirely in FSI (at least not for me in my setup).
The function I came up with looks like this:
open Microsoft.FSharp.Reflection
let letBindingsWithTypeAndAttribute<'t,'attr> (assembly: Assembly) : 't array =
let publicTypes = assembly.GetExportedTypes ()
let modules = publicTypes |> Array.filter FSharpType.IsModule
let members = modules |> Array.collect (fun m -> m.GetMembers ())
let miHasAttribute (mi : MemberInfo) =
mi.GetCustomAttributes ()
|> Seq.exists (fun attr' -> attr'.GetType() = typeof<'attr>)
let withAttr =
members
|> Array.filter miHasAttribute
let valueOfBinding (mi : MemberInfo) =
let property = mi.Name
mi.DeclaringType.GetProperty(property).GetValue null
withAttr
|> Array.map valueOfBinding
|> Array.choose (fun o -> match o with
| :? 't as x -> Some x
| _ -> None)

this expression was expected to have type IDataReader but here has type SqlDataReader

The following code is not casting my return value of SqlDataReader from getReader correctly to IDataReaderin the call to Seq.unfold. What am I doing wrong?
open System.Data
open System.Data.SqlClient
open System.Configuration
type Foo = { id:int; name:string }
let populateFoo (r:IDataReader) =
let o = r.GetOrdinal
{ id = o "id" |> r.GetInt32; name = o "name" |> r.GetString; }
let iter populateObject (r:IDataReader) =
match r.Read() with
| true -> Some(populateObject r, r)
| _ -> None
let iterFoo = iter populateFoo
let getReader : IDataReader =
let cnstr = ConfigurationManager.ConnectionStrings.["db"].ConnectionString
let cn = new SqlConnection(cnstr)
let cmd = new SqlCommand("select * from Foo", cn)
cmd.ExecuteReader()
let foos = Seq.unfold iterFoo getReader
F# does not automatic upcasting like C#, except in some specific scenarios (see the spec, section 14.4.2).
You have to explicitly cast the expression: cmd.ExecuteReader() :> IDataReader then you can remove the type annotation after getReader.
Alternatively you may leave that function returning an SqlDataReader and upcast at the call site:
let foos = getReader :> IDataReader |> Seq.unfold iterFoo
If unfold was a static member of a type with a signature like this one:
type T() =
static member unfold(a, b:IDataReader) = Seq.unfold a b
you would be able to do directly T.unfold(iterFoo, getReader) and it will automatically upcast. That's one of the cases mentioned in the spec.

Time to live memoization in F#

Not sure if I got this right or whether there's a better way or an existing library solving this problem already.
In particular I'm not sure if the CAS would need a memory fence... I think not but better ask.
I also tried with an agent and mutable dictionary but my intuition that it would be slower was confirmed and the implementation was more involved.
module CAS =
open System.Threading
let create (value: 'T) =
let cell = ref value
let get () = !cell
let rec swap f =
let before = get()
let newValue = f before
match Interlocked.CompareExchange<'T>(cell, newValue, before) with
| result when obj.ReferenceEquals(before, result) ->
newValue
| _ ->
swap f
get, swap
module Memoization =
let timeToLive milis f =
let get, swap = CAS.create Map.empty
let evict key =
async {
do! Async.Sleep milis
swap (Map.remove key) |> ignore
} |> Async.Start
fun key ->
let data = get()
match data.TryFind key with
| Some v -> v
| None ->
let v = f key
swap (Map.add key v) |> ignore
evict key
v
If you are willing to limit what to memoize to functions that take a string input, you can reuse the functionality from System.Runtime.Caching.
This should be reasonably robust as part of the core library (you would hope...) but the string limitation is a pretty heavy one and you'd have to benchmark against your current implementation if you want to do a comparison on performance.
open System
open System.Runtime.Caching
type Cached<'a>(func : string -> 'a, cache : IDisposable) =
member x.Func : string -> 'a = func
interface IDisposable with
member x.Dispose () =
cache.Dispose ()
let cache timespan (func : string -> 'a) =
let cache = new MemoryCache(typeof<'a>.FullName)
let newFunc parameter =
match cache.Get(parameter) with
| null ->
let result = func parameter
let ci = CacheItem(parameter, result :> obj)
let cip = CacheItemPolicy()
cip.AbsoluteExpiration <- DateTimeOffset(DateTime.UtcNow + timespan)
cip.SlidingExpiration <- TimeSpan.Zero
cache.Add(ci, cip) |> ignore
result
| result ->
(result :?> 'a)
new Cached<'a>(newFunc, cache)
let cacheAsync timespan (func : string -> Async<'a>) =
let cache = new MemoryCache(typeof<'a>.FullName)
let newFunc parameter =
match cache.Get(parameter) with
| null ->
async {
let! result = func parameter
let ci = CacheItem(parameter, result :> obj)
let cip = CacheItemPolicy()
cip.AbsoluteExpiration <- DateTimeOffset(DateTime.UtcNow + timespan)
cip.SlidingExpiration <- TimeSpan.Zero
cache.Add(ci, cip) |> ignore
return result
}
| result ->
async { return (result :?> 'a) }
new Cached<Async<'a>>(newFunc, cache)
Usage:
let getStuff =
let cached = cacheAsync (TimeSpan(0, 0, 5)) uncachedGetStuff
// deal with the fact that the cache is IDisposable here
// however is appropriate...
cached.Func
If you're never interested in accessing the underlying cache directly you can obviously just return a new function with the same signature of the old - but given the cache is IDisposable, that seemed unwise.
I think in many ways I prefer your solution, but when I faced a similar problem I had a perverse thought that I should really use the built in stuff if I could.

Resources