Utilities/Utilities.SerDes.XML.fsx

Utilities.SerDes.XML.fsx

module Utilities.SerDes.XML
// Licence: Apache 2.0
// Author: Matthew Moloney

open System.Reflection
open Microsoft.FSharp.Reflection
open System
open System.Text
open System.IO
open System.Net
open System.Net.Sockets
open Microsoft.FSharp.Control.WebExtensions
open System.Xml

let rec isSimple (o:obj) = 
    if o = null then true
        else    
            let t = o.GetType()
            match t.Name with 
            | "Boolean" | "Int32"   | "Int64"   | "Single"  | "Double"  | "String"  | "Byte[]" | "Guid" | "DateTime" -> true
            | "FSharpOption`1" -> // Is Some Case ?
                let cases = FSharpType.GetUnionCases t
                let tag = FSharpValue.PreComputeUnionTagReader(t) o
                if tag = 0 then true
                    else
                        let property = cases.[tag].GetFields() |> Seq.head 
                        property.GetValue(o, [||]) |> isSimple                
            | _ -> false

let settingsXML = new XmlWriterSettings(Indent = true, OmitXmlDeclaration = true, NewLineOnAttributes = false;)
do
    settingsXML.ConformanceLevel <- ConformanceLevel.Fragment

let rec serializeXML (xw:XmlWriter) (o:obj)  =    
        if o <> null then // represents the None option
            let t = o.GetType()
            match t.Name with
            | "Boolean" | "Int32"   | "Int64"   | "Single"  | "Double"  | "String"  -> xw.WriteString(o.ToString())
            | "Byte[]"  -> let bytes = o :?> byte array
                           xw.WriteBase64(bytes, 0, bytes.Length);
            | "List`1" -> 
                let list = o :?> System.Collections.IList
                for x in list do 
                    if x |> isSimple 
                        then
                            xw.WriteStartElement("item")
                            xw.WriteStartAttribute("value")
                            serializeXML xw x
                            xw.WriteEndAttribute()
                            xw.WriteEndElement()
                        else
                                serializeXML xw x
        
            | "FSharpOption`1" ->
                let cases = FSharpType.GetUnionCases t
                let tag = FSharpValue.PreComputeUnionTagReader(t) o
                if tag = 0 then ()
                    else
                        let property = cases.[tag].GetFields() |> Seq.head 
                        serializeXML xw (property.GetValue(o, [||]))
            | _ -> 
                match t with
                | t when FSharpType.IsTuple  t -> 
                    let (attr,els) = FSharpValue.GetTupleFields o 
                                        |> Array.mapi (fun i x -> (i,x)) 
                                        |> Array.filter (fun (_,x) -> x <> null)
                                        |> Array.partition (fun (_,x) -> x |> isSimple)
                    xw.WriteStartElement("tuple")
                
                    attr |> Array.iter (fun (i,x) -> 
                        xw.WriteStartAttribute("item" + i.ToString())
                        serializeXML xw x
                        xw.WriteEndAttribute())
                
                    els |> Array.iter (fun (i,x) ->
                        xw.WriteStartElement("item" + i.ToString())
                        serializeXML xw x
                        xw.WriteEndElement())
                    xw.WriteEndElement()
                | t when FSharpType.IsUnion  t ->
                    let cases = FSharpType.GetUnionCases t
                    let tag = FSharpValue.PreComputeUnionTagReader(t) o
                    let case = cases.[tag]
                    xw.WriteStartElement(case.Name)
                    xw.WriteAttributeString("tag", tag.ToString())
                    let (attr,els) = 
                        cases.[tag].GetFields() 
                            |> Array.filter (fun f -> f.GetValue(o,[||]) <> null)
                            |> Array.partition (fun f -> f.GetValue(o,[||]) |> isSimple)
                    attr |> Array.iter (fun f -> 
                        xw.WriteStartAttribute(f.Name)
                        serializeXML xw (f.GetValue(o,[||]))
                        xw.WriteEndAttribute())
                    els |> Array.iter (fun f ->
                        xw.WriteStartElement(f.Name)
                        serializeXML xw (f.GetValue(o,[||]))
                        xw.WriteEndElement())
                    xw.WriteEndElement()
                | t when FSharpType.IsRecord t -> 
                    xw.WriteStartElement(t.Name)
                    let (attr,els) = 
                        FSharpType.GetRecordFields(t)  
                            |> Array.filter (fun f -> f.GetValue(o,[||]) <> null)
                            |> Array.partition (fun f -> f.GetValue(o,[||]) |> isSimple)
                    attr |> Array.iter (fun f -> 
                        xw.WriteStartAttribute(f.Name)
                        serializeXML xw (f.GetValue(o,[||]))
                        xw.WriteEndAttribute())
                    els  |> Array.iter (fun f ->
                        xw.WriteStartElement(f.Name)
                        serializeXML xw (f.GetValue(o,[||]))
                        xw.WriteEndElement())
                    xw.WriteEndElement()
                | t when t.IsArray -> 
                    let array = o :?> Array
                    for x in array do 
                        if x |> isSimple 
                            then
                                xw.WriteStartElement("item")
                                xw.WriteStartAttribute("value")
                                serializeXML xw x
                                xw.WriteEndAttribute()
                                xw.WriteEndElement()
                            else
                                    serializeXML xw x
                | _ -> failwith (sprintf "unrecognized type %A" t)

let toXML (a:'a) =
    use sw = new StringWriter()
    use xm = XmlWriter.Create(sw,settingsXML)
    serializeXML xm a
    xm.Flush()
    sw.ToString()