yobaprovider.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 <- false
      prs.OutputAssembly <- Path.ChangeExtension(Path.GetTempFileName() + "ASSEMBLY", ".dll")
      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)
      printfn "%A" res.CompiledAssembly.FullName
      if res.Errors.Count > 0 then raiseError res.Errors
      else res.PathToAssembly
    
    xsdPath
    |> getSchemaAndIncludes
    |> getNamespace
    |> compileAssembly
//    |> buildTypes

[<TypeProvider>]
type XsdTypeProvider(config : TypeProviderConfig) as this = 
  inherit TypeProviderForNamespaces()
  let thisAssembly = Assembly.GetExecutingAssembly()
  let thisNamespace = this.GetType().Namespace
  let provider = ProvidedTypeDefinition(thisAssembly, thisNamespace, "Xsd", Some typeof<obj>, IsErased = false)
  let providerParams = [ ProvidedStaticParameter("XsdPath", typeof<string>) ]
 
  let cache = System.Collections.Concurrent.ConcurrentDictionary<_, _>()

  let provideTypes typeName (args : obj array) = 
    let xsdPath = args.[0] :?> string
    let rootType = ProvidedTypeDefinition(thisAssembly, thisNamespace, typeName, Some typeof<obj>, IsErased = false)

    let asm = cache.GetOrAdd (xsdPath, lazy (XsdCompiler.compile thisNamespace xsdPath |> ProvidedAssembly.RegisterGenerated))
//    for ty in genAsm.Value.GetExportedTypes() do
//        rootType.AddMember(ty)
//    let res = XsdCompiler.compile typeName xsdPath
//    let asm = ProvidedAssembly.RegisterGenerated(res.PathToAssembly)
    for ty in asm.Value.GetExportedTypes() do
      rootType.AddMember(ty)
    //rootType.AddAssemblyTypesAsNestedTypesDelayed(fun _ -> res.CompiledAssembly)
    let providedAssemblyPath = Path.ChangeExtension(Path.GetTempFileName() + "ASSEMBLY", ".dll")
    let providedAssembly = ProvidedAssembly providedAssemblyPath
    providedAssembly.AddTypes [ rootType ]
    rootType
 
  do 
    provider.DefineStaticParameters(providerParams, provideTypes)
    this.RegisterRuntimeAssemblyLocationAsProbingFolder config
    this.AddNamespace(thisNamespace, [ provider ])

[<TypeProviderAssembly>]
do ()