Merge pull request #160 from rojepp/master

#87: Xaml TP supports external components
fsprojects · Nov 27, 2012 · 67f8169 · 67f8169
2 parents 6386fc4 + 94f6522
commit 67f8169
Show file tree

Hide file tree

Showing 11 changed files with 180 additions and 30 deletions.
diff --git a/src/FSharpx.TypeProviders.Xaml/FSharpx.TypeProviders.Xaml.fsproj b/src/FSharpx.TypeProviders.Xaml/FSharpx.TypeProviders.Xaml.fsproj
@@ -21,6 +21,7 @@
     <DefineConstants>DEBUG;TRACE</DefineConstants>
     <WarningLevel>3</WarningLevel>
     <DocumentationFile>bin\Debug\FSharpx.TypeProviders.Xaml.XML</DocumentationFile>
+    <PlatformTarget>AnyCPU</PlatformTarget>
   </PropertyGroup>
   <PropertyGroup Condition=" '$(Configuration)|$(Platform)' == 'Release|AnyCPU' ">
     <DebugType>pdbonly</DebugType>

diff --git a/src/FSharpx.TypeProviders.Xaml/XamlProvider.fs b/src/FSharpx.TypeProviders.Xaml/XamlProvider.fs
@@ -13,11 +13,12 @@ open System.Xml
 open System.Linq.Expressions
 open FSharpx.TypeProviders.Helper
 
-let wpfAssembly = typeof<System.Windows.Controls.Button>.Assembly
+let private wpfAssembly = typeof<System.Windows.Controls.Button>.Assembly
 
 /// Simple type wrapping Xaml file
-type XamlFile(root:FrameworkElement) =
+type XamlFile(schema: string) =
     let dict = new Dictionary<_,_>()
+    let root = XamlReader.Parse(schema) :?> FrameworkElement
 
     member this.GetChild name = 
         match dict.TryGetValue name with
@@ -46,10 +47,9 @@ let internal posOfReader filename (xaml:XmlReader) =
       Column = lineInfo.LinePosition
       FileName = filename }
 
-let internal createXamlNode filename isRoot (xaml:XmlReader) =
+let internal createXamlNode (schemaContext: Xaml.XamlSchemaContext) filename isRoot (xaml:XmlReader) =
     let pos = posOfReader filename xaml
-    try
-        let typeName = xaml.Name
+    try 
         let name =                        
             match xaml.GetAttribute("Name") with
             | name when name <> null -> Some name
@@ -62,13 +62,11 @@ let internal createXamlNode filename isRoot (xaml:XmlReader) =
         | None -> None
         | Some name -> 
             let propertyType =
