diff --git a/paket.dependencies b/paket.dependencies index 73f7d60f97..ae354bc0f8 100644 --- a/paket.dependencies +++ b/paket.dependencies @@ -10,6 +10,7 @@ nuget DotNetZip ~> 1.9.3 nuget SourceLink.Fake nuget NuGet.CommandLine nuget FSharp.Core.Microsoft.Signed +nuget FSharp.Compiler.Service github forki/FsUnit FsUnit.fs github fsharp/FAKE modules/Octokit/Octokit.fsx diff --git a/paket.lock b/paket.lock index c91d8b2dbd..78e5535246 100644 --- a/paket.lock +++ b/paket.lock @@ -3,10 +3,10 @@ NUGET specs: DotNetZip (1.9.3) FAKE (3.7.8) - FSharp.Compiler.Service (0.0.67) + FSharp.Compiler.Service (0.0.72) FSharp.Core.Microsoft.Signed (3.1.1.1) - FSharp.Formatting (2.4.36) - FSharp.Compiler.Service (0.0.67) + FSharp.Formatting (2.4.33) + FSharp.Compiler.Service (>= 0.0.62) Microsoft.AspNet.Razor (2.0.30506.0) RazorEngine (3.3.0) Microsoft.AspNet.Razor (2.0.30506.0) diff --git a/src/Paket.Core/DependencyOrdering.fs b/src/Paket.Core/DependencyOrdering.fs new file mode 100644 index 0000000000..b4d1cc5437 --- /dev/null +++ b/src/Paket.Core/DependencyOrdering.fs @@ -0,0 +1,162 @@ +module Paket.DependencyOrdering + +open Microsoft.Build +open Microsoft.Build.Framework +open Microsoft.Build.Tasks +open Microsoft.Build.Utilities +open System.Reflection +open System + +type String = string +type Seq<'a> = seq<'a> +type Bool = bool + +module List = + let toStringWithDelims (fr: String) (sep: String) (bk: String) (xs: List<'a>) : String = + let rec toSWD acc ys = + match ys with + | [] -> acc + | [z] -> sprintf "%s%A" acc z + | y::z::zs -> toSWD (sprintf "%s%A%s" acc y sep) (z::zs) + fr + toSWD "" xs + bk + +module Object = + let eqHack (f: 'a -> 'b) (x: 'a) (yobj: Object) : Boolean = + match yobj with + | :? 'a as y -> f x = f y + | _ -> false + + let compHack (f: 'a -> 'b) (x: 'a) (yobj: Object) : Int32 = + match yobj with + | :? 'a as y -> compare (f x) (f y) + | _ -> invalidArg "yobj" "Cannot compare elements of incompatible types" + +type Digraph<'n> when 'n : comparison = + Map<'n, Set<'n>> + +module Digraph = + + let addNode (n: 'n) (g: Digraph<'n>) : Digraph<'n> = + match Map.tryFind n g with + | None -> Map.add n Set.empty g + | Some _ -> g + + let addEdge ((n1, n2): 'n * 'n) (g: Digraph<'n>) : Digraph<'n> = + let g' = + match Map.tryFind n2 g with + | None -> addNode n2 g + | Some _ -> g + match Map.tryFind n1 g with + | None -> Map.add n1 (Set.singleton n2) g' + | Some ns -> Map.add n1 (Set.add n2 ns) g' + + let nodes (g: Digraph<'n>) : List<'n> = + Map.fold (fun xs k _ -> k::xs) [] g + + let roots (g: Digraph<'n>) : List<'n> = + List.filter (fun n -> not (Map.exists (fun _ v -> Set.contains n v) g)) (nodes g) + + let topSort (h: Digraph<'n>) : List<'n> = + let rec dfs (g: Digraph<'n>, order: List<'n>, rts: List<'n>) : List<'n> = + if List.isEmpty rts then + order + else + let n = List.head rts + let children = Map.find n g + let order' = n::order + let g' = Map.remove n g + let rts' = roots g' + dfs (g', order', rts') + dfs (h, [], roots h) + +[] +[] +[] +type AssemblyRef = + { + Path: String + Assembly: Assembly + Name: String + } + + member this.show = this.ToString () + + override this.Equals (obj: Object) : bool = + Object.eqHack (fun (a:AssemblyRef) -> a.Name) this obj + + override this.GetHashCode () = + hash this.Name + + interface System.IComparable with + member this.CompareTo (obj: Object) = + Object.compHack (fun (p:AssemblyRef) -> p.Name) this obj + + override x.ToString () = x.Path + +[] +type ForeignAidWorker () = + + let mkGraph (seeds: seq) : Digraph = + + let findRef (s: Seq) (m: AssemblyName) : Seq = + match Seq.tryFind (fun (r: AssemblyRef) -> r.Name = m.Name) seeds with + | None -> s + | Some ar -> Seq.append (Seq.singleton ar) s + + let processNode (g: Digraph) (n: AssemblyRef) : Digraph = + let depNames = n.Assembly.GetReferencedAssemblies () + let depRefs = Array.fold findRef Seq.empty depNames + Seq.fold (fun h c -> Digraph.addEdge (n, c) h) g depRefs + + let rec fixpoint (g: Digraph) : Digraph = + let ns = Digraph.nodes g + let g' = List.fold processNode g ns + if g = g' then g else fixpoint g' + + fixpoint (Seq.fold (fun g s -> Digraph.addNode s g) Map.empty seeds) + + let mkAssemblyRef (t: String) : AssemblyRef = + let asmBytes = System.IO.File.ReadAllBytes(t) + let assm = Assembly.Load(asmBytes) + { + Path = t + Assembly = assm + Name = assm.GetName().Name + } + + member x.Work(rs: String[]) : String = + let asmRefs = Array.map mkAssemblyRef rs + let graph = mkGraph asmRefs + let ordering = Digraph.topSort graph + let str = List.toStringWithDelims "#r @\"" "\"\n#r @\"" "\"" ordering + str + +type OrderAssemblyReferences() = + inherit Task () + + // These dlls are explicitly excluded. This is to prevent + // triggering a bug in Mono where the path to mscorlib is + // overridden by the empty string. In any case, System.dll + // depends on itself, and was never output by the topological + // sort. All these dlls are loaded by FSI automatically. + let excludes = ["mscorlib.dll"; "System.dll"; "FSharp.Core.dll"; "System.Core.dll"] + + member val ReferencePaths = null with get,set + + [] + member val Ordering = "" with get,set + + override x.Execute () : Bool = + let setup = AppDomainSetup() + do setup.ApplicationBase <- System.IO.Path.GetDirectoryName(System.Reflection.Assembly.GetExecutingAssembly().Location) + let appDomain = AppDomain.CreateDomain("TestDomain", null, setup) + try + let paths = Array.map (fun (i: ITaskItem) -> i.ItemSpec) x.ReferencePaths + |> Array.filter (fun (s: String) -> List.forall (fun s' -> not (s.EndsWith s')) excludes) + let faw = (appDomain.CreateInstanceAndUnwrap(typeof.Assembly.FullName, typeof.FullName)) :?> ForeignAidWorker + let ordering = faw.Work(paths) + do x.Ordering <- ordering + true + finally + do AppDomain.Unload(appDomain) + diff --git a/src/Paket.Core/EmitFsx.fs b/src/Paket.Core/EmitFsx.fs new file mode 100644 index 0000000000..64bf8f8c53 --- /dev/null +++ b/src/Paket.Core/EmitFsx.fs @@ -0,0 +1,26 @@ +module Paket.EmitFsx + +open Paket +open System +open System.IO +open Paket.Logging + +let PrintFsx projectFile properties = + let p = ProjectParser.FSharpProjectFileInfo.Parse(projectFile, properties) + + let assemblies = + [| match p.OutputFile with Some f -> yield f | None -> () + for ref in p.References do yield ref |] + + printfn "References: %A" assemblies + + printfn "Dir: %s" p.Directory + + let dir = Environment.CurrentDirectory + Environment.CurrentDirectory <- p.Directory + + let faw = DependencyOrdering.ForeignAidWorker() + + + printfn "Script includes:\n%s" (faw.Work(assemblies)) + Environment.CurrentDirectory <- dir diff --git a/src/Paket.Core/FSharpProjectFileInfo.fs b/src/Paket.Core/FSharpProjectFileInfo.fs new file mode 100644 index 0000000000..8f59644184 --- /dev/null +++ b/src/Paket.Core/FSharpProjectFileInfo.fs @@ -0,0 +1,348 @@ +module Paket.ProjectParser + +open Microsoft.Build.Framework +open Microsoft.Build.Utilities +open System.IO +open System.Text +open System + +let runningOnMono = try System.Type.GetType("Mono.Runtime") <> null with e -> false + +type internal BasicStringLogger() = + inherit Logger() + + let sb = new StringBuilder() + + let log (e: BuildEventArgs) = + sb.Append(e.Message) |> ignore + sb.AppendLine() |> ignore + + override x.Initialize(eventSource:IEventSource) = + sb.Clear() |> ignore + eventSource.AnyEventRaised.Add(log) + + member x.Log = sb.ToString() + +type FSharpProjectFileInfo (fsprojFileName:string, ?properties, ?enableLogging) = + + let properties = defaultArg properties [] + let enableLogging = defaultArg enableLogging false + let mkAbsolute dir v = + if Path.IsPathRooted v then v + else Path.Combine(dir, v) + + let mkAbsoluteOpt dir v = Option.map (mkAbsolute dir) v + + let logOpt = + if enableLogging then + let log = new BasicStringLogger() + do log.Verbosity <- LoggerVerbosity.Diagnostic + Some log + else + None + + // Use the old API on Mono, with ToolsVersion = 12.0 + let CrackProjectUsingOldBuildAPI(fsprojFile:string) = + let engine = new Microsoft.Build.BuildEngine.Engine() +// Does Paket have .NET 4.0 build? +//#if FX_ATLEAST_45 + engine.DefaultToolsVersion <- "12.0" +// #else +// engine.DefaultToolsVersion <- "4.0" +// #endif + + Option.iter (fun l -> engine.RegisterLogger(l)) logOpt + + let bpg = Microsoft.Build.BuildEngine.BuildPropertyGroup() + + for (prop, value) in properties do + bpg.SetProperty(prop, value) + + engine.GlobalProperties <- bpg + + let projectFromFile (fsprojFile:string) = + // We seem to need to pass 12.0/4.0 in here for some unknown reason + let project = new Microsoft.Build.BuildEngine.Project(engine, engine.DefaultToolsVersion) + do project.Load(fsprojFile) + project + + let project = projectFromFile fsprojFile + + project.Build([|"ResolveAssemblyReferences"; "ImplicitlyExpandTargetFramework"|]) |> ignore + + let directory = Path.GetDirectoryName project.FullFileName + + let getProp (p: Microsoft.Build.BuildEngine.Project) s = + let v = p.GetEvaluatedProperty s + if String.IsNullOrWhiteSpace v then None + else Some v + + let outdir p = mkAbsoluteOpt directory (getProp p "OutDir") + let outFileOpt p = + match outdir p with + | None -> None + | Some d -> mkAbsoluteOpt d (getProp p "TargetFileName") + + let getItems s = + let fs = project.GetEvaluatedItemsByName(s) + [ for f in fs -> mkAbsolute directory f.FinalItemSpec ] + + let projectReferences = + [ for i in project.GetEvaluatedItemsByName("ProjectReference") do + yield mkAbsolute directory i.FinalItemSpec + ] + + let references = + [ for i in project.GetEvaluatedItemsByName("ResolvedFiles") do + yield i.FinalItemSpec + for fsproj in projectReferences do + match (try let p' = projectFromFile fsproj + do p'.Load(fsproj) + Some (outFileOpt p') with _ -> None) with + | Some (Some output) -> yield output + | _ -> () ] + + outFileOpt project, directory, getItems, references, projectReferences, getProp project, project.FullFileName + + let CrackProjectUsingNewBuildAPI(fsprojFile) = + let fsprojFullPath = try Path.GetFullPath(fsprojFile) with _ -> fsprojFile + let fsprojAbsDirectory = Path.GetDirectoryName fsprojFullPath + + use _pwd = + let dir = Environment.CurrentDirectory + Environment.CurrentDirectory <- fsprojAbsDirectory + { new System.IDisposable with member x.Dispose() = Environment.CurrentDirectory <- dir } + use engine = new Microsoft.Build.Evaluation.ProjectCollection() + + let projectInstanceFromFullPath (fsprojFullPath: string) = + use stream = new StreamReader(fsprojFullPath) + use xmlReader = System.Xml.XmlReader.Create(stream) + + let project = engine.LoadProject(xmlReader, FullPath=fsprojFullPath) + for (prop, value) in properties do + project.SetProperty(prop, value) |> ignore + + project.CreateProjectInstance() + + let project = projectInstanceFromFullPath fsprojFullPath + let directory = project.Directory + + let getprop (p: Microsoft.Build.Execution.ProjectInstance) s = + let v = p.GetPropertyValue s + if String.IsNullOrWhiteSpace v then None + else Some v + + let outFileOpt p = mkAbsoluteOpt directory (getprop p "TargetPath") + + let log = match logOpt with + | None -> [] + | Some l -> [l :> ILogger] + + project.Build([| "ResolveAssemblyReferences"; "ImplicitlyExpandTargetFramework" |], log) |> ignore + + let getItems s = [ for f in project.GetItems(s) -> mkAbsolute directory f.EvaluatedInclude ] + + let projectReferences = + [ for cp in project.GetItems("ProjectReference") do + yield cp.GetMetadataValue("FullPath") + ] + + let references = + [ for i in project.GetItems("ReferencePath") do + yield i.EvaluatedInclude + for fsproj in projectReferences do + match (try let p' = projectInstanceFromFullPath fsproj + Some (outFileOpt p') with _ -> None) with + | Some (Some output) -> yield output + | _ -> () + ] + + outFileOpt project, directory, getItems, references, projectReferences, getprop project, project.FullPath + + let outFileOpt, directory, getItems, references, projectReferences, getProp, fsprojFullPath = + try + if runningOnMono then + CrackProjectUsingOldBuildAPI(fsprojFileName) + else + CrackProjectUsingNewBuildAPI(fsprojFileName) + with + | :? Microsoft.Build.BuildEngine.InvalidProjectFileException as e -> + raise (Microsoft.Build.Exceptions.InvalidProjectFileException( + e.ProjectFile, + e.LineNumber, + e.ColumnNumber, + e.EndLineNumber, + e.EndColumnNumber, + e.Message, + e.ErrorSubcategory, + e.ErrorCode, + e.HelpKeyword)) + | :? ArgumentException as e -> raise (IO.FileNotFoundException(e.Message)) + + + let logOutput = match logOpt with None -> "" | Some l -> l.Log + let pages = getItems "Page" + let embeddedResources = getItems "EmbeddedResource" + let files = getItems "Compile" + let resources = getItems "Resource" + let noaction = getItems "None" + let content = getItems "Content" + + let split (s : string option) (cs : char []) = + match s with + | None -> [||] + | Some s -> + if String.IsNullOrWhiteSpace s then [||] + else s.Split(cs, StringSplitOptions.RemoveEmptyEntries) + + let getbool (s : string option) = + match s with + | None -> false + | Some s -> + match (Boolean.TryParse s) with + | (true, result) -> result + | (false, _) -> false + + let fxVer = getProp "TargetFrameworkVersion" + let optimize = getProp "Optimize" |> getbool + let assemblyNameOpt = getProp "AssemblyName" + let tailcalls = getProp "Tailcalls" |> getbool + let outputPathOpt = getProp "OutputPath" + let docFileOpt = getProp "DocumentationFile" + let outputTypeOpt = getProp "OutputType" + let debugTypeOpt = getProp "DebugType" + let baseAddressOpt = getProp "BaseAddress" + let sigFileOpt = getProp "GenerateSignatureFile" + let keyFileOpt = getProp "KeyFile" + let pdbFileOpt = getProp "PdbFile" + let platformOpt = getProp "Platform" + let targetTypeOpt = getProp "TargetType" + let versionFileOpt = getProp "VersionFile" + let targetProfileOpt = getProp "TargetProfile" + let warnLevelOpt = getProp "Warn" + let subsystemVersionOpt = getProp "SubsystemVersion" + let win32ResOpt = getProp "Win32ResourceFile" + let heOpt = getProp "HighEntropyVA" |> getbool + let win32ManifestOpt = getProp "Win32ManifestFile" + let debugSymbols = getProp "DebugSymbols" |> getbool + let prefer32bit = getProp "Prefer32Bit" |> getbool + let warnAsError = getProp "TreatWarningsAsErrors" |> getbool + let defines = split (getProp "DefineConstants") [| ';'; ','; ' ' |] + let nowarn = split (getProp "NoWarn") [| ';'; ','; ' ' |] + let warningsAsError = split (getProp "WarningsAsErrors") [| ';'; ','; ' ' |] + let libPaths = split (getProp "ReferencePath") [| ';'; ',' |] + let otherFlags = split (getProp "OtherFlags") [| ' ' |] + let isLib = (outputTypeOpt = Some "Library") + + let docFileOpt = + match docFileOpt with + | None -> None + | Some docFile -> Some(mkAbsolute directory docFile) + + + let options = + [ yield "--simpleresolution" + yield "--noframework" + match outFileOpt with + | None -> () + | Some outFile -> yield "--out:" + outFile + match docFileOpt with + | None -> () + | Some docFile -> yield "--doc:" + docFile + match baseAddressOpt with + | None -> () + | Some baseAddress -> yield "--baseaddress:" + baseAddress + match keyFileOpt with + | None -> () + | Some keyFile -> yield "--keyfile:" + keyFile + match sigFileOpt with + | None -> () + | Some sigFile -> yield "--sig:" + sigFile + match pdbFileOpt with + | None -> () + | Some pdbFile -> yield "--pdb:" + pdbFile + match versionFileOpt with + | None -> () + | Some versionFile -> yield "--versionfile:" + versionFile + match warnLevelOpt with + | None -> () + | Some warnLevel -> yield "--warn:" + warnLevel + match subsystemVersionOpt with + | None -> () + | Some s -> yield "--subsystemversion:" + s + if heOpt then yield "--highentropyva+" + match win32ResOpt with + | None -> () + | Some win32Res -> yield "--win32res:" + win32Res + match win32ManifestOpt with + | None -> () + | Some win32Manifest -> yield "--win32manifest:" + win32Manifest + match targetProfileOpt with + | None -> () + | Some targetProfile -> yield "--targetprofile:" + targetProfile + yield "--fullpaths" + yield "--flaterrors" + if warnAsError then yield "--warnaserror" + yield + if isLib then "--target:library" + else "--target:exe" + for symbol in defines do + if not (String.IsNullOrWhiteSpace symbol) then yield "--define:" + symbol + for nw in nowarn do + if not (String.IsNullOrWhiteSpace nw) then yield "--nowarn:" + nw + for nw in warningsAsError do + if not (String.IsNullOrWhiteSpace nw) then yield "--warnaserror:" + nw + yield if debugSymbols then "--debug+" + else "--debug-" + yield if optimize then "--optimize+" + else "--optimize-" + yield if tailcalls then "--tailcalls+" + else "--tailcalls-" + match debugTypeOpt with + | None -> () + | Some debugType -> + match debugType.ToUpperInvariant() with + | "NONE" -> () + | "PDBONLY" -> yield "--debug:pdbonly" + | "FULL" -> yield "--debug:full" + | _ -> () + match platformOpt |> Option.map (fun o -> o.ToUpperInvariant()), prefer32bit, + targetTypeOpt |> Option.map (fun o -> o.ToUpperInvariant()) with + | Some "ANYCPU", true, Some "EXE" | Some "ANYCPU", true, Some "WINEXE" -> yield "--platform:anycpu32bitpreferred" + | Some "ANYCPU", _, _ -> yield "--platform:anycpu" + | Some "X86", _, _ -> yield "--platform:x86" + | Some "X64", _, _ -> yield "--platform:x64" + | Some "ITANIUM", _, _ -> yield "--platform:Itanium" + | _ -> () + match targetTypeOpt |> Option.map (fun o -> o.ToUpperInvariant()) with + | Some "LIBRARY" -> yield "--target:library" + | Some "EXE" -> yield "--target:exe" + | Some "WINEXE" -> yield "--target:winexe" + | Some "MODULE" -> yield "--target:module" + | _ -> () + yield! otherFlags + for f in resources do + yield "--resource:" + f + for i in libPaths do + yield "--lib:" + mkAbsolute directory i + for r in references do + yield "-r:" + r + yield! files ] + + member x.Options = options + member x.FrameworkVersion = fxVer + member x.ProjectReferences = projectReferences + member x.References = references + member x.CompileFiles = files + member x.ResourceFiles = resources + member x.EmbeddedResourceFiles = embeddedResources + member x.ContentFiles = content + member x.OtherFiles = noaction + member x.PageFiles = pages + member x.OutputFile = outFileOpt + member x.Directory = directory + member x.AssemblyName = assemblyNameOpt + member x.OutputPath = outputPathOpt + member x.FullPath = fsprojFullPath + member x.LogOutput = logOutput + static member Parse(fsprojFileName:string, ?properties, ?enableLogging) = new FSharpProjectFileInfo(fsprojFileName, ?properties=properties, ?enableLogging=enableLogging) diff --git a/src/Paket.Core/Paket.Core.fsproj b/src/Paket.Core/Paket.Core.fsproj index 387ba59c54..34868ebdac 100644 --- a/src/Paket.Core/Paket.Core.fsproj +++ b/src/Paket.Core/Paket.Core.fsproj @@ -9,7 +9,7 @@ Library Paket Paket.Core - v4.0 + v4.5 4.3.0.0 Paket @@ -74,6 +74,9 @@ + + + @@ -112,6 +115,17 @@ + + + + + + + + + + +