From 014af4d4a0b194f55a042a1024b477b74568d1db Mon Sep 17 00:00:00 2001 From: Oleg Zaimkin Date: Fri, 8 Nov 2019 13:29:59 +0700 Subject: [PATCH 01/16] 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/16] 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 079c137a3ae6e8a21a7fd41516b8c4eb706d703b Mon Sep 17 00:00:00 2001 From: Oleg Zee Date: Wed, 21 Feb 2024 23:55:42 +0100 Subject: [PATCH 03/16] recompiled for netcore, dropped net 4.6 target, updated samples (referencing nuget), fixed console garbling in VS, added support for substitutions in phony rules, closing database on Ctrl-C, support for Tasks in recipes --- build.cmd | 3 +- build.fsx | 84 ++++++++++++++-------------------- build.fsx.lock | 14 ------ build.proj | 10 ---- build.sh | 3 +- docs/overview.md | 3 +- docs/todo.md | 3 +- global.json | 6 +++ readme.md | 14 +++--- samples/book/intro.fsx | 6 +-- samples/catch_errors.fsx | 3 +- samples/features.fsx | 9 +--- samples/gettingstarted.fsx | 5 +- samples/rmdir.fsx | 2 +- src/core/Database.fs | 2 +- src/core/DependencyAnalysis.fs | 3 +- src/core/ExecCore.fs | 56 +++++++++++++---------- src/core/ExecTypes.fs | 40 ++++++++-------- src/core/Fileset.fs | 2 +- src/core/Logging.fs | 49 ++++++++------------ src/core/Pickler.fs | 2 +- src/core/Program.fs | 2 +- src/core/Progress.fs | 2 +- src/core/RecipeBuilder.fs | 6 +++ src/core/ScriptFuncs.fs | 7 +-- src/core/Tasks/misc.fs | 22 +++++++-- src/core/WorkerPool.fs | 13 ++---- src/core/Xake.fsproj | 4 +- src/tests/tests.fsproj | 10 ++-- xake.sln | 5 -- 30 files changed, 180 insertions(+), 210 deletions(-) delete mode 100644 build.fsx.lock delete mode 100644 build.proj create mode 100644 global.json diff --git a/build.cmd b/build.cmd index 3986414..4d1719c 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 +dotnet fsi build.fsx -- -- build \ No newline at end of file diff --git a/build.fsx b/build.fsx index 0e27744..e572a62 100644 --- a/build.fsx +++ b/build.fsx @@ -1,14 +1,9 @@ -#r "paket: - nuget Xake ~> 1.1 prerelease //" - -#if !FAKE -#load ".fake/build.fsx/intellisense.fsx" -#endif +#r "nuget: Xake, 1.1.4.427-beta" open Xake open Xake.Tasks -let frameworks = ["netstandard2.0"; "net46"] +let frameworks = ["netstandard2.0" (*; "net46" *)] let libtargets = [ for t in frameworks do for e in ["dll"; "xml"] @@ -33,23 +28,19 @@ let getVersion () = recipe { let makePackageName = sprintf "Xake.%s.nupkg" -let dotnet arglist = recipe { - do! shell { +let dotnet arglist = + shell { cmd "dotnet" args arglist failonerror - } |> Recipe.Ignore -} + } |> Ignore do xakeScript { filelog "build.log" Verbosity.Diag // consolelog Verbosity.Normal rules [ - "main" => recipe { - do! need ["build"] - do! need ["test"] - } + "main" <<< ["build"; "test"] "build" <== libtargets "clean" => rm {dir "out"} @@ -59,37 +50,34 @@ do xakeScript { let! where = getVar("FILTER") - |> Recipe.map (function |Some clause -> ["--filter"; sprintf "Name~\"%s\"" clause] | None -> []) + |> map (function |Some clause -> ["--filter"; $"Name~\"{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"] @ where @ limitFwk } libtargets *..> recipe { - let! allFiles - = getFiles <| fileset { - basedir "src/core" - includes "Xake.fsproj" - includes "**/*.fs" - } + let! allFiles = getFiles <| fileset { + basedir "src/core" + includes "Xake.fsproj" + includes "**/*.fs" + } do! needFiles allFiles 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 +90,13 @@ 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 +104,12 @@ 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/build.fsx.lock b/build.fsx.lock deleted file mode 100644 index fd2204b..0000000 --- a/build.fsx.lock +++ /dev/null @@ -1,14 +0,0 @@ -STORAGE: NONE -RESTRICTION: == netstandard2.0 -NUGET - remote: https://api.nuget.org/v3/index.json - FSharp.Core (4.3.4) - Microsoft.Win32.Registry (4.4) - System.Security.AccessControl (>= 4.4) - System.Security.Principal.Windows (>= 4.4) - System.Security.AccessControl (4.4.1) - System.Security.Principal.Windows (>= 4.4) - System.Security.Principal.Windows (4.4.1) - Xake (1.0.3-alpha5) - FSharp.Core (>= 4.3.4) - Microsoft.Win32.Registry (>= 4.4) 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..359a510 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 +dotnet fsi build.fsx -- -- \ No newline at end of file diff --git a/docs/overview.md b/docs/overview.md index d3f5db6..497e026 100644 --- a/docs/overview.md +++ b/docs/overview.md @@ -37,7 +37,7 @@ The most simple, but structured script looks as follows: ```fsharp -#r @".tools/Xake.Core.dll" // (1) +#r "nuget: Xake, 1.1.4.427-beta" // (1) open Xake // (2) @@ -152,6 +152,7 @@ There're several forms of rules including: * `rule ( => )` - creates a phony rule (the rule that does not create a file) * `rule ( <== [targets])` - creates a phony rule which demands specified targets +* `rule ( <<< [targets])` - the same as above, but the targets are requested one by one (non-parallel excution) * `rule ( ..> )` - rule for single file or group of files matching the specified wildcards pattern. The file and an optional matching groups can be accessed via getTargetFile and getRuleMatch methods * `rule ( ..?> )` - allows to use function instead of file name or wildcards diff --git a/docs/todo.md b/docs/todo.md index 68def05..d4ffcb5 100644 --- a/docs/todo.md +++ b/docs/todo.md @@ -2,7 +2,6 @@ * change the first page to a tutorial with script and usage examples - * switch development to mono under windows * idea: xake script as a task. Override/inherit variables. How to change variable on the fly is the original question. (we have got it out of the box, need more info) * accept filemasks in 'need' parameters (WHY I added it here?, the use case is very unclear) * detect changes in build script (internal changes), e.g. new target added that was not in .xake database @@ -29,6 +28,8 @@ ## Done (top is recent) + * support tasks in line with recipes and asyncs + * rules should accept #seq not just the list * <<< for running tasks one by one. Current one runs in parallel only. * complete copyFiles method diff --git a/global.json b/global.json new file mode 100644 index 0000000..23e9da9 --- /dev/null +++ b/global.json @@ -0,0 +1,6 @@ +{ + "sdk": { + "rollForward": "major", + "version": "7.0.0" + } +} \ No newline at end of file diff --git a/readme.md b/readme.md index e10defb..da72650 100644 --- a/readme.md +++ b/readme.md @@ -15,7 +15,7 @@ See [documentation](docs/overview.md) for more details. The simple script looks like: ```fsharp -#r "paket: nuget Xake ~> 1.0 prerelease //" +#r "nuget: Xake, 1.1.4.427-beta" open Xake open Xake.Tasks.Dotnet @@ -32,7 +32,7 @@ This script compiles helloworld assembly from helloworld.cs file. ## Getting started -Make sure dotnet SDK 2.0+ is installed. dotnet 2.1.300+ is required to make production build as it properly write package metadata. +Make sure dotnet SDK 7.0+ is installed. 1. Clone the project: @@ -43,13 +43,12 @@ Make sure dotnet SDK 2.0+ is installed. dotnet 2.1.300+ is required to make prod ``` cd samples - dotnet restore dotnet-fake.csproj - dotnet fake run gettingstarted.fsx + dotnet fsi gettingstarted.fsx ``` 1. Run the showcase script: ``` - dotnet fake run features.fsx + dotnet fsi features.fsx ``` @@ -58,14 +57,15 @@ Make sure dotnet SDK 2.0+ is installed. dotnet 2.1.300+ is required to make prod 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 +dotnet fsi build.fsx -- -- build test ``` ... or use `build.cmd` (`build.sh`) in the root folder ## Getting started for Mono on Linux/OSX +> This is untested and mono nowadays is poorly explored territory for me. + Make sure mono with F# is installed and root certificates are imported: ``` diff --git a/samples/book/intro.fsx b/samples/book/intro.fsx index c664765..c16887f 100644 --- a/samples/book/intro.fsx +++ b/samples/book/intro.fsx @@ -1,6 +1,6 @@ -#r "paket: - nuget Xake ~> 1.1 prerelease - nuget Xake.Dotnet ~> 1.1 prerelease //" // (1) +#r "nuget: Xake, 1.1.4.427-beta" +#r "nuget: Xake.Dotnet, 1.1.4.7-beta" (1) + open Xake // (2) open Xake.Dotnet // (2.1) diff --git a/samples/catch_errors.fsx b/samples/catch_errors.fsx index 22f83ab..70bf25a 100644 --- a/samples/catch_errors.fsx +++ b/samples/catch_errors.fsx @@ -1,5 +1,4 @@ -#r "paket: nuget Xake ~> 1.1 prerelease //" - +#r "nuget: Xake, 1.1.4.427-beta" open Xake do xakeScript { diff --git a/samples/features.fsx b/samples/features.fsx index b4e42bb..739d56a 100644 --- a/samples/features.fsx +++ b/samples/features.fsx @@ -1,10 +1,5 @@ -#r "paket: - nuget Xake ~> 1.1 prerelease - nuget Xake.Dotnet ~> 1.1 prerelease //" - -#if !FAKE -#load ".fake/features.fsx/intellisense.fsx" -#endif +#r "nuget: Xake, 1.1.4.427-beta" +#r "nuget: Xake.Dotnet, 1.1.4.7-beta" // This a sample Xake script to show off some features. // diff --git a/samples/gettingstarted.fsx b/samples/gettingstarted.fsx index 4a25411..9df937f 100644 --- a/samples/gettingstarted.fsx +++ b/samples/gettingstarted.fsx @@ -1,6 +1,5 @@ -#r "paket: - nuget Xake ~> 1.1 prerelease - nuget Xake.Dotnet ~> 1.1 prerelease //" +#r "nuget: Xake, 1.1.4.427-beta" +#r "nuget: Xake.Dotnet, 1.1.4.7-beta" open Xake open Xake.Dotnet diff --git a/samples/rmdir.fsx b/samples/rmdir.fsx index 938760c..439d819 100644 --- a/samples/rmdir.fsx +++ b/samples/rmdir.fsx @@ -1,4 +1,4 @@ -#r "paket: nuget Xake ~> 1.1 prerelease //" +#r "nuget: Xake, 1.1.4.427-beta" open Xake open Xake.Tasks diff --git a/src/core/Database.fs b/src/core/Database.fs index d36dca3..1e45c6b 100644 --- a/src/core/Database.fs +++ b/src/core/Database.fs @@ -59,7 +59,7 @@ module Storage = | FileDep _ -> 1 | EnvVar _ -> 2 | Var _ -> 3 - | AlwaysRerun _ -> 4 + | 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) diff --git a/src/core/DependencyAnalysis.fs b/src/core/DependencyAnalysis.fs index 2f747b6..efc152e 100644 --- a/src/core/DependencyAnalysis.fs +++ b/src/core/DependencyAnalysis.fs @@ -25,7 +25,8 @@ let getExecTime ctx target = |> 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 +let getDepState getVar getFileList (getChangedDeps: Target -> ChangeReason list) x = + match x with | FileDep (a:File, wrtime) when not((File.exists a) && abs((File.getLastWriteTime a - wrtime).TotalMilliseconds) < TimeCompareToleranceMs) -> let dbgInfo = File.exists a |> function | false -> "file does not exists" diff --git a/src/core/ExecCore.fs b/src/core/ExecCore.fs index 2e50fe8..f83132d 100644 --- a/src/core/ExecCore.fs +++ b/src/core/ExecCore.fs @@ -5,11 +5,6 @@ module internal ExecCore = open System.Text.RegularExpressions open DependencyAnalysis - /// Default options - [] - let XakeOptions = ExecOptions.Default - - open WorkerPool open Storage /// Writes the message with formatting to a log @@ -74,9 +69,12 @@ module internal ExecCore = 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]) + |PhonyRule (pattern,_), PhonyAction phony -> + // printfn $"Phony rule {phony}, pattern {pattern}" + // Some (rule, [], [target]) + phony + |> Path.matchGroups pattern "" + |> Option.map (fun groups -> rule,groups,[target]) | _ -> None @@ -187,7 +185,10 @@ module internal ExecCore = /// 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 + let isPhonyRule nm = function + |PhonyRule (pattern,_) -> + nm |> Path.matchGroups pattern "" |> Option.isSome + | _ -> false in match rules |> List.exists (isPhonyRule name) with | true -> PhonyAction name @@ -206,21 +207,21 @@ module internal ExecCore = let rec showDepStatus ii reasons = reasons |> function - | ChangeReason.Other reason -> + | Other reason -> print "%sReason: %s" (indent ii) reason - | ChangeReason.Depends t -> + | Depends t -> print "%sDepends '%s' - changed target" (indent ii) t.ShortName - | ChangeReason.DependsMissingTarget t -> + | DependsMissingTarget t -> print "%sDepends on '%s' - missing target" (indent ii) t.ShortName - | ChangeReason.FilesChanged (file:: rest) -> + | 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 - | ChangeReason.DependsMissingTarget t - | ChangeReason.Depends t -> + | DependsMissingTarget t + | Depends t -> showTargetStatus ii t | _ -> () and showTargetStatus ii target = @@ -276,10 +277,10 @@ module internal ExecCore = 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 + | 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 @@ -310,17 +311,25 @@ module internal ExecCore = /// 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 + | _, 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 finalize () = + db.PostAndReply Storage.CloseWait + FlushLogs() + + System.Console.CancelKeyPress + |> Event.add (fun _ -> + logger.Log Error "Build interrupted by user" + finalize() + exit 1) + let ctx = { Ordinal = 0 TaskPool = pool; Throttler = throttler @@ -363,8 +372,7 @@ module internal ExecCore = 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() + finalize() /// "need" implementation let need targets = diff --git a/src/core/ExecTypes.fs b/src/core/ExecTypes.fs index 5f87557..7f4c0ae 100644 --- a/src/core/ExecTypes.fs +++ b/src/core/ExecTypes.fs @@ -44,30 +44,28 @@ type ExecOptions = { /// Dump dependencies only Progress: bool -} with -static member Default = - { - ProjectRoot = System.IO.Directory.GetCurrentDirectory() - Threads = System.Environment.ProcessorCount - ConLogLevel = Normal - - CustomLogger = CustomLogger (fun _ -> false) ignore - FileLog = "build.log" - FileLogLevel = Chatty - Targets = [] - FailOnError = false - Vars = List.Empty - IgnoreCommandLine = false - Nologo = false - DbFileName = ".xake" - DryRun = false - DumpDeps = false - Progress = true +} with static member Default = { + ProjectRoot = System.IO.Directory.GetCurrentDirectory() + Threads = System.Environment.ProcessorCount + ConLogLevel = Normal + + CustomLogger = CustomLogger (fun _ -> false) ignore + FileLog = "build.log" + FileLogLevel = Chatty + Targets = [] + FailOnError = false + Vars = List.Empty + IgnoreCommandLine = false + Nologo = false + DbFileName = ".xake" + DryRun = false + DumpDeps = false + 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/Fileset.fs b/src/core/Fileset.fs index 9d481ba..d6ae187 100644 --- a/src/core/Fileset.fs +++ b/src/core/Fileset.fs @@ -249,7 +249,7 @@ module Fileset = Fileset (opts, pts @ [includes |> Path.parse |> Includes]) /// Adds excludes pattern to a fileset. - static member (--) (Fileset (opts,pts), excludes) = + static member (--) (Fileset (opts,pts), excludes): Fileset = Fileset (opts, pts @ [excludes |> Path.parse |> Excludes]) end diff --git a/src/core/Logging.fs b/src/core/Logging.fs index a8124df..61fa35b 100644 --- a/src/core/Logging.fs +++ b/src/core/Logging.fs @@ -124,9 +124,10 @@ module private ConsoleSink = let rec loop (progressMessage) = let wipeProgressMessage () = let len = progressMessage |> Option.fold (fun _ -> String.length) 0 - // printfn "cleft: %A len: %d" Console.CursorLeft len - match len - Console.CursorLeft with - | e when e > 0 -> System.Console.Write (String.replicate e " ") + Console.Out.Flush() + let cursorLeft = Console.CursorLeft + len - cursorLeft |> function + | e when e > 0 -> Console.Write (String.replicate e " ") | _ -> () let renderProgress = function | Some (outputString: string) -> @@ -141,9 +142,9 @@ module private ConsoleSink = Console.Write (sprintf "\r[%s] " level) Console.ForegroundColor <- textColor - System.Console.Write txt + Console.Write txt wipeProgressMessage() - System.Console.WriteLine() + Console.WriteLine() async { let! msg = mbox.Receive() @@ -152,16 +153,9 @@ module private ConsoleSink = match level |> levelToColor with | Some colors -> // in case of CRLF in the string make sure we washed out the progress message - let rec writeLines = function - | [] -> fun _ -> () - | (txt: string)::tail -> - function - | true -> - renderLineWithInfo colors (LevelToString level) txt - do writeLines tail false - | false -> System.Console.WriteLine txt; do writeLines tail false - - writeLines (text.Split('\n') |> List.ofArray) true + text.Split('\n') |> Seq.iteri (function + | 0 -> renderLineWithInfo colors (LevelToString level) + | _ -> System.Console.WriteLine) renderProgress progressMessage | _ -> () @@ -181,7 +175,8 @@ module private ConsoleSink = | Flush ch -> wipeProgressMessage() - Console.Write "\r" + do! Console.Out.FlushAsync() |> Async.AwaitTask + ch.Reply () return! loop None @@ -206,9 +201,7 @@ let private ConsoleLoggerBase (write: Level -> string -> unit) maxLevel = /// Simplistic console logger. let DumbConsoleLogger = - ConsoleLoggerBase ( - fun level -> (LevelToString level) |> sprintf "[%s] %s" >> System.Console.WriteLine - ) + ConsoleLoggerBase (fun l -> l |> LevelToString |> sprintf "[%s] %s" >> System.Console.WriteLine) /// Console logger with colors highlighting let ConsoleLogger = @@ -217,7 +210,7 @@ let ConsoleLogger = /// Ensures all logs finished pending output. let FlushLogs () = try - ConsoleSink.po.PostAndReply (ConsoleSink.Flush, 200) |> ignore + ConsoleSink.po.PostAndTryAsyncReply (ConsoleSink.Flush, 200) |> Async.RunSynchronously |> ignore with _ -> () /// Draws a progress bar to console log. @@ -233,9 +226,7 @@ let WriteConsoleProgress = let CombineLogger (log1 : ILogger) (log2 : ILogger) = { new ILogger with member __.Log level (fmt : Printf.StringFormat<'a, unit>) : 'a = - let write s = - log1.Log level "%s" s - log2.Log level "%s" s + let write s = log1.Log level "%s" s; log2.Log level "%s" s Printf.kprintf write fmt } /// @@ -254,11 +245,11 @@ let PrefixLogger (prefix:string) (log : ILogger) = /// /// let parseVerbosity = function - | "Silent" -> Verbosity.Silent - | "Quiet" -> Verbosity.Quiet - | "Normal" -> Verbosity.Normal - | "Loud" -> Verbosity.Loud - | "Chatty" -> Verbosity.Chatty - | "Diag" -> Verbosity.Diag + | "Silent" -> Silent + | "Quiet" -> Quiet + | "Normal" -> Normal + | "Loud" -> Loud + | "Chatty" -> Chatty + | "Diag" -> Diag | s -> failwithf "invalid verbosity: %s. Expected one of %s" s "Silent | Quiet | Normal | Loud | Chatty | Diag" diff --git a/src/core/Pickler.fs b/src/core/Pickler.fs index c6560d8..701c22a 100644 --- a/src/core/Pickler.fs +++ b/src/core/Pickler.fs @@ -84,7 +84,7 @@ module Pickler = /// let option pu = alt - (function | None _ -> 0 | Some _ -> 1) + (function | None -> 0 | Some _ -> 1) [| wrap ((fun () -> None), ignore) unit wrap (Some, Option.get) pu diff --git a/src/core/Program.fs b/src/core/Program.fs index 887d0bc..a9ebf89 100644 --- a/src/core/Program.fs +++ b/src/core/Program.fs @@ -21,7 +21,7 @@ module internal ParseArgs = begin | "-h" | "/h" | "--help" | "/help" | "/?" | "-?" -> printf """ Usage: - fsi