netcore compatible `GetUnionFields`

getUnionFields.fsx

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