|
| 1 | +namespace BioFSharp.IO.INSDC.Internal |
| 2 | + |
| 3 | +open System |
| 4 | +open System.Collections |
| 5 | +open System.Collections.Generic |
| 6 | +open System.Reflection |
| 7 | +open System.Text |
| 8 | +open System.Xml.Serialization |
| 9 | + |
| 10 | +open Microsoft.FSharp.Quotations |
| 11 | + |
| 12 | +/// Resolves the concrete, position-qualified W3C XPointer of a property on a parsed INSDC value. |
| 13 | +/// Public entity modules expose this as `<Entity>.xpathOf`. The property is named with a quotation |
| 14 | +/// (`<@ fun b -> b.Name @>`) rather than piped by value, because a scalar value carries no |
| 15 | +/// back-reference to its property, owner, or array position. The XPath is derived from the same |
| 16 | +/// `System.Xml.Serialization` attributes the serializer uses, with array positions taken from the |
| 17 | +/// indices written in the quotation and validated against the instance — so it points at exactly |
| 18 | +/// the node `read` produced. This is the runtime, per-instance counterpart of the generated, |
| 19 | +/// type-level `FragmentSelectors` maps in BioFSharp.FileFormats.INSDC. |
| 20 | +module XPathTracking = |
| 21 | + |
| 22 | + /// The single attribute of type `'a` on a member, or None. |
| 23 | + let private tryAttr<'a when 'a :> Attribute> (m: MemberInfo) : 'a option = |
| 24 | + match Attribute.GetCustomAttribute(m, typeof<'a>) with |
| 25 | + | null -> None |
| 26 | + | a -> Some(a :?> 'a) |
| 27 | + |
| 28 | + let private hasAttr<'a when 'a :> Attribute> (m: MemberInfo) : bool = (tryAttr<'a> m).IsSome |
| 29 | + |
| 30 | + /// True for an element/array property whose value is a repeatable collection (not a string). |
| 31 | + let private isCollection (t: Type) : bool = |
| 32 | + t <> typeof<string> |
| 33 | + && (t.IsArray |
| 34 | + || t.GetInterfaces() |
| 35 | + |> Array.exists (fun i -> |
| 36 | + i.IsGenericType && i.GetGenericTypeDefinition() = typedefof<IEnumerable<_>>)) |
| 37 | + |
| 38 | + /// The relative XPath piece for a property and whether it is a repeatable collection, or None |
| 39 | + /// when the property is not serialized (`[XmlIgnore]` or unannotated). |
| 40 | + let private relativeStep (p: PropertyInfo) : (string * bool) option = |
| 41 | + let orElse fallback (s: string) = if String.IsNullOrEmpty s then fallback else s |
| 42 | + if hasAttr<XmlIgnoreAttribute> p then None |
| 43 | + else |
| 44 | + match tryAttr<XmlAttributeAttribute> p with |
| 45 | + | Some att -> Some("@" + (att.AttributeName |> orElse p.Name), false) |
| 46 | + | None -> |
| 47 | + match tryAttr<XmlArrayAttribute> p with |
| 48 | + | Some arr -> |
| 49 | + let arrName = arr.ElementName |> orElse p.Name |
| 50 | + let itemName = |
| 51 | + match tryAttr<XmlArrayItemAttribute> p with |
| 52 | + | Some item -> item.ElementName |> orElse arrName |
| 53 | + | None -> arrName |
| 54 | + Some(arrName + "/" + itemName, true) |
| 55 | + | None -> |
| 56 | + match tryAttr<XmlElementAttribute> p with |
| 57 | + | Some el -> Some(el.ElementName |> orElse p.Name, isCollection p.PropertyType) |
| 58 | + | None -> if hasAttr<XmlTextAttribute> p then Some("text()", false) else None |
| 59 | + |
| 60 | + /// Append a 1-based positional predicate to the last element of a relative piece: |
| 61 | + /// `COLLABORATORS/COLLABORATOR`, index 1 -> `COLLABORATORS/COLLABORATOR[2]`. |
| 62 | + let private withIndex (piece: string) (index: int) : string = |
| 63 | + let slash = piece.LastIndexOf('/') |
| 64 | + if slash < 0 then sprintf "%s[%d]" piece (index + 1) |
| 65 | + else sprintf "%s%s[%d]" (piece.Substring(0, slash + 1)) (piece.Substring(slash + 1)) (index + 1) |
| 66 | + |
| 67 | + /// The XML root element name for a type carrying `[XmlRoot]`. |
| 68 | + let private rootElementName (t: Type) : string = |
| 69 | + match tryAttr<XmlRootAttribute> t with |
| 70 | + | Some r -> r.ElementName |> fun s -> if String.IsNullOrEmpty s then t.Name else s |
| 71 | + | None -> failwithf "Type '%s' has no [XmlRoot] and cannot anchor an absolute XPath." t.Name |
| 72 | + |
| 73 | + /// Evaluate a quotation index expression to an int (a literal, or a captured value). |
| 74 | + let private evalIndex (e: Expr) : int = |
| 75 | + match e with |
| 76 | + | Patterns.Value(v, _) when (v :? int) -> unbox<int> v |
| 77 | + | _ -> unbox<int> (Microsoft.FSharp.Linq.RuntimeHelpers.LeafExpressionConverter.EvaluateQuotation e) |
| 78 | + |
| 79 | + /// Flatten a selector body into an ordered list of (property, optional index) steps. An indexer |
| 80 | + /// (`xs.[i]`, however the quotation encodes it) attaches its index to the collection property |
| 81 | + /// that produced it. |
| 82 | + let rec private parseChain (e: Expr) : (PropertyInfo * int option) list = |
| 83 | + let attach target idx = |
| 84 | + match List.rev (parseChain target) with |
| 85 | + | (p, _) :: rest -> List.rev ((p, Some(evalIndex idx)) :: rest) |
| 86 | + | [] -> failwithf "Index in selector has no preceding collection property: %A" e |
| 87 | + match e with |
| 88 | + | Patterns.Var _ -> [] |
| 89 | + | Patterns.PropertyGet(Some target, prop, []) -> parseChain target @ [ prop, None ] |
| 90 | + | Patterns.PropertyGet(Some target, _, [ idx ]) -> attach target idx |
| 91 | + | Patterns.Call(Some target, mi, [ idx ]) when mi.Name = "get_Item" -> attach target idx |
| 92 | + | Patterns.Call(None, mi, [ target; idx ]) when mi.Name = "GetArray" -> attach target idx |
| 93 | + | _ -> |
| 94 | + failwithf "Unsupported selector shape: %A. Use a property/index chain like <@ fun x -> x.A.[0].B @>." e |
| 95 | + |
| 96 | + /// Materialize a collection value's items (for index bounds checking and navigation). |
| 97 | + let private items (value: obj) : obj[] = (value :?> IEnumerable) |> Seq.cast<obj> |> Seq.toArray |
| 98 | + |
| 99 | + let private build (rootType: Type) (steps: (PropertyInfo * int option) list) (root: obj) : string = |
| 100 | + let sb = StringBuilder("/").Append(rootElementName rootType) |
| 101 | + let mutable current = root |
| 102 | + for (prop, idxOpt) in steps do |
| 103 | + match relativeStep prop with |
| 104 | + | None -> failwithf "Property '%s' is not serialized to XML." prop.Name |
| 105 | + | Some(piece, repeatable) -> |
| 106 | + let value = if isNull current then null else prop.GetValue current |
| 107 | + match idxOpt with |
| 108 | + | Some i -> |
| 109 | + if not repeatable then |
| 110 | + failwithf "Property '%s' is not a collection and cannot be indexed." prop.Name |
| 111 | + if isNull value then failwithf "Collection '%s' is absent in this instance." prop.Name |
| 112 | + let xs = items value |
| 113 | + if i < 0 || i >= xs.Length then |
| 114 | + failwithf "Index %d is out of range for '%s' (count %d)." i prop.Name xs.Length |
| 115 | + sb.Append('/').Append(withIndex piece i) |> ignore |
| 116 | + current <- xs.[i] |
| 117 | + | None -> |
| 118 | + sb.Append('/').Append(piece) |> ignore |
| 119 | + current <- value |
| 120 | + sb.ToString() |
| 121 | + |
| 122 | + /// Resolve the `#xpointer(...)` fragment selector for the property named by `selector` on the |
| 123 | + /// parsed `root` value, with real array positions taken from the indices in the quotation. |
| 124 | + let xpathOf (selector: Expr<'Root -> 'P>) (root: 'Root) : string = |
| 125 | + let steps = |
| 126 | + match (selector :> Expr) with |
| 127 | + | Patterns.Lambda(_, body) -> parseChain body |
| 128 | + | _ -> failwith "Expected a selector lambda, e.g. <@ fun x -> x.Prop @>." |
| 129 | + "#xpointer(" + build typeof<'Root> steps (box root) + ")" |
0 commit comments