XsdTypeProvider.fs

namespace NBox.Data

open Microsoft.FSharp.Core.CompilerServices
open ProviderImplementation.ProvidedTypes
open System.IO
open System.Reflection

module Seq = 
  let ofType<'a> (source : System.Collections.IEnumerable) : seq<'a> = 
    seq { 
      for item in source do
        if item :? 'a then yield item :?> 'a
    }

module XsdCompiler = 
  open Microsoft.CSharp
  open Microsoft.FSharp.Quotations
  open System
  open System.CodeDom
  open System.CodeDom.Compiler
  open System.Text
  open System.Xml.Schema
  open System.Xml.Serialization
  
  type MutableDict<'k, 'v> = Collections.Generic.Dictionary<'k, 'v>
  
  type MutableSet<'v> = Collections.Generic.HashSet<'v>
  
  type MutableList<'v> = Collections.Generic.List<'v>
  
  type MutableQueue<'v> = Collections.Generic.Queue<'v>
  
  let compile namespaceName xsdPath = 
    let getSchemaAndIncludes schemaPath = 
      let readXsd path = 
        use s = File.OpenRead(path)
        XmlSchema.Read(s, null)
      
      let normalizePath dir pth = Path.Combine(dir, pth) |> Path.GetFullPath
      let visited = MutableSet<_>()
      let mutable includes = MutableList<_>()
      let queue = MutableQueue<string>()
      queue.Enqueue schemaPath
      while queue.Count > 0 do
        let path = queue.Dequeue()
        if visited.Add(path) then 
          let dir = Path.GetDirectoryName path
          let xsd = readXsd path
          includes.Add xsd
          for inc in xsd.Includes |> Seq.ofType<XmlSchemaExternal> do
            let loc = inc.SchemaLocation
            if Path.IsPathRooted loc then loc
            else normalizePath dir loc
            |> queue.Enqueue
      (includes.[0], 
       includes
       |> Seq.skip 1
       |> Seq.toList)
    
    let getNamespace (xsd : XmlSchema, includes : XmlSchema list) = 
      let xsds = XmlSchemas()
      xsds.Add(xsd) |> ignore
      for inc in includes do
        xsds.Add(inc) |> ignore
      xsds.Compile(null, true)
      let imp = XmlSchemaImporter(xsds)
      let cns = CodeNamespace(namespaceName)
      let exp = XmlCodeExporter(cns)
      for typ in Seq.ofType<XmlSchemaType> xsd.SchemaTypes.Values do
        typ.QualifiedName
        |> imp.ImportSchemaType
        |> exp.ExportTypeMapping
      for elm in Seq.ofType<XmlSchemaElement> xsd.Elements.Values do
        elm.QualifiedName
        |> imp.ImportTypeMapping
        |> exp.ExportTypeMapping
      CodeGenerator.ValidateIdentifiers(cns)
      cns
    
    let compileAssembly cns = 
      let raiseError (errors : CompilerErrorCollection) = 
        let sb = StringBuilder()
        for err in errors do
          sb.AppendLine(err.ErrorText) |> ignore
        failwith (sb.ToString())
      
      let unt = CodeCompileUnit()
      unt.Namespaces.Add(cns) |> ignore
      let prs = CompilerParameters()
      prs.GenerateInMemory <- true
      let rfs = [ "System.dll"; "System.Xml.dll" ]
      for ref in rfs do
        unt.ReferencedAssemblies.Add(ref) |> ignore
        prs.ReferencedAssemblies.Add(ref) |> ignore
      use csc = new CSharpCodeProvider()
      let res = csc.CompileAssemblyFromDom(prs, unt)
      if res.Errors.Count > 0 then raiseError res.Errors
      else res.CompiledAssembly
    
    let backFieldName = 
      function 
      | null | "" -> failwith "Empty name"
      | str -> "_" + (str.Substring(0, 1).ToLower()) + str.Substring(1)
    
    let buildTypes (asm : Assembly) = 
      let map = MutableDict<_, _>()
      
      let findType (t : Type) = 
        if map.ContainsKey(t) then 
          let res = map.[t] :> Type
          //qostilique
          if t.IsEnum then t.GetEnumUnderlyingType()
          else res
        else t
      
      let addEmptyCtor (typ : ProvidedTypeDefinition) = 
        let ctr = ProvidedConstructor([], InvokeCode = fun _ -> <@@ () @@>)
        typ.AddMember(ctr)
      
      let addProp (typ : ProvidedTypeDefinition) (p : PropertyInfo) = 
        let prpType = findType p.PropertyType
        let fldName = backFieldName p.Name
        let fld = ProvidedField(fldName, prpType)
        fld.SetFieldAttributes(FieldAttributes.Private ||| FieldAttributes.HasDefault)
        let getter = fun [ obj ] -> Expr.FieldGet(obj, fld)
        let setter = fun [ obj; v ] -> Expr.FieldSet(obj, fld :> FieldInfo, v)
        let prp = ProvidedProperty(p.Name, prpType, GetterCode = getter, SetterCode = setter)
        for atr in p.CustomAttributes do
          prp.AddCustomAttribute(atr)
        typ.AddMember(fld)
        typ.AddMember(prp)
      
      let addEnumField (typ : ProvidedTypeDefinition) (eut : Type) (f : FieldInfo) = 
        let fvl = Convert.ChangeType(f.GetValue(null), eut)
        let fld = ProvidedLiteralField(f.Name, typ, fvl)
        typ.AddMember(fld)
      
      let fillType (typ : ProvidedTypeDefinition) (t : Type) = 
        if t.IsEnum then 
          let eut = t.GetEnumUnderlyingType()
          typ.SetBaseType(typeof<Enum>)
          typ.SetEnumUnderlyingType(eut)
          for f in t.GetFields(BindingFlags.Public ||| BindingFlags.Static) do
            addEnumField typ eut f
        else 
          typ.SetBaseType(findType t.BaseType)
          for p in t.GetProperties(BindingFlags.Public ||| BindingFlags.Instance) do
            addProp typ p
          addEmptyCtor typ
        typ.SetAttributes(t.Attributes)
        for atr in t.CustomAttributes do
          typ.AddCustomAttribute(atr)
      
      for t in asm.GetTypes() do
        let typ = ProvidedTypeDefinition(t.Name, None, IsErased = false)
        map.Add(t, typ)
      for kv in map do
        fillType kv.Value kv.Key
      map.Values |> List.ofSeq
    
    xsdPath
    |> getSchemaAndIncludes
    |> getNamespace
    |> compileAssembly
    |> buildTypes