-                match typeName with
-                | "Window" -> typeof<Window>
-                | other ->
-                    match wpfAssembly.GetType(sprintf "System.Windows.Controls.%s" other) with
-                    | null -> typeof<obj>
-                    | st -> st
-
+                let r = schemaContext.GetAllXamlTypes(xaml.NamespaceURI)
+                let xamltype = r |> Seq.tryFind (fun xt -> xt.Name = xaml.LocalName)
+                match xamltype with
+                | None   -> typeof<obj>
+                | Some t -> t.UnderlyingType
             { Position = pos
               IsRoot = isRoot
               Name = name
@@ -77,13 +75,13 @@ let internal createXamlNode filename isRoot (xaml:XmlReader) =
     with
     | :? XmlException -> failwithf "Error near %A" pos
 
-let internal readXamlFile filename (xaml:XmlReader) =    
+let internal readXamlFile (schemaContext: Xaml.XamlSchemaContext) filename (xaml:XmlReader) =    
     seq {
         let isRoot = ref true
         while xaml.Read() do
             match xaml.NodeType with
             | XmlNodeType.Element ->               
-                match createXamlNode filename (!isRoot) xaml with
+                match createXamlNode schemaContext filename (!isRoot) xaml with
                 | Some node ->
                     yield node
                     isRoot := false
@@ -94,11 +92,11 @@ let internal readXamlFile filename (xaml:XmlReader) =
 let createXmlReader(textReader:TextReader) =
     XmlReader.Create(textReader, XmlReaderSettings(IgnoreProcessingInstructions = true, IgnoreWhitespace = true))
 
-let internal createTypeFromReader typeName fileName schema (reader: TextReader) =
+let internal createTypeFromReader (schemaContext: Xaml.XamlSchemaContext) typeName fileName schema (reader: TextReader) =
     let elements = 
         reader
         |> createXmlReader 
-        |> readXamlFile fileName
+        |> readXamlFile schemaContext fileName
         |> Seq.toList
 
     let root = List.head elements
@@ -114,7 +112,7 @@ let internal createTypeFromReader typeName fileName schema (reader: TextReader)
     let ctor = 
         ProvidedConstructor(
             parameters = [], 
-            InvokeCode = (fun args -> <@@ XamlFile(XamlReader.Parse(schema) :?> FrameworkElement) @@>))
+            InvokeCode = (fun args -> <@@ XamlFile(schema) @@>))
 
     ctor.AddXmlDoc (sprintf "Initializes typed access to %s" fileName)
     ctor.AddDefinitionLocation(root.Position.Line,root.Position.Column,root.Position.FileName)
@@ -134,15 +132,35 @@ let internal createTypeFromReader typeName fileName schema (reader: TextReader)
 
 /// Infer schema from the loaded data and generate type with properties     
 let internal xamlType (ownerType:TypeProviderForNamespaces)  (cfg:TypeProviderConfig) =
+
+    cfg.ReferencedAssemblies 
+    |> Seq.map (fun a -> System.IO.FileInfo(a).DirectoryName)
+    |> Set.ofSeq
+    |> Set.iter (fun p -> ownerType.RegisterProbingFolder p)
+
+    let assemblies = 
+        cfg.ReferencedAssemblies 
+        |> Seq.map (fun r -> Assembly.Load(IO.File.ReadAllBytes r))
+        |> Seq.append [wpfAssembly]
+        |> Array.ofSeq
+    let ss = Xaml.XamlSchemaContextSettings()
+    ss.FullyQualifyAssemblyNamesInClrNamespaces <- false
+    ss.SupportMarkupExtensionsWithDuplicateArity <- false
+    let schemaContext = System.Xaml.XamlSchemaContext(assemblies, ss)//  (assemblies)
+
     let createTypeFromFileName typeName (fileName:string) =        
         use reader = new StreamReader(fileName)
-        createTypeFromReader typeName fileName (File.ReadAllText fileName) reader
+        createTypeFromReader schemaContext typeName fileName (File.ReadAllText fileName) reader
 
     let createTypeFromSchema typeName (schema:string) =        
         use reader = new StringReader(schema)
-        createTypeFromReader typeName null schema reader
+        createTypeFromReader schemaContext typeName null schema reader
 
     let missingValue = "@@@missingValue###"
+
+
+
+
     let xamlType = erasedType<obj> thisAssembly rootNamespace "XAML"
     xamlType.DefineStaticParameters(
         parameters = [ProvidedStaticParameter("FileName", typeof<string>, missingValue) // Parameterize the type by the file to use as a template

diff --git a/src/FSharpx.TypeProviders/ProvidedTypes.fs b/src/FSharpx.TypeProviders/ProvidedTypes.fs
@@ -1873,14 +1873,21 @@ type TypeProviderForNamespaces(namespacesAndTypes : list<(string * list<Provided
 #else
     abstract member ResolveAssembly : args : System.ResolveEventArgs -> Assembly
     default this.ResolveAssembly(args) = 
-        let expectedName = (AssemblyName(args.Name)).Name + ".dll"
-        let expectedLocationOpt = 
-            probingFolders 
-            |> Seq.map (fun f -> IO.Path.Combine(f, expectedName))
-            |> Seq.tryFind IO.File.Exists
-        match expectedLocationOpt with
-        | Some f -> Assembly.LoadFrom f
-        | None -> null
+        let name = AssemblyName(args.Name)
+        let existingAssembly = 
+            System.AppDomain.CurrentDomain.GetAssemblies()
+            |> Seq.tryFind(fun a -> System.Reflection.AssemblyName.ReferenceMatchesDefinition(name, a.GetName()))
+        match existingAssembly with
+        | Some a -> a
+        | None -> 
+           let expectedName = (AssemblyName(args.Name)).Name + ".dll"
+           let expectedLocationOpt = 
+               probingFolders 
+               |> Seq.map (fun f -> IO.Path.Combine(f, expectedName))
+               |> Seq.tryFind IO.File.Exists
+           match expectedLocationOpt with
+           | Some f -> Assembly.Load(IO.File.ReadAllBytes f)
+           | None -> null
 
     member this.RegisterProbingFolder (folder) = 
         // use GetFullPath to ensure that folder is valid

diff --git a/src/FSharpx.TypeProviders/TypeProvider.Helper.fs b/src/FSharpx.TypeProviders/TypeProvider.Helper.fs
@@ -1,6 +1,6 @@
 /// Starting to implement some helpers on top of ProvidedTypes API
 module internal FSharpx.TypeProviders.Helper
-
+open System
 open System.IO
 open FSharpx.Strings
 open Samples.FSharp.ProvidedTypes

diff --git a/...viders.Xaml.Tests.ExternalControl/FSharpx.TypeProviders.Xaml.Tests.ExternalControl.fsproj b/...viders.Xaml.Tests.ExternalControl/FSharpx.TypeProviders.Xaml.Tests.ExternalControl.fsproj
@@ -0,0 +1,63 @@
+<?xml version="1.0" encoding="utf-8"?>
+<Project ToolsVersion="4.0" DefaultTargets="Build" xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
+  <Import Project="$(MSBuildExtensionsPath)\$(MSBuildToolsVersion)\Microsoft.Common.props" Condition="Exists('$(MSBuildExtensionsPath)\$(MSBuildToolsVersion)\Microsoft.Common.props')" />
+  <PropertyGroup>
+    <Configuration Condition=" '$(Configuration)' == '' ">Debug</Configuration>
+    <Platform Condition=" '$(Platform)' == '' ">AnyCPU</Platform>
+    <SchemaVersion>2.0</SchemaVersion>
+    <ProjectGuid>94b8edad-06d1-44a8-ac44-906d7b6a37ab</ProjectGuid>
+    <OutputType>Library</OutputType>
+    <RootNamespace>FSharpx.TypeProviders.Xaml.Tests.ExternalControl</RootNamespace>
+    <AssemblyName>FSharpx.TypeProviders.Xaml.Tests.ExternalControl</AssemblyName>
+    <TargetFrameworkVersion>v4.0</TargetFrameworkVersion>
+    <Name>FSharpx.TypeProviders.Xaml.Tests.ExternalControl</Name>
+    <TargetFrameworkProfile />
+  </PropertyGroup>
+  <PropertyGroup Condition=" '$(Configuration)|$(Platform)' == 'Debug|AnyCPU' ">
+    <DebugSymbols>true</DebugSymbols>
+    <DebugType>full</DebugType>
+    <Optimize>false</Optimize>
+    <Tailcalls>false</Tailcalls>
+    <OutputPath>bin\Debug\</OutputPath>
+    <DefineConstants>DEBUG;TRACE</DefineConstants>
+    <WarningLevel>3</WarningLevel>
+    <DocumentationFile>bin\Debug\FSharpx.TypeProviders.Xaml.Tests.ExternalControl.XML</DocumentationFile>
+  </PropertyGroup>
+  <PropertyGroup Condition=" '$(Configuration)|$(Platform)' == 'Release|AnyCPU' ">
+    <DebugType>pdbonly</DebugType>
+    <Optimize>true</Optimize>
+    <Tailcalls>true</Tailcalls>
+    <OutputPath>bin\Release\</OutputPath>
+    <DefineConstants>TRACE</DefineConstants>
+    <WarningLevel>3</WarningLevel>
+    <DocumentationFile>bin\Release\FSharpx.TypeProviders.Xaml.Tests.ExternalControl.XML</DocumentationFile>
+  </PropertyGroup>
+  <ItemGroup>
+    <Reference Include="mscorlib" />
+    <Reference Include="FSharp.Core, Version=4.3.0.0, Culture=neutral, PublicKeyToken=b03f5f7f11d50a3a">
+      <Private>True</Private>
+    </Reference>
+    <Reference Include="PresentationCore" />
+    <Reference Include="PresentationFramework" />
+    <Reference Include="System" />
+    <Reference Include="System.Core" />
+    <Reference Include="System.Numerics" />
+    <Reference Include="System.Xaml" />
+    <Reference Include="UIAutomationTypes" />
+    <Reference Include="WindowsBase" />
+  </ItemGroup>
+  <ItemGroup>
+    <Compile Include="MyExternalButton.fs" />
+  </ItemGroup>
+  <PropertyGroup>
+    <MinimumVisualStudioVersion Condition="'$(MinimumVisualStudioVersion)' == ''">11</MinimumVisualStudioVersion>
+  </PropertyGroup>
+  <Import Project="$(MSBuildExtensionsPath32)\..\Microsoft SDKs\F#\3.0\Framework\v4.0\Microsoft.FSharp.Targets" Condition=" Exists('$(MSBuildExtensionsPath32)\..\Microsoft SDKs\F#\3.0\Framework\v4.0\Microsoft.FSharp.Targets')" />
+  <!-- To modify your build process, add your task inside one of the targets below and uncomment it. 
+       Other similar extension points exist, see Microsoft.Common.targets.
+  <Target Name="BeforeBuild">
+  </Target>
+  <Target Name="AfterBuild">
+  </Target>
+  -->
+</Project>
diff --git a/tests/FSharpx.TypeProviders.Xaml.Tests.ExternalControl/MyExternalButton.fs b/tests/FSharpx.TypeProviders.Xaml.Tests.ExternalControl/MyExternalButton.fs
@@ -0,0 +1,7 @@
+namespace FSharpx.TypeProviders.Tests.Xaml
+
+type public MyExternalButton() =
+   inherit System.Windows.Controls.Button() 
+
+
+
diff --git a/tests/FSharpx.TypeProviders.Xaml.Tests/FSharpx.TypeProviders.Xaml.Tests.fsproj b/tests/FSharpx.TypeProviders.Xaml.Tests/FSharpx.TypeProviders.Xaml.Tests.fsproj
@@ -48,12 +48,14 @@
     <Reference Include="System.Core" />
     <Reference Include="System.Numerics" />
     <Reference Include="System.Xaml" />
+    <Reference Include="UIAutomationTypes" />
     <Reference Include="WindowsBase" />
   </ItemGroup>
   <ItemGroup>
     <Compile Include="..\FSharpx.Tests\FsUnit.fs">
       <Link>FsUnit.fs</Link>
     </Compile>
+    <Compile Include="MyButton.fs" />
     <Content Include="NamedRoot.xaml">
       <CopyToOutputDirectory>Always</CopyToOutputDirectory>
     </Content>
@@ -62,6 +64,13 @@
     </Content>
     <Compile Include="Xaml.Tests.fs" />
   </ItemGroup>
+  <ItemGroup>
+    <ProjectReference Include="..\FSharpx.TypeProviders.Xaml.Tests.ExternalControl\FSharpx.TypeProviders.Xaml.Tests.ExternalControl.fsproj">
+      <Name>FSharpx.TypeProviders.Xaml.Tests.ExternalControl</Name>
+      <Project>{94b8edad-06d1-44a8-ac44-906d7b6a37ab}</Project>
+      <Private>True</Private>
+    </ProjectReference>
+  </ItemGroup>
   <PropertyGroup>
     <MinimumVisualStudioVersion Condition="'$(MinimumVisualStudioVersion)' == ''">11</MinimumVisualStudioVersion>
   </PropertyGroup>

diff --git a/tests/FSharpx.TypeProviders.Xaml.Tests/FSharpx.TypeProviders.Xaml.Tests.sln b/tests/FSharpx.TypeProviders.Xaml.Tests/FSharpx.TypeProviders.Xaml.Tests.sln
@@ -0,0 +1,26 @@
+
+Microsoft Visual Studio Solution File, Format Version 12.00
+# Visual Studio 2012
+Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FSharpx.TypeProviders.Xaml.Tests", "FSharpx.TypeProviders.Xaml.Tests.fsproj", "{36B258D4-1AA4-4031-906A-228E649A3EC4}"
+EndProject
+Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FSharpx.TypeProviders.Xaml.Tests.ExternalControl", "..\FSharpx.TypeProviders.Xaml.Tests.ExternalControl\FSharpx.TypeProviders.Xaml.Tests.ExternalControl.fsproj", "{94B8EDAD-06D1-44A8-AC44-906D7B6A37AB}"
+EndProject
+Global
+	GlobalSection(SolutionConfigurationPlatforms) = preSolution
+		Debug|Any CPU = Debug|Any CPU
+		Release|Any CPU = Release|Any CPU
+	EndGlobalSection
+	GlobalSection(ProjectConfigurationPlatforms) = postSolution
+		{36B258D4-1AA4-4031-906A-228E649A3EC4}.Debug|Any CPU.ActiveCfg = Debug|Any CPU
+		{36B258D4-1AA4-4031-906A-228E649A3EC4}.Debug|Any CPU.Build.0 = Debug|Any CPU
+		{36B258D4-1AA4-4031-906A-228E649A3EC4}.Release|Any CPU.ActiveCfg = Release|Any CPU
+		{36B258D4-1AA4-4031-906A-228E649A3EC4}.Release|Any CPU.Build.0 = Release|Any CPU
+		{94B8EDAD-06D1-44A8-AC44-906D7B6A37AB}.Debug|Any CPU.ActiveCfg = Debug|Any CPU
+		{94B8EDAD-06D1-44A8-AC44-906D7B6A37AB}.Debug|Any CPU.Build.0 = Debug|Any CPU
+		{94B8EDAD-06D1-44A8-AC44-906D7B6A37AB}.Release|Any CPU.ActiveCfg = Release|Any CPU
+		{94B8EDAD-06D1-44A8-AC44-906D7B6A37AB}.Release|Any CPU.Build.0 = Release|Any CPU
+	EndGlobalSection
+	GlobalSection(SolutionProperties) = preSolution
+		HideSolutionNode = FALSE
+	EndGlobalSection
+EndGlobal
diff --git a/tests/FSharpx.TypeProviders.Xaml.Tests/MyButton.fs b/tests/FSharpx.TypeProviders.Xaml.Tests/MyButton.fs
@@ -0,0 +1,5 @@
+namespace any
+type MyButton() =
+   inherit System.Windows.Controls.Button()
+
+
diff --git a/tests/FSharpx.TypeProviders.Xaml.Tests/StackPanel.xaml b/tests/FSharpx.TypeProviders.Xaml.Tests/StackPanel.xaml
@@ -1,11 +1,14 @@
 <Window xmlns="http://schemas.microsoft.com/winfx/2006/xaml/presentation"
         xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml"
+        xmlns:ext="clr-namespace:FSharpx.TypeProviders.Tests.Xaml;assembly=FSharpx.TypeProviders.Xaml.Tests.ExternalControl"
+        xmlns:any="clr-namespace:any;assembly=FSharpx.TypeProviders.Xaml.Tests"
         Title="MainWindow" Height="350" Width="525">
     <Grid Name="MainGrid">
         <StackPanel Name="StackPanel1">
             <Button Name="Button1">First Button</Button>
             <Button Name="Button2">Second Button</Button>
-            <!-- <Button Name="Control">An unfortunately named button</Button> -->
+            <any:MyButton x:Name="InternalComponent">My internal component should get the type object</any:MyButton>
+            <ext:MyExternalButton x:Name="ExternalComponent">My external component should get a type other than object</ext:MyExternalButton>
         </StackPanel>
     </Grid>
 </Window>
diff --git a/tests/FSharpx.TypeProviders.Xaml.Tests/Xaml.Tests.fs b/tests/FSharpx.TypeProviders.Xaml.Tests/Xaml.Tests.fs
@@ -5,7 +5,7 @@ open FSharpx
 open FsUnit
 
 type StackPanel = XAML<"StackPanel.xaml">
-
+ 
 [<Test>][<RequiresSTA>]
 let ``Can access the grid``() =      
    StackPanel().MainGrid.Name |> should equal "MainGrid"
@@ -20,6 +20,17 @@ let ``Can access the stackpanel from cache``() =
    window.StackPanel1.Name |> should equal "StackPanel1"
    window.StackPanel1.Name |> should equal "StackPanel1" // this goes through the cache
 
+[<Test>][<RequiresSTA>]
+let ``Internal components have obj at design-time but correct at run-time``() =      
+   let int = StackPanel().InternalComponent
+   int.GetType() |> should equal typedefof<any.MyButton>
+
+[<Test>][<RequiresSTA>]
+let ``External components have proper types``() =      
+   let ext = StackPanel().ExternalComponent
+   let clickmode = ext.ClickMode // Check compile-time type by accessing something
+   ext.GetType() |> should equal typedefof<TypeProviders.Tests.Xaml.MyExternalButton> // Check run-time type
+
 [<Test>][<RequiresSTA>]
 let ``Can access the first button``() =      
    StackPanel().Button1.Name |> should equal "Button1"