From 014af4d4a0b194f55a042a1024b477b74568d1db Mon Sep 17 00:00:00 2001 From: Oleg Zaimkin Date: Fri, 8 Nov 2019 13:29:59 +0700 Subject: [PATCH 01/22] fix compilation and tests for most-recent F# compiler and dotnet SDK, minor cleanup (namespaces and modules) --- .gitignore | 1 + build.fsx | 2 +- src/core/CommonLib.fs | 100 +++-- src/core/ExecCore.fs | 730 ++++++++++++++++++------------------ src/core/ExecTypes.fs | 10 +- src/core/File.fs | 4 +- src/core/Fileset.fs | 514 +++++++++++++------------ src/core/Logging.fs | 2 +- src/core/Path.fs | 448 +++++++++++----------- src/core/PathExt.fs | 19 + src/core/Pickler.fs | 148 ++++---- src/core/ProcessExec.fs | 81 ++-- src/core/RecipeFunctions.fs | 147 ++++---- src/core/ScriptFuncs.fs | 2 - src/core/WorkerPool.fs | 99 +++-- src/core/Xake.fsproj | 1 + 16 files changed, 1141 insertions(+), 1167 deletions(-) create mode 100644 src/core/PathExt.fs diff --git a/.gitignore b/.gitignore index 8bbb6ff..7887589 100644 --- a/.gitignore +++ b/.gitignore @@ -14,6 +14,7 @@ _UpgradeReport* packages .nuget .paket +.ionide # Ignore Visual Studio files *.pdb diff --git a/build.fsx b/build.fsx index 0e27744..dd1649b 100644 --- a/build.fsx +++ b/build.fsx @@ -64,7 +64,7 @@ do xakeScript { // in case of travis only run tests for standard runtime, eventually will add more let! limitFwk = getEnv("TRAVIS") |> Recipe.map (function | Some _ -> ["-f:netcoreapp2.0"] | _ -> []) - do! dotnet <| ["test"; "src/tests"; "-c"; "Release"] @ where @ limitFwk + do! dotnet <| ["test"; "src/tests"; "-c"; "Release"; "-p:ParallelizeTestCollections=false"] @ where @ limitFwk } libtargets *..> recipe { diff --git a/src/core/CommonLib.fs b/src/core/CommonLib.fs index 0796fac..ec1488e 100644 --- a/src/core/CommonLib.fs +++ b/src/core/CommonLib.fs @@ -1,57 +1,55 @@ -namespace Xake +[] +module internal Xake.CommonLib -[] -module internal CommonLib = +type private CacheKey<'K> = K of 'K - type private CacheKey<'K> = K of 'K +/// +/// Creates a memoized function with the same signature. Performs memoization by storing run results to a cache. +/// +/// +let memoize f = + let cache = ref Map.empty + let lck = System.Object() + fun x -> + match !cache |> Map.tryFind (K x) with + | Some v -> v + | None -> + lock lck (fun () -> + match !cache |> Map.tryFind (K x) with + | Some v -> v + | None -> + let res = f x + cache := !cache |> Map.add (K x) res + res) - /// - /// Creates a memoized function with the same signature. Performs memoization by storing run results to a cache. - /// - /// - let memoize f = - let cache = ref Map.empty - let lck = System.Object() - fun x -> - match !cache |> Map.tryFind (K x) with - | Some v -> v - | None -> - lock lck (fun () -> - match !cache |> Map.tryFind (K x) with - | Some v -> v - | None -> - let res = f x - cache := !cache |> Map.add (K x) res - res) - - ///**Description** - /// Memoizes the recursive function. Memoized function is passed as first argument to f. - ///**Parameters** - /// * `f` - parameter of type `('a -> 'b) -> 'a -> 'b` The function to be memoized. - /// - ///**Output Type** - /// * `'a -> 'b` - /// - ///**Exceptions** - /// - let memoizeRec f = - let rec fn x = f fm x - and fm = fn |> memoize - in - fm +///**Description** +/// Memoizes the recursive function. Memoized function is passed as first argument to f. +///**Parameters** +/// * `f` - parameter of type `('a -> 'b) -> 'a -> 'b` The function to be memoized. +/// +///**Output Type** +/// * `'a -> 'b` +/// +///**Exceptions** +/// +let memoizeRec f = + let rec fn x = f fm x + and fm = fn |> memoize + in + fm - /// - /// Takes n first elements from a list. - /// - /// - let rec take cnt = function |_ when cnt <= 0 -> [] |[] -> [] |a::rest -> a :: (take (cnt-1) rest) +/// +/// Takes n first elements from a list. +/// +/// +let rec take cnt = function |_ when cnt <= 0 -> [] |[] -> [] |a::rest -> a :: (take (cnt-1) rest) - /// - /// Returns a list of unique values for a specific list. - /// - /// - let distinct ls = - ls |> - List.fold (fun map item -> if map |> Map.containsKey item then map else map |> Map.add item 1) Map.empty - |> Map.toList |> List.map fst +/// +/// Returns a list of unique values for a specific list. +/// +/// +let distinct ls = + ls |> + List.fold (fun map item -> if map |> Map.containsKey item then map else map |> Map.add item 1) Map.empty + |> Map.toList |> List.map fst diff --git a/src/core/ExecCore.fs b/src/core/ExecCore.fs index 2e50fe8..b9d50d3 100644 --- a/src/core/ExecCore.fs +++ b/src/core/ExecCore.fs @@ -1,381 +1,377 @@ -namespace Xake - -module internal ExecCore = +module internal Xake.ExecCore + +open System.Text.RegularExpressions +open DependencyAnalysis + +/// Default options +[] +let XakeOptions = ExecOptions.Default + +open Storage + +/// Writes the message with formatting to a log +let traceLog (level:Logging.Level) fmt = + let write s = action { + let! ctx = getCtx() + return ctx.Logger.Log level "%s" s + } + Printf.kprintf write fmt + +let wildcardsRegex = Regex(@"\*\*|\*|\?", RegexOptions.Compiled) +let patternTagRegex = Regex(@"\((?'tag'\w+?)\:[^)]+\)", RegexOptions.Compiled) +let replace (regex:Regex) (evaluator: Match -> string) text = regex.Replace(text, evaluator) +let ifNone x = function |Some x -> x | _ -> x + +let (|Dump|Dryrun|Run|) (opts:ExecOptions) = + match opts with + | _ when opts.DumpDeps -> Dump + | _ when opts.DryRun -> Dryrun + | _ -> Run + +let applyWildcards = function + | None -> id + | Some matches -> + fun pat -> + let mutable i = 0 + let evaluator m = + i <- i + 1 + matches |> Map.tryFind (i.ToString()) |> ifNone "" + let evaluatorTag (m: Match) = + matches |> (Map.tryFind m.Groups.["tag"].Value) |> ifNone "" + pat + |> replace wildcardsRegex evaluator + |> replace patternTagRegex evaluatorTag + +// locates the rule +let locateRule (Rules rules) projectRoot target = + let matchRule rule = + match rule, target with + + |FileConditionRule (meetCondition,_), FileTarget file when file |> File.getFullName |> meetCondition -> + //writeLog Level.Debug "Found conditional pattern '%s'" name + // TODO let condition rule extracting named groups + Some (rule,[],[target]) + + |FileRule (pattern,_), FileTarget file -> + file + |> File.getFullName + |> Path.matchGroups pattern projectRoot + |> Option.map (fun groups -> rule,groups,[target]) + + |MultiFileRule (patterns, _), FileTarget file -> + let fname = file |> File.getFullName + patterns + |> List.tryPick(fun pattern -> + Path.matchGroups pattern projectRoot fname + |> Option.map(fun groups -> groups, pattern) + ) + |> Option.map (fun (groups, _) -> + let generateName = applyWildcards (Map.ofList groups |> Some) + + let targets = patterns |> List.map (generateName >> () projectRoot >> File.make >> FileTarget) + rule, groups, targets) + + |PhonyRule (name,_), PhonyAction phony when phony = name -> + // writeLog Verbose "Found phony pattern '%s'" name + Some (rule, [], [target]) + + | _ -> None + + rules |> List.tryPick matchRule + +let reportError ctx error details = + do ctx.Logger.Log Error "Error '%s'. See build.log for details" error + do ctx.Logger.Log Verbose "Error details are:\n%A\n\n" details + +let raiseError ctx error details = + do reportError ctx error details + raise (XakeException(sprintf "Script failed (error code: %A)\n%A" error details)) + +// Ordinal of the task being added to a task pool +let refTaskOrdinal = ref 0 + +/// +/// Creates a context for a new task +/// +let newTaskContext targets matches ctx = + let ordinal = System.Threading.Interlocked.Increment(refTaskOrdinal) + let prefix = ordinal |> sprintf "%i> " + in + {ctx with + Ordinal = ordinal; Logger = PrefixLogger prefix ctx.RootLogger + Targets = targets + RuleMatches = matches + } + +// executes single artifact +let rec execOne ctx target = + + let run ruleMatches action targets = + let primaryTarget = targets |> List.head + async { + match ctx.NeedRebuild targets with + | true -> + let taskContext = newTaskContext targets ruleMatches ctx + do ctx.Logger.Log Command "Started %s as task %i" primaryTarget.ShortName taskContext.Ordinal - open System.Text.RegularExpressions - open DependencyAnalysis + do Progress.TaskStart primaryTarget |> ctx.Progress.Post - /// Default options - [] - let XakeOptions = ExecOptions.Default + let startResult = {BuildLog.makeResult targets with Steps = [Step.start "all"]} + let! (result,_) = action (startResult, taskContext) + let result = Step.updateTotalDuration result - open WorkerPool - open Storage + Store result |> ctx.Db.Post - /// Writes the message with formatting to a log - let traceLog (level:Logging.Level) fmt = - let write s = action { - let! ctx = getCtx() - return ctx.Logger.Log level "%s" s - } - Printf.kprintf write fmt - - let wildcardsRegex = Regex(@"\*\*|\*|\?", RegexOptions.Compiled) - let patternTagRegex = Regex(@"\((?'tag'\w+?)\:[^)]+\)", RegexOptions.Compiled) - let replace (regex:Regex) (evaluator: Match -> string) text = regex.Replace(text, evaluator) - let ifNone x = function |Some x -> x | _ -> x - - let (|Dump|Dryrun|Run|) (opts:ExecOptions) = - match opts with - | _ when opts.DumpDeps -> Dump - | _ when opts.DryRun -> Dryrun - | _ -> Run - - let applyWildcards = function - | None -> id - | Some matches -> - fun pat -> - let mutable i = 0 - let evaluator m = - i <- i + 1 - matches |> Map.tryFind (i.ToString()) |> ifNone "" - let evaluatorTag (m: Match) = - matches |> (Map.tryFind m.Groups.["tag"].Value) |> ifNone "" - pat - |> replace wildcardsRegex evaluator - |> replace patternTagRegex evaluatorTag - - // locates the rule - let locateRule (Rules rules) projectRoot target = - let matchRule rule = - match rule, target with - - |FileConditionRule (meetCondition,_), FileTarget file when file |> File.getFullName |> meetCondition -> - //writeLog Level.Debug "Found conditional pattern '%s'" name - // TODO let condition rule extracting named groups - Some (rule,[],[target]) - - |FileRule (pattern,_), FileTarget file -> - file - |> File.getFullName - |> Path.matchGroups pattern projectRoot - |> Option.map (fun groups -> rule,groups,[target]) - - |MultiFileRule (patterns, _), FileTarget file -> - let fname = file |> File.getFullName - patterns - |> List.tryPick(fun pattern -> - Path.matchGroups pattern projectRoot fname - |> Option.map(fun groups -> groups, pattern) - ) - |> Option.map (fun (groups, pattern) -> - let generateName = applyWildcards (Map.ofList groups |> Some) - - let targets = patterns |> List.map (generateName >> () projectRoot >> File.make >> FileTarget) - rule, groups, targets) - - |PhonyRule (name,_), PhonyAction phony when phony = name -> - // writeLog Verbose "Found phony pattern '%s'" name - Some (rule, [], [target]) - - | _ -> None - - rules |> List.tryPick matchRule - - let reportError ctx error details = - do ctx.Logger.Log Error "Error '%s'. See build.log for details" error - do ctx.Logger.Log Verbose "Error details are:\n%A\n\n" details - - let raiseError ctx error details = - do reportError ctx error details - raise (XakeException(sprintf "Script failed (error code: %A)\n%A" error details)) - - // Ordinal of the task being added to a task pool - let refTaskOrdinal = ref 0 - - /// - /// Creates a context for a new task - /// - let newTaskContext targets matches ctx = - let ordinal = System.Threading.Interlocked.Increment(refTaskOrdinal) - let prefix = ordinal |> sprintf "%i> " - in - {ctx with - Ordinal = ordinal; Logger = PrefixLogger prefix ctx.RootLogger - Targets = targets - RuleMatches = matches + do Progress.TaskComplete primaryTarget |> ctx.Progress.Post + do ctx.Logger.Log Command "Completed %s in %A ms (wait %A ms)" primaryTarget.ShortName (Step.lastStep result).OwnTime (Step.lastStep result).WaitTime + return Succeed + | false -> + do ctx.Logger.Log Command "Skipped %s (up to date)" primaryTarget.ShortName + return Skipped } - // executes single artifact - let rec execOne ctx target = - - let run ruleMatches action targets = - let primaryTarget = targets |> List.head - async { - match ctx.NeedRebuild targets with - | true -> - let taskContext = newTaskContext targets ruleMatches ctx - do ctx.Logger.Log Command "Started %s as task %i" primaryTarget.ShortName taskContext.Ordinal - - do Progress.TaskStart primaryTarget |> ctx.Progress.Post - - let startResult = {BuildLog.makeResult targets with Steps = [Step.start "all"]} - let! (result,_) = action (startResult, taskContext) - let result = Step.updateTotalDuration result - - Store result |> ctx.Db.Post - - do Progress.TaskComplete primaryTarget |> ctx.Progress.Post - do ctx.Logger.Log Command "Completed %s in %A ms (wait %A ms)" primaryTarget.ShortName (Step.lastStep result).OwnTime (Step.lastStep result).WaitTime - return ExecStatus.Succeed - | false -> - do ctx.Logger.Log Command "Skipped %s (up to date)" primaryTarget.ShortName - return ExecStatus.Skipped - } - - let getAction = function - | FileRule (_, a) - | FileConditionRule (_, a) - | MultiFileRule (_, a) - | PhonyRule (_, a) -> a - - // result expression is... - match target |> locateRule ctx.Rules ctx.Options.ProjectRoot with - | Some(rule,groups,targets) -> - let groupsMap = groups |> Map.ofSeq - let (Recipe action) = rule |> getAction - async { - let! waitTask = (fun channel -> Run(target, targets, run groupsMap action targets, channel)) |> ctx.TaskPool.PostAndAsyncReply - let! status = waitTask - return target, status, ArtifactDep target - } - | None -> - target |> function - | FileTarget file when File.exists file -> - async.Return <| (target, ExecStatus.JustFile, FileDep (file, File.getLastWriteTime file)) - | _ -> raiseError ctx (sprintf "Neither rule nor file is found for '%s'" target.FullName) "" - - /// - /// Executes several artifacts in parallel. - /// - and execParallel ctx = List.map (execOne ctx) >> Seq.ofList >> Async.Parallel - - /// - /// Gets the status of dependency artifacts (obtained from 'need' calls). - /// - /// - /// ExecStatus.Succeed,... in case at least one dependency was rebuilt - /// - and execNeed ctx targets : Async = + let getAction = function + | FileRule (_, a) + | FileConditionRule (_, a) + | MultiFileRule (_, a) + | PhonyRule (_, a) -> a + + // result expression is... + match target |> locateRule ctx.Rules ctx.Options.ProjectRoot with + | Some(rule,groups,targets) -> + let groupsMap = groups |> Map.ofSeq + let (Recipe action) = rule |> getAction async { - let primaryTarget = ctx.Targets |> List.head - primaryTarget |> (Progress.TaskSuspend >> ctx.Progress.Post) - - do ctx.Throttler.Release() |> ignore - let! statuses = targets |> execParallel ctx - do! ctx.Throttler.WaitAsync(-1) |> Async.AwaitTask |> Async.Ignore - - primaryTarget |> (Progress.TaskResume >> ctx.Progress.Post) - - let dependencies = statuses |> Array.map (fun (_,_,x) -> x) |> List.ofArray in - return - (match statuses |> Array.exists (fun (_,x,_) -> x = ExecStatus.Succeed) with - |true -> ExecStatus.Succeed - |false -> ExecStatus.Skipped), dependencies + let! waitTask = (fun channel -> WorkerPool.Run(target, targets, run groupsMap action targets, channel)) |> ctx.TaskPool.PostAndAsyncReply + let! status = waitTask + return target, status, ArtifactDep target } - - /// phony actions are detected by their name so if there's "clean" phony and file "clean" in `need` list if will choose first - let makeTarget ctx name = - let (Rules rules) = ctx.Rules - let isPhonyRule nm = function |PhonyRule (n,_) when n = nm -> true | _ -> false - in - match rules |> List.exists (isPhonyRule name) with - | true -> PhonyAction name - | _ -> ctx.Options.ProjectRoot name |> File.make |> FileTarget - - /// Implementation of "dry run" - let dryRun ctx options (groups: string list list) = + | None -> + target |> function + | FileTarget file when File.exists file -> + async.Return <| (target, JustFile, FileDep (file, File.getLastWriteTime file)) + | _ -> raiseError ctx (sprintf "Neither rule nor file is found for '%s'" target.FullName) "" + +/// +/// Executes several artifacts in parallel. +/// +and execParallel ctx = List.map (execOne ctx) >> Seq.ofList >> Async.Parallel + +/// +/// Gets the status of dependency artifacts (obtained from 'need' calls). +/// +/// +/// ExecStatus.Succeed,... in case at least one dependency was rebuilt +/// +and execNeed ctx targets : Async = + async { + let primaryTarget = ctx.Targets |> List.head + primaryTarget |> (Progress.TaskSuspend >> ctx.Progress.Post) + + do ctx.Throttler.Release() |> ignore + let! statuses = targets |> execParallel ctx + do! ctx.Throttler.WaitAsync(-1) |> Async.AwaitTask |> Async.Ignore + + primaryTarget |> (Progress.TaskResume >> ctx.Progress.Post) + + let dependencies = statuses |> Array.map (fun (_,_,x) -> x) |> List.ofArray in + return + (match statuses |> Array.exists (fun (_,x,_) -> x = ExecStatus.Succeed) with + |true -> Succeed + |false -> Skipped), dependencies + } + +/// phony actions are detected by their name so if there's "clean" phony and file "clean" in `need` list if will choose first +let makeTarget ctx name = + let (Rules rules) = ctx.Rules + let isPhonyRule nm = function |PhonyRule (n,_) when n = nm -> true | _ -> false + in + match rules |> List.exists (isPhonyRule name) with + | true -> PhonyAction name + | _ -> ctx.Options.ProjectRoot name |> File.make |> FileTarget + +/// Implementation of "dry run" +let dryRun ctx options (groups: string list list) = + let getDeps = getChangeReasons ctx |> memoizeRec + + // getPlainDeps getDeps (getExecTime ctx) + do ctx.Logger.Log Command "Running (dry) targets %A" groups + let doneTargets = System.Collections.Hashtable() + + let print f = ctx.Logger.Log Info f + let indent i = String.replicate i " " + + let rec showDepStatus ii reasons = + reasons |> function + | Other reason -> + print "%sReason: %s" (indent ii) reason + | Depends t -> + print "%sDepends '%s' - changed target" (indent ii) t.ShortName + | DependsMissingTarget t -> + print "%sDepends on '%s' - missing target" (indent ii) t.ShortName + | FilesChanged (file:: rest) -> + print "%sFile is changed '%s' %s" (indent ii) file (if List.isEmpty rest then "" else sprintf " and %d more file(s)" <| List.length rest) + | reasons -> + do print "%sSome reason %A" (indent ii) reasons + () + let rec displayNestedDeps ii = + function + | DependsMissingTarget t + | Depends t -> + showTargetStatus ii t + | _ -> () + and showTargetStatus ii target = + if not <| doneTargets.ContainsKey(target) then + doneTargets.Add(target, 1) + let deps = getDeps target + if not <| List.isEmpty deps then + let execTimeEstimate = getExecTime ctx target + do ctx.Logger.Log Command "%sRebuild %A (~%Ams)" (indent ii) target.ShortName execTimeEstimate + deps |> List.iter (showDepStatus (ii+1)) + deps |> List.iter (displayNestedDeps (ii+1)) + + let targetGroups = makeTarget ctx |> List.map |> List.map <| groups in + let toSec v = float (v / 1) * 0.001 + let endTime = Progress.estimateEndTime (getDurationDeps ctx getDeps) options.Threads targetGroups |> toSec + + targetGroups |> List.collect id |> List.iter (showTargetStatus 0) + let alldeps = targetGroups |> List.collect id |> List.collect getDeps + if List.isEmpty alldeps then + ctx.Logger.Log Message "\n\n\tNo changed dependencies. Nothing to do.\n" + else + let parallelismMsg = + let endTimeTotal = Progress.estimateEndTime (getDurationDeps ctx getDeps) 1 targetGroups |> toSec + if options.Threads > 1 && endTimeTotal > endTime * 1.05 then + sprintf "\n\tTotal tasks duration is (estimate) in %As\n\tParallelist degree: %.2f" endTimeTotal (endTimeTotal / endTime) + else "" + ctx.Logger.Log Message "\n\n\tBuild will be completed (estimate) in %As%s\n" endTime parallelismMsg + +let rec unwindAggEx (e:System.Exception) = seq { + match e with + | :? System.AggregateException as a -> yield! a.InnerExceptions |> Seq.collect unwindAggEx + | a -> yield a + } + +let rec runSeq<'r> :Async<'r> list -> Async<'r list> = + List.fold + (fun rest i -> async { + let! tail = rest + let! head = i + return head::tail + }) + (async {return []}) + +let asyncMap f c = async.Bind(c, f >> async.Return) + +/// Runs the build (main function of xake) +let runBuild ctx options groups = + + let runTargets ctx options targets = let getDeps = getChangeReasons ctx |> memoizeRec - - // getPlainDeps getDeps (getExecTime ctx) - do ctx.Logger.Log Command "Running (dry) targets %A" groups - let doneTargets = System.Collections.Hashtable() - - let print f = ctx.Logger.Log Info f - let indent i = String.replicate i " " - - let rec showDepStatus ii reasons = - reasons |> function - | ChangeReason.Other reason -> - print "%sReason: %s" (indent ii) reason - | ChangeReason.Depends t -> - print "%sDepends '%s' - changed target" (indent ii) t.ShortName - | ChangeReason.DependsMissingTarget t -> - print "%sDepends on '%s' - missing target" (indent ii) t.ShortName - | ChangeReason.FilesChanged (file:: rest) -> - print "%sFile is changed '%s' %s" (indent ii) file (if List.isEmpty rest then "" else sprintf " and %d more file(s)" <| List.length rest) - | reasons -> - do print "%sSome reason %A" (indent ii) reasons - () - let rec displayNestedDeps ii = + + let needRebuild (target: Target) = + getDeps >> function - | ChangeReason.DependsMissingTarget t - | ChangeReason.Depends t -> - showTargetStatus ii t - | _ -> () - and showTargetStatus ii target = - if not <| doneTargets.ContainsKey(target) then - doneTargets.Add(target, 1) - let deps = getDeps target - if not <| List.isEmpty deps then - let execTimeEstimate = getExecTime ctx target - do ctx.Logger.Log Command "%sRebuild %A (~%Ams)" (indent ii) target.ShortName execTimeEstimate - deps |> List.iter (showDepStatus (ii+1)) - deps |> List.iter (displayNestedDeps (ii+1)) - - let targetGroups = makeTarget ctx |> List.map |> List.map <| groups in - let toSec v = float (v / 1) * 0.001 - let endTime = Progress.estimateEndTime (getDurationDeps ctx getDeps) options.Threads targetGroups |> toSec - - targetGroups |> List.collect id |> List.iter (showTargetStatus 0) - let alldeps = targetGroups |> List.collect id |> List.collect getDeps - if List.isEmpty alldeps then - ctx.Logger.Log Message "\n\n\tNo changed dependencies. Nothing to do.\n" - else - let parallelismMsg = - let endTimeTotal = Progress.estimateEndTime (getDurationDeps ctx getDeps) 1 targetGroups |> toSec - if options.Threads > 1 && endTimeTotal > endTime * 1.05 then - sprintf "\n\tTotal tasks duration is (estimate) in %As\n\tParallelist degree: %.2f" endTimeTotal (endTimeTotal / endTime) - else "" - ctx.Logger.Log Message "\n\n\tBuild will be completed (estimate) in %As%s\n" endTime parallelismMsg - - let rec unwindAggEx (e:System.Exception) = seq { - match e with - | :? System.AggregateException as a -> yield! a.InnerExceptions |> Seq.collect unwindAggEx - | a -> yield a - } - - let rec runSeq<'r> :Async<'r> list -> Async<'r list> = - List.fold - (fun rest i -> async { - let! tail = rest - let! head = i - return head::tail - }) - (async {return []}) + | [] -> false, "" + | Other reason::_ -> true, reason + | Depends t ::_ -> true, "Depends on target " + t.ShortName + | DependsMissingTarget t ::_ -> true, sprintf "Depends on target %s (missing)" t.ShortName + | FilesChanged (file::_) ::_ -> true, "File(s) changed " + file + | reasons -> true, sprintf "Some reason %A" reasons + >> + function + | false, _ -> false + | true, reason -> + do ctx.Logger.Log Info "Rebuild %A: %s" target.ShortName reason + true + <| target + // todo improve output by printing primary target - let asyncMap f c = async.Bind(c, f >> async.Return) + async { + do ctx.Logger.Log Info "Build target list %A" targets - /// Runs the build (main function of xake) - let runBuild ctx options groups = + let progressSink = Progress.openProgress (getDurationDeps ctx getDeps) options.Threads targets options.Progress + let stepCtx = {ctx with NeedRebuild = List.exists needRebuild; Progress = progressSink} - let runTargets ctx options targets = - let getDeps = getChangeReasons ctx |> memoizeRec - - let needRebuild (target: Target) = - getDeps >> - function - | [] -> false, "" - | ChangeReason.Other reason::_ -> true, reason - | ChangeReason.Depends t ::_ -> true, "Depends on target " + t.ShortName - | ChangeReason.DependsMissingTarget t ::_ -> true, sprintf "Depends on target %s (missing)" t.ShortName - | ChangeReason.FilesChanged (file::_) ::_ -> true, "File(s) changed " + file - | reasons -> true, sprintf "Some reason %A" reasons - >> - function - | false, _ -> false - | true, reason -> - do ctx.Logger.Log Info "Rebuild %A: %s" target.ShortName reason - true - <| target - // todo improve output by printing primary target - - async { - do ctx.Logger.Log Info "Build target list %A" targets - - let progressSink = Progress.openProgress (getDurationDeps ctx getDeps) options.Threads targets options.Progress - let stepCtx = {ctx with NeedRebuild = List.exists needRebuild; Progress = progressSink} - - try - return! targets |> execParallel stepCtx - finally - do Progress.Finish |> progressSink.Post - } - - groups |> List.map - (List.map (makeTarget ctx) >> (runTargets ctx options)) - |> runSeq - |> asyncMap (Array.concat >> List.ofArray) - - /// Executes the build script - let runScript options rules = - let logger = CombineLogger (ConsoleLogger options.ConLogLevel) options.CustomLogger - - let logger = - match options.FileLog, options.FileLogLevel with - | null,_ | "",_ - | _,Verbosity.Silent -> logger - | logFileName,level -> CombineLogger logger (FileLogger logFileName level) - - let (throttler, pool) = WorkerPool.create logger options.Threads - - let db = Storage.openDb (options.ProjectRoot options.DbFileName) logger - - let ctx = { - Ordinal = 0 - TaskPool = pool; Throttler = throttler - Options = options; Rules = rules - Logger = logger; RootLogger = logger; Db = db - Progress = Progress.emptyProgress() - NeedRebuild = fun _ -> false - Targets = [] - RuleMatches = Map.empty - } - - logger.Log Info "Options: %A" options - - // splits list of targets ["t1;t2"; "t3;t4"] into list of list. - let targetLists = - options.Targets |> - function - | [] -> - do logger.Log Level.Message "No target(s) specified. Defaulting to 'main'" - [["main"]] - | tt -> - tt |> List.map (fun (s: string) -> s.Split(';', '|') |> List.ofArray) - - try - match options with - | Dump -> - do logger.Log Level.Command "Dumping dependencies for targets %A" targetLists - targetLists |> List.iter (List.map (makeTarget ctx) >> (dumpDeps ctx)) - | Dryrun -> - targetLists |> (dryRun ctx options) - | _ -> - let start = System.DateTime.Now - try - targetLists |> (runBuild ctx options) |> Async.RunSynchronously |> ignore - ctx.Logger.Log Message "\n\n Build completed in %A\n" (System.DateTime.Now - start) - with | exn -> - let th = if options.FailOnError then raiseError else reportError - let errors = exn |> unwindAggEx |> Seq.map (fun e -> e.Message) in - th ctx (exn.Message + "\n" + (errors |> String.concat "\r\n ")) exn - ctx.Logger.Log Message "\n\n\tBuild failed after running for %A\n" (System.DateTime.Now - start) - exit 2 - finally - db.PostAndReply Storage.CloseWait - Logging.FlushLogs() - - /// "need" implementation - let need targets = - action { - let startTime = System.DateTime.Now - - let! ctx = getCtx() - let! _,deps = targets |> execNeed ctx - - let totalDuration = int (System.DateTime.Now - startTime).TotalMilliseconds * 1 - let! result = getResult() - let result' = {result with Depends = result.Depends @ deps} |> (Step.updateWaitTime totalDuration) - do! setResult result' + try + return! targets |> execParallel stepCtx + finally + do Progress.Finish |> progressSink.Post } + + groups |> List.map + (List.map (makeTarget ctx) >> (runTargets ctx options)) + |> runSeq + |> asyncMap (Array.concat >> List.ofArray) + +/// Executes the build script +let runScript options rules = + let logger = CombineLogger (ConsoleLogger options.ConLogLevel) options.CustomLogger + + let logger = + match options.FileLog, options.FileLogLevel with + | null,_ | "",_ + | _, Silent -> logger + | logFileName,level -> CombineLogger logger (FileLogger logFileName level) + + let (throttler, pool) = WorkerPool.create logger options.Threads + + let db = openDb (options.ProjectRoot options.DbFileName) logger + + let ctx = { + Ordinal = 0 + TaskPool = pool; Throttler = throttler + Options = options; Rules = rules + Logger = logger; RootLogger = logger; Db = db + Progress = Progress.emptyProgress() + NeedRebuild = fun _ -> false + Targets = [] + RuleMatches = Map.empty } + + logger.Log Info "Options: %A" options + + // splits list of targets ["t1;t2"; "t3;t4"] into list of list. + let targetLists = + options.Targets |> + function + | [] -> + do logger.Log Message "No target(s) specified. Defaulting to 'main'" + [["main"]] + | tt -> + tt |> List.map (fun (s: string) -> s.Split(';', '|') |> List.ofArray) + + try + match options with + | Dump -> + do logger.Log Command "Dumping dependencies for targets %A" targetLists + targetLists |> List.iter (List.map (makeTarget ctx) >> (dumpDeps ctx)) + | Dryrun -> + targetLists |> (dryRun ctx options) + | _ -> + let start = System.DateTime.Now + try + targetLists |> (runBuild ctx options) |> Async.RunSynchronously |> ignore + ctx.Logger.Log Message "\n\n Build completed in %A\n" (System.DateTime.Now - start) + with | exn -> + let th = if options.FailOnError then raiseError else reportError + let errors = exn |> unwindAggEx |> Seq.map (fun e -> e.Message) in + th ctx (exn.Message + "\n" + (errors |> String.concat "\r\n ")) exn + ctx.Logger.Log Message "\n\n\tBuild failed after running for %A\n" (System.DateTime.Now - start) + exit 2 + finally + db.PostAndReply Storage.CloseWait + FlushLogs() + +/// "need" implementation +let need targets = + action { + let startTime = System.DateTime.Now + + let! ctx = getCtx() + let! _,deps = targets |> execNeed ctx + + let totalDuration = int (System.DateTime.Now - startTime).TotalMilliseconds * 1 + let! result = getResult() + let result' = {result with Depends = result.Depends @ deps} |> (Step.updateWaitTime totalDuration) + do! setResult result' + } diff --git a/src/core/ExecTypes.fs b/src/core/ExecTypes.fs index 5f87557..69a8c37 100644 --- a/src/core/ExecTypes.fs +++ b/src/core/ExecTypes.fs @@ -45,8 +45,7 @@ type ExecOptions = { /// Dump dependencies only Progress: bool } with -static member Default = - { +static member Default = { ProjectRoot = System.IO.Directory.GetCurrentDirectory() Threads = System.Environment.ProcessorCount ConLogLevel = Normal @@ -62,12 +61,11 @@ static member Default = DbFileName = ".xake" DryRun = false DumpDeps = false - Progress = true - } + Progress = true } end -type internal ExecStatus = | Succeed | Skipped | JustFile -type private TaskPool = Agent> +type ExecStatus = | Succeed | Skipped | JustFile +type TaskPool = Agent> /// Script execution context type ExecContext = { diff --git a/src/core/File.fs b/src/core/File.fs index 4dd6e0a..5d340e8 100644 --- a/src/core/File.fs +++ b/src/core/File.fs @@ -3,8 +3,8 @@ module private impl = let compareNames : string -> string -> int = - let isUnix = Env.isUnix - fun a b -> System.String.Compare(a, b, isUnix) + let ignoreCase = Env.isUnix + fun a b -> System.String.Compare(a, b, ignoreCase) let getFileHash : string -> int = if Env.isUnix then diff --git a/src/core/Fileset.fs b/src/core/Fileset.fs index 9d481ba..1cc8426 100644 --- a/src/core/Fileset.fs +++ b/src/core/Fileset.fs @@ -1,297 +1,295 @@ -namespace Xake +[] +module Xake.Fileset -[] -module Fileset = +open System.IO +open Xake - open System.IO - open Xake +/// +/// Defines interface to a file system +/// +type FileSystemType = { + GetDisk: string -> string + GetDirRoot: string -> string + GetParent: string -> string + AllDirs: string -> string seq + ScanDirs: string -> string -> string seq // mask -> dir -> dirs + ScanFiles: string -> string -> string seq // mask -> dir -> files +} - /// - /// Defines interface to a file system - /// - type FileSystemType = { - GetDisk: string -> string - GetDirRoot: string -> string - GetParent: string -> string - AllDirs: string -> string seq - ScanDirs: string -> string -> string seq // mask -> dir -> dirs - ScanFiles: string -> string -> string seq // mask -> dir -> files - } +type FilePattern = string - type FilePattern = string - - /// Filesystem pattern - type FilesetElement = | Includes of Path.PathMask | Excludes of Path.PathMask - - type FilesetOptions = {FailOnEmpty:bool; BaseDir:string option} - - // Fileset is either set of rules or list of files (materialized) - type Fileset = Fileset of FilesetOptions * FilesetElement list - type Filelist = Filelist of File list - - /// Default fileset options - let DefaultOptions = {FilesetOptions.BaseDir = None; FailOnEmpty = false} - - let Empty = Fileset (DefaultOptions,[]) - let EmptyList = Filelist [] - - /// Implementation module - module private Impl = - - open Path - - let fullname (f:DirectoryInfo) = f.FullName - - let FileSystem = { - GetDisk = fun d -> d + Path.DirectorySeparatorChar.ToString() - GetDirRoot = fun x -> Directory.GetDirectoryRoot x - GetParent = Directory.GetParent >> fullname - AllDirs = fun dir -> Directory.EnumerateDirectories(dir, "*", SearchOption.AllDirectories) - ScanDirs = fun mask dir -> Directory.EnumerateDirectories(dir, mask, SearchOption.TopDirectoryOnly) - ScanFiles = fun mask dir -> Directory.EnumerateFiles(dir, mask) - } - - /// - /// Changes current directory - /// - /// File system implementation - /// Starting path - /// target path - let cd (fs:FileSystemType) startIn (Path.PathMask path) = - // TODO check path exists after each step - let applyPart (path:string) = function - | CurrentDir -> path - | Disk d -> fs.GetDisk d - | FsRoot -> path |> fs.GetDirRoot - | Parent -> path |> fs.GetParent - | Directory d -> Path.Combine(path, d) - | _ -> failwith "ChDir could only contain disk or directory names" - in - (startIn, path) ||> List.fold applyPart - - let listFiles (fs:FileSystemType) startIn (Path.PathMask pat) = - - // The pattern without mask become "explicit" file reference which is always included in resulting file list, regardless file presence. See impl notes for details. - let isExplicitRule = pat |> List.exists (function | DirectoryMask _ | FileMask _ | Recurse -> true | _ -> false) |> not - let filterDir = if isExplicitRule then id else Seq.filter Directory.Exists - let filterFile = if isExplicitRule then id else Seq.filter File.Exists - - // Recursively applies the pattern rules to every item is start list - let applyPart (paths: seq) :_ -> seq = function - | Disk d -> fs.GetDisk d |> Seq.singleton - | FsRoot -> paths |> Seq.map fs.GetDirRoot - | CurrentDir -> paths - | Parent -> paths |> Seq.map fs.GetParent - | Recurse -> paths |> Seq.collect fs.AllDirs |> Seq.append paths - | DirectoryMask mask -> paths |> Seq.collect (fs.ScanDirs mask) - | Directory d -> paths |> Seq.map (fun dir -> Path.Combine(dir, d)) |> filterDir - | FileMask mask -> paths |> Seq.collect (fs.ScanFiles mask) - | FileName f -> paths |> Seq.map (fun dir -> Path.Combine(dir, f)) |> filterFile - in - (startIn, pat) ||> List.fold applyPart - - let ifNone = Option.fold (fun _ -> id) - - /// Implementation of fileset execute - /// "Materializes" fileset to a filelist - let scan fileSystem root (Fileset (options,filesetItems)) = - - let startDirPat = options.BaseDir |> ifNone root |> Path.parseDir - let startDir = startDirPat |> cd fileSystem "." - - // TODO check performance, build function - let includes src = [startDir] |> (listFiles fileSystem) >> Seq.append src - let excludes src pat = - let matchFile = Path.join startDirPat pat |> Path.matchesPattern in - src |> Seq.filter (matchFile >> not) - - let folditem i = function - | Includes pat -> includes i pat - | Excludes pat -> excludes i pat - - filesetItems |> Seq.ofList |> Seq.fold folditem Seq.empty |> Seq.map File.make |> List.ofSeq |> Filelist - - // combines two fileset options - let combineOptions (o1:FilesetOptions) (o2:FilesetOptions) = - {DefaultOptions with - BaseDir = - match o1.BaseDir,o2.BaseDir with - | Some _, Some _ -> failwith "Cannot combine filesets with basedirs defined in both (not implemented)" - | Some _, None -> o1.BaseDir - | _ -> o2.BaseDir - FailOnEmpty = o1.FailOnEmpty || o2.FailOnEmpty} - - // combines two filesets - let combineWith (Fileset (o2, set2)) (Fileset (o1,set1)) = Fileset(combineOptions o1 o2, set1 @ set2) - - // Combines result of reading file to a fileset - let combineWithFile map (file:FileInfo) (Fileset (opts,fs)) = - let elements = File.ReadAllLines file.FullName |> Array.toList |> List.map map in - Fileset (opts, fs @ elements) - // TODO filter comments, empty lines? |> Array.filter - - let changeBasedir dir (Fileset (opts,ps)) = Fileset ({opts with BaseDir = Some dir}, ps) - let changeFailonEmpty f (Fileset (opts,ps)) = Fileset ({opts with FailOnEmpty = f}, ps) - - /// Fileset persistance implementation - module private PicklerImpl = - - open Pickler - - let filesetoptions = - wrap( - (fun(foe,bdir) -> {FilesetOptions.FailOnEmpty = foe; BaseDir = bdir}), - fun o -> (o.FailOnEmpty, o.BaseDir)) - (pair bool (option str)) - - let filesetElement = - alt - (function | Includes _ -> 0 | Excludes _ -> 1) - [| - wrap (Includes, fun (Includes p | OtherwiseFail p) -> p) Path.pickler - wrap (Excludes, fun (Excludes p | OtherwiseFail p) -> p) Path.pickler - |] - - let fileinfo = wrap(File.make, File.getFullName) str - - let fileset = wrap(Fileset, fun (Fileset (o,l)) -> o,l) (pair filesetoptions (list filesetElement)) - let filelist = wrap(Filelist, fun (Filelist l) -> l) (list fileinfo) - - open Impl - - /// Gets the pickler for fileset type - let filesetPickler = PicklerImpl.fileset - let filelistPickler = PicklerImpl.filelist +/// Filesystem pattern +type FilesetElement = | Includes of Path.PathMask | Excludes of Path.PathMask - /// - /// Creates a new fileset with default options. - /// - /// - let ls (filePattern:FilePattern) = - // TODO Path.parse is expected to handle trailing slash character - let parse = match filePattern.EndsWith ("/") || filePattern.EndsWith ("\\") with | true -> Path.parseDir | _-> Path.parse - Fileset (DefaultOptions, [filePattern |> parse |> Includes]) +type FilesetOptions = {FailOnEmpty:bool; BaseDir:string option} - /// - /// Create a file set for specific file mask. The same as "ls" - /// - let (!!) = ls +// Fileset is either set of rules or list of files (materialized) +type Fileset = Fileset of FilesetOptions * FilesetElement list +type Filelist = Filelist of File list - /// - /// Defines the empty fileset with a specified base dir. - /// - /// - let (~+) dir = - Fileset ({DefaultOptions with BaseDir = Some dir}, []) +/// Default fileset options +let DefaultOptions = {FilesetOptions.BaseDir = None; FailOnEmpty = false} - [] - let parseFileMask = Path.parse +let Empty = Fileset (DefaultOptions,[]) +let EmptyList = Filelist [] - [] - let parseDirMask = Path.parseDir +/// Implementation module +module private Impl = - // let matches filePattern projectRoot - [] - let matches = Path.matches + open Path - let FileSystem = Impl.FileSystem + let fullname (f:DirectoryInfo) = f.FullName - /// - /// "Materializes" fileset to a filelist - /// - let toFileList = Impl.scan Impl.FileSystem - - /// - /// "Materializes" file mask to a list of files/paths - /// - let listByMask (root:string) = Impl.listFiles Impl.FileSystem [root] + let FileSystem = { + GetDisk = fun d -> d + Path.DirectorySeparatorChar.ToString() + GetDirRoot = fun x -> Directory.GetDirectoryRoot x + GetParent = Directory.GetParent >> fullname + AllDirs = fun dir -> Directory.EnumerateDirectories(dir, "*", SearchOption.AllDirectories) + ScanDirs = fun mask dir -> Directory.EnumerateDirectories(dir, mask, SearchOption.TopDirectoryOnly) + ScanFiles = fun mask dir -> Directory.EnumerateFiles(dir, mask) + } /// - /// The same as toFileList but allows to provide file system adapter + /// Changes current directory /// - let toFileList1 = Impl.scan + /// File system implementation + /// Starting path + /// target path + let cd (fs:FileSystemType) startIn (Path.PathMask path) = + // TODO check path exists after each step + let applyPart (path:string) = function + | CurrentDir -> path + | Disk d -> fs.GetDisk d + | FsRoot -> path |> fs.GetDirRoot + | Parent -> path |> fs.GetParent + | Directory d -> Path.Combine(path, d) + | _ -> failwith "ChDir could only contain disk or directory names" + in + (startIn, path) ||> List.fold applyPart + + let listFiles (fs:FileSystemType) startIn (Path.PathMask pat) = + + // The pattern without mask become "explicit" file reference which is always included in resulting file list, regardless file presence. See impl notes for details. + let isExplicitRule = pat |> List.exists (function | DirectoryMask _ | FileMask _ | Recurse -> true | _ -> false) |> not + let filterDir = if isExplicitRule then id else Seq.filter Directory.Exists + let filterFile = if isExplicitRule then id else Seq.filter File.Exists + + // Recursively applies the pattern rules to every item is start list + let applyPart (paths: seq) :_ -> seq = function + | Disk d -> fs.GetDisk d |> Seq.singleton + | FsRoot -> paths |> Seq.map fs.GetDirRoot + | CurrentDir -> paths + | Parent -> paths |> Seq.map fs.GetParent + | Recurse -> paths |> Seq.collect fs.AllDirs |> Seq.append paths + | DirectoryMask mask -> paths |> Seq.collect (fs.ScanDirs mask) + | Directory d -> paths |> Seq.map (fun dir -> Path.Combine(dir, d)) |> filterDir + | FileMask mask -> paths |> Seq.collect (fs.ScanFiles mask) + | FileName f -> paths |> Seq.map (fun dir -> Path.Combine(dir, f)) |> filterFile + in + (startIn, pat) ||> List.fold applyPart + + let ifNone = Option.fold (fun _ -> id) + + /// Implementation of fileset execute + /// "Materializes" fileset to a filelist + let scan fileSystem root (Fileset (options,filesetItems)) = + + let startDirPat = options.BaseDir |> ifNone root |> Path.parseDir + let startDir = startDirPat |> cd fileSystem "." + + // TODO check performance, build function + let includes src = [startDir] |> (listFiles fileSystem) >> Seq.append src + let excludes src pat = + let matchFile = Path.join startDirPat pat |> Path.matchesPattern in + src |> Seq.filter (matchFile >> not) + + let folditem i = function + | Includes pat -> includes i pat + | Excludes pat -> excludes i pat + + filesetItems |> Seq.ofList |> Seq.fold folditem Seq.empty |> Seq.map File.make |> List.ofSeq |> Filelist + + // combines two fileset options + let combineOptions (o1:FilesetOptions) (o2:FilesetOptions) = + {DefaultOptions with + BaseDir = + match o1.BaseDir,o2.BaseDir with + | Some _, Some _ -> failwith "Cannot combine filesets with basedirs defined in both (not implemented)" + | Some _, None -> o1.BaseDir + | _ -> o2.BaseDir + FailOnEmpty = o1.FailOnEmpty || o2.FailOnEmpty} + + // combines two filesets + let combineWith (Fileset (o2, set2)) (Fileset (o1,set1)) = Fileset(combineOptions o1 o2, set1 @ set2) + + // Combines result of reading file to a fileset + let combineWithFile map (file:FileInfo) (Fileset (opts,fs)) = + let elements = File.ReadAllLines file.FullName |> Array.toList |> List.map map in + Fileset (opts, fs @ elements) + // TODO filter comments, empty lines? |> Array.filter + + let changeBasedir dir (Fileset (opts,ps)) = Fileset ({opts with BaseDir = Some dir}, ps) + let changeFailonEmpty f (Fileset (opts,ps)) = Fileset ({opts with FailOnEmpty = f}, ps) + +/// Fileset persistance implementation +module private PicklerImpl = + + open Pickler + + let filesetoptions = + wrap( + (fun(foe,bdir) -> {FilesetOptions.FailOnEmpty = foe; BaseDir = bdir}), + fun o -> (o.FailOnEmpty, o.BaseDir)) + (pair bool (option str)) + + let filesetElement = + alt + (function | Includes _ -> 0 | Excludes _ -> 1) + [| + wrap (Includes, fun (Includes p | OtherwiseFail p) -> p) Path.pickler + wrap (Excludes, fun (Excludes p | OtherwiseFail p) -> p) Path.pickler + |] + + let fileinfo = wrap(File.make, File.getFullName) str + + let fileset = wrap(Fileset, fun (Fileset (o,l)) -> o,l) (pair filesetoptions (list filesetElement)) + let filelist = wrap(Filelist, fun (Filelist l) -> l) (list fileinfo) + +open Impl + +/// Gets the pickler for fileset type +let filesetPickler = PicklerImpl.fileset +let filelistPickler = PicklerImpl.filelist + +/// +/// Creates a new fileset with default options. +/// +/// +let ls (filePattern:FilePattern) = + // TODO Path.parse is expected to handle trailing slash character + let parse = match filePattern.EndsWith ("/") || filePattern.EndsWith ("\\") with | true -> Path.parseDir | _-> Path.parse + Fileset (DefaultOptions, [filePattern |> parse |> Includes]) + +/// +/// Create a file set for specific file mask. The same as "ls" +/// +let (!!) = ls - type ListDiffType<'a> = | Added of 'a | Removed of 'a +/// +/// Defines the empty fileset with a specified base dir. +/// +/// +let (~+) dir = + Fileset ({DefaultOptions with BaseDir = Some dir}, []) - /// - /// Compares two file lists and returns differences list. - /// - /// - /// - let compareFileList (Filelist list1) (Filelist list2) = +[] +let parseFileMask = Path.parse - let setOfNames = List.map File.getFullName >> Set.ofList +[] +let parseDirMask = Path.parseDir - let set1, set2 = setOfNames list1, setOfNames list2 +// let matches filePattern projectRoot +[] +let matches = Path.matches - let removed = Set.difference set1 set2 |> List.ofSeq |> List.map (Removed) - let added = Set.difference set2 set1 |> List.ofSeq |> List.map (Added) +let FileSystem = Impl.FileSystem - removed @ added +/// +/// "Materializes" fileset to a filelist +/// +let toFileList = Impl.scan Impl.FileSystem - /// - /// Defines various operations on Fieset type. - /// - type Fileset with - static member (+) (fs1, fs2: Fileset) :Fileset = fs1 |> combineWith fs2 - static member (+) (fs1: Fileset, pat) = fs1 ++ pat - static member (-) (fs1: Fileset, pat) = fs1 -- pat - static member (@@) (fs1, basedir) = fs1 |> Impl.changeBasedir basedir - static member (@@) (Fileset (_,lst), options) = Fileset (options,lst) +/// +/// "Materializes" file mask to a list of files/paths +/// +let listByMask (root:string) = Impl.listFiles Impl.FileSystem [root] + +/// +/// The same as toFileList but allows to provide file system adapter +/// +let toFileList1 = Impl.scan + +type ListDiffType<'a> = | Added of 'a | Removed of 'a + +/// +/// Compares two file lists and returns differences list. +/// +/// +/// +let compareFileList (Filelist list1) (Filelist list2) = + + let setOfNames = List.map File.getFullName >> Set.ofList + + let set1, set2 = setOfNames list1, setOfNames list2 + + let removed = Set.difference set1 set2 |> List.ofSeq |> List.map (Removed) + let added = Set.difference set2 set1 |> List.ofSeq |> List.map (Added) + + removed @ added + +/// +/// Defines various operations on Fieset type. +/// +type Fileset with + static member (+) (fs1, fs2: Fileset) :Fileset = fs1 |> combineWith fs2 + static member (+) (fs1: Fileset, pat) = fs1 ++ pat + static member (-) (fs1: Fileset, pat) = fs1 -- pat + static member (@@) (fs1, basedir) = fs1 |> Impl.changeBasedir basedir + static member (@@) (Fileset (_,lst), options) = Fileset (options,lst) - /// Conditional include/exclude operator - static member (+?) (fs1: Fileset, (condition:bool,pat: FilePattern)) = if condition then fs1 ++ pat else fs1 - static member (+?) (fs1: Fileset, (condition:bool,fs2: Fileset)) :Fileset = if condition then fs1 |> combineWith fs2 else fs1 - static member (-?) (fs1: Fileset, (condition:bool,pat: FilePattern)) = if condition then fs1 -- pat else fs1 + /// Conditional include/exclude operator + static member (+?) (fs1: Fileset, (condition:bool,pat: FilePattern)) = if condition then fs1 ++ pat else fs1 + static member (+?) (fs1: Fileset, (condition:bool,fs2: Fileset)) :Fileset = if condition then fs1 |> combineWith fs2 else fs1 + static member (-?) (fs1: Fileset, (condition:bool,pat: FilePattern)) = if condition then fs1 -- pat else fs1 - /// Adds includes pattern to a fileset. - static member (++) ((Fileset (opts,pts)), includes) :Fileset = - Fileset (opts, pts @ [includes |> Path.parse |> Includes]) + /// Adds includes pattern to a fileset. + static member (++) ((Fileset (opts,pts)), includes) :Fileset = + Fileset (opts, pts @ [includes |> Path.parse |> Includes]) - /// Adds excludes pattern to a fileset. - static member (--) (Fileset (opts,pts), excludes) = - Fileset (opts, pts @ [excludes |> Path.parse |> Excludes]) - end + /// Adds excludes pattern to a fileset. + static member (--) (Fileset (opts,pts), excludes) = + Fileset (opts, pts @ [excludes |> Path.parse |> Excludes]) +end - (******** builder ********) - type FilesetBuilder() = +(******** builder ********) +type FilesetBuilder() = - [] - member __.FailOnEmpty(fs,f) = fs |> changeFailonEmpty f + [] + member __.FailOnEmpty(fs,f) = fs |> changeFailonEmpty f - [] - member __.Basedir(fs,dir) = fs |> changeBasedir dir + [] + member __.Basedir(fs,dir) = fs |> changeBasedir dir - [] - member __.Includes(fs:Fileset,pattern) = fs ++ pattern + [] + member __.Includes(fs:Fileset,pattern) = fs ++ pattern - [] - member __.IncludesIf(fs:Fileset,condition, pattern:FilePattern) = fs +? (condition,pattern) + [] + member __.IncludesIf(fs:Fileset,condition, pattern:FilePattern) = fs +? (condition,pattern) - [] - member __.JoinFileset(fs1, fs2) = fs1 |> Impl.combineWith fs2 + [] + member __.JoinFileset(fs1, fs2) = fs1 |> Impl.combineWith fs2 - [] - member __.Excludes(fs:Fileset, pattern) = fs -- pattern + [] + member __.Excludes(fs:Fileset, pattern) = fs -- pattern - [] - member __.ExcludesIf(fs:Fileset, pattern) = fs -? pattern + [] + member __.ExcludesIf(fs:Fileset, pattern) = fs -? pattern - [] - member __.IncludeFile(fs, file) = (fs,file) ||> combineWithFile (Path.parse >> Includes) + [] + member __.IncludeFile(fs, file) = (fs,file) ||> combineWithFile (Path.parse >> Includes) - [] - member __.ExcludeFile(fs,file) = (fs,file) ||> combineWithFile (Path.parse >> Excludes) + [] + member __.ExcludeFile(fs,file) = (fs,file) ||> combineWithFile (Path.parse >> Excludes) - member __.Yield(()) = Empty - member __.Return(pattern:FilePattern) = Empty ++ pattern + member __.Yield(()) = Empty + member __.Return(pattern:FilePattern) = Empty ++ pattern - member __.Combine(fs1, fs2) = fs1 |> Impl.combineWith fs2 - member __.Delay(f) = f() - member this.Zero() = this.Yield ( () ) + member __.Combine(fs1, fs2) = fs1 |> Impl.combineWith fs2 + member __.Delay(f) = f() + member this.Zero() = this.Yield ( () ) - member __.Bind(fs1:Fileset, f) = let fs2 = f() in fs1 |> Impl.combineWith fs2 - member x.For(fs, f) = x.Bind(fs, f) - member x.Return(a) = x.Yield(a) + member __.Bind(fs1:Fileset, f) = let fs2 = f() in fs1 |> Impl.combineWith fs2 + member x.For(fs, f) = x.Bind(fs, f) + member x.Return(a) = x.Yield(a) - let fileset = FilesetBuilder() +let fileset = FilesetBuilder() diff --git a/src/core/Logging.fs b/src/core/Logging.fs index a8124df..0607cdb 100644 --- a/src/core/Logging.fs +++ b/src/core/Logging.fs @@ -153,7 +153,7 @@ module private ConsoleSink = | Some colors -> // in case of CRLF in the string make sure we washed out the progress message let rec writeLines = function - | [] -> fun _ -> () + | [] -> ignore | (txt: string)::tail -> function | true -> diff --git a/src/core/Path.fs b/src/core/Path.fs index f85ef95..2ebd4a8 100644 --- a/src/core/Path.fs +++ b/src/core/Path.fs @@ -1,258 +1,240 @@ -namespace Xake +module Xake.Path open System.IO open System.Text.RegularExpressions -module Path = - - type Part = - | FsRoot - | Parent - | CurrentDir - | Disk of string - | DirectoryMask of string - | Directory of string - | Recurse - | FileMask of string - | FileName of string - - type PathMask = PathMask of Part list - - type MatchResult = - | Matches of (string*string) list - | Nope - - module private impl = - - let notNullOrEmpty = System.String.IsNullOrEmpty >> not - - let driveRegex = Regex(@"^[A-Za-z]:$", RegexOptions.Compiled) - let isMask (a:string) = a.IndexOfAny([|'*';'?'|]) >= 0 - let iif fn b c a = match fn a with | true -> b a | _ -> c a - - let isRoot = function | FsRoot::_ | Disk _::_ -> true | _ -> false - - /// - /// Normalizes the pattern by resolving parent references and removing \.\ - /// - let rec normalize = function - | [] -> [] - | [x] -> [x] - | x::tail -> - match x::(normalize tail) with - | Directory _::Parent::t -> t - | CurrentDir::t -> t - | rest -> rest - - /// - /// Maps part of file path to a path part. - /// - /// - let mapPart isLast = function - | "**" -> Recurse - | "." -> CurrentDir - | ".." -> Parent (* works well now with Path.Combine() *) - | a when a.EndsWith(":") && driveRegex.IsMatch(a) -> Disk(a) - | a when not isLast -> a |> iif isMask DirectoryMask Directory - | a -> a |> iif isMask FileMask FileName - - let parse isLastPart pattern = - - if notNullOrEmpty pattern then - let parts = pattern.Split([|'\\'; '/'|], System.StringSplitOptions.RemoveEmptyEntries) - let fsroot = pattern.[0] |> function | '\\' | '/' -> [FsRoot] | _ -> [] - in - let isLast = isLastPart parts - fsroot @ (parts |> Array.mapi (isLast >> mapPart) |> List.ofArray) - |> normalize |> PathMask - else - PathMask [] - - /// - /// supplementary function for parsing directory - /// - let isLastPartForDir _ _ = false - /// - /// supplementary function for parsing file - /// - let isLastPartForFile (parts:_ array) = (=) (parts.Length-1) - - let dirSeparator = string Path.DirectorySeparatorChar - let partToString = - function - | Directory s - | FileName s - | DirectoryMask s - | FileMask s - -> s - | Parent -> ".." - | Part.CurrentDir -> "." - | Part.Disk d -> d + dirSeparator - | Part.Recurse -> "**" - | Part.FsRoot -> dirSeparator - - - module private PicklerImpl = - - open Pickler - - let patternpart= - alt(function - | FsRoot -> 0 - | Parent -> 1 - | Disk _ -> 2 - | DirectoryMask _ -> 3 - | Directory _ -> 4 - | Recurse -> 5 - | FileMask _ -> 6 - | FileName _ -> 7 - | CurrentDir -> 8 - ) - [| - wrap0 FsRoot - wrap0 Parent - wrap (Disk, fun (Disk d | OtherwiseFail d) -> d) str - wrap (DirectoryMask, fun (DirectoryMask d | OtherwiseFail d) -> d) str - wrap (Directory, fun (Directory d | OtherwiseFail d) -> d) str - wrap0 Recurse - wrap (FileMask, fun (FileMask m | OtherwiseFail m) -> m) str - wrap (FileName, fun (FileName m | OtherwiseFail m) -> m) str - wrap0 CurrentDir - |] - - let pattern = wrap(PathMask, fun(PathMask pp) -> pp) (list patternpart) - - module internal matchImpl = - - let eq s1 s2 = System.StringComparer.OrdinalIgnoreCase.Equals(s1, s2) - - let wildcard2regexMap = - ["**", "(.*)" - "*", """([^/\\]*)""" - "?", "([^/\\\\])" - ".", "\\."; "$", "\\$"; "^", "\\^"; "[", "\\["; "]", "\\]" - "+", "\\+"; "!", "\\!"; "=", "\\="; "{", "\\{"; "}", "\\}" - ] |> dict - - let wildcardToRegex (m:Match) = - match m.Groups.Item("tag") with - | t when not t.Success -> - match wildcard2regexMap.TryGetValue(m.Value) with - | true, v -> v - | _ -> m.Value - | t -> "(?<" + t.Value + ">" - - let normalizeSlashes (pat: string) = - pat.Replace('\\', '/') - - let maskToRegex (pattern:string) = - let pat = Regex.Replace(pattern |> normalizeSlashes, @"\((?'tag'\w+?)\:|\*\*|([*.?$^+!={}])", wildcardToRegex) - // TODO mask with sq brackets - let ignoreCase = if Env.isUnix then RegexOptions.None else RegexOptions.IgnoreCase - in - Regex(@"^" + pat + "$", RegexOptions.Compiled + ignoreCase) - - let matchPart (mask:Part) (path:Part) = - let matchByMask (rx:Regex) value = rx.Match(value).Success - match mask,path with - | (FsRoot, FsRoot) -> true - | (Disk mask, Disk d) | (Directory mask, Directory d) | FileName mask, FileName d when eq mask d -> true - - | DirectoryMask mask, Directory d | FileMask mask, FileName d -> - matchByMask (maskToRegex mask) d +type Part = + | FsRoot + | Parent + | CurrentDir + | Disk of string + | DirectoryMask of string + | Directory of string + | Recurse + | FileMask of string + | FileName of string - | _ -> false +type PathMask = PathMask of Part list - let rec matchPaths (mask:Part list) (p:Part list) = - match mask,p with - | [], [] -> true - | [], _ | _, [] -> false +type MatchResult = + | Matches of (string*string) list + | Nope - | Directory _::Recurse::Parent::ms, _ -> matchPaths (Recurse::ms) p - | Recurse::Parent::ms, _ -> matchPaths (Recurse::ms) p // ignore parent ref +module private impl = - | Recurse::ms, (FileName _)::_ -> matchPaths ms p - | Recurse::ms, Directory _::xs -> (matchPaths mask xs) || (matchPaths ms p) - | m::ms, x::xs -> - matchPart m x && matchPaths ms xs + let notNullOrEmpty = System.String.IsNullOrEmpty >> not - // API - let pickler = PicklerImpl.pattern + let driveRegex = Regex(@"^[A-Za-z]:$", RegexOptions.Compiled) + let isMask (a:string) = a.IndexOfAny([|'*';'?'|]) >= 0 + let iif fn b c a = match fn a with | true -> b a | _ -> c a + + let isRoot = function | FsRoot::_ | Disk _::_ -> true | _ -> false /// - /// Converts path to string representation (platform specific). + /// Normalizes the pattern by resolving parent references and removing \.\ /// - let toString = - List.map impl.partToString - >> List.fold (fun s ps -> Path.Combine (s, ps)) "" + let rec normalize = function + | [] -> [] + | [x] -> [x] + | x::tail -> + match x::(normalize tail) with + | Directory _::Parent::t -> t + | CurrentDir::t -> t + | rest -> rest /// - /// Joins two patterns. + /// Maps part of file path to a path part. /// - /// - /// - let join (PathMask p1) (PathMask p2) = - match impl.isRoot p2 with - | true -> PathMask p2 - | _ -> p1 @ p2 |> impl.normalize |> PathMask + /// + let mapPart isLast = function + | "**" -> Recurse + | "." -> CurrentDir + | ".." -> Parent (* works well now with Path.Combine() *) + | a when a.EndsWith(":") && driveRegex.IsMatch(a) -> Disk(a) + | a when not isLast -> a |> iif isMask DirectoryMask Directory + | a -> a |> iif isMask FileMask FileName + + let parse isLastPart pattern = + + if notNullOrEmpty pattern then + let parts = pattern.Split([|'\\'; '/'|], System.StringSplitOptions.RemoveEmptyEntries) + let fsroot = pattern.[0] |> function | '\\' | '/' -> [FsRoot] | _ -> [] + in + let isLast = isLastPart parts + fsroot @ (parts |> Array.mapi (isLast >> mapPart) |> List.ofArray) + |> normalize |> PathMask + else + PathMask [] /// - /// Converts Ant-style file pattern to a list of parts. Assumes the path specified + /// supplementary function for parsing directory /// - let parseDir = impl.parse impl.isLastPartForDir - + let isLastPartForDir _ _ = false /// - /// Converts Ant-style file pattern to a PathMask. + /// supplementary function for parsing file /// - let parse = impl.parse impl.isLastPartForFile + let isLastPartForFile (parts:_ array) = (=) (parts.Length-1) + + let dirSeparator = string Path.DirectorySeparatorChar + let partToString = + function + | Directory s + | FileName s + | DirectoryMask s + | FileMask s + -> s + | Parent -> ".." + | Part.CurrentDir -> "." + | Part.Disk d -> d + dirSeparator + | Part.Recurse -> "**" + | Part.FsRoot -> dirSeparator + + +module private PicklerImpl = + + open Pickler + + let patternpart= + alt(function + | FsRoot -> 0 + | Parent -> 1 + | Disk _ -> 2 + | DirectoryMask _ -> 3 + | Directory _ -> 4 + | Recurse -> 5 + | FileMask _ -> 6 + | FileName _ -> 7 + | CurrentDir -> 8 + ) + [| + wrap0 FsRoot + wrap0 Parent + wrap (Disk, fun (Disk d | OtherwiseFail d) -> d) str + wrap (DirectoryMask, fun (DirectoryMask d | OtherwiseFail d) -> d) str + wrap (Directory, fun (Directory d | OtherwiseFail d) -> d) str + wrap0 Recurse + wrap (FileMask, fun (FileMask m | OtherwiseFail m) -> m) str + wrap (FileName, fun (FileName m | OtherwiseFail m) -> m) str + wrap0 CurrentDir + |] + + let pattern = wrap(PathMask, fun(PathMask pp) -> pp) (list patternpart) + +module internal matchImpl = + + let eq s1 s2 = System.StringComparer.OrdinalIgnoreCase.Equals(s1, s2) + + let wildcard2regexMap = + ["**", "(.*)" + "*", """([^/\\]*)""" + "?", "([^/\\\\])" + ".", "\\."; "$", "\\$"; "^", "\\^"; "[", "\\["; "]", "\\]" + "+", "\\+"; "!", "\\!"; "=", "\\="; "{", "\\{"; "}", "\\}" + ] |> dict + + let wildcardToRegex (m:Match) = + match m.Groups.Item("tag") with + | t when not t.Success -> + match wildcard2regexMap.TryGetValue(m.Value) with + | true, v -> v + | _ -> m.Value + | t -> "(?<" + t.Value + ">" + + let normalizeSlashes (pat: string) = + pat.Replace('\\', '/') + + let maskToRegex (pattern:string) = + let pat = Regex.Replace(pattern |> normalizeSlashes, @"\((?'tag'\w+?)\:|\*\*|([*.?$^+!={}])", wildcardToRegex) + // TODO mask with sq brackets + let ignoreCase = if Env.isUnix then RegexOptions.None else RegexOptions.IgnoreCase + in + Regex(@"^" + pat + "$", RegexOptions.Compiled + ignoreCase) + + let matchPart (mask:Part) (path:Part) = + let matchByMask (rx:Regex) value = rx.Match(value).Success + match mask,path with + | (FsRoot, FsRoot) -> true + | (Disk mask, Disk d) | (Directory mask, Directory d) | FileName mask, FileName d when eq mask d -> true + + | DirectoryMask mask, Directory d | FileMask mask, FileName d -> + matchByMask (maskToRegex mask) d + + | _ -> false + + let rec matchPaths (mask:Part list) (p:Part list) = + match mask,p with + | [], [] -> true + | [], _ | _, [] -> false + + | Directory _::Recurse::Parent::ms, _ -> matchPaths (Recurse::ms) p + | Recurse::Parent::ms, _ -> matchPaths (Recurse::ms) p // ignore parent ref + + | Recurse::ms, (FileName _)::_ -> matchPaths ms p + | Recurse::ms, Directory _::xs -> (matchPaths mask xs) || (matchPaths ms p) + | m::ms, x::xs -> + matchPart m x && matchPaths ms xs + +// API +let pickler = PicklerImpl.pattern + +/// +/// Converts path to string representation (platform specific). +/// +let toString = + List.map impl.partToString + >> List.fold (fun s ps -> Path.Combine (s, ps)) "" + +/// +/// Joins two patterns. +/// +/// +/// +let join (PathMask p1) (PathMask p2) = + match impl.isRoot p2 with + | true -> PathMask p2 + | _ -> p1 @ p2 |> impl.normalize |> PathMask + +/// +/// Converts Ant-style file pattern to a list of parts. Assumes the path specified +/// +let parseDir = impl.parse impl.isLastPartForDir + +/// +/// Converts Ant-style file pattern to a PathMask. +/// +let parse = impl.parse impl.isLastPartForFile (* - /// - /// Returns true if a file name (parsed to p) matches specific file mask. - /// - /// - /// - let matchesPattern (pattern:string) = - - let regex = matchImpl.maskToRegex pattern - fun file -> regex.Match(matchImpl.normalizeSlashes file).Success +/// +/// Returns true if a file name (parsed to p) matches specific file mask. +/// +/// +/// +let matchesPattern (pattern:string) = + + let regex = matchImpl.maskToRegex pattern + fun file -> regex.Match(matchImpl.normalizeSlashes file).Success *) - let matchesPattern (PathMask mask) file = - let (PathMask fileParts) = file |> impl.parse impl.isLastPartForFile in - matchImpl.matchPaths mask fileParts - - let matches filePattern rootPath = - // IDEA: make relative path then match to pattern? - // matches "src/**/*.cs" "c:\!\src\a\b\c.cs" -> true - - matchesPattern <| join (parseDir rootPath) (parse filePattern) - - /// file name match implementation for rules - let matchGroups (pattern:string) rootPath = - - let regex = Path.Combine(rootPath, pattern) |> matchImpl.maskToRegex - fun file -> - let m = regex.Match(matchImpl.normalizeSlashes file) - if m.Success then - [for groupName in regex.GetGroupNames() do - let group = m.Groups.[groupName] - yield groupName, group.Value] |> Some - else - None - -[] -module PathExt = - /// - /// Changes or appends file extension. - /// - let (-.) path ext = Path.ChangeExtension(path, ext) +let matchesPattern (PathMask mask) file = + let (PathMask fileParts) = file |> impl.parse impl.isLastPartForFile in + matchImpl.matchPaths mask fileParts - /// - /// Combines two paths. - /// - let () path1 path2 = Path.Combine(path1, path2) +let matches filePattern rootPath = + // IDEA: make relative path then match to pattern? + // matches "src/**/*.cs" "c:\!\src\a\b\c.cs" -> true + + matchesPattern <| join (parseDir rootPath) (parse filePattern) + +/// file name match implementation for rules +let matchGroups (pattern:string) rootPath = + + let regex = Path.Combine(rootPath, pattern) |> matchImpl.maskToRegex + fun file -> + let m = regex.Match(matchImpl.normalizeSlashes file) + if m.Success then + [for groupName in regex.GetGroupNames() do + let group = m.Groups.[groupName] + yield groupName, group.Value] |> Some + else + None - /// - /// Appends the file extension. - /// - let (<.>) path ext = if System.String.IsNullOrWhiteSpace(ext) then path else path + "." + ext diff --git a/src/core/PathExt.fs b/src/core/PathExt.fs new file mode 100644 index 0000000..62d64e6 --- /dev/null +++ b/src/core/PathExt.fs @@ -0,0 +1,19 @@ +[] +module Xake.PathExt + +open System.IO + +/// +/// Changes or appends file extension. +/// +let (-.) path ext = Path.ChangeExtension(path, ext) + +/// +/// Combines two paths. +/// +let () path1 path2 = Path.Combine(path1, path2) + +/// +/// Appends the file extension. +/// +let (<.>) path ext = if System.String.IsNullOrWhiteSpace(ext) then path else path + "." + ext diff --git a/src/core/Pickler.fs b/src/core/Pickler.fs index c6560d8..1b3ecc2 100644 --- a/src/core/Pickler.fs +++ b/src/core/Pickler.fs @@ -1,91 +1,89 @@ -namespace Xake +module Xake.Pickler open System /// Pickler Combinators implementation -module Pickler = +type OutState = IO.BinaryWriter +type InState = IO.BinaryReader - type OutState = System.IO.BinaryWriter - type InState = System.IO.BinaryReader +/// +/// Main pickler type. +/// +type 'a PU = { pickle: 'a -> OutState -> unit; unpickle: InState -> 'a } - /// - /// Main pickler type. - /// - type 'a PU = { pickle: 'a -> OutState -> unit; unpickle: InState -> 'a } +/// +/// Unit pickler, does nothing. +/// +let unit = {pickle = (fun () _ -> ()); unpickle = ignore} - /// - /// Unit pickler, does nothing. - /// - let unit = {pickle = (fun () _ -> ()); unpickle = ignore} +/// +/// Translates pickler of one type into another's +/// +let wrap (d:'a -> 'b, r: 'b -> 'a) (pu: PU<'a>) = {pickle = r >> pu.pickle; unpickle = pu.unpickle >> d} - /// - /// Translates pickler of one type into another's - /// - let wrap (d:'a -> 'b, r: 'b -> 'a) (pu: PU<'a>) = {pickle = r >> pu.pickle; unpickle = pu.unpickle >> d} +/// +/// 'wrap' helper for argumentless variants +/// +let wrap0 r = wrap ((fun () -> r), ignore) unit - /// - /// 'wrap' helper for argumentless variants - /// - let wrap0 r = wrap ((fun () -> r), ignore) unit +let byte = {pickle = (fun (b:byte) st -> st.Write(b)); unpickle = fun st -> st.ReadByte()} +let int = {pickle = (fun (i:Int32) st -> st.Write(i)); unpickle = fun st -> st.ReadInt32()} +let int64 = {pickle = (fun (i:Int64) st -> st.Write(i)); unpickle = fun st -> st.ReadInt64()} +let str = {pickle = (fun (s:string) st -> st.Write(s)); unpickle = fun st -> st.ReadString()} +let float = {pickle = (fun (s:single) st -> st.Write(s)); unpickle = fun st -> st.ReadSingle()} +let double = {pickle = (fun (s:float) st -> st.Write(s)); unpickle = fun st -> st.ReadDouble()} - let byte = {pickle = (fun (b:byte) st -> st.Write(b)); unpickle = fun st -> st.ReadByte()} - let int = {pickle = (fun (i:Int32) st -> st.Write(i)); unpickle = fun st -> st.ReadInt32()} - let int64 = {pickle = (fun (i:Int64) st -> st.Write(i)); unpickle = fun st -> st.ReadInt64()} - let str = {pickle = (fun (s:string) st -> st.Write(s)); unpickle = fun st -> st.ReadString()} - let float = {pickle = (fun (s:single) st -> st.Write(s)); unpickle = fun st -> st.ReadSingle()} - let double = {pickle = (fun (s:float) st -> st.Write(s)); unpickle = fun st -> st.ReadDouble()} +let date = wrap (DateTime.FromBinary, fun (d:DateTime) -> d.Ticks) int64 +let bool = wrap ((<>) 0uy, function | true -> 1uy |false -> 0uy) byte - let date = wrap (DateTime.FromBinary, fun (d:DateTime) -> d.Ticks) int64 - let bool = wrap ((<>) 0uy, function | true -> 1uy |false -> 0uy) byte +/// Tuple picklers +let pair pu1 pu2 = { + pickle = (fun (a,b) st -> (pu1.pickle a st : unit); (pu2.pickle b st)) + unpickle = fun st -> pu1.unpickle st, pu2.unpickle st} +let triple pu1 pu2 pu3 = { + pickle = (fun (a,b,c) st -> (pu1.pickle a st : unit); (pu2.pickle b st : unit); (pu3.pickle c st)) + unpickle = fun st -> pu1.unpickle st, pu2.unpickle st, pu3.unpickle st} - /// Tuple picklers - let pair pu1 pu2 = { - pickle = (fun (a,b) st -> (pu1.pickle a st : unit); (pu2.pickle b st)) - unpickle = fun st -> pu1.unpickle st, pu2.unpickle st} - let triple pu1 pu2 pu3 = { - pickle = (fun (a,b,c) st -> (pu1.pickle a st : unit); (pu2.pickle b st : unit); (pu3.pickle c st)) - unpickle = fun st -> pu1.unpickle st, pu2.unpickle st, pu3.unpickle st} +let quad pu1 pu2 pu3 pu4 = + wrap ((fun ((a,b),(c,d)) -> (a,b,c,d)), fun(a,b,c,d) -> (a,b),(c,d)) <| pair (pair pu1 pu2) (pair pu3 pu4) - let quad pu1 pu2 pu3 pu4 = - wrap ((fun ((a,b),(c,d)) -> (a,b,c,d)), fun(a,b,c,d) -> (a,b),(c,d)) <| pair (pair pu1 pu2) (pair pu3 pu4) +let private mux3 (a,b,c) x = (a x : unit); (b x : unit); (c x : unit) +let private mux2 (a,b) x = (a x : unit); (b x : unit) - let private mux3 (a,b,c) x = (a x : unit); (b x : unit); (c x : unit) - let private mux2 (a,b) x = (a x : unit); (b x : unit) +/// +/// List pickler. +/// +/// +let list pu = + let rec listP f = function | [] -> byte.pickle 0uy | h :: t -> mux3 (byte.pickle 1uy, f h, listP f t) + let rec listUim f acc st = match byte.unpickle st with | 0uy -> List.rev acc | 1uy -> listUim f (f st :: acc) st | n -> failwithf "listU: found number %d" n + { + pickle = listP pu.pickle + unpickle = listUim pu.unpickle [] + } - /// - /// List pickler. - /// - /// - let list pu = - let rec listP f = function | [] -> byte.pickle 0uy | h :: t -> mux3 (byte.pickle 1uy, f h, listP f t) - let rec listUim f acc st = match byte.unpickle st with | 0uy -> List.rev acc | 1uy -> listUim f (f st :: acc) st | n -> failwithf "listU: found number %d" n - { - pickle = listP pu.pickle - unpickle = listUim pu.unpickle [] - } +/// +/// Variant (discriminated union) pickler. +/// +/// Maps type to index in array of picklers. +/// Array of picklers for each type. +let alt<'a> (ftag: 'a -> Core.int) (puu: PU<'a> array): PU<'a> = + { + pickle = fun (a:'a) -> + let tag = ftag a in + mux2 (tag |> Convert.ToByte |> byte.pickle, puu.[tag].pickle a) + unpickle = fun st -> + let tag = st |> byte.unpickle |> Convert.ToInt32 in + (puu.[tag].unpickle st) + } - /// - /// Variant (discriminated union) pickler. - /// - /// Maps type to index in array of picklers. - /// Array of picklers for each type. - let alt<'a> (ftag: 'a -> Core.int) (puu: PU<'a> array): PU<'a> = - { - pickle = fun (a:'a) -> - let tag = ftag a in - mux2 (tag |> Convert.ToByte |> byte.pickle, puu.[tag].pickle a) - unpickle = fun st -> - let tag = st |> byte.unpickle |> Convert.ToInt32 in - (puu.[tag].unpickle st) - } - - /// - /// Option type pickler. - /// - let option pu = - alt - (function | None _ -> 0 | Some _ -> 1) - [| - wrap ((fun () -> None), ignore) unit - wrap (Some, Option.get) pu - |] +/// +/// Option type pickler. +/// +let option pu = + alt + (function | None _ -> 0 | Some _ -> 1) + [| + wrap ((fun () -> None), ignore) unit + wrap (Some, Option.get) pu + |] diff --git a/src/core/ProcessExec.fs b/src/core/ProcessExec.fs index 5e53c39..0a53dd4 100644 --- a/src/core/ProcessExec.fs +++ b/src/core/ProcessExec.fs @@ -1,42 +1,41 @@ // common tasks -namespace Xake - -module internal ProcessExec = - open System.Diagnostics - - // internal implementation - let pexec handleStd handleErr cmd args (envvars:(string * string) list) workDir = - let pinfo = - ProcessStartInfo - (cmd, args, - UseShellExecute = false, WindowStyle = ProcessWindowStyle.Hidden, - RedirectStandardError = true, RedirectStandardOutput = true) - - for name,value in envvars do - pinfo.EnvironmentVariables.[name] <- value - - match workDir with - | Some path -> pinfo.WorkingDirectory <- path - | _ -> () - - let proc = new Process(StartInfo = pinfo) - - proc.ErrorDataReceived.Add(fun e -> if e.Data <> null then handleErr e.Data) - proc.OutputDataReceived.Add(fun e -> if e.Data <> null then handleStd e.Data) - - do proc.Start() |> ignore - - do proc.BeginOutputReadLine() - do proc.BeginErrorReadLine() - - // task might be completed by that time - Async.RunSynchronously <| - async { - do! Async.Sleep 50 - if proc.HasExited then - return proc.ExitCode - else - proc.EnableRaisingEvents <- true - do! Async.AwaitEvent proc.Exited |> Async.Ignore - return proc.ExitCode - } +module internal Xake.ProcessExec + +open System.Diagnostics + +// internal implementation +let pexec handleStd handleErr cmd args (envvars:(string * string) list) workDir = + let pinfo = + ProcessStartInfo + (cmd, args, + UseShellExecute = false, WindowStyle = ProcessWindowStyle.Hidden, + RedirectStandardError = true, RedirectStandardOutput = true) + + for name,value in envvars do + pinfo.EnvironmentVariables.[name] <- value + + match workDir with + | Some path -> pinfo.WorkingDirectory <- path + | _ -> () + + let proc = new Process(StartInfo = pinfo) + + proc.ErrorDataReceived.Add(fun e -> if e.Data <> null then handleErr e.Data) + proc.OutputDataReceived.Add(fun e -> if e.Data <> null then handleStd e.Data) + + do proc.Start() |> ignore + + do proc.BeginOutputReadLine() + do proc.BeginErrorReadLine() + + // task might be completed by that time + Async.RunSynchronously <| + async { + do! Async.Sleep 50 + if proc.HasExited then + return proc.ExitCode + else + proc.EnableRaisingEvents <- true + do! Async.AwaitEvent proc.Exited |> Async.Ignore + return proc.ExitCode + } diff --git a/src/core/RecipeFunctions.fs b/src/core/RecipeFunctions.fs index d2028c9..3bee24c 100644 --- a/src/core/RecipeFunctions.fs +++ b/src/core/RecipeFunctions.fs @@ -1,88 +1,81 @@ -namespace Xake +[] +module Xake.Recipe -[] -module Recipe = +open Xake - open Xake +/// +/// Ignores action result in case task returns the value but you don't need it. +/// +/// +let Ignore act = act |> A.ignoreF - /// - /// Ignores action result in case task returns the value but you don't need it. - /// - /// - let Ignore act = act |> A.ignoreF +/// +/// Translates the recipe result. +/// +let map f (rc: Recipe<_,_>) = recipe { + let! r = rc + return f r +} - /// - /// Translates the recipe result. - /// - let map f (rc: Recipe<_,_>) = recipe { - let! r = rc - return f r - } - - /// - /// Gets action context. - /// - let getCtx() = Recipe (fun (r,c) -> async {return (r,c)}) - - /// - /// Gets current task result. - /// - let getResult() = Recipe (fun (s,_) -> async {return (s,s)}) +/// +/// Gets action context. +/// +let getCtx() = Recipe (fun (r,c) -> async {return (r,c)}) - /// - /// Updates the build result - /// - /// - let setResult s' = Recipe (fun (_,_) -> async {return (s',())}) +/// +/// Gets current task result. +/// +let getResult() = Recipe (fun (s,_) -> async {return (s,s)}) - /// - /// Finalizes current build step and starts a new one - /// - /// New step name - let newstep name = - Recipe (fun (r,_) -> - async { - let r' = Step.updateTotalDuration r - let r'' = {r' with Steps = (Step.start name) :: r'.Steps} - return (r'',()) - }) - - /// - /// Consumes the task output and in case condition is met raises the error. - /// - /// - /// - let FailWhen cond err (act: Recipe<_,_>) = - recipe { - let! b = act - if cond b then failwith err - return b - } +/// +/// Updates the build result +/// +/// +let setResult s' = Recipe (fun (_,_) -> async {return (s',())}) - /// - /// Supplemental for FailWhen to verify errorlevel set by system command. - /// - let Not0 = (<>) 0 +/// +/// Finalizes current build step and starts a new one +/// +/// New step name +let newstep name = + Recipe (fun (r,_) -> + async { + let r' = Step.updateTotalDuration r + let r'' = {r' with Steps = (Step.start name) :: r'.Steps} + return (r'',()) + }) - /// - /// Error handler verifying result of system command. - /// - /// - let CheckErrorLevel rc = rc |> FailWhen Not0 "system command returned a non-zero result" +/// +/// Consumes the task output and in case condition is met raises the error. +/// +/// +/// +let FailWhen cond err (act: Recipe<_,_>) = + recipe { + let! b = act + if cond b then failwith err + return b + } - /// - /// Wraps action so that exceptions occured while executing action are ignored. - /// - /// - let WhenError handler (rc:Recipe<_,_>) = - recipe { - try - let! r = rc - return r - with e -> return handler e - } +/// +/// Supplemental for FailWhen to verify errorlevel set by system command. +/// +let Not0 = (<>) 0 -[] -module Action = +/// +/// Error handler verifying result of system command. +/// +/// +let CheckErrorLevel rc = rc |> FailWhen Not0 "system command returned a non-zero result" - let Ignore = Recipe.Ignore +/// +/// Wraps action so that exceptions occured while executing action are ignored. +/// +/// +let WhenError handler (rc:Recipe<_,_>) = + recipe { + try + let! r = rc + return r + with e -> return handler e + } diff --git a/src/core/ScriptFuncs.fs b/src/core/ScriptFuncs.fs index 3f09e14..cf89b3b 100644 --- a/src/core/ScriptFuncs.fs +++ b/src/core/ScriptFuncs.fs @@ -3,8 +3,6 @@ [] module ScriptFuncs = - open XakeScript - /// /// Gets the script options. /// diff --git a/src/core/WorkerPool.fs b/src/core/WorkerPool.fs index f8f2494..c27e9e5 100644 --- a/src/core/WorkerPool.fs +++ b/src/core/WorkerPool.fs @@ -1,53 +1,46 @@ -namespace Xake - -module internal WorkerPool = - - open System.IO - open System.Threading - open System.Threading.Tasks - - open BuildLog - - // TODO consider removing first argument - // execution context - type ExecMessage<'r> = - | Run of Target * Target list * Async<'r> * AsyncReplyChannel> - - let create (logger:ILogger) maxThreads = - // controls how many threads are running in parallel - let throttler = new SemaphoreSlim (maxThreads) - let log = logger.Log - - let mapKey (artifact:Target) = artifact.FullName - - throttler, MailboxProcessor.Start(fun mbox -> - let rec loop(map) = async { - let! msg = mbox.Receive() - - match msg with - | Run(artifact, targets, action, chnl) -> - let mkey = artifact |> mapKey - - match map |> Map.tryFind mkey with - | Some (task:Task<'a>) -> - log Never "Task found for '%s'. Status %A" artifact.ShortName task.Status - chnl.Reply <| Async.AwaitTask task - return! loop(map) - - | None -> - do log Info "Task queued '%s'" artifact.ShortName - do! throttler.WaitAsync(-1) |> Async.AwaitTask |> Async.Ignore - - let task = Async.StartAsTask (async { - try - let! buildResult = action - do log Info "Task done '%s'" artifact.ShortName - return buildResult - finally - throttler.Release() |> ignore - }) - chnl.Reply <| Async.AwaitTask task - let newMap = targets |> List.fold (fun m t -> m |> Map.add (mapKey t) task) map - return! loop newMap - } - loop(Map.empty) ) +module Xake.WorkerPool + +type ExecMessage<'r> = + | Run of Target * Target list * Async<'r> * AsyncReplyChannel> + +open System.Threading +open System.Threading.Tasks + +// TODO consider removing first argument +// execution context +let internal create (logger:ILogger) maxThreads = + // controls how many threads are running in parallel + let throttler = new SemaphoreSlim (maxThreads) + let log = logger.Log + + let mapKey (artifact:Target) = artifact.FullName + + throttler, MailboxProcessor.Start(fun mbox -> + let rec loop(map) = async { + match! mbox.Receive() with + | Run(artifact, targets, action, chnl) -> + let mkey = artifact |> mapKey + + match map |> Map.tryFind mkey with + | Some (task:Task<'a>) -> + log Never "Task found for '%s'. Status %A" artifact.ShortName task.Status + chnl.Reply <| Async.AwaitTask task + return! loop(map) + + | None -> + do log Info "Task queued '%s'" artifact.ShortName + do! throttler.WaitAsync(-1) |> Async.AwaitTask |> Async.Ignore + + let task = Async.StartAsTask (async { + try + let! buildResult = action + do log Info "Task done '%s'" artifact.ShortName + return buildResult + finally + throttler.Release() |> ignore + }) + chnl.Reply <| Async.AwaitTask task + let newMap = targets |> List.fold (fun m t -> m |> Map.add (mapKey t) task) map + return! loop newMap + } + loop(Map.empty) ) diff --git a/src/core/Xake.fsproj b/src/core/Xake.fsproj index 3a31364..e242e3d 100644 --- a/src/core/Xake.fsproj +++ b/src/core/Xake.fsproj @@ -17,6 +17,7 @@ + From 3c0cd47981c99b419aae14d8eb82bad966e03a45 Mon Sep 17 00:00:00 2001 From: OlegZee Date: Mon, 11 Nov 2019 00:10:43 +0700 Subject: [PATCH 02/22] project cleanup --- .gitignore | 2 ++ .vscode/settings.json | 5 ----- build.fsx | 10 +++++----- docs/cheatsheet.md | 9 +++++++++ samples/features.fsx | 29 ++++++++++++----------------- src/core/ScriptFuncs.fs | 15 --------------- 6 files changed, 28 insertions(+), 42 deletions(-) delete mode 100644 .vscode/settings.json create mode 100644 docs/cheatsheet.md diff --git a/.gitignore b/.gitignore index 8bbb6ff..d3a2e07 100644 --- a/.gitignore +++ b/.gitignore @@ -32,6 +32,8 @@ TestResult.* .xake* .fake .vs/ +.vscode/ +.ionide/ samples/**/*.exe samples/**/*.dll samples/**/*.fsx.lock diff --git a/.vscode/settings.json b/.vscode/settings.json deleted file mode 100644 index e2dfd84..0000000 --- a/.vscode/settings.json +++ /dev/null @@ -1,5 +0,0 @@ -// Place your settings in this file to overwrite default and user settings. -{ - "editor.wordWrap": "wordWrapColumn", - "editor.wordWrapColumn": 120 -} \ No newline at end of file diff --git a/build.fsx b/build.fsx index 0e27744..a45d59b 100644 --- a/build.fsx +++ b/build.fsx @@ -16,12 +16,12 @@ let libtargets = ] let getVersion () = recipe { - let! verVar = getVar("VER") - let! verEnv = getEnv("VER") + let! verVar = getVar "VER" + let! verEnv = getEnv "VER" let ver = verVar |> Option.defaultValue (verEnv |> Option.defaultValue "0.0.1") let! verSuffix = - getVar("SUFFIX") + getVar "SUFFIX" |> Recipe.map ( function | None -> "-beta" @@ -101,7 +101,7 @@ do xakeScript { } "out/Xake.(ver:*).nupkg" ..> recipe { - let! ver = getRuleMatch("ver") + let! ver = getRuleMatch "ver" do! dotnet [ "pack"; "src/core" @@ -116,7 +116,7 @@ do xakeScript { "push" => recipe { let! version = getVersion() - let! nuget_key = getEnv("NUGET_KEY") + let! nuget_key = getEnv "NUGET_KEY" do! dotnet [ "nuget"; "push" diff --git a/docs/cheatsheet.md b/docs/cheatsheet.md new file mode 100644 index 0000000..1fed66a --- /dev/null +++ b/docs/cheatsheet.md @@ -0,0 +1,9 @@ +## Operators ## + +### `<<<` - depends on targets (run sequentially) + +> `"main" <<< ["restore"; "build-debug"; "unit-test"]` + +### `<==` - depends on targets that are allowed to run in parallel +> `"main" <<< ["build-debug"; "build-release"]` + diff --git a/samples/features.fsx b/samples/features.fsx index b474bde..07fab0c 100644 --- a/samples/features.fsx +++ b/samples/features.fsx @@ -39,13 +39,19 @@ do xakeScript { // this is shorter way to express the same. See also `<==` and '<<<' operators. "main" => need ["tracetest"; "temp/a.exe"] - // .NET build rules - // build .net executable using full .net framework (or mono under unix) - - // define a "phony rule", which has goal to produce a file - "clean" => rm {file "temp/a*"} + // "phony" rule that produces no file but just removes the files + // `rm` recipe (Xake.Tasks namespace) allow to remove files and folders + "clean" => recipe { + do! rm {file "paket-files/*.*"} + do! rm {dir "out"} + do! rm {files (fileset { + includes "samplefile*" + }); verbose + } + } - // rule to build an a.exe executable by using c# compiler + // .NET build rules + // build .net executable from C# sources using full .net framework (or mono under unix) // notice there's no "out" parameter: csc recipe will use the target file as an output "temp/a.exe" ..> csc {src (!!"temp/a.cs" + "temp/AssemblyInfo.cs")} @@ -107,17 +113,6 @@ do xakeScript { return () } - // "phony" rule that produces no file but just removes the files - // `rm` recipe (Xake.Tasks namespace) allow to remove files and folders - "clean" => recipe { - do! rm {file "paket-files/*.*"} - do! rm {dir "out"} - do! rm {files (fileset { - includes "samplefile*" - }); verbose - } - } - "libs" => recipe { // this command will copy all dlls to `lib` (flat files) do! cp {file "packages/mylib/net46/*.dll"; todir "lib"} diff --git a/src/core/ScriptFuncs.fs b/src/core/ScriptFuncs.fs index 3f09e14..0d561d9 100644 --- a/src/core/ScriptFuncs.fs +++ b/src/core/ScriptFuncs.fs @@ -124,9 +124,6 @@ module ScriptFuncs = do! need targets do! alwaysRerun() // always check demanded dependencies. Otherwise it wan't check any target is available }) - - [] - let (==>) = (<==) /// Defines a rule which demands the other targets to be sequentially built. /// Unlike '<==' operator, this one waits the completion of one before issuing another rule. @@ -136,16 +133,4 @@ module ScriptFuncs = do! alwaysRerun() }) - type RuleActionArgs = - RuleActionArgs of File * Map - with - /// Gets the resulting file. - member this.File = let (RuleActionArgs (file,_)) = this in file - /// Gets the full name of resulting file. - member this.FullName = let (RuleActionArgs (file,_)) = this in File.getFullName file - - /// Gets group (part of the name) by its name. - member this.GetGroup(key) = - let (RuleActionArgs (_,groups)) = this in - groups |> Map.tryFind key |> function |Some v -> v | None -> "" From 19449cdae33d9f7342cd95236993ae4dc3439f1c Mon Sep 17 00:00:00 2001 From: OlegZee Date: Mon, 11 Nov 2019 01:33:16 +0700 Subject: [PATCH 03/22] refactoring database storage/types --- src/core/BuildDatabase.fs | 40 ++++ src/core/Database.fs | 335 +++++++++++++-------------------- src/core/DependencyAnalysis.fs | 22 +-- src/core/ExecCore.fs | 31 ++- src/core/ExecTypes.fs | 44 ++++- src/core/Prelude.fs | 2 + src/core/RecipeBuilder.fs | 18 +- src/core/RecipeFunctions.fs | 22 +-- src/core/ScriptFuncs.fs | 14 +- src/core/Types.fs | 8 +- src/core/Xake.fsproj | 3 +- 11 files changed, 265 insertions(+), 274 deletions(-) create mode 100644 src/core/BuildDatabase.fs diff --git a/src/core/BuildDatabase.fs b/src/core/BuildDatabase.fs new file mode 100644 index 0000000..15a1d38 --- /dev/null +++ b/src/core/BuildDatabase.fs @@ -0,0 +1,40 @@ +module Xake.BuildDatabase + +module internal Picklers = + + open Pickler + + let target = Database.Picklers.targetPu + + let file = wrap (File.make, fun a -> a.FullName) str + + let step = + wrap + ((fun (n, s, o, w) -> {StepInfo.Name = n; Start = s; OwnTime = o * 1; WaitTime = w * 1}), + fun ({StepInfo.Name = n; Start = s; OwnTime = o; WaitTime = w}) -> (n, s, o / 1, w / 1)) (quad str date int int) + + // Fileset of FilesetOptions * FilesetElement list + let dependency = + alt (function + | ArtifactDep _ -> 0 + | FileDep _ -> 1 + | EnvVar _ -> 2 + | Var _ -> 3 + | AlwaysRerun _ -> 4 + | GetFiles _ -> 5) + [| wrap (ArtifactDep, fun (ArtifactDep f | OtherwiseFail f) -> f) target + wrap (FileDep, fun (FileDep(f, ts) | OtherwiseFail (f, ts)) -> (f, ts)) (pair file date) + wrap (EnvVar, fun (EnvVar(n, v) | OtherwiseFail (n,v)) -> n, v) (pair str (option str)) + wrap (Var, fun (Var(n, v)| OtherwiseFail (n,v)) -> n, v) (pair str (option str)) + wrap0 AlwaysRerun + wrap (GetFiles, fun (GetFiles(fs, fi)| OtherwiseFail (fs,fi)) -> fs, fi) (pair filesetPickler filelistPickler) |] + + let result = + wrap + ((fun (r, built, deps, steps) -> + { Targets = r + Built = built + Depends = deps + Steps = steps }), + fun r -> (r.Targets, r.Built, r.Depends, r.Steps)) + (quad (list target) date (list dependency) (list step)) diff --git a/src/core/Database.fs b/src/core/Database.fs index d36dca3..9f1ea52 100644 --- a/src/core/Database.fs +++ b/src/core/Database.fs @@ -1,218 +1,139 @@ -namespace Xake +module Xake.Database -module BuildLog = - open Xake - open System - - let XakeDbVersion = "0.4" - - type Database = { Status : Map } - - (* API *) +open Xake - /// Creates a new build result - let makeResult target = - { Targets = target - Built = DateTime.Now - Depends = [] - Steps = [] } - - /// Creates a new database - let newDatabase() = { Database.Status = Map.empty } - - /// Adds result to a database - let internal addResult db result = - { db with Status = result.Targets |> List.fold (fun m i -> Map.add i result m) db.Status } +let XakeDbVersion = "0.4" -type 't Agent = 't MailboxProcessor +type Database<'result> = { Status : Map } -module Storage = - open Xake - open BuildLog - - module private Persist = - open Pickler +type DatabaseHeader = + { XakeSign : string + XakeVer : string + ScriptDate : Timestamp } + +(* API *) + +/// Creates a new database +let newDatabase() = { Database.Status = Map.empty } + +/// Adds result to a database +let internal addResult db targets (result: 'result) = + { db with Status = targets |> List.fold (fun m i -> Map.add i result m) db.Status } + +module Picklers = + open Pickler + + let targetPu = + alt (function + | FileTarget _ -> 0 + | PhonyAction _ -> 1) + [| wrap (File.make >> FileTarget, fun (FileTarget f | OtherwiseFail f) -> f.Name) str + wrap (PhonyAction, (fun (PhonyAction a | OtherwiseFail a) -> a)) str |] - type DatabaseHeader = - { XakeSign : string - XakeVer : string - ScriptDate : Timestamp } - - let file = wrap (File.make, fun a -> a.FullName) str - - let target = - alt (function - | FileTarget _ -> 0 - | PhonyAction _ -> 1) - [| wrap (File.make >> FileTarget, fun (FileTarget f | OtherwiseFail f) -> f.Name) str - wrap (PhonyAction, (fun (PhonyAction a | OtherwiseFail a) -> a)) str |] - - let step = - wrap - ((fun (n, s, o, w) -> {StepInfo.Name = n; Start = s; OwnTime = o * 1; WaitTime = w * 1}), - fun ({StepInfo.Name = n; Start = s; OwnTime = o; WaitTime = w}) -> (n, s, o / 1, w / 1)) (quad str date int int) - - // Fileset of FilesetOptions * FilesetElement list - let dependency = - alt (function - | ArtifactDep _ -> 0 - | FileDep _ -> 1 - | EnvVar _ -> 2 - | Var _ -> 3 - | AlwaysRerun _ -> 4 - | GetFiles _ -> 5) - [| wrap (ArtifactDep, fun (ArtifactDep f | OtherwiseFail f) -> f) target - wrap (FileDep, fun (FileDep(f, ts) | OtherwiseFail (f, ts)) -> (f, ts)) (pair file date) - wrap (EnvVar, fun (EnvVar(n, v) | OtherwiseFail (n,v)) -> n, v) (pair str (option str)) - wrap (Var, fun (Var(n, v)| OtherwiseFail (n,v)) -> n, v) (pair str (option str)) - wrap0 AlwaysRerun - wrap (GetFiles, fun (GetFiles(fs, fi)| OtherwiseFail (fs,fi)) -> fs, fi) (pair filesetPickler filelistPickler) |] - - let result = - wrap - ((fun (r, built, deps, steps) -> - { Targets = r - Built = built - Depends = deps - Steps = steps }), - fun r -> (r.Targets, r.Built, r.Depends, r.Steps)) - (quad (list target) date (list dependency) (list step)) - - let dbHeader = - wrap - ((fun (sign, ver, scriptDate) -> - { DatabaseHeader.XakeSign = sign - XakeVer = ver - ScriptDate = scriptDate }), - fun h -> (h.XakeSign, h.XakeVer, h.ScriptDate)) - (triple str str date) + let dbHeaderPu = + wrap + ((fun (sign, ver, scriptDate) -> + { DatabaseHeader.XakeSign = sign + XakeVer = ver + ScriptDate = scriptDate }), + fun h -> (h.XakeSign, h.XakeVer, h.ScriptDate)) + (triple str str date) + +module private impl = + open System.IO + open Pickler + open Picklers + + let writeHeader w = + let h = + { DatabaseHeader.XakeSign = "XAKE" + XakeVer = XakeDbVersion + ScriptDate = System.DateTime.Now } + dbHeaderPu.pickle h w - module private impl = - open System.IO - open Persist - - let writeHeader w = - let h = - { DatabaseHeader.XakeSign = "XAKE" - XakeVer = XakeDbVersion - ScriptDate = System.DateTime.Now } - Persist.dbHeader.pickle h w - - let openDatabaseFile dbpath (logger : ILogger) = - let log = logger.Log - let resultPU = Persist.result - let bkpath = dbpath <.> "bak" - // if exists backup restore - if File.Exists(bkpath) then - log Level.Message "Backup file found ('%s'), restoring db" - bkpath + let openDatabaseFile (resultPU: 'result PU) dbpath (logger : ILogger) = + let log = logger.Log + let bkpath = dbpath <.> "bak" + // if exists backup restore + if File.Exists(bkpath) then + log Level.Message "Backup file found ('%s'), restoring db" + bkpath + try + File.Delete(dbpath) + with _ -> () + File.Move(bkpath, dbpath) + let db = ref (newDatabase()) + let recordCount = ref 0 + + let targetListPu = list targetPu + // read database + if File.Exists(dbpath) then + try + use reader = new BinaryReader(File.OpenRead(dbpath)) + let stream = reader.BaseStream + let header = dbHeaderPu.unpickle reader + if header.XakeVer < XakeDbVersion then + failwith "Database version is old." + while stream.Position < stream.Length do + let targets = targetListPu.unpickle reader + let result = resultPU.unpickle reader + db := addResult !db targets result + recordCount := !recordCount + 1 + // if fails create new + with ex -> + log Level.Error + "Failed to read database, so recreating. Got \"%s\"" + <| ex.ToString() try File.Delete(dbpath) with _ -> () - File.Move(bkpath, dbpath) - let db = ref (newDatabase()) - let recordCount = ref 0 - // read database - if File.Exists(dbpath) then - try - use reader = new BinaryReader(File.OpenRead(dbpath)) - let stream = reader.BaseStream - let header = Persist.dbHeader.unpickle reader - if header.XakeVer < XakeDbVersion then - failwith "Database version is old." - while stream.Position < stream.Length do - let result = resultPU.unpickle reader - db := result |> addResult !db - recordCount := !recordCount + 1 - // if fails create new - with ex -> - log Level.Error - "Failed to read database, so recreating. Got \"%s\"" - <| ex.ToString() - try - File.Delete(dbpath) - with _ -> () - // check if we can cleanup db - if !recordCount > (!db).Status.Count * 5 then - log Level.Message "Compacting database" - File.Move(dbpath, bkpath) - use writer = - new BinaryWriter(File.Open(dbpath, FileMode.CreateNew)) - writeHeader writer - (!db).Status - |> Map.toSeq - |> Seq.map snd - |> Seq.iter (fun r -> resultPU.pickle r writer) - File.Delete(bkpath) - let dbwriter = - new BinaryWriter(File.Open (dbpath, FileMode.Append, FileAccess.Write)) - if dbwriter.BaseStream.Position = 0L then writeHeader dbwriter - db, dbwriter - - type DatabaseApi = - | GetResult of Target * AsyncReplyChannel> - | Store of BuildResult - | Close - | CloseWait of AsyncReplyChannel + // check if we can cleanup db + if !recordCount > (!db).Status.Count * 5 then + log Level.Message "Compacting database" + File.Move(dbpath, bkpath) + use writer = + new BinaryWriter(File.Open(dbpath, FileMode.CreateNew)) + writeHeader writer + (!db).Status + |> Map.toSeq + |> Seq.map snd + |> Seq.iter (fun r -> resultPU.pickle r writer) + File.Delete(bkpath) + let dbwriter = + new BinaryWriter(File.Open (dbpath, FileMode.Append, FileAccess.Write)) + if dbwriter.BaseStream.Position = 0L then writeHeader dbwriter + db, dbwriter - /// - /// Build result pickler. - /// - let resultPU = Persist.result - - /// - /// Opens database. - /// - /// Full xake database file name - /// - let openDb dbpath (logger : ILogger) = - let db, dbwriter = impl.openDatabaseFile dbpath logger - MailboxProcessor.Start(fun mbox -> - let rec loop (db) = - async { - let! msg = mbox.Receive() - match msg with - | GetResult(key, chnl) -> - db.Status - |> Map.tryFind key - |> chnl.Reply - return! loop (db) - | Store result -> - Persist.result.pickle result dbwriter - return! loop (result |> addResult db) - | Close -> - logger.Log Info "Closing database" - dbwriter.Dispose() - return () - | CloseWait ch -> - logger.Log Info "Closing database" - dbwriter.Dispose() - ch.Reply() - return () - } - loop (!db)) - -/// Utility methods to manipulate build stats -module internal Step = - - type DateTime = System.DateTime - - let start name = {StepInfo.Empty with Name = name; Start = DateTime.Now} - - /// - /// Updated last (current) build step - /// - let updateLastStep fn = function - | {Steps = current :: rest} as result -> {result with Steps = (fn current) :: rest} - | result -> result +type DatabaseApi<'result> = + | GetResult of Target * AsyncReplyChannel<'result option> + | Store of Target list * 'result + | Close + | CloseWait of AsyncReplyChannel - /// - /// Adds specific amount to a wait time - /// - let updateWaitTime delta = updateLastStep (fun c -> {c with WaitTime = c.WaitTime + delta}) - let updateTotalDuration = - let durationSince (startTime: DateTime) = int (DateTime.Now - startTime).TotalMilliseconds * 1 - updateLastStep (fun c -> {c with OwnTime = (durationSince c.Start) - c.WaitTime}) - let lastStep = function - | {Steps = current :: _} -> current - | _ -> start "dummy" +/// Opens database. +let openDb resultPU dbpath (logger : ILogger) = + let db, dbwriter = impl.openDatabaseFile resultPU dbpath logger + MailboxProcessor.Start(fun mbox -> + let rec loop (db) = + async { + let! msg = mbox.Receive() + match msg with + | GetResult(key, chnl) -> + db.Status + |> Map.tryFind key + |> chnl.Reply + return! loop (db) + | Store (targets, result) -> + resultPU.pickle result dbwriter + return! loop (addResult db targets result) + | Close -> + logger.Log Info "Closing database" + dbwriter.Dispose() + return () + | CloseWait ch -> + logger.Log Info "Closing database" + dbwriter.Dispose() + ch.Reply() + return () + } + loop (!db)) diff --git a/src/core/DependencyAnalysis.fs b/src/core/DependencyAnalysis.fs index 2f747b6..09ad0e3 100644 --- a/src/core/DependencyAnalysis.fs +++ b/src/core/DependencyAnalysis.fs @@ -1,7 +1,7 @@ module internal Xake.DependencyAnalysis open Xake -open Storage +open Database /// /// Dependency state. @@ -21,7 +21,7 @@ let TimeCompareToleranceMs = 10.0 /// /// let getExecTime ctx target = - (fun ch -> Storage.GetResult(target, ch)) |> ctx.Db.PostAndReply + (fun ch -> GetResult(target, ch)) |> ctx.Db.PostAndReply |> Option.fold (fun _ r -> r.Steps |> List.sumBy (fun s -> s.OwnTime)) 0 /// Gets single dependency state and reason of a change. @@ -30,26 +30,26 @@ let getDepState getVar getFileList (getChangedDeps: Target -> ChangeReason list) let dbgInfo = File.exists a |> function | false -> "file does not exists" | _ -> sprintf "write time: %A vs %A" (File.getLastWriteTime a) wrtime - ChangeReason.FilesChanged [a.Name], Some dbgInfo + FilesChanged [a.Name], Some dbgInfo | ArtifactDep (FileTarget file) when not (File.exists file) -> - ChangeReason.DependsMissingTarget (FileTarget file), None + DependsMissingTarget (FileTarget file), None | ArtifactDep dependeeTarget -> - dependeeTarget |> getChangedDeps |> List.filter ((<>) ChangeReason.NotChanged) + dependeeTarget |> getChangedDeps |> List.filter ((<>) NotChanged) |> function | [] -> NotChanged, None |item::_ -> - ChangeReason.Depends dependeeTarget, Some (sprintf "E.g. %A..." item) + Depends dependeeTarget, Some (sprintf "E.g. %A..." item) | EnvVar (name,value) when value <> Util.getEnvVar name -> - ChangeReason.Other <| sprintf "Environment variable %s was changed from '%A' to '%A'" name value (Util.getEnvVar name), None + Other <| sprintf "Environment variable %s was changed from '%A' to '%A'" name value (Util.getEnvVar name), None | Var (name,value) when value <> getVar name -> - ChangeReason.Other <| sprintf "Global script variable %s was changed '%A'->'%A'" name value (getVar name), None + Other <| sprintf "Global script variable %s was changed '%A'->'%A'" name value (getVar name), None | AlwaysRerun -> - ChangeReason.Other <| "AlwaysRerun rule", Some "Rule indicating target has to be run regardless dependencies state" + Other <| "AlwaysRerun rule", Some "Rule indicating target has to be run regardless dependencies state" | GetFiles (fileset,files) -> let newfiles = getFileList fileset @@ -96,12 +96,12 @@ let getChangeReasons ctx getTargetDeps target = | [] -> match result with | targetList when targetList |> List.exists (function | FileTarget file when not (File.exists file) -> true | _ -> false) -> - [ChangeReason.Other "target file does not exist", Some "The file has to be rebuilt regardless all its dependencies were not changed"] + [Other "target file does not exist", Some "The file has to be rebuilt regardless all its dependencies were not changed"] | _ -> [] | ls -> ls | _ -> - [ChangeReason.Other "Not built yet", Some "Target was not built before or build results were cleaned so we don't know dependencies."] + [Other "Not built yet", Some "Target was not built before or build results were cleaned so we don't know dependencies."] |> List.map fst // gets task duration and list of targets it depends on. No clue why one method does both. diff --git a/src/core/ExecCore.fs b/src/core/ExecCore.fs index b9d50d3..96d56d4 100644 --- a/src/core/ExecCore.fs +++ b/src/core/ExecCore.fs @@ -7,7 +7,7 @@ open DependencyAnalysis [] let XakeOptions = ExecOptions.Default -open Storage +open Database /// Writes the message with formatting to a log let traceLog (level:Logging.Level) fmt = @@ -116,11 +116,11 @@ let rec execOne ctx target = do Progress.TaskStart primaryTarget |> ctx.Progress.Post - let startResult = {BuildLog.makeResult targets with Steps = [Step.start "all"]} + let startResult = {BuildResult.makeResult targets with Steps = [Step.start "all"]} let! (result,_) = action (startResult, taskContext) let result = Step.updateTotalDuration result - Store result |> ctx.Db.Post + Store (result.Targets, result) |> ctx.Db.Post do Progress.TaskComplete primaryTarget |> ctx.Progress.Post do ctx.Logger.Log Command "Completed %s in %A ms (wait %A ms)" primaryTarget.ShortName (Step.lastStep result).OwnTime (Step.lastStep result).WaitTime @@ -316,7 +316,7 @@ let runScript options rules = let (throttler, pool) = WorkerPool.create logger options.Threads - let db = openDb (options.ProjectRoot options.DbFileName) logger + let db = openDb BuildDatabase.Picklers.result (options.ProjectRoot options.DbFileName) logger let ctx = { Ordinal = 0 @@ -326,7 +326,8 @@ let runScript options rules = Progress = Progress.emptyProgress() NeedRebuild = fun _ -> false Targets = [] - RuleMatches = Map.empty } + RuleMatches = Map.empty + Result = BuildResult.makeResult [] } logger.Log Info "Options: %A" options @@ -359,19 +360,17 @@ let runScript options rules = ctx.Logger.Log Message "\n\n\tBuild failed after running for %A\n" (System.DateTime.Now - start) exit 2 finally - db.PostAndReply Storage.CloseWait + db.PostAndReply Database.CloseWait FlushLogs() /// "need" implementation -let need targets = - action { - let startTime = System.DateTime.Now +let need targets = recipe { + let startTime = System.DateTime.Now - let! ctx = getCtx() - let! _,deps = targets |> execNeed ctx + let! ctx = getCtx() + let! _,deps = targets |> execNeed ctx - let totalDuration = int (System.DateTime.Now - startTime).TotalMilliseconds * 1 - let! result = getResult() - let result' = {result with Depends = result.Depends @ deps} |> (Step.updateWaitTime totalDuration) - do! setResult result' - } + let totalDuration = int (System.DateTime.Now - startTime).TotalMilliseconds * 1 + let result' = {ctx.Result with Depends = ctx.Result.Depends @ deps} |> (Step.updateWaitTime totalDuration) + do! setCtx { ctx with Result = result' } +} diff --git a/src/core/ExecTypes.fs b/src/core/ExecTypes.fs index 69a8c37..21f2729 100644 --- a/src/core/ExecTypes.fs +++ b/src/core/ExecTypes.fs @@ -1,6 +1,8 @@ namespace Xake open System.Threading +open Prelude +open Xake.Database /// Script execution options type ExecOptions = { @@ -67,10 +69,16 @@ end type ExecStatus = | Succeed | Skipped | JustFile type TaskPool = Agent> +type BuildResult = + { Targets : Target list + Built : Timestamp + Depends : Dependency list + Steps : StepInfo list } + /// Script execution context type ExecContext = { TaskPool: TaskPool - Db: Agent + Db: Agent> Throttler: SemaphoreSlim Options: ExecOptions Rules: Rules @@ -81,6 +89,7 @@ type ExecContext = { RuleMatches: Map Ordinal: int NeedRebuild: Target list -> bool + Result: BuildResult } module internal Util = @@ -90,3 +99,36 @@ module internal Util = let private valueByName variableName = function |name,value when name = variableName -> Some value | _ -> None let getVar (options: ExecOptions) name = options.Vars |> List.tryPick (valueByName name) + +/// Utility methods to manipulate build stats // TODO moveme +module internal Step = + + type DateTime = System.DateTime + + let start name = {StepInfo.Empty with Name = name; Start = DateTime.Now} + + /// + /// Updated last (current) build step + /// + let updateLastStep fn = function + | {Steps = current :: rest} as result -> {result with Steps = (fn current) :: rest} + | result -> result + + /// + /// Adds specific amount to a wait time + /// + let updateWaitTime delta = updateLastStep (fun c -> {c with WaitTime = c.WaitTime + delta}) + let updateTotalDuration = + let durationSince (startTime: DateTime) = int (DateTime.Now - startTime).TotalMilliseconds * 1 + updateLastStep (fun c -> {c with OwnTime = (durationSince c.Start) - c.WaitTime}) + let lastStep = function + | {Steps = current :: _} -> current + | _ -> start "dummy" + +module internal BuildResult = + /// Creates a new build result + let makeResult target = + { Targets = target + Built = System.DateTime.Now + Depends = [] + Steps = [] } diff --git a/src/core/Prelude.fs b/src/core/Prelude.fs index d7fc990..3f0b4ec 100644 --- a/src/core/Prelude.fs +++ b/src/core/Prelude.fs @@ -4,3 +4,5 @@ module Prelude let (><) f a b = f b a let inline (|OtherwiseFail|) _ = failwith "no choice" let inline (|OtherwiseFailErr|) message _ = failwith message + +type 't Agent = 't MailboxProcessor diff --git a/src/core/RecipeBuilder.fs b/src/core/RecipeBuilder.fs index e4ed98e..a5715bf 100644 --- a/src/core/RecipeBuilder.fs +++ b/src/core/RecipeBuilder.fs @@ -1,23 +1,23 @@ namespace Xake -module internal A = +module internal RecipeAlgebra = let runAction (Recipe r) = r - let returnF a = Recipe (fun (s,_) -> async {return (s,a)}) + let returnF a = Recipe (fun s -> async {return (s,a)}) - let bindF m f = Recipe (fun (s, a) -> async { - let! (s', b) = runAction m (s, a) in - return! runAction (f b) (s', a) + let bindF m f = Recipe (fun s -> async { + let! (s', b) = runAction m s in + return! runAction (f b) s' }) - let bindA m f = Recipe (fun (s, r) -> async { + let bindA m f = Recipe (fun s -> async { let! a = m in - return! runAction (f a) (s, r) + return! runAction (f a) s }) let resultFromF m = m let callF f a = bindF (returnF a) f let delayF f = callF f () - let doneF = Recipe (fun (s,_) -> async {return (s,())}) + let doneF = Recipe (fun s -> async {return (s,())}) let ignoreF p = bindF p (fun _ -> doneF) let combineF f g = bindF f (fun _ -> g) @@ -61,7 +61,7 @@ module internal A = [] module Builder = - open A + open RecipeAlgebra type RecipeBuilder() = member this.Return(c) = returnF c member this.Zero() = doneF diff --git a/src/core/RecipeFunctions.fs b/src/core/RecipeFunctions.fs index 3bee24c..1d70e8e 100644 --- a/src/core/RecipeFunctions.fs +++ b/src/core/RecipeFunctions.fs @@ -7,7 +7,7 @@ open Xake /// Ignores action result in case task returns the value but you don't need it. /// /// -let Ignore act = act |> A.ignoreF +let Ignore act = act |> RecipeAlgebra.ignoreF /// /// Translates the recipe result. @@ -17,33 +17,19 @@ let map f (rc: Recipe<_,_>) = recipe { return f r } -/// /// Gets action context. -/// -let getCtx() = Recipe (fun (r,c) -> async {return (r,c)}) +let getCtx() = Recipe (fun c -> async {return (c,c)}) /// /// Gets current task result. /// -let getResult() = Recipe (fun (s,_) -> async {return (s,s)}) +// let getResult() = Recipe (fun (s,_) -> async {return (s,s)}) /// /// Updates the build result /// /// -let setResult s' = Recipe (fun (_,_) -> async {return (s',())}) - -/// -/// Finalizes current build step and starts a new one -/// -/// New step name -let newstep name = - Recipe (fun (r,_) -> - async { - let r' = Step.updateTotalDuration r - let r'' = {r' with Steps = (Step.start name) :: r'.Steps} - return (r'',()) - }) +let setCtx ctx = Recipe (fun _ -> async {return (ctx,())}) /// /// Consumes the task output and in case condition is met raises the error. diff --git a/src/core/ScriptFuncs.fs b/src/core/ScriptFuncs.fs index 1727603..f0047e5 100644 --- a/src/core/ScriptFuncs.fs +++ b/src/core/ScriptFuncs.fs @@ -26,8 +26,8 @@ module ScriptFuncs = files |> List.map FileTarget |> ExecCore.need let private record d = recipe { - let! result = getResult() - do! setResult { result with Depends = d :: result.Depends } + let! ctx = getCtx() + do! setCtx { ctx with Result = { ctx.Result with Depends = d :: ctx.Result.Depends } } } /// @@ -123,6 +123,14 @@ module ScriptFuncs = do! alwaysRerun() // always check demanded dependencies. Otherwise it wan't check any target is available }) + /// Finalizes current build step and starts a new one // TODO put it somewhere + let newstep name = recipe { + let! c = getCtx() + let r' = Step.updateTotalDuration c.Result + let r'' = {r' with Steps = (Step.start name) :: r'.Steps} + do! setCtx { c with Result = r''} + } + /// Defines a rule which demands the other targets to be sequentially built. /// Unlike '<==' operator, this one waits the completion of one before issuing another rule. let (<<<) name targets = PhonyRule (name, recipe { @@ -130,5 +138,3 @@ module ScriptFuncs = do! need [t] do! alwaysRerun() }) - - diff --git a/src/core/Types.fs b/src/core/Types.fs index d0665ba..102a6ed 100644 --- a/src/core/Types.fs +++ b/src/core/Types.fs @@ -50,14 +50,8 @@ module DomainTypes = { Name: string; Start: System.DateTime; OwnTime: int; WaitTime: int } with static member Empty = {Name = ""; Start = new System.DateTime(1900,1,1); OwnTime = 0; WaitTime = 0} - type BuildResult = - { Targets : Target list - Built : Timestamp - Depends : Dependency list - Steps : StepInfo list } - // expression type - type Recipe<'a,'b> = Recipe of (BuildResult * 'a -> Async) + type Recipe<'a,'b> = Recipe of ('a -> Async<'a * 'b>) /// Data type for action's out parameter. Defined target file and named groups in pattern diff --git a/src/core/Xake.fsproj b/src/core/Xake.fsproj index e242e3d..378daa8 100644 --- a/src/core/Xake.fsproj +++ b/src/core/Xake.fsproj @@ -22,13 +22,14 @@ - + + From 7d3a79a328c5fe2f49042a65b7c3184fd635a33b Mon Sep 17 00:00:00 2001 From: Oleg Zaimkin Date: Mon, 11 Nov 2019 14:00:08 +0700 Subject: [PATCH 04/22] completing database refatoring --- build.fsx | 67 ++++++++++++++-------------------- src/core/BuildDatabase.fs | 7 +++- src/core/Database.fs | 20 +++++----- src/core/DependencyAnalysis.fs | 2 +- src/core/ExecCore.fs | 9 ++--- src/core/ExecTypes.fs | 7 ++-- src/tests/StorageTests.fs | 57 +++++++++++++++-------------- src/tests/XakeScriptTests.fs | 11 +++--- 8 files changed, 87 insertions(+), 93 deletions(-) diff --git a/build.fsx b/build.fsx index 45ca67a..92da69b 100644 --- a/build.fsx +++ b/build.fsx @@ -11,9 +11,7 @@ open Xake.Tasks let frameworks = ["netstandard2.0"; "net46"] let libtargets = [ for t in frameworks do - for e in ["dll"; "xml"] - -> sprintf "out/%s/Xake.%s" t e - ] + for e in ["dll"; "xml"] -> sprintf "out/%s/Xake.%s" t e ] let getVersion () = recipe { let! verVar = getVar "VER" @@ -22,12 +20,11 @@ let getVersion () = recipe { let! verSuffix = getVar "SUFFIX" - |> Recipe.map ( + |> map ( function | None -> "-beta" | Some "" -> "" // this is release! - | Some s -> "-" + s - ) + | Some s -> "-" + s ) return ver + verSuffix } @@ -37,8 +34,7 @@ let dotnet arglist = recipe { do! shell { cmd "dotnet" args arglist - failonerror - } |> Recipe.Ignore + failonerror } |> Ignore } do xakeScript { @@ -46,10 +42,7 @@ do xakeScript { // consolelog Verbosity.Normal rules [ - "main" => recipe { - do! need ["build"] - do! need ["test"] - } + "main" <<< ["build"; "test"] "build" <== libtargets "clean" => rm {dir "out"} @@ -58,11 +51,11 @@ do xakeScript { do! alwaysRerun() let! where = - getVar("FILTER") - |> Recipe.map (function |Some clause -> ["--filter"; sprintf "Name~\"%s\"" clause] | None -> []) + getVar "FILTER" + |> map (function |Some clause -> ["--filter"; sprintf "Name~\"%s\"" clause] | None -> []) // in case of travis only run tests for standard runtime, eventually will add more - let! limitFwk = getEnv("TRAVIS") |> Recipe.map (function | Some _ -> ["-f:netcoreapp2.0"] | _ -> []) + let! limitFwk = getEnv "TRAVIS" |> map (function | Some _ -> ["-f:netcoreapp2.0"] | _ -> []) do! dotnet <| ["test"; "src/tests"; "-c"; "Release"; "-p:ParallelizeTestCollections=false"] @ where @ limitFwk } @@ -80,16 +73,14 @@ do xakeScript { let! version = getVersion() for framework in frameworks do - do! dotnet - [ - "build" - "src/core" - "/p:Version=" + version - "--configuration"; "Release" - "--framework"; framework - "--output"; "../../out/" + framework - "/p:DocumentationFile=Xake.xml" - ] + do! dotnet [ + "build" + "src/core" + "/p:Version=" + version + "--configuration"; "Release" + "--framework"; framework + "--output"; "../../out/" + framework + "/p:DocumentationFile=Xake.xml" ] } ] @@ -102,14 +93,12 @@ do xakeScript { "out/Xake.(ver:*).nupkg" ..> recipe { let! ver = getRuleMatch "ver" - do! dotnet - [ - "pack"; "src/core" - "-c"; "Release" - "/p:Version=" + ver - "--output"; "../../out/" - "/p:DocumentationFile=Xake.xml" - ] + do! dotnet [ + "pack"; "src/core" + "-c"; "Release" + "/p:Version=" + ver + "--output"; "../../out/" + "/p:DocumentationFile=Xake.xml" ] } // push need pack to be explicitly called in advance @@ -117,13 +106,11 @@ do xakeScript { let! version = getVersion() let! nuget_key = getEnv "NUGET_KEY" - do! dotnet - [ - "nuget"; "push" - "out" makePackageName version - "--source"; "https://www.nuget.org/api/v2/package" - "--api-key"; nuget_key |> Option.defaultValue "" - ] + do! dotnet [ + "nuget"; "push" + "out" makePackageName version + "--source"; "https://www.nuget.org/api/v2/package" + "--api-key"; nuget_key |> Option.defaultValue "" ] } ] } diff --git a/src/core/BuildDatabase.fs b/src/core/BuildDatabase.fs index 15a1d38..5ad8e95 100644 --- a/src/core/BuildDatabase.fs +++ b/src/core/BuildDatabase.fs @@ -1,6 +1,6 @@ module Xake.BuildDatabase -module internal Picklers = +module Picklers = open Pickler @@ -38,3 +38,8 @@ module internal Picklers = Steps = steps }), fun r -> (r.Targets, r.Built, r.Depends, r.Steps)) (quad (list target) date (list dependency) (list step)) + +type DatabaseApi<'result> = Database.DatabaseApi<'result> + +/// Opens the database +let openDb path loggers = Database.openDb Picklers.result path loggers \ No newline at end of file diff --git a/src/core/Database.fs b/src/core/Database.fs index 9f1ea52..8c6d4a3 100644 --- a/src/core/Database.fs +++ b/src/core/Database.fs @@ -2,7 +2,7 @@ open Xake -let XakeDbVersion = "0.4" +let XakeDbVersion = "0.5" type Database<'result> = { Status : Map } @@ -50,6 +50,8 @@ module private impl = XakeVer = XakeDbVersion ScriptDate = System.DateTime.Now } dbHeaderPu.pickle h w + + let targetListPu = list targetPu let openDatabaseFile (resultPU: 'result PU) dbpath (logger : ILogger) = let log = logger.Log @@ -65,7 +67,6 @@ module private impl = let db = ref (newDatabase()) let recordCount = ref 0 - let targetListPu = list targetPu // read database if File.Exists(dbpath) then try @@ -111,28 +112,29 @@ type DatabaseApi<'result> = | CloseWait of AsyncReplyChannel /// Opens database. -let openDb resultPU dbpath (logger : ILogger) = - let db, dbwriter = impl.openDatabaseFile resultPU dbpath logger +let openDb resultPU dbPath (logger : ILogger) = + let db, dbWriter = impl.openDatabaseFile resultPU dbPath logger MailboxProcessor.Start(fun mbox -> let rec loop (db) = async { let! msg = mbox.Receive() match msg with - | GetResult(key, chnl) -> + | GetResult(key, chan) -> db.Status |> Map.tryFind key - |> chnl.Reply + |> chan.Reply return! loop (db) | Store (targets, result) -> - resultPU.pickle result dbwriter + impl.targetListPu.pickle targets dbWriter + resultPU.pickle result dbWriter return! loop (addResult db targets result) | Close -> logger.Log Info "Closing database" - dbwriter.Dispose() + dbWriter.Dispose() return () | CloseWait ch -> logger.Log Info "Closing database" - dbwriter.Dispose() + dbWriter.Dispose() ch.Reply() return () } diff --git a/src/core/DependencyAnalysis.fs b/src/core/DependencyAnalysis.fs index 09ad0e3..507b6fd 100644 --- a/src/core/DependencyAnalysis.fs +++ b/src/core/DependencyAnalysis.fs @@ -83,7 +83,7 @@ let getChangeReasons ctx getTargetDeps target = match lastBuild with | Some {BuildResult.Depends = []} -> - [ChangeReason.Other "No dependencies", Some "It means target is not \"pure\" and depends on something beyond our control (oracle)"] + [Other "No dependencies", Some "It means target is not \"pure\" and depends on something beyond our control (oracle)"] | Some {BuildResult.Depends = depends; Targets = result} -> let depState = getDepState (Util.getVar ctx.Options) (toFileList ctx.Options.ProjectRoot) getTargetDeps diff --git a/src/core/ExecCore.fs b/src/core/ExecCore.fs index 96d56d4..85e99b4 100644 --- a/src/core/ExecCore.fs +++ b/src/core/ExecCore.fs @@ -106,7 +106,7 @@ let newTaskContext targets matches ctx = // executes single artifact let rec execOne ctx target = - let run ruleMatches action targets = + let run ruleMatches (Recipe action) targets = let primaryTarget = targets |> List.head async { match ctx.NeedRebuild targets with @@ -117,7 +117,7 @@ let rec execOne ctx target = do Progress.TaskStart primaryTarget |> ctx.Progress.Post let startResult = {BuildResult.makeResult targets with Steps = [Step.start "all"]} - let! (result,_) = action (startResult, taskContext) + let! ({Result = result},_) = action { taskContext with Result = startResult } let result = Step.updateTotalDuration result Store (result.Targets, result) |> ctx.Db.Post @@ -140,9 +140,8 @@ let rec execOne ctx target = match target |> locateRule ctx.Rules ctx.Options.ProjectRoot with | Some(rule,groups,targets) -> let groupsMap = groups |> Map.ofSeq - let (Recipe action) = rule |> getAction async { - let! waitTask = (fun channel -> WorkerPool.Run(target, targets, run groupsMap action targets, channel)) |> ctx.TaskPool.PostAndAsyncReply + let! waitTask = (fun channel -> WorkerPool.Run(target, targets, run groupsMap (getAction rule) targets, channel)) |> ctx.TaskPool.PostAndAsyncReply let! status = waitTask return target, status, ArtifactDep target } @@ -316,7 +315,7 @@ let runScript options rules = let (throttler, pool) = WorkerPool.create logger options.Threads - let db = openDb BuildDatabase.Picklers.result (options.ProjectRoot options.DbFileName) logger + let db = BuildDatabase.openDb (options.ProjectRoot options.DbFileName) logger let ctx = { Ordinal = 0 diff --git a/src/core/ExecTypes.fs b/src/core/ExecTypes.fs index 21f2729..1a1a643 100644 --- a/src/core/ExecTypes.fs +++ b/src/core/ExecTypes.fs @@ -125,10 +125,11 @@ module internal Step = | {Steps = current :: _} -> current | _ -> start "dummy" -module internal BuildResult = +[] +module BuildResult = /// Creates a new build result - let makeResult target = - { Targets = target + let makeResult targets = + { Targets = targets Built = System.DateTime.Now Depends = [] Steps = [] } diff --git a/src/tests/StorageTests.fs b/src/tests/StorageTests.fs index b2f37b1..1f04c25 100644 --- a/src/tests/StorageTests.fs +++ b/src/tests/StorageTests.fs @@ -4,8 +4,8 @@ open System.IO open NUnit.Framework open Xake -open Xake.BuildLog -open Xake.Storage +open Xake.Database +open Xake.BuildDatabase type Bookmark = | Bookmark of string * string @@ -31,15 +31,19 @@ module private impl = let logger = ConsoleLogger Verbosity.Diag let createResult name = - { ([name - |> File.make - |> FileTarget] - |> makeResult) with Depends = - [ "abc.c" |> mkFileTarget |> ArtifactDep - Var("DEBUG", Some "false") ] - Steps = [ newStepInfo ("compile", 217) ] } - - let (<-*) (a : Agent) t = a.PostAndReply(fun ch -> GetResult(t, ch)) + let targets = [name |> File.make |> FileTarget ] + targets, { + (BuildResult.makeResult targets) with + Depends = [ "abc.c" |> mkFileTarget |> ArtifactDep + Var("DEBUG", Some "false") ] + Steps = [ newStepInfo ("compile", 217) ] } + + let (<-*) (a : Agent<_ DatabaseApi>) t = a.PostAndReply(fun ch -> GetResult(t, ch)) + + let inline (<--) (agent : ^a) (msg : 'b) = + (^a : (member Post : 'b -> unit) (agent, msg)) + agent + // Is.Any predicate for assertions let IsAny() = Is.Not.All.Not @@ -55,7 +59,7 @@ let Setup() = [] let ``persists simple data``() = - let testee = makeResult <| [mkFileTarget "abc.exe"] + let testee = BuildResult.makeResult <| [mkFileTarget "abc.exe"] let testee = { testee with @@ -71,7 +75,7 @@ let ``persists simple data``() = newStepInfo ("compile", 217) newStepInfo ("link", 471) ] } - let (buf, repl) = writeAndRead Storage.resultPU testee + let (buf, repl) = writeAndRead BuildDatabase.Picklers.result testee printfn "size is %A" buf.Length printfn "src %A" testee printfn "repl %A" repl @@ -79,15 +83,12 @@ let ``persists simple data``() = [] let ``persists build data in Xake db``() = - let inline (<--) (agent : ^a) (msg : 'b) = - (^a : (member Post : 'b -> unit) (agent, msg)) - agent - use testee = Storage.openDb dbname logger + use testee = BuildDatabase.openDb dbname logger testee <-- Store(createResult "abc.exe") <-- Store(createResult "def.exe") <-- Store(createResult "fgh.exe") |> ignore testee.PostAndReply CloseWait - use testee = Storage.openDb dbname logger + use testee = BuildDatabase.openDb dbname logger let abc = testee <-* (mkFileTarget "abc.exe") Assert.IsTrue(Option.isSome abc) let def = testee <-* (mkFileTarget "def.exe") @@ -106,14 +107,14 @@ let ``compresses database when limit is reached``() = (^a : (member Post : 'b -> unit) (agent, msg)) agent - use testee = Storage.openDb dbname logger + use testee = BuildDatabase.openDb dbname logger for _ in seq { 1..20 } do for i in seq { 1..20 } do let name = sprintf "a%A.exe" i testee <-- Store(createResult name) |> ignore testee.PostAndReply CloseWait let oldLen = (FileInfo dbname).Length - use testee = Storage.openDb dbname logger + use testee = BuildDatabase.openDb dbname logger testee.PostAndReply CloseWait let newLen = (FileInfo dbname).Length printfn "old size: %A, new size: %A" oldLen newLen @@ -126,13 +127,13 @@ let ``updates data in file storage``() = (^a : (member Post : 'b -> unit) (agent, msg)) agent - use testee = Storage.openDb dbname logger - let result = createResult "abc" - testee <-- Store result |> ignore + use testee = BuildDatabase.openDb dbname logger + let targets, result = createResult "abc" + testee <-- Store (targets, result) |> ignore let updatedResult = { result with Depends = [ Var("DEBUG", Some "true") ] } - testee <-- Store updatedResult |> ignore + testee <-- Store (targets, updatedResult) |> ignore testee.PostAndReply CloseWait - use testee = Storage.openDb dbname logger + use testee = BuildDatabase.openDb dbname logger match testee <-* (mkFileTarget "abc") with | Some read -> testee.PostAndReply CloseWait @@ -150,13 +151,13 @@ let ``restores db in case write failed``() = (^a : (member Post : 'b -> unit) (agent, msg)) agent - use testee = Storage.openDb dbname logger + use testee = BuildDatabase.openDb dbname logger testee <-- Store(createResult "abc") |> ignore testee.PostAndReply CloseWait let bkdb = "." ".xake" <.> "bak" File.Move(dbname, bkdb) File.WriteAllText(dbname, "dummy text") - use testee = Storage.openDb dbname logger + use testee = BuildDatabase.openDb dbname logger let read = testee <-* (mkFileTarget "abc") Assert.IsTrue(Option.isSome read) testee.PostAndReply CloseWait @@ -171,7 +172,7 @@ let ``repairs (cleans) broken db``() = (^a : (member Post : 'b -> unit) (agent, msg)) agent File.WriteAllText(dbname, "dummy text") - use testee = Storage.openDb dbname logger + use testee = BuildDatabase.openDb dbname logger testee <-- Store(createResult "abc") |> ignore let read = testee <-* mkFileTarget "abc" Assert.IsTrue(Option.isSome read) diff --git a/src/tests/XakeScriptTests.fs b/src/tests/XakeScriptTests.fs index d07609e..8e7d5bf 100644 --- a/src/tests/XakeScriptTests.fs +++ b/src/tests/XakeScriptTests.fs @@ -4,8 +4,8 @@ open System.IO open NUnit.Framework open Xake +open Xake.BuildDatabase open Xake.Tasks -open Storage type Runtime = {Ver: string; Folder: string} @@ -456,7 +456,7 @@ type ``XakeScript tests``() = ] } - use testee = Storage.openDb "./.xake" (ConsoleLogger Verbosity.Diag) + use testee = openDb "./.xake" (ConsoleLogger Verbosity.Diag) try match testee.PostAndReply <| fun ch -> DatabaseApi.GetResult ((PhonyAction "test"), ch) with | Some { @@ -507,10 +507,9 @@ type ``XakeScript tests``() = ] } - let (<-*) (a:Agent) t = a.PostAndReply(fun ch -> GetResult (t,ch)) - let logger = ConsoleLogger Verbosity.Diag + let (<-*) (a:Agent>) t = a.PostAndReply(fun ch -> DatabaseApi.GetResult (t,ch)) - use db = Storage.openDb "./.xake" logger + use db = BuildDatabase.openDb "./.xake" (ConsoleLogger Diag) try match db <-* (PhonyAction "main") with | Some {Steps = step1::_} -> @@ -519,7 +518,7 @@ type ``XakeScript tests``() = printfn "%A" raaa |_ -> Assert.Fail "no results from db" finally - db.PostAndReply CloseWait + db.PostAndReply DatabaseApi.CloseWait [] member x.``dryrun for not executing``() = From 799ec399d28568be329a9f47ea0ed6aca40cc854 Mon Sep 17 00:00:00 2001 From: Oleg Zaimkin Date: Mon, 11 Nov 2019 16:41:08 +0700 Subject: [PATCH 05/22] more types/modules clean up --- src/core/BuildDatabase.fs | 5 +- src/core/Database.fs | 2 +- src/core/DependencyAnalysis.fs | 4 +- src/core/ExecCore.fs | 24 +- src/core/ExecTypes.fs | 28 ++- src/core/Prelude.fs | 2 + src/core/Progress.fs | 23 +- src/core/{RecipeBuilder.fs => Recipe.fs} | 3 + src/core/ScriptFuncs.fs | 266 +++++++++++------------ src/core/Target.fs | 40 ++++ src/core/Tasks/Cp.fs | 1 - src/core/Types.fs | 74 ------- src/core/WorkerPool.fs | 8 +- src/core/Xake.fsproj | 4 +- src/core/XakeScript.fs | 118 +++++----- src/tests/ProgressTests.fs | 2 +- src/tests/XakeScriptTests.fs | 2 +- 17 files changed, 304 insertions(+), 302 deletions(-) rename src/core/{RecipeBuilder.fs => Recipe.fs} (97%) create mode 100644 src/core/Target.fs delete mode 100644 src/core/Types.fs diff --git a/src/core/BuildDatabase.fs b/src/core/BuildDatabase.fs index 5ad8e95..1c52b05 100644 --- a/src/core/BuildDatabase.fs +++ b/src/core/BuildDatabase.fs @@ -3,10 +3,11 @@ module Xake.BuildDatabase module Picklers = open Pickler + open ExecTypes let target = Database.Picklers.targetPu - let file = wrap (File.make, fun a -> a.FullName) str + let file = wrap (File.make, fun a -> a.FullName) str let step = wrap @@ -39,7 +40,7 @@ module Picklers = fun r -> (r.Targets, r.Built, r.Depends, r.Steps)) (quad (list target) date (list dependency) (list step)) -type DatabaseApi<'result> = Database.DatabaseApi<'result> +type DatabaseApi = Database.DatabaseApi /// Opens the database let openDb path loggers = Database.openDb Picklers.result path loggers \ No newline at end of file diff --git a/src/core/Database.fs b/src/core/Database.fs index 8c6d4a3..9c97b07 100644 --- a/src/core/Database.fs +++ b/src/core/Database.fs @@ -9,7 +9,7 @@ type Database<'result> = { Status : Map } type DatabaseHeader = { XakeSign : string XakeVer : string - ScriptDate : Timestamp } + ScriptDate : System.DateTime } (* API *) diff --git a/src/core/DependencyAnalysis.fs b/src/core/DependencyAnalysis.fs index 507b6fd..83ab81f 100644 --- a/src/core/DependencyAnalysis.fs +++ b/src/core/DependencyAnalysis.fs @@ -126,7 +126,7 @@ let dumpDeps (ctx: ExecContext) (target: Target list) = let rec displayNestedDeps ii = function | ArtifactDep dependeeTarget -> - printfn "%sArtifact: %A" (indent ii) dependeeTarget.FullName + printfn "%sArtifact: %A" (indent ii) (Target.fullName dependeeTarget) showTargetStatus (ii+1) dependeeTarget | _ -> () and showDepStatus ii (d: Dependency) = @@ -158,7 +158,7 @@ let dumpDeps (ctx: ExecContext) (target: Target list) = if not <| doneTargets.ContainsKey(target) then doneTargets.Add(target, 1) - printfn "%sTarget %A" (indent ii) target.ShortName + printfn "%sTarget %A" (indent ii) (Target.shortName target) let lastResult = (fun ch -> GetResult(target, ch)) |> ctx.Db.PostAndReply match lastResult with diff --git a/src/core/ExecCore.fs b/src/core/ExecCore.fs index 85e99b4..b10d6c8 100644 --- a/src/core/ExecCore.fs +++ b/src/core/ExecCore.fs @@ -1,6 +1,8 @@ module internal Xake.ExecCore open System.Text.RegularExpressions + +open Xake open DependencyAnalysis /// Default options @@ -11,7 +13,7 @@ open Database /// Writes the message with formatting to a log let traceLog (level:Logging.Level) fmt = - let write s = action { + let write s = recipe { let! ctx = getCtx() return ctx.Logger.Log level "%s" s } @@ -112,7 +114,7 @@ let rec execOne ctx target = match ctx.NeedRebuild targets with | true -> let taskContext = newTaskContext targets ruleMatches ctx - do ctx.Logger.Log Command "Started %s as task %i" primaryTarget.ShortName taskContext.Ordinal + do ctx.Logger.Log Command "Started %s as task %i" (Target.shortName primaryTarget) taskContext.Ordinal do Progress.TaskStart primaryTarget |> ctx.Progress.Post @@ -123,10 +125,10 @@ let rec execOne ctx target = Store (result.Targets, result) |> ctx.Db.Post do Progress.TaskComplete primaryTarget |> ctx.Progress.Post - do ctx.Logger.Log Command "Completed %s in %A ms (wait %A ms)" primaryTarget.ShortName (Step.lastStep result).OwnTime (Step.lastStep result).WaitTime + do ctx.Logger.Log Command "Completed %s in %A ms (wait %A ms)" (Target.shortName primaryTarget) (Step.lastStep result).OwnTime (Step.lastStep result).WaitTime return Succeed | false -> - do ctx.Logger.Log Command "Skipped %s (up to date)" primaryTarget.ShortName + do ctx.Logger.Log Command "Skipped %s (up to date)" (Target.shortName primaryTarget) return Skipped } @@ -149,7 +151,7 @@ let rec execOne ctx target = target |> function | FileTarget file when File.exists file -> async.Return <| (target, JustFile, FileDep (file, File.getLastWriteTime file)) - | _ -> raiseError ctx (sprintf "Neither rule nor file is found for '%s'" target.FullName) "" + | _ -> raiseError ctx (sprintf "Neither rule nor file is found for '%s'" <| Target.fullName target) "" /// /// Executes several artifacts in parallel. @@ -205,9 +207,9 @@ let dryRun ctx options (groups: string list list) = | Other reason -> print "%sReason: %s" (indent ii) reason | Depends t -> - print "%sDepends '%s' - changed target" (indent ii) t.ShortName + print "%sDepends '%s' - changed target" (indent ii) (Target.shortName t) | DependsMissingTarget t -> - print "%sDepends on '%s' - missing target" (indent ii) t.ShortName + print "%sDepends on '%s' - missing target" (indent ii) (Target.shortName t) | FilesChanged (file:: rest) -> print "%sFile is changed '%s' %s" (indent ii) file (if List.isEmpty rest then "" else sprintf " and %d more file(s)" <| List.length rest) | reasons -> @@ -225,7 +227,7 @@ let dryRun ctx options (groups: string list list) = let deps = getDeps target if not <| List.isEmpty deps then let execTimeEstimate = getExecTime ctx target - do ctx.Logger.Log Command "%sRebuild %A (~%Ams)" (indent ii) target.ShortName execTimeEstimate + do ctx.Logger.Log Command "%sRebuild %A (~%Ams)" (indent ii) (Target.shortName target) execTimeEstimate deps |> List.iter (showDepStatus (ii+1)) deps |> List.iter (displayNestedDeps (ii+1)) @@ -273,15 +275,15 @@ let runBuild ctx options groups = function | [] -> false, "" | Other reason::_ -> true, reason - | Depends t ::_ -> true, "Depends on target " + t.ShortName - | DependsMissingTarget t ::_ -> true, sprintf "Depends on target %s (missing)" t.ShortName + | Depends t ::_ -> true, "Depends on target " + (Target.shortName t) + | DependsMissingTarget t ::_ -> true, sprintf "Depends on target %s (missing)" (Target.shortName t) | FilesChanged (file::_) ::_ -> true, "File(s) changed " + file | reasons -> true, sprintf "Some reason %A" reasons >> function | false, _ -> false | true, reason -> - do ctx.Logger.Log Info "Rebuild %A: %s" target.ShortName reason + do ctx.Logger.Log Info "Rebuild %A: %s" (Target.shortName target) reason true <| target // todo improve output by printing primary target diff --git a/src/core/ExecTypes.fs b/src/core/ExecTypes.fs index 1a1a643..588d0c3 100644 --- a/src/core/ExecTypes.fs +++ b/src/core/ExecTypes.fs @@ -1,4 +1,5 @@ -namespace Xake +[] +module Xake.ExecTypes open System.Threading open Prelude @@ -68,6 +69,19 @@ end type ExecStatus = | Succeed | Skipped | JustFile type TaskPool = Agent> +type Timestamp = System.DateTime + +type Dependency = + | FileDep of File * Timestamp // regular file (such as source code file), triggers when file date/time is changed + | ArtifactDep of Target // other target (triggers when target is rebuilt) + | EnvVar of string * string option // environment variable + | Var of string * string option // any other data such as compiler version (not used yet) + | AlwaysRerun // trigger always + | GetFiles of Fileset * Filelist // depends on set of files. Triggers when resulting filelist is changed + +type StepInfo = + { Name: string; Start: System.DateTime; OwnTime: int; WaitTime: int } + with static member Empty = {Name = ""; Start = new System.DateTime(1900,1,1); OwnTime = 0; WaitTime = 0} type BuildResult = { Targets : Target list @@ -75,6 +89,13 @@ type BuildResult = Depends : Dependency list Steps : StepInfo list } +type 'ctx Rule = + | FileRule of string * Recipe<'ctx,unit> + | MultiFileRule of string list * Recipe<'ctx,unit> + | PhonyRule of string * Recipe<'ctx,unit> + | FileConditionRule of (string -> bool) * Recipe<'ctx,unit> +type 'ctx Rules = Rules of 'ctx Rule list + /// Script execution context type ExecContext = { TaskPool: TaskPool @@ -84,7 +105,7 @@ type ExecContext = { Rules: Rules Logger: ILogger RootLogger: ILogger - Progress: Agent + Progress: Agent> Targets: Target list RuleMatches: Map Ordinal: int @@ -92,6 +113,9 @@ type ExecContext = { Result: BuildResult } +/// Defines common exception type +exception XakeException of string + module internal Util = let private nullableToOption = function | null -> None | s -> Some s diff --git a/src/core/Prelude.fs b/src/core/Prelude.fs index 3f0b4ec..dbc8b54 100644 --- a/src/core/Prelude.fs +++ b/src/core/Prelude.fs @@ -6,3 +6,5 @@ let inline (|OtherwiseFail|) _ = failwith "no choice" let inline (|OtherwiseFailErr|) message _ = failwith message type 't Agent = 't MailboxProcessor + +[] type ms diff --git a/src/core/Progress.fs b/src/core/Progress.fs index 0a5c5f8..3869403 100644 --- a/src/core/Progress.fs +++ b/src/core/Progress.fs @@ -1,5 +1,14 @@ module Xake.Progress +/// +/// A message to a progress reporter. +/// +type ProgressMessage = + | Begin of System.TimeSpan + | Progress of System.TimeSpan * int + | End + + module internal WindowsProgress = open System @@ -144,11 +153,11 @@ module Estimate = /// /// Interface for progress module. /// -type ProgressReport = - | TaskStart of Target - | TaskSuspend of Target - | TaskResume of Target - | TaskComplete of Target +type ProgressReport<'TKey> when 'TKey: comparison = + | TaskStart of 'TKey + | TaskSuspend of 'TKey + | TaskResume of 'TKey + | TaskComplete of 'TKey | Refresh | Finish @@ -195,7 +204,7 @@ let openProgress getDurationDeps threadCount goals toConsole = let _,endTime = execMany machineState getDurationDeps goals let startTime = System.DateTime.Now - progressBar <| ProgressMessage.Begin (System.TimeSpan.FromMilliseconds (float endTime)) + progressBar <| Begin (System.TimeSpan.FromMilliseconds (float endTime)) /// We track currently running tasks and subtract already passed time from task duration let getDuration2 runningTasks t = @@ -214,7 +223,7 @@ let openProgress getDurationDeps threadCount goals toConsole = //printf "progress %A to %A " timePassed endTime let percentDone = timePassed * 100 / (timePassed + leftTime) |> int let progressData = System.TimeSpan.FromMilliseconds (leftTime/1 |> float), percentDone - do ProgressMessage.Progress progressData |> progressBar + do Progress progressData |> progressBar if toConsole then do WriteConsoleProgress progressData diff --git a/src/core/RecipeBuilder.fs b/src/core/Recipe.fs similarity index 97% rename from src/core/RecipeBuilder.fs rename to src/core/Recipe.fs index a5715bf..11457ce 100644 --- a/src/core/RecipeBuilder.fs +++ b/src/core/Recipe.fs @@ -1,5 +1,8 @@ namespace Xake +// expression type +type Recipe<'a,'b> = Recipe of ('a -> Async<'a * 'b>) + module internal RecipeAlgebra = let runAction (Recipe r) = r let returnF a = Recipe (fun s -> async {return (s,a)}) diff --git a/src/core/ScriptFuncs.fs b/src/core/ScriptFuncs.fs index f0047e5..6281b91 100644 --- a/src/core/ScriptFuncs.fs +++ b/src/core/ScriptFuncs.fs @@ -1,140 +1,138 @@ -namespace Xake - -[] -module ScriptFuncs = - - /// - /// Gets the script options. - /// - let getCtxOptions () = recipe { - let! (ctx: ExecContext) = getCtx() - return ctx.Options - } - - /// - /// Executes and awaits specified artifacts. - /// - /// - let need targets = - action { - let! ctx = getCtx() - let t' = targets |> (List.map (ExecCore.makeTarget ctx)) - do! ExecCore.need t' - } - - let needFiles (Filelist files) = - files |> List.map FileTarget |> ExecCore.need - - let private record d = recipe { +[] +module Xake.ScriptFuncs + +/// +/// Gets the script options. +/// +let getCtxOptions () = recipe { + let! (ctx: ExecContext) = getCtx() + return ctx.Options +} + +/// +/// Executes and awaits specified artifacts. +/// +/// +let need targets = + action { let! ctx = getCtx() - do! setCtx { ctx with Result = { ctx.Result with Depends = d :: ctx.Result.Depends } } + let t' = targets |> (List.map (ExecCore.makeTarget ctx)) + do! ExecCore.need t' } - /// - /// Instructs Xake to rebuild the target even if dependencies are not changed. - /// - let alwaysRerun() = AlwaysRerun |> record - - /// - /// Gets the environment variable. - /// - /// - let getEnv variableName = - let value = Util.getEnvVar variableName - action { - do! EnvVar (variableName,value) |> record - return value - } - - /// - /// Gets the global (options) variable. - /// - /// - let getVar variableName = recipe { - let! ctx = getCtx() - let value = Util.getVar ctx.Options variableName - - do! Var (variableName,value) |> record +let needFiles (Filelist files) = + files |> List.map FileTarget |> ExecCore.need + +let private record d = recipe { + let! ctx = getCtx() + do! setCtx { ctx with Result = { ctx.Result with Depends = d :: ctx.Result.Depends } } +} + +/// +/// Instructs Xake to rebuild the target even if dependencies are not changed. +/// +let alwaysRerun() = AlwaysRerun |> record + +/// +/// Gets the environment variable. +/// +/// +let getEnv variableName = + let value = Util.getEnvVar variableName + action { + do! EnvVar (variableName,value) |> record return value } - /// - /// Gets the list of files matching specified fileset. - /// - /// - let getFiles fileset = recipe { - let! ctx = getCtx() - let files = fileset |> toFileList ctx.Options.ProjectRoot - do! GetFiles (fileset,files) |> record - - return files - } - - /// - /// Gets current target file - /// - let getTargetFile() = recipe { - let! ctx = getCtx() - return ctx.Targets - |> function - | FileTarget file::_ -> file - | _ -> failwith "getTargetFile is not available for phony actions" - } - - /// - /// Gets current target file - /// - let getTargetFiles() : Recipe = recipe { - let! ctx = getCtx() - return ctx.Targets |> List.collect (function |FileTarget file -> [file] |_ -> failwith "Expected only a file targets"; []) - } - - /// - /// Gets current target file name with path - /// - let getTargetFullName() = recipe { - let! file = getTargetFile() - return File.getFullName file - } - - let getRuleMatches () = recipe { - let! ctx = getCtx() - return ctx.RuleMatches - } - - /// - /// Gets group (part of the name) by its name. - /// - let getRuleMatch key = action { - let! groups = getRuleMatches() - return groups |> Map.tryFind key |> function |Some v -> v | None -> "" - } - - - /// - /// Writes a message to a log. - /// - let trace = ExecCore.traceLog - - /// Defines a rule that demands specified targets - /// e.g. "main" ==> ["build-release"; "build-debug"; "unit-test"] - let (<==) name targets = PhonyRule (name, recipe { - do! need targets - do! alwaysRerun() // always check demanded dependencies. Otherwise it wan't check any target is available - }) - - /// Finalizes current build step and starts a new one // TODO put it somewhere - let newstep name = recipe { - let! c = getCtx() - let r' = Step.updateTotalDuration c.Result - let r'' = {r' with Steps = (Step.start name) :: r'.Steps} - do! setCtx { c with Result = r''} - } - - /// Defines a rule which demands the other targets to be sequentially built. - /// Unlike '<==' operator, this one waits the completion of one before issuing another rule. - let (<<<) name targets = PhonyRule (name, recipe { - for t in targets do - do! need [t] - do! alwaysRerun() - }) +/// +/// Gets the global (options) variable. +/// +/// +let getVar variableName = recipe { + let! ctx = getCtx() + let value = Util.getVar ctx.Options variableName + + do! Var (variableName,value) |> record + return value +} + +/// +/// Gets the list of files matching specified fileset. +/// +/// +let getFiles fileset = recipe { + let! ctx = getCtx() + let files = fileset |> toFileList ctx.Options.ProjectRoot + do! GetFiles (fileset,files) |> record + + return files +} + +/// +/// Gets current target file +/// +let getTargetFile() = recipe { + let! ctx = getCtx() + return ctx.Targets + |> function + | FileTarget file::_ -> file + | _ -> failwith "getTargetFile is not available for phony actions" +} + +/// +/// Gets current target file +/// +let getTargetFiles() : Recipe = recipe { + let! ctx = getCtx() + return ctx.Targets |> List.collect (function |FileTarget file -> [file] |_ -> failwith "Expected only a file targets"; []) +} + +/// +/// Gets current target file name with path +/// +let getTargetFullName() = recipe { + let! file = getTargetFile() + return File.getFullName file +} + +let getRuleMatches () = recipe { + let! ctx = getCtx() + return ctx.RuleMatches +} + +/// +/// Gets group (part of the name) by its name. +/// +let getRuleMatch key = action { + let! groups = getRuleMatches() + return groups |> Map.tryFind key |> function |Some v -> v | None -> "" +} + + +/// +/// Writes a message to a log. +/// +let trace = ExecCore.traceLog + +/// Defines a rule that demands specified targets +/// e.g. "main" ==> ["build-release"; "build-debug"; "unit-test"] +let (<==) name targets = PhonyRule (name, recipe { + do! need targets + do! alwaysRerun() // always check demanded dependencies. Otherwise it wan't check any target is available +}) + +/// Finalizes current build step and starts a new one // TODO put it somewhere +let newstep name = recipe { + let! c = getCtx() + let r' = Step.updateTotalDuration c.Result + let r'' = {r' with Steps = (Step.start name) :: r'.Steps} + do! setCtx { c with Result = r''} +} + +/// Defines a rule which demands the other targets to be sequentially built. +/// Unlike '<==' operator, this one waits the completion of one before issuing another rule. +let (<<<) name targets = PhonyRule (name, recipe { + for t in targets do + do! need [t] + do! alwaysRerun() +}) diff --git a/src/core/Target.fs b/src/core/Target.fs new file mode 100644 index 0000000..11d1272 --- /dev/null +++ b/src/core/Target.fs @@ -0,0 +1,40 @@ +[] +module Xake.Target + +let private stringCompare = if Env.isUnix then System.StringComparer.Ordinal else System.StringComparer.OrdinalIgnoreCase + +[] +type Target = + | FileTarget of Xake.File + | PhonyAction of string + +with + member private this.FullName = + match this with + | FileTarget file -> file.FullName + | PhonyAction name -> name + + override x.Equals(yobj) = + match yobj with + | :? Target as y -> stringCompare.Equals (x.FullName, y.FullName) + | _ -> false + + override x.GetHashCode() = stringCompare.GetHashCode x.FullName + interface System.IComparable with + member x.CompareTo y = + match y with + | :? Target as y -> stringCompare.Compare(x.FullName, y.FullName) + | _ -> invalidArg "y" "cannot compare target to different types" + +[] +module Target = + + /// Gets short (user friendly) target name + let shortName = function + | FileTarget file -> file.Name + | PhonyAction name -> name + + // Get fully qualifying target name + let fullName = function + | FileTarget file -> file.FullName + | PhonyAction name -> name diff --git a/src/core/Tasks/Cp.fs b/src/core/Tasks/Cp.fs index 6831985..c3a07f3 100644 --- a/src/core/Tasks/Cp.fs +++ b/src/core/Tasks/Cp.fs @@ -2,7 +2,6 @@ namespace Xake.Tasks open Xake open System.IO -open Xake.FileTasksImpl [] module CpImpl = diff --git a/src/core/Types.fs b/src/core/Types.fs deleted file mode 100644 index 102a6ed..0000000 --- a/src/core/Types.fs +++ /dev/null @@ -1,74 +0,0 @@ -namespace Xake - -[] -module DomainTypes = - - let private stringCompare = if Env.isUnix then System.StringComparer.Ordinal else System.StringComparer.OrdinalIgnoreCase - - [] - type Target = - | FileTarget of File - | PhonyAction of string - - with - member internal this.ShortName = - match this with - | FileTarget file -> file.Name - | PhonyAction name -> name - member internal this.FullName = - match this with - | FileTarget file -> file.FullName - | PhonyAction name -> name - - override x.Equals(yobj) = - match yobj with - | :? Target as y -> stringCompare.Equals (x.FullName, y.FullName) - | _ -> false - - override x.GetHashCode() = stringCompare.GetHashCode x.FullName - interface System.IComparable with - member x.CompareTo y = - match y with - | :? Target as y -> stringCompare.Compare(x.FullName, y.FullName) - | _ -> invalidArg "y" "cannot compare target to different types" - - // structures, database processor and store - type Timestamp = System.DateTime - - [] - type ms - - type Dependency = - | FileDep of File * Timestamp // regular file (such as source code file), triggers when file date/time is changed - | ArtifactDep of Target // other target (triggers when target is rebuilt) - | EnvVar of string * string option // environment variable - | Var of string * string option // any other data such as compiler version (not used yet) - | AlwaysRerun // trigger always - | GetFiles of Fileset * Filelist // depends on set of files. Triggers when resulting filelist is changed - - type StepInfo = - { Name: string; Start: System.DateTime; OwnTime: int; WaitTime: int } - with static member Empty = {Name = ""; Start = new System.DateTime(1900,1,1); OwnTime = 0; WaitTime = 0} - - // expression type - type Recipe<'a,'b> = Recipe of ('a -> Async<'a * 'b>) - - /// Data type for action's out parameter. Defined target file and named groups in pattern - - type 'ctx Rule = - | FileRule of string * Recipe<'ctx,unit> - | MultiFileRule of string list * Recipe<'ctx,unit> - | PhonyRule of string * Recipe<'ctx,unit> - | FileConditionRule of (string -> bool) * Recipe<'ctx,unit> - type 'ctx Rules = Rules of 'ctx Rule list - - /// Defines common exception type - exception XakeException of string - -/// -/// A message to a progress reporter. -/// -type ProgressMessage = - | Begin of System.TimeSpan - | Progress of System.TimeSpan * int - | End diff --git a/src/core/WorkerPool.fs b/src/core/WorkerPool.fs index c27e9e5..73fe927 100644 --- a/src/core/WorkerPool.fs +++ b/src/core/WorkerPool.fs @@ -13,7 +13,7 @@ let internal create (logger:ILogger) maxThreads = let throttler = new SemaphoreSlim (maxThreads) let log = logger.Log - let mapKey (artifact:Target) = artifact.FullName + let mapKey = Target.fullName throttler, MailboxProcessor.Start(fun mbox -> let rec loop(map) = async { @@ -23,18 +23,18 @@ let internal create (logger:ILogger) maxThreads = match map |> Map.tryFind mkey with | Some (task:Task<'a>) -> - log Never "Task found for '%s'. Status %A" artifact.ShortName task.Status + log Never "Task found for '%s'. Status %A" (Target.shortName artifact) task.Status chnl.Reply <| Async.AwaitTask task return! loop(map) | None -> - do log Info "Task queued '%s'" artifact.ShortName + do log Info "Task queued '%s'" (Target.shortName artifact) do! throttler.WaitAsync(-1) |> Async.AwaitTask |> Async.Ignore let task = Async.StartAsTask (async { try let! buildResult = action - do log Info "Task done '%s'" artifact.ShortName + do log Info "Task done '%s'" (Target.shortName artifact) return buildResult finally throttler.Release() |> ignore diff --git a/src/core/Xake.fsproj b/src/core/Xake.fsproj index 378daa8..4404daa 100644 --- a/src/core/Xake.fsproj +++ b/src/core/Xake.fsproj @@ -21,10 +21,10 @@ - + - + diff --git a/src/core/XakeScript.fs b/src/core/XakeScript.fs index 8379b86..2a2d552 100644 --- a/src/core/XakeScript.fs +++ b/src/core/XakeScript.fs @@ -1,84 +1,82 @@ -namespace Xake +[] +module Xake.XakeScript -[] -module XakeScript = +/// Creates the rule for specified file pattern. +let ( ..?> ) fn fnRule = FileConditionRule (fn, fnRule) - /// Creates the rule for specified file pattern. - let ( ..?> ) fn fnRule = FileConditionRule (fn, fnRule) +let ( ..> ) pattern actionBody = FileRule (pattern, actionBody) - let ( ..> ) pattern actionBody = FileRule (pattern, actionBody) +let ( *..> ) (patterns: #seq) actionBody = + MultiFileRule (patterns |> List.ofSeq, actionBody) - let ( *..> ) (patterns: #seq) actionBody = - MultiFileRule (patterns |> List.ofSeq, actionBody) +/// Creates phony action (check if I can unify the operator name) +let (=>) name action = PhonyRule (name, action) - /// Creates phony action (check if I can unify the operator name) - let (=>) name action = PhonyRule (name, action) +/// Main type. +type XakeScript = XakeScript of ExecOptions * Rules - /// Main type. - type XakeScript = XakeScript of ExecOptions * Rules +/// Script builder. +type RulesBuilder(options) = - /// Script builder. - type RulesBuilder(options) = + let updRules (XakeScript (options,rules)) f = XakeScript (options, f(rules)) + let updTargets (XakeScript (options,rules)) f = XakeScript ({options with Targets = f(options.Targets)}, rules) + let addRule rule (Rules rules) :Rules<_> = Rules (rule :: rules) - let updRules (XakeScript (options,rules)) f = XakeScript (options, f(rules)) - let updTargets (XakeScript (options,rules)) f = XakeScript ({options with Targets = f(options.Targets)}, rules) - let addRule rule (Rules rules) :Rules<_> = Rules (rule :: rules) + let updateVar (key: string) (value: string) = + List.filter(fst >> ((<>) key)) >> ((@) [key, value]) - let updateVar (key: string) (value: string) = - List.filter(fst >> ((<>) key)) >> ((@) [key, value]) + member __.Zero() = XakeScript (options, Rules []) + member this.Yield(()) = this.Zero() - member __.Zero() = XakeScript (options, Rules []) - member this.Yield(()) = this.Zero() + member __.Run(XakeScript (options,rules)) = + ExecCore.runScript options rules - member __.Run(XakeScript (options,rules)) = - ExecCore.runScript options rules + [] + member __.DryRun(XakeScript (options, rules)) = + + XakeScript ({options with DryRun = true}, rules) - [] - member __.DryRun(XakeScript (options, rules)) = - - XakeScript ({options with DryRun = true}, rules) + [] + member __.AddVar(XakeScript (options, rules), name, value) = - [] - member __.AddVar(XakeScript (options, rules), name, value) = + XakeScript ({options with Vars = options.Vars |> updateVar name value }, rules) - XakeScript ({options with Vars = options.Vars |> updateVar name value }, rules) + [] + member __.FileLog(XakeScript (options, rules), filename, ?loglevel) = - [] - member __.FileLog(XakeScript (options, rules), filename, ?loglevel) = + let loglevel = defaultArg loglevel Verbosity.Chatty in + XakeScript ({options with FileLog = filename; FileLogLevel = loglevel}, rules) - let loglevel = defaultArg loglevel Verbosity.Chatty in - XakeScript ({options with FileLog = filename; FileLogLevel = loglevel}, rules) + [] + member __.ConLog(XakeScript (options, rules), ?loglevel) = - [] - member __.ConLog(XakeScript (options, rules), ?loglevel) = + let loglevel = defaultArg loglevel Verbosity.Chatty in + XakeScript ({options with ConLogLevel =loglevel}, rules) - let loglevel = defaultArg loglevel Verbosity.Chatty in - XakeScript ({options with ConLogLevel =loglevel}, rules) + [] + member __.Rule(script, rule) = + + updRules script (addRule rule) - [] - member __.Rule(script, rule) = - - updRules script (addRule rule) + // [] member this.AddRule(script, pattern, action) + // = updRules script (pattern *> action |> addRule) - // [] member this.AddRule(script, pattern, action) - // = updRules script (pattern *> action |> addRule) + [] + member __.Phony(script, name, action) = - [] - member __.Phony(script, name, action) = + updRules script (name => action |> addRule) - updRules script (name => action |> addRule) + [] + member __.Rules(script, rules: #seq) = + + (rules |> Seq.map addRule |> Seq.fold (>>) id) |> updRules script - [] - member __.Rules(script, rules: #seq) = - - (rules |> Seq.map addRule |> Seq.fold (>>) id) |> updRules script + [] + member __.Want(script, targets) = + + updTargets script (function |[] -> targets |x -> x) // Options override script! - [] - member __.Want(script, targets) = - - updTargets script (function |[] -> targets |x -> x) // Options override script! - - [] - member __.WantOverride(script,targets) = - - updTargets script (fun _ -> targets) + [] + member __.WantOverride(script,targets) = + + updTargets script (fun _ -> targets) diff --git a/src/tests/ProgressTests.fs b/src/tests/ProgressTests.fs index 5682714..ac35095 100644 --- a/src/tests/ProgressTests.fs +++ b/src/tests/ProgressTests.fs @@ -1,7 +1,7 @@ module ``Progress estimator`` open NUnit.Framework -open Xake.DomainTypes + open Xake.Progress.Estimate type TaskDeps = string list diff --git a/src/tests/XakeScriptTests.fs b/src/tests/XakeScriptTests.fs index 8e7d5bf..b49201c 100644 --- a/src/tests/XakeScriptTests.fs +++ b/src/tests/XakeScriptTests.fs @@ -507,7 +507,7 @@ type ``XakeScript tests``() = ] } - let (<-*) (a:Agent>) t = a.PostAndReply(fun ch -> DatabaseApi.GetResult (t,ch)) + let (<-*) (a:Agent) t = a.PostAndReply(fun ch -> DatabaseApi.GetResult (t,ch)) use db = BuildDatabase.openDb "./.xake" (ConsoleLogger Diag) try From 16ec9e40128641fe7591328b15f0e6f74db2487b Mon Sep 17 00:00:00 2001 From: olegz Date: Mon, 11 Nov 2019 21:14:01 +0700 Subject: [PATCH 06/22] made database even more abstract --- src/core/BuildDatabase.fs | 13 +++++++--- src/core/{ => Common}/Database.fs | 42 +++++++++++++------------------ src/core/{ => Common}/Env.fs | 0 src/core/{ => Common}/Logging.fs | 0 src/core/{ => Common}/Pickler.fs | 0 src/core/{ => Common}/Prelude.fs | 0 src/core/DependencyAnalysis.fs | 2 +- src/core/ExecTypes.fs | 2 +- src/core/Xake.fsproj | 10 ++++---- 9 files changed, 33 insertions(+), 36 deletions(-) rename src/core/{ => Common}/Database.fs (81%) rename src/core/{ => Common}/Env.fs (100%) rename src/core/{ => Common}/Logging.fs (100%) rename src/core/{ => Common}/Pickler.fs (100%) rename src/core/{ => Common}/Prelude.fs (100%) diff --git a/src/core/BuildDatabase.fs b/src/core/BuildDatabase.fs index 1c52b05..c0c8815 100644 --- a/src/core/BuildDatabase.fs +++ b/src/core/BuildDatabase.fs @@ -5,10 +5,15 @@ module Picklers = open Pickler open ExecTypes - let target = Database.Picklers.targetPu - let file = wrap (File.make, fun a -> a.FullName) str + let target = + alt (function + | FileTarget _ -> 0 + | PhonyAction _ -> 1) + [| wrap (File.make >> FileTarget, fun (FileTarget f | OtherwiseFail f) -> f.Name) str + wrap (PhonyAction, (fun (PhonyAction a | OtherwiseFail a) -> a)) str |] + let step = wrap ((fun (n, s, o, w) -> {StepInfo.Name = n; Start = s; OwnTime = o * 1; WaitTime = w * 1}), @@ -40,7 +45,7 @@ module Picklers = fun r -> (r.Targets, r.Built, r.Depends, r.Steps)) (quad (list target) date (list dependency) (list step)) -type DatabaseApi = Database.DatabaseApi +type DatabaseApi = Database.DatabaseApi /// Opens the database -let openDb path loggers = Database.openDb Picklers.result path loggers \ No newline at end of file +let openDb path loggers = Database.openDb (Picklers.target, Picklers.result) path loggers \ No newline at end of file diff --git a/src/core/Database.fs b/src/core/Common/Database.fs similarity index 81% rename from src/core/Database.fs rename to src/core/Common/Database.fs index 9c97b07..3f34972 100644 --- a/src/core/Database.fs +++ b/src/core/Common/Database.fs @@ -4,7 +4,8 @@ open Xake let XakeDbVersion = "0.5" -type Database<'result> = { Status : Map } +type Database<'target,'result> when 'target: comparison + = { Status : Map<'target, 'result> } type DatabaseHeader = { XakeSign : string @@ -20,16 +21,10 @@ let newDatabase() = { Database.Status = Map.empty } let internal addResult db targets (result: 'result) = { db with Status = targets |> List.fold (fun m i -> Map.add i result m) db.Status } -module Picklers = +module private impl = + open System.IO open Pickler - let targetPu = - alt (function - | FileTarget _ -> 0 - | PhonyAction _ -> 1) - [| wrap (File.make >> FileTarget, fun (FileTarget f | OtherwiseFail f) -> f.Name) str - wrap (PhonyAction, (fun (PhonyAction a | OtherwiseFail a) -> a)) str |] - let dbHeaderPu = wrap ((fun (sign, ver, scriptDate) -> @@ -38,11 +33,6 @@ module Picklers = ScriptDate = scriptDate }), fun h -> (h.XakeSign, h.XakeVer, h.ScriptDate)) (triple str str date) - -module private impl = - open System.IO - open Pickler - open Picklers let writeHeader w = let h = @@ -51,11 +41,9 @@ module private impl = ScriptDate = System.DateTime.Now } dbHeaderPu.pickle h w - let targetListPu = list targetPu - - let openDatabaseFile (resultPU: 'result PU) dbpath (logger : ILogger) = + let openDatabaseFile (targetPu: 'target PU, resultPU: 'result PU) dbpath (logger : ILogger) = let log = logger.Log - let bkpath = dbpath <.> "bak" + let bkpath = dbpath + ".bak" // if exists backup restore if File.Exists(bkpath) then log Level.Message "Backup file found ('%s'), restoring db" @@ -68,7 +56,9 @@ module private impl = let recordCount = ref 0 // read database - if File.Exists(dbpath) then + if File.Exists(dbpath) then + let targetListPu = list targetPu + try use reader = new BinaryReader(File.OpenRead(dbpath)) let stream = reader.BaseStream @@ -105,15 +95,17 @@ module private impl = if dbwriter.BaseStream.Position = 0L then writeHeader dbwriter db, dbwriter -type DatabaseApi<'result> = - | GetResult of Target * AsyncReplyChannel<'result option> - | Store of Target list * 'result +type DatabaseApi<'target,'result> = + | GetResult of 'target * AsyncReplyChannel<'result option> + | Store of 'target list * 'result | Close | CloseWait of AsyncReplyChannel /// Opens database. -let openDb resultPU dbPath (logger : ILogger) = - let db, dbWriter = impl.openDatabaseFile resultPU dbPath logger +let openDb (targetPu: 'target Pickler.PU, resultPU: 'result Pickler.PU) dbPath (logger : ILogger) = + let db, dbWriter = impl.openDatabaseFile (targetPu, resultPU) dbPath logger + let targetListPu = Pickler.list targetPu + MailboxProcessor.Start(fun mbox -> let rec loop (db) = async { @@ -125,7 +117,7 @@ let openDb resultPU dbPath (logger : ILogger) = |> chan.Reply return! loop (db) | Store (targets, result) -> - impl.targetListPu.pickle targets dbWriter + targetListPu.pickle targets dbWriter resultPU.pickle result dbWriter return! loop (addResult db targets result) | Close -> diff --git a/src/core/Env.fs b/src/core/Common/Env.fs similarity index 100% rename from src/core/Env.fs rename to src/core/Common/Env.fs diff --git a/src/core/Logging.fs b/src/core/Common/Logging.fs similarity index 100% rename from src/core/Logging.fs rename to src/core/Common/Logging.fs diff --git a/src/core/Pickler.fs b/src/core/Common/Pickler.fs similarity index 100% rename from src/core/Pickler.fs rename to src/core/Common/Pickler.fs diff --git a/src/core/Prelude.fs b/src/core/Common/Prelude.fs similarity index 100% rename from src/core/Prelude.fs rename to src/core/Common/Prelude.fs diff --git a/src/core/DependencyAnalysis.fs b/src/core/DependencyAnalysis.fs index 83ab81f..7b9ab1c 100644 --- a/src/core/DependencyAnalysis.fs +++ b/src/core/DependencyAnalysis.fs @@ -20,7 +20,7 @@ let TimeCompareToleranceMs = 10.0 /// /// /// -let getExecTime ctx target = +let getExecTime ctx (target: Target) = (fun ch -> GetResult(target, ch)) |> ctx.Db.PostAndReply |> Option.fold (fun _ r -> r.Steps |> List.sumBy (fun s -> s.OwnTime)) 0 diff --git a/src/core/ExecTypes.fs b/src/core/ExecTypes.fs index 588d0c3..602131e 100644 --- a/src/core/ExecTypes.fs +++ b/src/core/ExecTypes.fs @@ -99,7 +99,7 @@ type 'ctx Rules = Rules of 'ctx Rule list /// Script execution context type ExecContext = { TaskPool: TaskPool - Db: Agent> + Db: Agent> Throttler: SemaphoreSlim Options: ExecOptions Rules: Rules diff --git a/src/core/Xake.fsproj b/src/core/Xake.fsproj index 4404daa..202e03f 100644 --- a/src/core/Xake.fsproj +++ b/src/core/Xake.fsproj @@ -12,17 +12,17 @@ - - - - + + + + + - From fc914cfea089d02ddcff12fbf61235605efad635 Mon Sep 17 00:00:00 2001 From: OlegZee Date: Tue, 12 Nov 2019 01:49:07 +0700 Subject: [PATCH 07/22] refactoring more types --- src/core/Common/Prelude.fs | 10 ----- src/core/{ => Common}/Progress.fs | 1 - src/core/{ => Common}/Recipe.fs | 0 src/core/{ => Common}/RecipeFunctions.fs | 12 ------ src/core/{CommonLib.fs => Common/Util.fs} | 24 ++++++------ src/core/Common/WorkerPool.fs | 45 ++++++++++++++++++++++ src/core/ExecCore.fs | 13 ++++--- src/core/ExecTypes.fs | 38 ++++++++----------- src/core/ScriptFuncs.fs | 35 +++++------------ src/core/{ => Tasks}/ProcessExec.fs | 4 +- src/core/WorkerPool.fs | 46 ----------------------- src/core/Xake.fsproj | 13 +++---- src/tests/ProgressTests.fs | 1 + src/tests/StorageTests.fs | 2 +- 14 files changed, 99 insertions(+), 145 deletions(-) delete mode 100644 src/core/Common/Prelude.fs rename src/core/{ => Common}/Progress.fs (99%) rename src/core/{ => Common}/Recipe.fs (100%) rename src/core/{ => Common}/RecipeFunctions.fs (83%) rename src/core/{CommonLib.fs => Common/Util.fs} (80%) create mode 100644 src/core/Common/WorkerPool.fs rename src/core/{ => Tasks}/ProcessExec.fs (85%) delete mode 100644 src/core/WorkerPool.fs diff --git a/src/core/Common/Prelude.fs b/src/core/Common/Prelude.fs deleted file mode 100644 index dbc8b54..0000000 --- a/src/core/Common/Prelude.fs +++ /dev/null @@ -1,10 +0,0 @@ -[] -module Prelude - -let (><) f a b = f b a -let inline (|OtherwiseFail|) _ = failwith "no choice" -let inline (|OtherwiseFailErr|) message _ = failwith message - -type 't Agent = 't MailboxProcessor - -[] type ms diff --git a/src/core/Progress.fs b/src/core/Common/Progress.fs similarity index 99% rename from src/core/Progress.fs rename to src/core/Common/Progress.fs index 3869403..ac602b1 100644 --- a/src/core/Progress.fs +++ b/src/core/Common/Progress.fs @@ -8,7 +8,6 @@ type ProgressMessage = | Progress of System.TimeSpan * int | End - module internal WindowsProgress = open System diff --git a/src/core/Recipe.fs b/src/core/Common/Recipe.fs similarity index 100% rename from src/core/Recipe.fs rename to src/core/Common/Recipe.fs diff --git a/src/core/RecipeFunctions.fs b/src/core/Common/RecipeFunctions.fs similarity index 83% rename from src/core/RecipeFunctions.fs rename to src/core/Common/RecipeFunctions.fs index 1d70e8e..9ac313f 100644 --- a/src/core/RecipeFunctions.fs +++ b/src/core/Common/RecipeFunctions.fs @@ -20,22 +20,10 @@ let map f (rc: Recipe<_,_>) = recipe { /// Gets action context. let getCtx() = Recipe (fun c -> async {return (c,c)}) -/// -/// Gets current task result. -/// -// let getResult() = Recipe (fun (s,_) -> async {return (s,s)}) - -/// /// Updates the build result -/// -/// let setCtx ctx = Recipe (fun _ -> async {return (ctx,())}) -/// /// Consumes the task output and in case condition is met raises the error. -/// -/// -/// let FailWhen cond err (act: Recipe<_,_>) = recipe { let! b = act diff --git a/src/core/CommonLib.fs b/src/core/Common/Util.fs similarity index 80% rename from src/core/CommonLib.fs rename to src/core/Common/Util.fs index ec1488e..7242325 100644 --- a/src/core/CommonLib.fs +++ b/src/core/Common/Util.fs @@ -1,5 +1,13 @@ [] -module internal Xake.CommonLib +module Xake.Util + +let (><) f a b = f b a +let inline (|OtherwiseFail|) _ = failwith "no choice" +let inline (|OtherwiseFailErr|) message _ = failwith message + +type 't Agent = 't MailboxProcessor + +[] type ms type private CacheKey<'K> = K of 'K @@ -23,27 +31,17 @@ let memoize f = res) -///**Description** /// Memoizes the recursive function. Memoized function is passed as first argument to f. -///**Parameters** /// * `f` - parameter of type `('a -> 'b) -> 'a -> 'b` The function to be memoized. -/// -///**Output Type** -/// * `'a -> 'b` -/// -///**Exceptions** -/// let memoizeRec f = let rec fn x = f fm x and fm = fn |> memoize in fm -/// /// Takes n first elements from a list. -/// -/// -let rec take cnt = function |_ when cnt <= 0 -> [] |[] -> [] |a::rest -> a :: (take (cnt-1) rest) +let take cnt = + if cnt > 0 then List.chunkBySize cnt >> List.head else fun _ -> List.empty /// /// Returns a list of unique values for a specific list. diff --git a/src/core/Common/WorkerPool.fs b/src/core/Common/WorkerPool.fs new file mode 100644 index 0000000..0d4ae26 --- /dev/null +++ b/src/core/Common/WorkerPool.fs @@ -0,0 +1,45 @@ +module Xake.WorkerPool + +type ExecMessage<'target,'result> = + | Run of string * 'target list * Async<'result> * AsyncReplyChannel> + +open System.Threading +open System.Threading.Tasks + +// execution context +let create (logger:ILogger) maxThreads = + // controls how many threads are running in parallel + let throttler = new SemaphoreSlim (maxThreads) + let log = logger.Log + + throttler, MailboxProcessor.Start(fun mbox -> + let rec loop(map) = async { + match! mbox.Receive() with + | Run(_, [], _, _) -> + log Error "Empty target list" + return! loop map + | Run(title, (artifact::_ as targets), action, chnl) -> + match map |> Map.tryFind artifact with + | Some (task:Task<'a>) -> + log Never "Task found for '%s'. Status %A" title task.Status + chnl.Reply <| Async.AwaitTask task + return! loop map + + | None -> + do log Info "Task queued '%s'" title + do! throttler.WaitAsync(-1) |> Async.AwaitTask |> Async.Ignore + + let task = Async.StartAsTask <| async { + try + let! buildResult = action + do log Info "Task done '%s'" title + return buildResult + finally + throttler.Release() |> ignore + } + + chnl.Reply <| Async.AwaitTask task + let map' = List.fold (fun m t -> m |> Map.add t task) map targets + return! loop map' + } + loop(Map.empty) ) diff --git a/src/core/ExecCore.fs b/src/core/ExecCore.fs index b10d6c8..261d44c 100644 --- a/src/core/ExecCore.fs +++ b/src/core/ExecCore.fs @@ -118,14 +118,14 @@ let rec execOne ctx target = do Progress.TaskStart primaryTarget |> ctx.Progress.Post - let startResult = {BuildResult.makeResult targets with Steps = [Step.start "all"]} + let startResult = {BuildResult.makeResult targets with Steps = [BuildResult.startStep "all"]} let! ({Result = result},_) = action { taskContext with Result = startResult } - let result = Step.updateTotalDuration result + let result = BuildResult.updateTotalDuration result Store (result.Targets, result) |> ctx.Db.Post do Progress.TaskComplete primaryTarget |> ctx.Progress.Post - do ctx.Logger.Log Command "Completed %s in %A ms (wait %A ms)" (Target.shortName primaryTarget) (Step.lastStep result).OwnTime (Step.lastStep result).WaitTime + do ctx.Logger.Log Command "Completed %s in %A ms (wait %A ms)" (Target.shortName primaryTarget) (BuildResult.lastStep result).OwnTime (BuildResult.lastStep result).WaitTime return Succeed | false -> do ctx.Logger.Log Command "Skipped %s (up to date)" (Target.shortName primaryTarget) @@ -143,7 +143,8 @@ let rec execOne ctx target = | Some(rule,groups,targets) -> let groupsMap = groups |> Map.ofSeq async { - let! waitTask = (fun channel -> WorkerPool.Run(target, targets, run groupsMap (getAction rule) targets, channel)) |> ctx.TaskPool.PostAndAsyncReply + let taskTitle = Target.shortName target + let! waitTask = (fun channel -> WorkerPool.Run(taskTitle, target::targets, run groupsMap (getAction rule) targets, channel)) |> ctx.Workers.PostAndAsyncReply let! status = waitTask return target, status, ArtifactDep target } @@ -321,7 +322,7 @@ let runScript options rules = let ctx = { Ordinal = 0 - TaskPool = pool; Throttler = throttler + Workers = pool; Throttler = throttler Options = options; Rules = rules Logger = logger; RootLogger = logger; Db = db Progress = Progress.emptyProgress() @@ -372,6 +373,6 @@ let need targets = recipe { let! _,deps = targets |> execNeed ctx let totalDuration = int (System.DateTime.Now - startTime).TotalMilliseconds * 1 - let result' = {ctx.Result with Depends = ctx.Result.Depends @ deps} |> (Step.updateWaitTime totalDuration) + let result' = {ctx.Result with Depends = ctx.Result.Depends @ deps} |> (BuildResult.updateWaitTime totalDuration) do! setCtx { ctx with Result = result' } } diff --git a/src/core/ExecTypes.fs b/src/core/ExecTypes.fs index 602131e..764777d 100644 --- a/src/core/ExecTypes.fs +++ b/src/core/ExecTypes.fs @@ -2,7 +2,6 @@ module Xake.ExecTypes open System.Threading -open Prelude open Xake.Database /// Script execution options @@ -68,7 +67,7 @@ static member Default = { end type ExecStatus = | Succeed | Skipped | JustFile -type TaskPool = Agent> +type TaskPool = Agent> type Timestamp = System.DateTime type Dependency = @@ -98,7 +97,7 @@ type 'ctx Rules = Rules of 'ctx Rule list /// Script execution context type ExecContext = { - TaskPool: TaskPool + Workers: TaskPool Db: Agent> Throttler: SemaphoreSlim Options: ExecOptions @@ -116,7 +115,7 @@ type ExecContext = { /// Defines common exception type exception XakeException of string -module internal Util = +module internal Util = // TODO rename to an ExecOptions let private nullableToOption = function | null -> None | s -> Some s let getEnvVar = System.Environment.GetEnvironmentVariable >> nullableToOption @@ -124,36 +123,31 @@ module internal Util = let private valueByName variableName = function |name,value when name = variableName -> Some value | _ -> None let getVar (options: ExecOptions) name = options.Vars |> List.tryPick (valueByName name) -/// Utility methods to manipulate build stats // TODO moveme -module internal Step = +[] +module BuildResult = + open System - type DateTime = System.DateTime + /// Creates a new build result + let makeResult targets = { Targets = targets; Built = DateTime.Now; Depends = []; Steps = [] } - let start name = {StepInfo.Empty with Name = name; Start = DateTime.Now} + /// Start a new step + let startStep name = {StepInfo.Empty with Name = name; Start = DateTime.Now} - /// /// Updated last (current) build step - /// let updateLastStep fn = function | {Steps = current :: rest} as result -> {result with Steps = (fn current) :: rest} | result -> result - /// /// Adds specific amount to a wait time - /// let updateWaitTime delta = updateLastStep (fun c -> {c with WaitTime = c.WaitTime + delta}) + + /// Updates total duration of the build (adds to last step) let updateTotalDuration = let durationSince (startTime: DateTime) = int (DateTime.Now - startTime).TotalMilliseconds * 1 updateLastStep (fun c -> {c with OwnTime = (durationSince c.Start) - c.WaitTime}) + + /// Gets the last (current) step let lastStep = function | {Steps = current :: _} -> current - | _ -> start "dummy" - -[] -module BuildResult = - /// Creates a new build result - let makeResult targets = - { Targets = targets - Built = System.DateTime.Now - Depends = [] - Steps = [] } + | _ -> startStep "dummy" + \ No newline at end of file diff --git a/src/core/ScriptFuncs.fs b/src/core/ScriptFuncs.fs index 6281b91..51f94e7 100644 --- a/src/core/ScriptFuncs.fs +++ b/src/core/ScriptFuncs.fs @@ -1,20 +1,15 @@ [] module Xake.ScriptFuncs -/// /// Gets the script options. -/// let getCtxOptions () = recipe { let! (ctx: ExecContext) = getCtx() return ctx.Options } -/// /// Executes and awaits specified artifacts. -/// -/// let need targets = - action { + recipe { let! ctx = getCtx() let t' = targets |> (List.map (ExecCore.makeTarget ctx)) do! ExecCore.need t' @@ -39,7 +34,7 @@ let alwaysRerun() = AlwaysRerun |> record /// let getEnv variableName = let value = Util.getEnvVar variableName - action { + recipe { do! EnvVar (variableName,value) |> record return value } @@ -68,23 +63,18 @@ let getFiles fileset = recipe { return files } -/// +let private takeFile (FileTarget file | OtherwiseFailErr "Expected only a file targets" file) = Some file + /// Gets current target file -/// let getTargetFile() = recipe { let! ctx = getCtx() - return ctx.Targets - |> function - | FileTarget file::_ -> file - | _ -> failwith "getTargetFile is not available for phony actions" + return ctx.Targets |> List.choose takeFile |> List.head } -/// /// Gets current target file -/// -let getTargetFiles() : Recipe = recipe { - let! ctx = getCtx() - return ctx.Targets |> List.collect (function |FileTarget file -> [file] |_ -> failwith "Expected only a file targets"; []) +let getTargetFiles() = recipe { + let! (ctx: ExecContext) = getCtx() + return ctx.Targets |> List.choose takeFile } /// @@ -100,18 +90,13 @@ let getRuleMatches () = recipe { return ctx.RuleMatches } -/// /// Gets group (part of the name) by its name. -/// let getRuleMatch key = action { let! groups = getRuleMatches() return groups |> Map.tryFind key |> function |Some v -> v | None -> "" } - -/// /// Writes a message to a log. -/// let trace = ExecCore.traceLog /// Defines a rule that demands specified targets @@ -124,8 +109,8 @@ let (<==) name targets = PhonyRule (name, recipe { /// Finalizes current build step and starts a new one // TODO put it somewhere let newstep name = recipe { let! c = getCtx() - let r' = Step.updateTotalDuration c.Result - let r'' = {r' with Steps = (Step.start name) :: r'.Steps} + let r' = BuildResult.updateTotalDuration c.Result + let r'' = {r' with Steps = (BuildResult.startStep name) :: r'.Steps} do! setCtx { c with Result = r''} } diff --git a/src/core/ProcessExec.fs b/src/core/Tasks/ProcessExec.fs similarity index 85% rename from src/core/ProcessExec.fs rename to src/core/Tasks/ProcessExec.fs index 0a53dd4..e4e4fa4 100644 --- a/src/core/ProcessExec.fs +++ b/src/core/Tasks/ProcessExec.fs @@ -20,8 +20,8 @@ let pexec handleStd handleErr cmd args (envvars:(string * string) list) workDir let proc = new Process(StartInfo = pinfo) - proc.ErrorDataReceived.Add(fun e -> if e.Data <> null then handleErr e.Data) - proc.OutputDataReceived.Add(fun e -> if e.Data <> null then handleStd e.Data) + proc.ErrorDataReceived.Add(fun e -> if not (isNull e.Data) then handleErr e.Data) + proc.OutputDataReceived.Add(fun e -> if not (isNull e.Data) then handleStd e.Data) do proc.Start() |> ignore diff --git a/src/core/WorkerPool.fs b/src/core/WorkerPool.fs deleted file mode 100644 index 73fe927..0000000 --- a/src/core/WorkerPool.fs +++ /dev/null @@ -1,46 +0,0 @@ -module Xake.WorkerPool - -type ExecMessage<'r> = - | Run of Target * Target list * Async<'r> * AsyncReplyChannel> - -open System.Threading -open System.Threading.Tasks - -// TODO consider removing first argument -// execution context -let internal create (logger:ILogger) maxThreads = - // controls how many threads are running in parallel - let throttler = new SemaphoreSlim (maxThreads) - let log = logger.Log - - let mapKey = Target.fullName - - throttler, MailboxProcessor.Start(fun mbox -> - let rec loop(map) = async { - match! mbox.Receive() with - | Run(artifact, targets, action, chnl) -> - let mkey = artifact |> mapKey - - match map |> Map.tryFind mkey with - | Some (task:Task<'a>) -> - log Never "Task found for '%s'. Status %A" (Target.shortName artifact) task.Status - chnl.Reply <| Async.AwaitTask task - return! loop(map) - - | None -> - do log Info "Task queued '%s'" (Target.shortName artifact) - do! throttler.WaitAsync(-1) |> Async.AwaitTask |> Async.Ignore - - let task = Async.StartAsTask (async { - try - let! buildResult = action - do log Info "Task done '%s'" (Target.shortName artifact) - return buildResult - finally - throttler.Release() |> ignore - }) - chnl.Reply <| Async.AwaitTask task - let newMap = targets |> List.fold (fun m t -> m |> Map.add (mapKey t) task) map - return! loop newMap - } - loop(Map.empty) ) diff --git a/src/core/Xake.fsproj b/src/core/Xake.fsproj index 202e03f..c9fbb87 100644 --- a/src/core/Xake.fsproj +++ b/src/core/Xake.fsproj @@ -12,30 +12,29 @@ - + + + + + - - - - - - + diff --git a/src/tests/ProgressTests.fs b/src/tests/ProgressTests.fs index ac35095..2e416cd 100644 --- a/src/tests/ProgressTests.fs +++ b/src/tests/ProgressTests.fs @@ -2,6 +2,7 @@ open NUnit.Framework +open Xake open Xake.Progress.Estimate type TaskDeps = string list diff --git a/src/tests/StorageTests.fs b/src/tests/StorageTests.fs index 1f04c25..3c5eb24 100644 --- a/src/tests/StorageTests.fs +++ b/src/tests/StorageTests.fs @@ -38,7 +38,7 @@ module private impl = Var("DEBUG", Some "false") ] Steps = [ newStepInfo ("compile", 217) ] } - let (<-*) (a : Agent<_ DatabaseApi>) t = a.PostAndReply(fun ch -> GetResult(t, ch)) + let (<-*) (a : Agent) t = a.PostAndReply(fun ch -> GetResult(t, ch)) let inline (<--) (agent : ^a) (msg : 'b) = (^a : (member Post : 'b -> unit) (agent, msg)) From c6ce1f744129515033fa981b5fd289b1c6249372 Mon Sep 17 00:00:00 2001 From: OlegZee Date: Tue, 12 Nov 2019 02:03:39 +0700 Subject: [PATCH 08/22] code cleanup --- src/core/ExecCore.fs | 45 ++++++++++++++------------------------------ 1 file changed, 14 insertions(+), 31 deletions(-) diff --git a/src/core/ExecCore.fs b/src/core/ExecCore.fs index 261d44c..61a3e79 100644 --- a/src/core/ExecCore.fs +++ b/src/core/ExecCore.fs @@ -4,11 +4,6 @@ open System.Text.RegularExpressions open Xake open DependencyAnalysis - -/// Default options -[] -let XakeOptions = ExecOptions.Default - open Database /// Writes the message with formatting to a log @@ -92,18 +87,15 @@ let raiseError ctx error details = // Ordinal of the task being added to a task pool let refTaskOrdinal = ref 0 -/// /// Creates a context for a new task -/// let newTaskContext targets matches ctx = let ordinal = System.Threading.Interlocked.Increment(refTaskOrdinal) let prefix = ordinal |> sprintf "%i> " in - {ctx with + { ctx with Ordinal = ordinal; Logger = PrefixLogger prefix ctx.RootLogger Targets = targets - RuleMatches = matches - } + RuleMatches = matches } // executes single artifact let rec execOne ctx target = @@ -154,14 +146,10 @@ let rec execOne ctx target = async.Return <| (target, JustFile, FileDep (file, File.getLastWriteTime file)) | _ -> raiseError ctx (sprintf "Neither rule nor file is found for '%s'" <| Target.fullName target) "" -/// /// Executes several artifacts in parallel. -/// and execParallel ctx = List.map (execOne ctx) >> Seq.ofList >> Async.Parallel -/// /// Gets the status of dependency artifacts (obtained from 'need' calls). -/// /// /// ExecStatus.Succeed,... in case at least one dependency was rebuilt /// @@ -205,17 +193,12 @@ let dryRun ctx options (groups: string list list) = let rec showDepStatus ii reasons = reasons |> function - | Other reason -> - print "%sReason: %s" (indent ii) reason - | Depends t -> - print "%sDepends '%s' - changed target" (indent ii) (Target.shortName t) - | DependsMissingTarget t -> - print "%sDepends on '%s' - missing target" (indent ii) (Target.shortName t) - | FilesChanged (file:: rest) -> - print "%sFile is changed '%s' %s" (indent ii) file (if List.isEmpty rest then "" else sprintf " and %d more file(s)" <| List.length rest) - | reasons -> - do print "%sSome reason %A" (indent ii) reasons - () + | Other reason -> print "%sReason: %s" (indent ii) reason + | Depends t -> print "%sDepends '%s' - changed target" (indent ii) (Target.shortName t) + | DependsMissingTarget t -> print "%sDepends on '%s' - missing target" (indent ii) (Target.shortName t) + | FilesChanged (file:: rest) -> print "%sFile is changed '%s' %s" (indent ii) file (if List.isEmpty rest then "" else sprintf " and %d more file(s)" <| List.length rest) + | reasons -> print "%sSome reason %A" (indent ii) reasons + let rec displayNestedDeps ii = function | DependsMissingTarget t @@ -237,14 +220,14 @@ let dryRun ctx options (groups: string list list) = let endTime = Progress.estimateEndTime (getDurationDeps ctx getDeps) options.Threads targetGroups |> toSec targetGroups |> List.collect id |> List.iter (showTargetStatus 0) - let alldeps = targetGroups |> List.collect id |> List.collect getDeps - if List.isEmpty alldeps then + match targetGroups |> List.collect id |> List.collect getDeps with + | [] -> ctx.Logger.Log Message "\n\n\tNo changed dependencies. Nothing to do.\n" - else + | _ -> let parallelismMsg = let endTimeTotal = Progress.estimateEndTime (getDurationDeps ctx getDeps) 1 targetGroups |> toSec if options.Threads > 1 && endTimeTotal > endTime * 1.05 then - sprintf "\n\tTotal tasks duration is (estimate) in %As\n\tParallelist degree: %.2f" endTimeTotal (endTimeTotal / endTime) + sprintf "\n\tTotal tasks duration is (estimate) in %As\n\tParallelism degree: %.2f" endTimeTotal (endTimeTotal / endTime) else "" ctx.Logger.Log Message "\n\n\tBuild will be completed (estimate) in %As%s\n" endTime parallelismMsg @@ -254,7 +237,7 @@ let rec unwindAggEx (e:System.Exception) = seq { | a -> yield a } -let rec runSeq<'r> :Async<'r> list -> Async<'r list> = +let runSeq<'r> :Async<'r> list -> Async<'r list> = List.fold (fun rest i -> async { let! tail = rest @@ -375,4 +358,4 @@ let need targets = recipe { let totalDuration = int (System.DateTime.Now - startTime).TotalMilliseconds * 1 let result' = {ctx.Result with Depends = ctx.Result.Depends @ deps} |> (BuildResult.updateWaitTime totalDuration) do! setCtx { ctx with Result = result' } -} +} \ No newline at end of file From c076378e2323e2c63979186ca0d43f4e90c059ef Mon Sep 17 00:00:00 2001 From: Oleg Zaimkin Date: Tue, 12 Nov 2019 11:25:10 +0700 Subject: [PATCH 09/22] split Estimate and Progress modules, made Util an explicit module --- src/core/BuildDatabase.fs | 6 ++- src/core/Common/Estimate.fs | 80 +++++++++++++++++++++++++++ src/core/Common/Progress.fs | 99 ++++------------------------------ src/core/Common/Util.fs | 14 +---- src/core/DependencyAnalysis.fs | 7 ++- src/core/ExecCore.fs | 9 ++-- src/core/ExecTypes.fs | 9 ++-- src/core/Fileset.fs | 1 + src/core/Path.fs | 2 + src/core/ScriptFuncs.fs | 2 + src/core/Xake.fsproj | 1 + src/tests/ProgressTests.fs | 58 ++++++++++---------- src/tests/StorageTests.fs | 3 +- src/tests/XakeScriptTests.fs | 1 + 14 files changed, 149 insertions(+), 143 deletions(-) create mode 100644 src/core/Common/Estimate.fs diff --git a/src/core/BuildDatabase.fs b/src/core/BuildDatabase.fs index c0c8815..52ac726 100644 --- a/src/core/BuildDatabase.fs +++ b/src/core/BuildDatabase.fs @@ -1,5 +1,7 @@ module Xake.BuildDatabase +open Xake.Util + module Picklers = open Pickler @@ -16,8 +18,8 @@ module Picklers = let step = wrap - ((fun (n, s, o, w) -> {StepInfo.Name = n; Start = s; OwnTime = o * 1; WaitTime = w * 1}), - fun ({StepInfo.Name = n; Start = s; OwnTime = o; WaitTime = w}) -> (n, s, o / 1, w / 1)) (quad str date int int) + ((fun (n, s, o, w) -> {StepInfo.Name = n; Start = s; OwnTime = o * 1; WaitTime = w * 1}), + fun ({StepInfo.Name = n; Start = s; OwnTime = o; WaitTime = w}) -> (n, s, o / 1, w / 1)) (quad str date int int) // Fileset of FilesetOptions * FilesetElement list let dependency = diff --git a/src/core/Common/Estimate.fs b/src/core/Common/Estimate.fs new file mode 100644 index 0000000..e426895 --- /dev/null +++ b/src/core/Common/Estimate.fs @@ -0,0 +1,80 @@ +module Xake.Estimate + +open Xake.Util + +[] type Ms + +type CpuState = | BusyUntil of int +type MachineState<'T when 'T:comparison> = + { Cpu: CpuState list; Tasks: Map<'T,int>} + +module internal Impl = + /// + /// Updates the first item matching the criteria and returns the updated value. + /// + /// + /// + let rec updateFirst predicate upd = function + | [] -> None,[] + | c::list when predicate c -> + let updated = upd c in + Some updated, updated :: list + | c::list -> + let result,list = (updateFirst predicate upd list) in + result, c::list + + let ignoreFailures f a = + try + f a + with _ -> + () + +/// +/// "Executes" one task +/// +/// Initial "machine" state +/// Provide a task information to exec function +/// The task to execute +let rec exec state getDurationDeps task = + // Gets the thread that will be freed after specific moment + let nearest after = + let ready (BusyUntil x) = if x <= after then 0 else x in + List.minBy ready + + match state.Tasks |> Map.tryFind task with + | Some result -> state,result + | None -> + let duration,deps = task |> getDurationDeps + let readyAt (BusyUntil x)= x + + let mstate, endTime = execMany state getDurationDeps deps + let slot = mstate.Cpu |> nearest endTime + let (Some (BusyUntil result)|OtherwiseFail result), newState = + mstate.Cpu |> Impl.updateFirst ((=) slot) (readyAt >> max endTime >> (+) duration >> BusyUntil) + {Cpu = newState; Tasks = mstate.Tasks |> Map.add task result}, result +// |> fun r -> +// printf "after %A" task +// printf " %A\n\n" r +// r + +/// Executes multiple targers simultaneously +and execMany state getDurationDeps goals = + let machineState,endTime = + goals |> List.fold ( + fun (prevState,prevTime) t -> + let newState,time = exec prevState getDurationDeps t in + (newState, max time prevTime) + ) (state, 0) + + machineState, endTime + +/// Gets estimated execution time for several target groups. Each group start when previous group is completed and runs in parallel. +let estimateEndTime getDurationDeps threadCount groups = + let machineState = {Cpu = BusyUntil 0 |> List.replicate threadCount; Tasks = Map.empty} + + groups |> List.fold (fun (state, _) group -> + let newState, endTime = execMany state getDurationDeps group + let newState = {newState with Cpu = newState.Cpu |> List.map (fun _ -> BusyUntil endTime)} + newState, endTime + ) (machineState, 0) + |> snd diff --git a/src/core/Common/Progress.fs b/src/core/Common/Progress.fs index ac602b1..338a0c5 100644 --- a/src/core/Common/Progress.fs +++ b/src/core/Common/Progress.fs @@ -1,5 +1,8 @@ module Xake.Progress +open Xake.Util +open Xake.Estimate + /// /// A message to a progress reporter. /// @@ -82,73 +85,6 @@ module internal WindowsProgress = with _ -> ignore -module internal Impl = - /// - /// Updates the first item matching the criteria and returns the updated value. - /// - /// - /// - let rec updateFirst predicate upd = function - | [] -> None,[] - | c::list when predicate c -> - let updated = upd c in - Some updated, updated :: list - | c::list -> - let result,list = (updateFirst predicate upd list) in - result, c::list - - let ignoreFailures f a = - try - f a - with _ -> - () - -/// Estimate the task execution times -module Estimate = - - type CpuState = | BusyUntil of int - type MachineState<'T when 'T:comparison> = - { Cpu: CpuState list; Tasks: Map<'T,int>} - - /// - /// "Executes" one task - /// - /// Initial "machine" state - /// Provide a task information to exec function - /// The task to execute - let rec exec state getDurationDeps task = - // Gets the thread that will be freed after specific moment - let nearest after = - let ready (BusyUntil x) = if x <= after then 0 else x in - List.minBy ready - - match state.Tasks |> Map.tryFind task with - | Some result -> state,result - | None -> - let duration,deps = task |> getDurationDeps - let readyAt (BusyUntil x)= x - - let mstate, endTime = execMany state getDurationDeps deps - let slot = mstate.Cpu |> nearest endTime - let (Some (BusyUntil result)|OtherwiseFail result), newState = - mstate.Cpu |> Impl.updateFirst ((=) slot) (readyAt >> max endTime >> (+) duration >> BusyUntil) - {Cpu = newState; Tasks = mstate.Tasks |> Map.add task result}, result -// |> fun r -> -// printf "after %A" task -// printf " %A\n\n" r -// r - - /// Executes multiple targers simultaneously - and execMany state getDurationDeps goals = - let machineState,endTime = - goals |> List.fold ( - fun (prevState,prevTime) t -> - let newState,time = exec prevState getDurationDeps t in - (newState, max time prevTime) - ) (state, 0) - - machineState, endTime - /// /// Interface for progress module. /// @@ -160,8 +96,6 @@ type ProgressReport<'TKey> when 'TKey: comparison = | Refresh | Finish -open Estimate - /// /// Creates "null" progress reporter. /// @@ -176,19 +110,6 @@ let emptyProgress () = } loop ()) -/// -/// Gets estimated execution time for several target groups. Each group start when previous group is completed and runs in parallel. -/// -let estimateEndTime getDurationDeps threadCount groups = - let machineState = {Cpu = BusyUntil 0 |> List.replicate threadCount; Tasks = Map.empty} - - groups |> List.fold (fun (state, _) group -> - let newState, endTime = execMany state getDurationDeps group - let newState = {newState with Cpu = newState.Cpu |> List.map (fun _ -> BusyUntil endTime)} - newState, endTime - ) (machineState, 0) - |> snd - /// /// Creates windows taskbar progress reporter. /// @@ -198,7 +119,7 @@ let estimateEndTime getDurationDeps threadCount groups = let openProgress getDurationDeps threadCount goals toConsole = let progressBar = WindowsProgress.createTaskbarIndicator() |> Impl.ignoreFailures - let machineState = {Cpu = BusyUntil 0 |> List.replicate threadCount; Tasks = Map.empty} + let machineState = {Cpu = BusyUntil 0 |> List.replicate threadCount; Tasks = Map.empty} let _,endTime = execMany machineState getDurationDeps goals @@ -212,16 +133,16 @@ let openProgress getDurationDeps threadCount goals toConsole = let originalDuration,deps = getDurationDeps t //do printf "\nestimate %A: %A\n" t timeToComplete in - originalDuration - runningTime |> max 0, deps + originalDuration - runningTime |> max 0, deps | _ -> getDurationDeps t let reportProgress (state, runningTasks) = - let timePassed = 1 * int (System.DateTime.Now - startTime).TotalMilliseconds in + let timePassed = 1 * int (System.DateTime.Now - startTime).TotalMilliseconds in let _,leftTime = execMany state (getDuration2 runningTasks) goals //printf "progress %A to %A " timePassed endTime let percentDone = timePassed * 100 / (timePassed + leftTime) |> int - let progressData = System.TimeSpan.FromMilliseconds (leftTime/1 |> float), percentDone + let progressData = System.TimeSpan.FromMilliseconds (leftTime/1 |> float), percentDone do Progress progressData |> progressBar if toConsole then do WriteConsoleProgress progressData @@ -229,7 +150,7 @@ let openProgress getDurationDeps threadCount goals toConsole = let updTime = ref System.DateTime.Now let advanceRunningTime rt = let now = System.DateTime.Now - let increment = 1 * int (now - !updTime).TotalMilliseconds + let increment = 1 * int (now - !updTime).TotalMilliseconds updTime := now rt |> Map.map ( fun _ (cpu,isRunning) -> @@ -248,7 +169,7 @@ let openProgress getDurationDeps threadCount goals toConsole = let runningTasks = runningTasks |> advanceRunningTime match msg with - | TaskStart target -> return! loop (state, runningTasks |> Map.add target (0, true)) + | TaskStart target -> return! loop (state, runningTasks |> Map.add target (0, true)) | TaskSuspend target -> return! loop (state, runningTasks |> Map.map (suspend target)) | TaskResume target -> return! loop (state, runningTasks |> Map.map (resume target)) | Refresh _ -> @@ -256,7 +177,7 @@ let openProgress getDurationDeps threadCount goals toConsole = return! loop (state,runningTasks) | TaskComplete target -> - let newState = ({state with Tasks = state.Tasks |> Map.add target 0}, runningTasks |> Map.remove target) + let newState = ({state with Tasks = state.Tasks |> Map.add target 0}, runningTasks |> Map.remove target) reportProgress newState return! loop newState diff --git a/src/core/Common/Util.fs b/src/core/Common/Util.fs index 7242325..2495561 100644 --- a/src/core/Common/Util.fs +++ b/src/core/Common/Util.fs @@ -1,5 +1,4 @@ -[] -module Xake.Util +module Xake.Util let (><) f a b = f b a let inline (|OtherwiseFail|) _ = failwith "no choice" @@ -7,8 +6,6 @@ let inline (|OtherwiseFailErr|) message _ = failwith message type 't Agent = 't MailboxProcessor -[] type ms - type private CacheKey<'K> = K of 'K /// @@ -42,12 +39,3 @@ let memoizeRec f = /// Takes n first elements from a list. let take cnt = if cnt > 0 then List.chunkBySize cnt >> List.head else fun _ -> List.empty - -/// -/// Returns a list of unique values for a specific list. -/// -/// -let distinct ls = - ls |> - List.fold (fun map item -> if map |> Map.containsKey item then map else map |> Map.add item 1) Map.empty - |> Map.toList |> List.map fst diff --git a/src/core/DependencyAnalysis.fs b/src/core/DependencyAnalysis.fs index 7b9ab1c..7d609e7 100644 --- a/src/core/DependencyAnalysis.fs +++ b/src/core/DependencyAnalysis.fs @@ -1,6 +1,9 @@ module internal Xake.DependencyAnalysis open Xake +open Xake.Util +open Xake.Estimate + open Database /// @@ -22,7 +25,7 @@ let TimeCompareToleranceMs = 10.0 /// let getExecTime ctx (target: Target) = (fun ch -> GetResult(target, ch)) |> ctx.Db.PostAndReply - |> Option.fold (fun _ r -> r.Steps |> List.sumBy (fun s -> s.OwnTime)) 0 + |> Option.fold (fun _ r -> r.Steps |> List.sumBy (fun s -> s.OwnTime)) 0 /// Gets single dependency state and reason of a change. let getDepState getVar getFileList (getChangedDeps: Target -> ChangeReason list) = function @@ -107,7 +110,7 @@ let getChangeReasons ctx getTargetDeps target = // gets task duration and list of targets it depends on. No clue why one method does both. let getDurationDeps ctx getDeps t = match getDeps t with - | [] -> 0, [] + | [] -> 0, [] | deps -> let targets = deps |> List.collect (function |Depends t |DependsMissingTarget t -> [t] | _ -> []) (getExecTime ctx t, targets) diff --git a/src/core/ExecCore.fs b/src/core/ExecCore.fs index 61a3e79..51d610f 100644 --- a/src/core/ExecCore.fs +++ b/src/core/ExecCore.fs @@ -3,6 +3,7 @@ open System.Text.RegularExpressions open Xake +open Xake.Util open DependencyAnalysis open Database @@ -216,8 +217,8 @@ let dryRun ctx options (groups: string list list) = deps |> List.iter (displayNestedDeps (ii+1)) let targetGroups = makeTarget ctx |> List.map |> List.map <| groups in - let toSec v = float (v / 1) * 0.001 - let endTime = Progress.estimateEndTime (getDurationDeps ctx getDeps) options.Threads targetGroups |> toSec + let toSec v = float (v / 1) * 0.001 + let endTime = Estimate.estimateEndTime (getDurationDeps ctx getDeps) options.Threads targetGroups |> toSec targetGroups |> List.collect id |> List.iter (showTargetStatus 0) match targetGroups |> List.collect id |> List.collect getDeps with @@ -225,7 +226,7 @@ let dryRun ctx options (groups: string list list) = ctx.Logger.Log Message "\n\n\tNo changed dependencies. Nothing to do.\n" | _ -> let parallelismMsg = - let endTimeTotal = Progress.estimateEndTime (getDurationDeps ctx getDeps) 1 targetGroups |> toSec + let endTimeTotal = Estimate.estimateEndTime (getDurationDeps ctx getDeps) 1 targetGroups |> toSec if options.Threads > 1 && endTimeTotal > endTime * 1.05 then sprintf "\n\tTotal tasks duration is (estimate) in %As\n\tParallelism degree: %.2f" endTimeTotal (endTimeTotal / endTime) else "" @@ -355,7 +356,7 @@ let need targets = recipe { let! ctx = getCtx() let! _,deps = targets |> execNeed ctx - let totalDuration = int (System.DateTime.Now - startTime).TotalMilliseconds * 1 + let totalDuration = int (System.DateTime.Now - startTime).TotalMilliseconds * 1 let result' = {ctx.Result with Depends = ctx.Result.Depends @ deps} |> (BuildResult.updateWaitTime totalDuration) do! setCtx { ctx with Result = result' } } \ No newline at end of file diff --git a/src/core/ExecTypes.fs b/src/core/ExecTypes.fs index 764777d..7aeaf55 100644 --- a/src/core/ExecTypes.fs +++ b/src/core/ExecTypes.fs @@ -4,6 +4,9 @@ module Xake.ExecTypes open System.Threading open Xake.Database +type internal 't Agent = 't MailboxProcessor +[] type Ms = Estimate.Ms + /// Script execution options type ExecOptions = { /// Defines project root folder @@ -79,8 +82,8 @@ type Dependency = | GetFiles of Fileset * Filelist // depends on set of files. Triggers when resulting filelist is changed type StepInfo = - { Name: string; Start: System.DateTime; OwnTime: int; WaitTime: int } - with static member Empty = {Name = ""; Start = new System.DateTime(1900,1,1); OwnTime = 0; WaitTime = 0} + { Name: string; Start: System.DateTime; OwnTime: int; WaitTime: int } + with static member Empty = {Name = ""; Start = new System.DateTime(1900,1,1); OwnTime = 0; WaitTime = 0} type BuildResult = { Targets : Target list @@ -143,7 +146,7 @@ module BuildResult = /// Updates total duration of the build (adds to last step) let updateTotalDuration = - let durationSince (startTime: DateTime) = int (DateTime.Now - startTime).TotalMilliseconds * 1 + let durationSince (startTime: DateTime) = int (DateTime.Now - startTime).TotalMilliseconds * 1 updateLastStep (fun c -> {c with OwnTime = (durationSince c.Start) - c.WaitTime}) /// Gets the last (current) step diff --git a/src/core/Fileset.fs b/src/core/Fileset.fs index 1cc8426..20f1a64 100644 --- a/src/core/Fileset.fs +++ b/src/core/Fileset.fs @@ -3,6 +3,7 @@ module Xake.Fileset open System.IO open Xake +open Xake.Util /// /// Defines interface to a file system diff --git a/src/core/Path.fs b/src/core/Path.fs index 2ebd4a8..4e6d386 100644 --- a/src/core/Path.fs +++ b/src/core/Path.fs @@ -3,6 +3,8 @@ open System.IO open System.Text.RegularExpressions +open Xake.Util + type Part = | FsRoot | Parent diff --git a/src/core/ScriptFuncs.fs b/src/core/ScriptFuncs.fs index 51f94e7..7e7474d 100644 --- a/src/core/ScriptFuncs.fs +++ b/src/core/ScriptFuncs.fs @@ -1,6 +1,8 @@ [] module Xake.ScriptFuncs +open Xake.Util + /// Gets the script options. let getCtxOptions () = recipe { let! (ctx: ExecContext) = getCtx() diff --git a/src/core/Xake.fsproj b/src/core/Xake.fsproj index c9fbb87..111a47f 100644 --- a/src/core/Xake.fsproj +++ b/src/core/Xake.fsproj @@ -19,6 +19,7 @@ + diff --git a/src/tests/ProgressTests.fs b/src/tests/ProgressTests.fs index 2e416cd..db52e48 100644 --- a/src/tests/ProgressTests.fs +++ b/src/tests/ProgressTests.fs @@ -3,17 +3,17 @@ open NUnit.Framework open Xake -open Xake.Progress.Estimate +open Xake.Estimate type TaskDeps = string list -type Task = | Task of string * int * TaskDeps +type Task = | Task of string * int * TaskDeps let internal estimate threadCount completed_tasks tasks goals = let getTaskName (Task (name,_,_)) = name - let tasks_map = completed_tasks |> List.map (fun t -> (t, 0)) |> Map.ofList - let machine_state = {Cpu = BusyUntil 0 |> List.replicate threadCount; Tasks = tasks_map} + let tasks_map = completed_tasks |> List.map (fun t -> (t, 0)) |> Map.ofList + let machine_state = {Cpu = BusyUntil 0 |> List.replicate threadCount; Tasks = tasks_map} let taskMap = tasks |> List.map (fun task -> getTaskName task, task) |> Map.ofList let taskByName name = Map.find name taskMap @@ -22,63 +22,63 @@ let internal estimate threadCount completed_tasks tasks goals = in endTime -[)>] -[)>] +[)>] +[)>] let Test1(threads) = let tasks1 = [ - Task ("build", 1, ["link"]) - Task ("link", 2, ["compile"]) - Task ("compile", 5, []) + Task ("build", 1, ["link"]) + Task ("link", 2, ["compile"]) + Task ("compile", 5, []) ] estimate threads [] tasks1 ["build"] -[)>] -[)>] +[)>] +[)>] let TestPara(threads) = let tasks1 = [ - Task ("build", 1, ["link1"; "link2"]) - Task ("link1", 2, ["compile"]) - Task ("link2", 2, ["compile"]) - Task ("compile", 7, []) + Task ("build", 1, ["link1"; "link2"]) + Task ("link1", 2, ["compile"]) + Task ("link2", 2, ["compile"]) + Task ("compile", 7, []) ] estimate threads [] tasks1 ["build"] -[)>] -[)>] +[)>] +[)>] let ComplexCase(threads) = let tasks1 = [ - Task ("build", 1, ["compile"]) - Task ("compile", 5, + Task ("build", 1, ["compile"]) + Task ("compile", 5, [ "version.h" "commonheader.h" "resources" "resources-ru" ]) - Task ("version.h", 4, []) - Task ("commonheader.h", 4, []) - Task ("resources", 2, ["strings"]) - Task ("resources-ru", 3, ["strings"]) - Task ("strings", 2, []) + Task ("version.h", 4, []) + Task ("commonheader.h", 4, []) + Task ("resources", 2, ["strings"]) + Task ("resources-ru", 3, ["strings"]) + Task ("strings", 2, []) ] estimate threads [] tasks1 ["build"] -[)>] -[)>] +[)>] +[)>] let TestPara2(threads) = let tasks1 = [ - Task ("main", 0, ["t1"; "t2"]) - Task ("t1", 4, []) - Task ("t2", 5, []) + Task ("main", 0, ["t1"; "t2"]) + Task ("t1", 4, []) + Task ("t2", 5, []) ] estimate threads [] tasks1 ["main"] diff --git a/src/tests/StorageTests.fs b/src/tests/StorageTests.fs index 3c5eb24..8f39ea6 100644 --- a/src/tests/StorageTests.fs +++ b/src/tests/StorageTests.fs @@ -4,6 +4,7 @@ open System.IO open NUnit.Framework open Xake +open Xake.Util open Xake.Database open Xake.BuildDatabase @@ -17,7 +18,7 @@ module private impl = let mkFileTarget = File.make >> FileTarget let newStepInfo (name, duration) = { StepInfo.Empty with Name = name - OwnTime = duration * 1 } + OwnTime = duration * 1 } // stores object to a binary stream and immediately reads it let writeAndRead (pu : Pickler.PU<_>) testee = diff --git a/src/tests/XakeScriptTests.fs b/src/tests/XakeScriptTests.fs index b49201c..523640f 100644 --- a/src/tests/XakeScriptTests.fs +++ b/src/tests/XakeScriptTests.fs @@ -4,6 +4,7 @@ open System.IO open NUnit.Framework open Xake +open Xake.Util open Xake.BuildDatabase open Xake.Tasks From a3d27131978a48195e08c27b69ed151b8744c3e0 Mon Sep 17 00:00:00 2001 From: Oleg Zaimkin Date: Tue, 12 Nov 2019 11:50:50 +0700 Subject: [PATCH 10/22] preparing for publishing --- .travis.yml | 2 +- src/core/ExecCore.fs | 1 + src/core/Xake.fsproj | 6 +++--- 3 files changed, 5 insertions(+), 4 deletions(-) diff --git a/.travis.yml b/.travis.yml index d534405..03692e4 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,6 +1,6 @@ language: csharp mono: latest -dotnet: 2.1.300 +dotnet: 3.0 env: VER=$(if [[ "${TRAVIS_TAG:0:1}" == "v" ]]; then echo ${TRAVIS_TAG:1}.${TRAVIS_BUILD_NUMBER}; else echo 1.0.0.${TRAVIS_BUILD_NUMBER}; fi;) install: - dotnet restore build.proj diff --git a/src/core/ExecCore.fs b/src/core/ExecCore.fs index 51d610f..9db5ee8 100644 --- a/src/core/ExecCore.fs +++ b/src/core/ExecCore.fs @@ -344,6 +344,7 @@ let runScript options rules = let errors = exn |> unwindAggEx |> Seq.map (fun e -> e.Message) in th ctx (exn.Message + "\n" + (errors |> String.concat "\r\n ")) exn ctx.Logger.Log Message "\n\n\tBuild failed after running for %A\n" (System.DateTime.Now - start) + FlushLogs() exit 2 finally db.PostAndReply Database.CloseWait diff --git a/src/core/Xake.fsproj b/src/core/Xake.fsproj index 111a47f..f33570f 100644 --- a/src/core/Xake.fsproj +++ b/src/core/Xake.fsproj @@ -4,10 +4,10 @@ Xake Library net46;netstandard2.0 - (c) OlegZee 2014-2018 + (c) OlegZee 2014-2019 - https://github.com/xakebuild/Xake - https://github.com/xakebuild/Xake/raw/dev/Icon.png + https://github.com/Fakebuild/Xake + https://github.com/Fakebuild/Xake/raw/dev/Icon.png Xake build tool, the engine From 97b2cd86bd83ba693cb6d41f7b6517417c2b2967 Mon Sep 17 00:00:00 2001 From: Oleg Zaimkin Date: Tue, 12 Nov 2019 13:24:32 +0700 Subject: [PATCH 11/22] changed fake bootstrapper (to a most recent one) --- .travis.yml | 6 ++---- build.cmd | 3 +-- build.proj | 10 ---------- build.sh | 3 +-- fake.cmd | 7 +++++++ fake.sh | 27 +++++++++++++++++++++++++++ readme.md | 11 +++++------ 7 files changed, 43 insertions(+), 24 deletions(-) delete mode 100644 build.proj create mode 100644 fake.cmd create mode 100644 fake.sh diff --git a/.travis.yml b/.travis.yml index 03692e4..cf7a207 100644 --- a/.travis.yml +++ b/.travis.yml @@ -2,14 +2,12 @@ language: csharp mono: latest dotnet: 3.0 env: VER=$(if [[ "${TRAVIS_TAG:0:1}" == "v" ]]; then echo ${TRAVIS_TAG:1}.${TRAVIS_BUILD_NUMBER}; else echo 1.0.0.${TRAVIS_BUILD_NUMBER}; fi;) -install: - - dotnet restore build.proj script: - export FrameworkPathOverride=$(dirname $(which mono))/../lib/mono/4.5-api/ - - dotnet fake run build.fsx -- build test -ll Diag + - fake run build.fsx -- build test -ll Diag deploy: - provider: script - script: dotnet fake run build.fsx -- pack push -ll Diag + script: fake run build.fsx -- pack push -ll Diag skip_cleanup: true on: tags: true diff --git a/build.cmd b/build.cmd index 3986414..5119630 100644 --- a/build.cmd +++ b/build.cmd @@ -1,3 +1,2 @@ @echo off -dotnet restore build.proj -dotnet fake run build.fsx -- build \ No newline at end of file +fake run build.fsx -- build \ No newline at end of file diff --git a/build.proj b/build.proj deleted file mode 100644 index 5483b72..0000000 --- a/build.proj +++ /dev/null @@ -1,10 +0,0 @@ - - - - netstandard2.0 - - - - - - diff --git a/build.sh b/build.sh index f19bb05..b93f96d 100755 --- a/build.sh +++ b/build.sh @@ -1,3 +1,2 @@ #!/bin/bash -dotnet restore build.proj -dotnet fake run build.fsx -- build \ No newline at end of file +fake run build.fsx -- build \ No newline at end of file diff --git a/fake.cmd b/fake.cmd new file mode 100644 index 0000000..2f757d1 --- /dev/null +++ b/fake.cmd @@ -0,0 +1,7 @@ +SET TOOL_PATH=.fake + +IF NOT EXIST "%TOOL_PATH%\fake.exe" ( + dotnet tool install fake-cli --tool-path ./%TOOL_PATH% +) + +"%TOOL_PATH%/fake.exe" %* \ No newline at end of file diff --git a/fake.sh b/fake.sh new file mode 100644 index 0000000..4bd92af --- /dev/null +++ b/fake.sh @@ -0,0 +1,27 @@ +#!/usr/bin/env bash + +set -eu +set -o pipefail + +# liberated from https://stackoverflow.com/a/18443300/433393 +realpath() { + OURPWD=$PWD + cd "$(dirname "$1")" + LINK=$(readlink "$(basename "$1")") + while [ "$LINK" ]; do + cd "$(dirname "$LINK")" + LINK=$(readlink "$(basename "$1")") + done + REALPATH="$PWD/$(basename "$1")" + cd "$OURPWD" + echo "$REALPATH" +} + +TOOL_PATH=$(realpath .fake) +FAKE="$TOOL_PATH"/fake + +if ! [ -e "$FAKE" ] +then + dotnet tool install fake-cli --tool-path "$TOOL_PATH" +fi +"$FAKE" "$@" diff --git a/readme.md b/readme.md index be9cbd1..e1db639 100644 --- a/readme.md +++ b/readme.md @@ -1,6 +1,6 @@ Xake is a build utility that uses the full power of the F# programming language. Xake is inspired by [shake](https://github.com/ndmitchell/shake) build tool. -[![Build Status](https://travis-ci.org/xakebuild/Xake.svg?branch=dev)](https://travis-ci.org/xakebuild/Xake) +[![Build Status](https://travis-ci.org/Fakebuild/Xake.svg?branch=dev)](https://travis-ci.org/xakebuild/Xake) ## Sample script @@ -29,12 +29,13 @@ To run this script: 1. Clone the project: - ``` + ```bash git clone http://github.com/xakebuild/xake ``` + 1. Run the "Hello world" build sctipt: - ``` + ```bash cd samples dotnet restore dotnet-fake.csproj dotnet fake run gettingstarted.fsx @@ -51,8 +52,7 @@ To run this script: Once you cloned the repository you are ready to compile and test the binaries: ``` -dotnet restore build.proj -dotnet fake run build.fsx -- build test +fake run build.fsx -- build test ``` ... or use `build.cmd` (`build.sh`) in the root folder @@ -68,4 +68,3 @@ dotnet fake run build.fsx -- build test Xake requires 'pkg-config' to locate mono runtime. Pkg-config utility is deployed with mono, but it's not included in $PATH. The options available are described on [monobjc mailing list](http://www.mail-archive.com/users@lists.monobjc.net/msg00235.html) - From a5b9dd69a337be76f2a9b9f78267499f85405338 Mon Sep 17 00:00:00 2001 From: Oleg Zaimkin Date: Tue, 12 Nov 2019 14:56:25 +0700 Subject: [PATCH 12/22] fixed travis script --- .travis.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index cf7a207..f11c0c9 100644 --- a/.travis.yml +++ b/.travis.yml @@ -4,10 +4,10 @@ dotnet: 3.0 env: VER=$(if [[ "${TRAVIS_TAG:0:1}" == "v" ]]; then echo ${TRAVIS_TAG:1}.${TRAVIS_BUILD_NUMBER}; else echo 1.0.0.${TRAVIS_BUILD_NUMBER}; fi;) script: - export FrameworkPathOverride=$(dirname $(which mono))/../lib/mono/4.5-api/ - - fake run build.fsx -- build test -ll Diag + - ./fake.sh run build.fsx -- build test -ll Diag deploy: - provider: script - script: fake run build.fsx -- pack push -ll Diag + script: ./fake.sh run build.fsx -- pack push -ll Diag skip_cleanup: true on: tags: true From 87af8a148d23a1eae3c1434e2be3a16d1549648b Mon Sep 17 00:00:00 2001 From: Oleg Zaimkin Date: Tue, 12 Nov 2019 15:12:53 +0700 Subject: [PATCH 13/22] granted +x permissions to shell script --- .travis.yml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.travis.yml b/.travis.yml index f11c0c9..e18a02d 100644 --- a/.travis.yml +++ b/.travis.yml @@ -2,6 +2,8 @@ language: csharp mono: latest dotnet: 3.0 env: VER=$(if [[ "${TRAVIS_TAG:0:1}" == "v" ]]; then echo ${TRAVIS_TAG:1}.${TRAVIS_BUILD_NUMBER}; else echo 1.0.0.${TRAVIS_BUILD_NUMBER}; fi;) +install: + - chmod +x ./fake.sh script: - export FrameworkPathOverride=$(dirname $(which mono))/../lib/mono/4.5-api/ - ./fake.sh run build.fsx -- build test -ll Diag From 7edee708c315950d1ea40485a8f507267bb2a4b6 Mon Sep 17 00:00:00 2001 From: OlegZee Date: Thu, 14 Nov 2019 00:17:26 +0700 Subject: [PATCH 14/22] removed net46 target --- build.fsx | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/build.fsx b/build.fsx index 92da69b..e51c65e 100644 --- a/build.fsx +++ b/build.fsx @@ -8,7 +8,7 @@ open Xake open Xake.Tasks -let frameworks = ["netstandard2.0"; "net46"] +let frameworks = ["netstandard2.0"] let libtargets = [ for t in frameworks do for e in ["dll"; "xml"] -> sprintf "out/%s/Xake.%s" t e ] From 3f998ab30bac967d87c3144fb9a514c4db535838 Mon Sep 17 00:00:00 2001 From: OlegZee Date: Thu, 14 Nov 2019 01:05:46 +0700 Subject: [PATCH 15/22] removed net46 from proj file, refreshed build.fsx deps --- build.fsx | 2 +- build.fsx.lock | 4 ++-- src/core/Xake.fsproj | 5 +---- 3 files changed, 4 insertions(+), 7 deletions(-) diff --git a/build.fsx b/build.fsx index e51c65e..fecc750 100644 --- a/build.fsx +++ b/build.fsx @@ -1,5 +1,5 @@ #r "paket: - nuget Xake ~> 1.1 prerelease //" + nuget Xake ~> 1.1.4 prerelease //" #if !FAKE #load ".fake/build.fsx/intellisense.fsx" diff --git a/build.fsx.lock b/build.fsx.lock index 5497458..c924b70 100644 --- a/build.fsx.lock +++ b/build.fsx.lock @@ -2,6 +2,6 @@ STORAGE: NONE RESTRICTION: == netstandard2.0 NUGET remote: https://api.nuget.org/v3/index.json - FSharp.Core (4.3.4) - Xake (1.1.0.413-alpha) + FSharp.Core (4.7) + Xake (1.1.4.427-beta) FSharp.Core (>= 4.3.4) diff --git a/src/core/Xake.fsproj b/src/core/Xake.fsproj index f33570f..b4e2db2 100644 --- a/src/core/Xake.fsproj +++ b/src/core/Xake.fsproj @@ -3,7 +3,7 @@ Xake Library - net46;netstandard2.0 + netstandard2.0 (c) OlegZee 2014-2019 https://github.com/Fakebuild/Xake @@ -42,7 +42,4 @@ - - - From bf60da265a3a825301429afacd649d919c3cd6ed Mon Sep 17 00:00:00 2001 From: OlegZee Date: Thu, 14 Nov 2019 01:13:38 +0700 Subject: [PATCH 16/22] updated tests env --- src/tests/tests.fsproj | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) diff --git a/src/tests/tests.fsproj b/src/tests/tests.fsproj index 5b6228b..2a4d8ad 100644 --- a/src/tests/tests.fsproj +++ b/src/tests/tests.fsproj @@ -1,7 +1,7 @@  - net46;netcoreapp2.0 + netcoreapp3.0 false @@ -26,11 +26,8 @@ - - - - - - + + + \ No newline at end of file From 87b96523e46afacc2fc6ee21e8a668d9a697d4cd Mon Sep 17 00:00:00 2001 From: OlegZee Date: Thu, 14 Nov 2019 01:25:09 +0700 Subject: [PATCH 17/22] updated regular run args --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index e18a02d..05e59ab 100644 --- a/.travis.yml +++ b/.travis.yml @@ -6,7 +6,7 @@ install: - chmod +x ./fake.sh script: - export FrameworkPathOverride=$(dirname $(which mono))/../lib/mono/4.5-api/ - - ./fake.sh run build.fsx -- build test -ll Diag + - ./fake.sh run build.fsx -- -ll Diag deploy: - provider: script script: ./fake.sh run build.fsx -- pack push -ll Diag From 7a8a3c130de693da1ef0008b45548cb2ea34b84d Mon Sep 17 00:00:00 2001 From: OlegZee Date: Thu, 14 Nov 2019 01:41:57 +0700 Subject: [PATCH 18/22] separated build steps --- .travis.yml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 05e59ab..2e71ca9 100644 --- a/.travis.yml +++ b/.travis.yml @@ -6,7 +6,8 @@ install: - chmod +x ./fake.sh script: - export FrameworkPathOverride=$(dirname $(which mono))/../lib/mono/4.5-api/ - - ./fake.sh run build.fsx -- -ll Diag + - ./fake.sh run build.fsx -- build -ll Diag + - ./fake.sh run build.fsx -- test -ll Diag deploy: - provider: script script: ./fake.sh run build.fsx -- pack push -ll Diag From a31984d4b8ca81f2098062b08de4e5c574f670a0 Mon Sep 17 00:00:00 2001 From: OlegZee Date: Sat, 16 Nov 2019 00:47:46 +0700 Subject: [PATCH 19/22] not using fsx to build --- .travis.yml | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/.travis.yml b/.travis.yml index 2e71ca9..8535ef5 100644 --- a/.travis.yml +++ b/.travis.yml @@ -5,9 +5,8 @@ env: VER=$(if [[ "${TRAVIS_TAG:0:1}" == "v" ]]; then echo ${TRAVIS_TAG:1}.${TRAV install: - chmod +x ./fake.sh script: - - export FrameworkPathOverride=$(dirname $(which mono))/../lib/mono/4.5-api/ - - ./fake.sh run build.fsx -- build -ll Diag - - ./fake.sh run build.fsx -- test -ll Diag + - dotnet build src/core /p:Version=$VER -c Release /p:DocumentationFile=Xake.xml + - dotnet test src/test -c Release deploy: - provider: script script: ./fake.sh run build.fsx -- pack push -ll Diag From 861953dca15d58a5ce1d685961f56b5808882f4d Mon Sep 17 00:00:00 2001 From: OlegZee Date: Sat, 16 Nov 2019 01:05:46 +0700 Subject: [PATCH 20/22] typo --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 8535ef5..f3f5a45 100644 --- a/.travis.yml +++ b/.travis.yml @@ -6,7 +6,7 @@ install: - chmod +x ./fake.sh script: - dotnet build src/core /p:Version=$VER -c Release /p:DocumentationFile=Xake.xml - - dotnet test src/test -c Release + - dotnet test src/tests -c Release deploy: - provider: script script: ./fake.sh run build.fsx -- pack push -ll Diag From e838bb0398918b3d978d881d87a0ac3911a5d231 Mon Sep 17 00:00:00 2001 From: Oleg Zee Date: Sun, 24 Nov 2019 22:25:46 +0700 Subject: [PATCH 21/22] attempt to improve build time --- .travis.yml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index f3f5a45..224c47b 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,12 +1,11 @@ language: csharp -mono: latest dotnet: 3.0 env: VER=$(if [[ "${TRAVIS_TAG:0:1}" == "v" ]]; then echo ${TRAVIS_TAG:1}.${TRAVIS_BUILD_NUMBER}; else echo 1.0.0.${TRAVIS_BUILD_NUMBER}; fi;) install: - chmod +x ./fake.sh script: - dotnet build src/core /p:Version=$VER -c Release /p:DocumentationFile=Xake.xml - - dotnet test src/tests -c Release + - dotnet test src/tests -c Release -p:ParallelizeTestCollections=false deploy: - provider: script script: ./fake.sh run build.fsx -- pack push -ll Diag From dce55e5392bc3706f0ffb1c74820471b42f5235a Mon Sep 17 00:00:00 2001 From: Oleg Zee Date: Sun, 24 Nov 2019 22:26:45 +0700 Subject: [PATCH 22/22] mono: none --- .travis.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.travis.yml b/.travis.yml index 224c47b..d121ea2 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,4 +1,5 @@ language: csharp +mono: none dotnet: 3.0 env: VER=$(if [[ "${TRAVIS_TAG:0:1}" == "v" ]]; then echo ${TRAVIS_TAG:1}.${TRAVIS_BUILD_NUMBER}; else echo 1.0.0.${TRAVIS_BUILD_NUMBER}; fi;) install: