Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
netcore compatible `GetUnionFields`
open System
open System.Reflection
type CLIArguments =
| Working_Directory of string
| Listener of host:string * port:int
| Data of byte []
| Port of int
| Log_Level of int
| Detach
override self.ToString () = self |> function
| Working_Directory _ -> "Working Directory"
| Listener _ -> "Listener"
| Data _ -> "Data"
| Port _ -> "Port"
| Log_Level _ -> "Log Level"
| Detach -> "Detatch"
let emptyArray arr = (Array.length arr = 0)
let nonEmptyArray arr = Array.length arr > 0
let inline checkNonNull argName (v: 'T) =
match box v with
| null -> nullArg argName
| _ -> ()
let isNamedType(typ:TypeInfo) = not (typ.IsArray || typ.IsByRef || typ.IsPointer)
let equivHeadTypes (ty1:TypeInfo) (ty2:TypeInfo) =
isNamedType(ty1) &&
if ty1.IsGenericType then
ty2.IsGenericType && (ty1.GetGenericTypeDefinition()).Equals(ty2.GetGenericTypeDefinition())
else
ty1.Equals(ty2)
let option = typedefof<obj option>
let func = typedefof<(obj -> obj)>
let isOptionType typ = equivHeadTypes typ (typeof<int option>.GetTypeInfo())
let isFunctionType typ = equivHeadTypes typ (typeof<(int -> int)>.GetTypeInfo())
let isListType typ = equivHeadTypes typ (typeof<int list>.GetTypeInfo())
let hasInstancePropertyFlags (t:TypeInfo) = t.DeclaredProperties |> Seq.length > 0
let hasStaticPropertyFlags (t:TypeInfo) = t.DeclaredProperties |> Seq.length > 0
let hasStaticFieldFlags (t:TypeInfo) = t.DeclaredFields |> Seq.length > 0
let hasStaticMethodFlags (t:TypeInfo) = t.DeclaredMethods |> Seq.length > 0
let cmaName = typeof<CompilationMappingAttribute>.FullName
let assemblyName = typeof<CompilationMappingAttribute>.GetTypeInfo().Assembly.GetName().Name
let getInstancePropertyInfo (typ: TypeInfo,propName:string) = typ.GetDeclaredProperty(propName)
let getInstancePropertyInfos (typ:TypeInfo,names) = names |> Array.map (fun nm -> getInstancePropertyInfo (typ,nm))
let getInstancePropertyReader (typ: TypeInfo,propName) =
match getInstancePropertyInfo(typ, propName) with
| null -> None
| prop -> Some(fun (obj:obj) -> prop.GetValue(obj))
let getUnionCasesTyp (typ: TypeInfo) = typ
let tryFindCompilationMappingAttribute (attrs:obj[]) =
match attrs with
| null | [| |] -> None
| [| res |] -> let a = (res :?> CompilationMappingAttribute) in Some (a.SourceConstructFlags, a.SequenceNumber, a.VariantNumber)
| _ -> raise <| System.InvalidOperationException ("couldn't find attribute")
let findCompilationMappingAttribute (attrs:obj[]) =
match tryFindCompilationMappingAttribute attrs with
| None -> failwith "no compilation mapping attribute"
| Some a -> a
let tryFindCompilationMappingAttributeFromData (attrs:seq<CustomAttributeData>) =
match attrs with
| null -> None
| _ ->
let mutable res = None
for a in attrs do
if a.AttributeType.GetTypeInfo().DeclaringType.FullName = cmaName then
let args = a.ConstructorArguments
let flags =
match args.Count with
| 1 -> ((args.[0].Value :?> SourceConstructFlags), 0, 0)
| 2 -> ((args.[0].Value :?> SourceConstructFlags), (args.[1].Value :?> int), 0)
| 3 -> ((args.[0].Value :?> SourceConstructFlags), (args.[1].Value :?> int), (args.[2].Value :?> int))
| _ -> (enum 0, 0, 0)
res <- Some flags
res
let findCompilationMappingAttributeFromData attrs =
match tryFindCompilationMappingAttributeFromData attrs with
| None -> failwith "no compilation mapping attribute"
| Some a -> a
let getAssembly (t:Type) = t.GetTypeInfo().Assembly
let tryFindCompilationMappingAttributeFromType (typ:TypeInfo) =
let attrs = typ.GetCustomAttributes<CompilationMappingAttribute>(false)
if Seq.isEmpty attrs then None else Some attrs
let seqToObjArray sqs = sqs |> Seq.cast<obj> |> Array.ofSeq
let tryFindCompilationMappingAttributeFromMemberInfo (info:MemberInfo) =
let assem = getAssembly info.DeclaringType
tryFindCompilationMappingAttribute (info.GetCustomAttributes (typeof<CompilationMappingAttribute>,false)|> Seq.cast<obj> |> Array.ofSeq)
let findCompilationMappingAttributeFromMemberInfo (info:MemberInfo) =
findCompilationMappingAttribute (info.GetCustomAttributes (typeof<CompilationMappingAttribute>,false)|> Seq.cast<obj> |> Array.ofSeq)
let sequenceNumberOfMember (x: MemberInfo) = let (_,n,_) = findCompilationMappingAttributeFromMemberInfo x in n
let variantNumberOfMember (x: MemberInfo) = let (_,_,vn) = findCompilationMappingAttributeFromMemberInfo x in vn
let sortFreshArray f arr = Array.sortInPlaceWith f arr; arr
let isFieldProperty (prop : PropertyInfo) =
match tryFindCompilationMappingAttributeFromMemberInfo(prop) with
| None -> false
| Some (flags,_n,_vn) -> (flags &&& SourceConstructFlags.KindMask) = SourceConstructFlags.Field
let getUnionTypeTagNameMap (typ:TypeInfo) =
let enumTyp = typ.DeclaredNestedTypes |> Seq.find(fun nt -> nt.Name = "Tags")
match enumTyp with
| null ->
typ.DeclaredMethods
|> Seq.choose (fun minfo ->
match tryFindCompilationMappingAttributeFromMemberInfo(minfo) with
| None -> None
| Some (flags,n,_vn) ->
if (flags &&& SourceConstructFlags.KindMask) = SourceConstructFlags.UnionCase then
let nm = minfo.Name
// chop "get_" or "New" off the front
let nm =
if not (isListType typ) && not (isOptionType typ) then
if nm.Length > 4 && nm.[0..3] = "get_" then nm.[4..]
elif nm.Length > 3 && nm.[0..2] = "New" then nm.[3..]
else nm
else nm
Some (n, nm)
else
None)
|> Array.ofSeq
| _ ->
enumTyp.DeclaredFields
|> Seq.filter (fun (f:FieldInfo) -> f.IsStatic && f.IsLiteral) |> Seq.toArray
|> sortFreshArray (fun f1 f2 -> compare (f1.GetValue(null) :?> int) (f2.GetValue(null) :?> int))
|> Array.map (fun tagfield -> (tagfield.GetValue(null) :?> int),tagfield.Name)
let getUnionCaseTyp (typ: TypeInfo, tag: int) =
let tagFields = getUnionTypeTagNameMap typ
let tagField = tagFields |> Array.pick (fun (i,f) -> if i = tag then Some f else None)
if tagFields.Length = 1 then
typ
else
// special case: two-cased DU annotated with CompilationRepresentation(UseNullAsTrueValue)
// in this case it will be compiled as one class: return self type for non-nullary case and null for nullary
let isTwoCasedDU =
if tagFields.Length = 2 then
match typ.GetCustomAttributes(typeof<CompilationRepresentationAttribute>, false)|> Seq.toArray with
| [|:? CompilationRepresentationAttribute as attr|] ->
(attr.Flags &&& CompilationRepresentationFlags.UseNullAsTrueValue) = CompilationRepresentationFlags.UseNullAsTrueValue
| _ -> false
else
false
if isTwoCasedDU then
typ
else
let caseTyp = typ.GetDeclaredNestedType(tagField) // if this is null then the union is nullary
match caseTyp with
| null -> null
| _ when caseTyp.IsGenericTypeDefinition -> caseTyp.MakeGenericType(typ.GenericTypeArguments).GetTypeInfo()
| _ -> caseTyp
let fieldsPropsOfUnionCase(typ:TypeInfo, tag:int) =
if isOptionType typ then
match tag with
| 0 (* None *) -> getInstancePropertyInfos (typ,[| |])
| 1 (* Some *) -> getInstancePropertyInfos (typ,[| "Value" |] )
| _ -> failwith "fieldsPropsOfUnionCase"
elif isListType typ then
match tag with
| 0 (* Nil *) -> getInstancePropertyInfos (typ,[| |])
| 1 (* Cons *) -> getInstancePropertyInfos (typ,[| "Head"; "Tail" |])
| _ -> failwith "fieldsPropsOfUnionCase"
else
// Lookup the type holding the fields for the union case
let caseTyp = getUnionCaseTyp (typ, tag)
match caseTyp with
| null -> [| |]
| _ -> caseTyp.DeclaredProperties
|> Seq.filter isFieldProperty
|> Seq.filter (fun prop -> variantNumberOfMember prop = tag)
|> Seq.toArray
|> sortFreshArray (fun p1 p2 -> compare (sequenceNumberOfMember p1) (sequenceNumberOfMember p2))
let getUnionTagConverter (typ:TypeInfo) =
if isOptionType typ then (fun tag -> match tag with 0 -> "None" | 1 -> "Some" | _ -> invalidArg "tag" ("out of range"))
elif isListType typ then (fun tag -> match tag with 0 -> "Empty" | 1 -> "Cons" | _ -> invalidArg "tag" ("out of range"))
else
let tagfieldmap = getUnionTypeTagNameMap (typ) |> Map.ofSeq
(fun tag -> tagfieldmap.[tag])
let isUnionCaseNullary (typ:TypeInfo, tag:int) =
let props = fieldsPropsOfUnionCase(typ, tag)
emptyArray props
let tryFindSourceConstructFlagsOfType (typ:TypeInfo) =
match tryFindCompilationMappingAttributeFromType typ with
| None -> None
//| Some (flags,_n,_vn) -> Some flags
| Some attr -> Some (Seq.head attr).SourceConstructFlags
let isUnionType (typ:TypeInfo) =
isOptionType typ ||
isListType typ ||
match tryFindSourceConstructFlagsOfType(typ) with
| None -> false
| Some(flags) ->
(flags &&& SourceConstructFlags.KindMask) = SourceConstructFlags.SumType &&
// We see private representations only if BindingFlags.NonPublic is set
(if (flags &&& SourceConstructFlags.NonPublicRepresentation) <> enum(0) then
// (bindingFlags &&& BindingFlags.NonPublic) <> enum(0)
typ.IsNotPublic // TODO this is probably wrong
else
true)
let getUnionCaseConstructorMethod (typ:TypeInfo,tag:int) =
let constrname = getUnionTagConverter (typ) tag
let methname =
if isUnionCaseNullary (typ, tag) then "get_"+constrname
elif isListType typ || isOptionType typ then constrname
else "New"+constrname
match typ.GetDeclaredMethod(methname) with
| null -> raise <| System.InvalidOperationException ("can't get constructor method name")
| meth -> meth
let isConstructorRepr (typ:TypeInfo) =
let rec get (typ:TypeInfo) = isUnionType (typ) || match typ.BaseType.GetTypeInfo() with null -> false | b -> get b
get typ
let unionTypeOfUnionCaseType (typ:TypeInfo) =
let rec get (typ:TypeInfo) = if isUnionType (typ) then typ else match typ.BaseType.GetTypeInfo() with null -> typ | b -> get b
get typ
let swap (x,y) = (y,x)
type UnionCaseInfo(typ: TypeInfo, tag:int) =
// Cache the tag -> name map
let mutable names = None
let getMethInfo() = getUnionCaseConstructorMethod (typ, tag)
member x.Name =
match names with
| None -> (let conv = getUnionTagConverter (typ) in names <- Some conv; conv tag)
| Some conv -> conv tag
member x.DeclaringType = typ
//member x.CustomAttributes = failwith<obj[]> "nyi"
member x.GetFields() =
let props = fieldsPropsOfUnionCase(typ,tag)
props
member x.GetCustomAttributes() = getMethInfo().GetCustomAttributes(false)
member x.GetCustomAttributes(attributeType) = getMethInfo().GetCustomAttributes(attributeType,false)
let isExceptionRepr (typ:TypeInfo) =
match tryFindSourceConstructFlagsOfType(typ) with
| None -> false
| Some(flags) ->
((flags &&& SourceConstructFlags.KindMask) = SourceConstructFlags.Exception) &&
// We see private representations only if BindingFlags.NonPublic is set
(if (flags &&& SourceConstructFlags.NonPublicRepresentation) <> enum(0) then
// (bindingFlags &&& BindingFlags.NonPublic) <> enum(0)
//(bindingFlags &&& BindingFlags.NonPublic) <> enum(0)
typ.IsNotPublic // ^ no idea what should be happening here
else
true)
let rec isClosureRepr typ =
isFunctionType typ ||
(match typ.BaseType.GetTypeInfo() with null -> false | bty -> isClosureRepr bty)
let getTypeOfReprType (typ:TypeInfo) =
if isExceptionRepr(typ) then typ.BaseType.GetTypeInfo()
elif isConstructorRepr(typ) then unionTypeOfUnionCaseType(typ)
elif isClosureRepr(typ) then
let rec get (typ:TypeInfo) = if isFunctionType typ then typ else match typ.BaseType.GetTypeInfo() with null -> typ | b -> get b
get typ
else typ
let checkUnionType(unionType) =
checkNonNull "unionType" unionType;
if not (isUnionType (unionType)) then
if isUnionType (unionType) then
invalidArg "unionType" ("isn't a union type")
else
invalidArg "unionType" ("isn't a union type")
let emptyObjArray : obj[] = [| |]
let getUnionCaseRecordReader (typ:TypeInfo,tag:int) =
let props = fieldsPropsOfUnionCase(typ,tag)
(fun (obj:obj) -> props |> Array.map (fun prop -> prop.GetValue(obj)))
let getUnionTagReader (typ:TypeInfo) : (obj -> int) =
if isOptionType typ then
(fun (obj:obj) -> match obj with null -> 0 | _ -> 1)
else
let tagMap = getUnionTypeTagNameMap (typ)
if tagMap.Length <= 1 then
(fun (_obj:obj) -> 0)
else
match getInstancePropertyReader (typ,"Tag") with
| Some reader -> (fun (obj:obj) -> reader obj :?> int)
| None ->
(fun (obj:obj) ->
let m2b = typ.GetDeclaredMethod("GetTag")
m2b.Invoke(null, [|obj|]) :?> int)
let getUnionFields(obj:obj,unionType:Type) =
let ensureType (typ:Type,obj:obj) =
match typ with
| null ->
match obj with
| null -> invalidArg "obj" ("object is null and has not type")
| _ -> obj.GetType()
| _ -> typ
//System.Console.WriteLine("typ1 = {0}",box unionType)
let unionType = ensureType(unionType,obj).GetTypeInfo()
//System.Console.WriteLine("typ2 = {0}",box unionType)
checkNonNull "unionType" unionType;
let unionType = getTypeOfReprType (unionType)
//System.Console.WriteLine("typ3 = {0}",box unionType)
checkUnionType(unionType);
let tag = getUnionTagReader (unionType) obj
let flds = getUnionCaseRecordReader (unionType,tag) obj
UnionCaseInfo(unionType,tag), flds
let getUnionFieldName<'T> case =
let uci, _ = getUnionFields(case,typeof<'T>)
uci.Name
;;
getUnionFieldName<CLIArguments> Detach
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment