ProjectProvider.fs

namespace FSharpVSPowerTools.ProjectSystem

open System
open System.IO
open System.Diagnostics
open EnvDTE
open VSLangProj
open FSharp.CompilerBinding
open System.Reflection
open Microsoft.FSharp.Reflection

module Reflection = 
    // Various flags configurations for Reflection
    let staticFlags = BindingFlags.NonPublic ||| BindingFlags.Public ||| BindingFlags.Static
    let instanceFlags = BindingFlags.NonPublic ||| BindingFlags.Public ||| BindingFlags.Instance
    let ctorFlags = instanceFlags
    let inline asMethodBase (a : #MethodBase) = a :> MethodBase
    
    let (?) (o : obj) name : 'R = 
        // The return type is a function, which means that we want to invoke a method
        if FSharpType.IsFunction(typeof<'R>) then 
            let argType, _resType = FSharpType.GetFunctionElements(typeof<'R>)            
            FSharpValue.MakeFunction(typeof<'R>, 
                fun args -> 
                    // We treat elements of a tuple passed as argument as a list of arguments
                    // When the 'o' object is 'System.Type', we call static methods
                    let methods, instance, args = 
                        let typeInfo = o.GetType()
                        let args = 
                            if argType = typeof<unit> then [||]
                            elif not (FSharpType.IsTuple(argType)) then [| args |]
                            else FSharpValue.GetTupleFields(args)                        
                        if (typeof<System.Type>).IsAssignableFrom(typeInfo) then 
                            let methods = (unbox<Type> o).GetMethods(staticFlags) |> Array.map asMethodBase
                            let ctors = 
                                (unbox<Type> o).GetConstructors(ctorFlags) 
                                |> Array.map asMethodBase
                            Array.concat [ methods; ctors ], null, args
                        else 
                            typeInfo.GetMethods(instanceFlags) |> Array.map asMethodBase, o, 
                            args
                                         
                    // A simple overload resolution based on the name and number of parameters only
                    let methods = 
                        [ for m in methods do
                            if m.Name = name && m.GetParameters().Length = args.Length then 
                                yield m ]
                                         
                    match methods with
                    | [] -> failwithf "No method '%s' with %d arguments found" name args.Length
                    | _ :: _ :: _ -> 
                        failwithf "Multiple methods '%s' with %d arguments found" name args.Length
                    | [ :? ConstructorInfo as c ] -> c.Invoke(args)
                    | [ m ] -> m.Invoke(instance, args))
            |> unbox<'R>
        else 
            // When the 'o' object is 'System.Type', we access static properties
            let typ, flags, instance = 
                if (typeof<System.Type>).IsAssignableFrom(o.GetType()) then unbox o, staticFlags, null
                else o.GetType(), instanceFlags, o
            
            // Find a property that we can call and get the value
            let prop = typ.GetProperty(name, flags)
            if prop = null then failwithf "Property '%s' not found in '%s' using flags '%A'." name typ.Name flags
            let meth = prop.GetGetMethod(true)
            if prop = null then failwithf "Property '%s' found, but doesn't have 'get' method." name
            meth.Invoke(instance, [||]) |> unbox<'R>

open Reflection
    
type internal ProjectSite(wrapped : obj) =
    member __.SourceFilesOnDisk : string [] = wrapped?SourceFilesOnDisk()
    member __.CompilerFlags : string [] = wrapped?CompilerFlags()

type internal ProvideProjectSite(wrapped : obj) =
    member __.GetProjectSite() : ProjectSite = ProjectSite(wrapped?GetProjectSite())

open EnvDTE80
open Microsoft.VisualStudio
open Microsoft.VisualStudio.Shell
open Microsoft.VisualStudio.Shell.Interop
open Microsoft.VisualStudio.OLE.Interop

type ProjectProvider(project : VSProject) = 
    do Debug.Assert(project <> null && project.Project <> null, "Input project should be well-formed.")
    
    let getProperty (tag : string) =
        let prop = try project.Project.Properties.[tag] with _ -> null
        match prop with
        | null -> null
        | _ -> prop.Value.ToString()

    let hierarchy =
        let dte2 = Package.GetGlobalService(typedefof<SDTE>) :?> DTE2
        use serviceProvider = new ServiceProvider(dte2 :?> IServiceProvider)
        
        let solution = serviceProvider.GetService(typedefof<SVsSolution>) :?> IVsSolution        
        match solution.GetProjectOfUniqueName(project.Project.FullName) with
        | VSConstants.S_OK, hierarchy -> 
            hierarchy
        | _ -> null

    /// Wraps the given string between double quotes
    let wrap (s : string) = if s.StartsWith "\"" then s else String.Join("", "\"", s, "\"")  

    let currentDir = getProperty "FullPath"
    let projectFileName = 
        let fileName = getProperty "FileName"
        Debug.Assert(fileName <> null && currentDir <> null, "Should have a file name for the project.")
        Path.Combine(currentDir, fileName)

    member __.ProjectFileName = projectFileName

    member __.TargetFSharpCoreVersion = 
        getProperty "TargetFSharpCoreVersion"

    member __.TargetFramework = 
        match getProperty "TargetFrameworkVersion" with
        | null | "v4.5" | "v4.5.1" -> FSharpTargetFramework.NET_4_5
        | "v4.0" -> FSharpTargetFramework.NET_4_0
        | "v3.5" -> FSharpTargetFramework.NET_3_5
        | "v3.0" -> FSharpTargetFramework.NET_3_5
        | "v2.0" -> FSharpTargetFramework.NET_2_0
        | _ -> invalidArg "prop" "Unsupported .NET framework version"

    member private __.References = 
        project.References
        |> Seq.cast<Reference>
        // Remove all project references for now
        |> Seq.choose (fun r -> if r.SourceProject = null then Some(Path.Combine(r.Path, r.Name)) else None)
        |> Seq.map (fun name -> 
            let assemblyName = if name.EndsWith ".dll" then name else name + ".dll"
            sprintf "-r:%s" (wrap assemblyName))

    member this.CompilerOptions = 
        try
            Debug.Assert(hierarchy <> null, "Should have a well-formed hierachy.")
            let provideProjectSite = ProvideProjectSite(hierarchy :> obj)
            let projectSite = provideProjectSite.GetProjectSite()
            projectSite.CompilerFlags
        with e ->
            Debug.WriteLine(sprintf "[Project System] %O exception occurs. Fall back to default compiler flags." e) 
            [|  
               yield "--noframework"
               yield "--debug-"
               yield "--optimize-"
               yield "--tailcalls-"               
               yield! this.References
            |]

    member __.SourceFiles = 
        try
            Debug.Assert(hierarchy <> null, "Should have a well-formed hierachy.")
            let provideProjectSite = ProvideProjectSite(hierarchy :> obj)
            let projectSite = provideProjectSite.GetProjectSite()
            projectSite.SourceFilesOnDisk
        with e ->
            Debug.WriteLine(sprintf "[Project System] %O exception occurs. Fall back to incomplete source file listing." e) 
            let projectItems = project.Project.ProjectItems
            Debug.Assert(Seq.cast<ProjectItem> projectItems <> null && projectItems.Count > 0, "Should have file names in the project.")
            projectItems
            |> Seq.cast<ProjectItem>
            |> Seq.filter (fun item -> try item.Document <> null with _ -> false)
            |> Seq.choose (fun item -> 
                // TODO: there should be a better way to get source files
                let buildAction = item.Properties.["BuildAction"].Value.ToString()
                if buildAction = "BuildAction=Compile" then Some item else None)    
            |> Seq.map (fun item -> Path.Combine(currentDir, item.Properties.["FileName"].Value.ToString()))
            |> Seq.toArray