[<TypeProvider>]
type XsdTypeProvider(config : TypeProviderConfig) as this = 
  inherit TypeProviderForNamespaces()
  let thisAssembly = Assembly.GetExecutingAssembly()
  let thisNamespace = this.GetType().Namespace
  let providedAssemblyPath = Path.ChangeExtension(Path.GetTempFileName(), ".dll")
  let providedAssembly = ProvidedAssembly providedAssemblyPath
  let provider = ProvidedTypeDefinition(thisAssembly, thisNamespace, "Xsd", Some typeof<obj>, IsErased = false)
  let providerParams = [ ProvidedStaticParameter("XsdPath", typeof<string>) ]
  
  let provideTypes typeName (args : obj array) = 
    let xsdPath = args.[0] :?> string
    let rootType = ProvidedTypeDefinition(thisAssembly, thisNamespace, typeName, Some typeof<obj>, IsErased = false)
    let types = XsdCompiler.compile typeName xsdPath
    rootType.AddMembers types
    providedAssembly.AddTypes [ rootType ]
    rootType
  
  do 
    provider.DefineStaticParameters(providerParams, provideTypes)
    this.RegisterRuntimeAssemblyLocationAsProbingFolder config
    this.AddNamespace(thisNamespace, [ provider ])

[<TypeProviderAssembly>]
do ()