diff --git a/.gitignore b/.gitignore index 8bbb6ff..931a514 100644 --- a/.gitignore +++ b/.gitignore @@ -14,6 +14,7 @@ _UpgradeReport* packages .nuget .paket +.ionide # Ignore Visual Studio files *.pdb @@ -32,6 +33,8 @@ TestResult.* .xake* .fake .vs/ +.vscode/ +.ionide/ samples/**/*.exe samples/**/*.dll samples/**/*.fsx.lock diff --git a/.travis.yml b/.travis.yml index d534405..d121ea2 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,15 +1,15 @@ language: csharp -mono: latest -dotnet: 2.1.300 +mono: none +dotnet: 3.0 env: VER=$(if [[ "${TRAVIS_TAG:0:1}" == "v" ]]; then echo ${TRAVIS_TAG:1}.${TRAVIS_BUILD_NUMBER}; else echo 1.0.0.${TRAVIS_BUILD_NUMBER}; fi;) install: - - dotnet restore build.proj + - chmod +x ./fake.sh script: - - export FrameworkPathOverride=$(dirname $(which mono))/../lib/mono/4.5-api/ - - dotnet fake run build.fsx -- build test -ll Diag + - dotnet build src/core /p:Version=$VER -c Release /p:DocumentationFile=Xake.xml + - dotnet test src/tests -c Release -p:ParallelizeTestCollections=false deploy: - provider: script - script: dotnet fake run build.fsx -- pack push -ll Diag + script: ./fake.sh run build.fsx -- pack push -ll Diag skip_cleanup: true on: tags: true 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.cmd b/build.cmd index 3986414..5119630 100644 --- a/build.cmd +++ b/build.cmd @@ -1,3 +1,2 @@ @echo off -dotnet restore build.proj -dotnet fake run build.fsx -- build \ No newline at end of file +fake run build.fsx -- build \ No newline at end of file diff --git a/build.fsx b/build.fsx index 0e27744..fecc750 100644 --- a/build.fsx +++ b/build.fsx @@ -1,5 +1,5 @@ #r "paket: - nuget Xake ~> 1.1 prerelease //" + nuget Xake ~> 1.1.4 prerelease //" #if !FAKE #load ".fake/build.fsx/intellisense.fsx" @@ -8,26 +8,23 @@ open Xake open Xake.Tasks -let frameworks = ["netstandard2.0"; "net46"] +let frameworks = ["netstandard2.0"] let libtargets = [ for t in frameworks do - for e in ["dll"; "xml"] - -> sprintf "out/%s/Xake.%s" t e - ] + for e in ["dll"; "xml"] -> sprintf "out/%s/Xake.%s" t e ] 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") - |> Recipe.map ( + getVar "SUFFIX" + |> map ( function | None -> "-beta" | Some "" -> "" // this is release! - | Some s -> "-" + s - ) + | Some s -> "-" + s ) return ver + verSuffix } @@ -37,8 +34,7 @@ let dotnet arglist = recipe { do! shell { cmd "dotnet" args arglist - failonerror - } |> Recipe.Ignore + failonerror } |> Ignore } do xakeScript { @@ -46,10 +42,7 @@ do xakeScript { // consolelog Verbosity.Normal rules [ - "main" => recipe { - do! need ["build"] - do! need ["test"] - } + "main" <<< ["build"; "test"] "build" <== libtargets "clean" => rm {dir "out"} @@ -58,13 +51,13 @@ do xakeScript { do! alwaysRerun() let! where = - getVar("FILTER") - |> Recipe.map (function |Some clause -> ["--filter"; sprintf "Name~\"%s\"" clause] | None -> []) + getVar "FILTER" + |> map (function |Some clause -> ["--filter"; sprintf "Name~\"%s\"" clause] | None -> []) // in case of travis only run tests for standard runtime, eventually will add more - let! limitFwk = getEnv("TRAVIS") |> Recipe.map (function | Some _ -> ["-f:netcoreapp2.0"] | _ -> []) + let! limitFwk = getEnv "TRAVIS" |> map (function | Some _ -> ["-f:netcoreapp2.0"] | _ -> []) - do! dotnet <| ["test"; "src/tests"; "-c"; "Release"] @ where @ limitFwk + do! dotnet <| ["test"; "src/tests"; "-c"; "Release"; "-p:ParallelizeTestCollections=false"] @ where @ limitFwk } libtargets *..> recipe { @@ -80,16 +73,14 @@ do xakeScript { let! version = getVersion() for framework in frameworks do - do! dotnet - [ - "build" - "src/core" - "/p:Version=" + version - "--configuration"; "Release" - "--framework"; framework - "--output"; "../../out/" + framework - "/p:DocumentationFile=Xake.xml" - ] + do! dotnet [ + "build" + "src/core" + "/p:Version=" + version + "--configuration"; "Release" + "--framework"; framework + "--output"; "../../out/" + framework + "/p:DocumentationFile=Xake.xml" ] } ] @@ -101,29 +92,25 @@ 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" - ] + let! ver = getRuleMatch "ver" + 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 "push" => recipe { 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 "" - ] + 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 "" ] } ] } diff --git a/build.fsx.lock b/build.fsx.lock index 5497458..c924b70 100644 --- a/build.fsx.lock +++ b/build.fsx.lock @@ -2,6 +2,6 @@ STORAGE: NONE RESTRICTION: == netstandard2.0 NUGET remote: https://api.nuget.org/v3/index.json - FSharp.Core (4.3.4) - Xake (1.1.0.413-alpha) + FSharp.Core (4.7) + Xake (1.1.4.427-beta) FSharp.Core (>= 4.3.4) diff --git a/build.proj b/build.proj deleted file mode 100644 index 5483b72..0000000 --- a/build.proj +++ /dev/null @@ -1,10 +0,0 @@ - - - - netstandard2.0 - - - - - - diff --git a/build.sh b/build.sh index f19bb05..b93f96d 100755 --- a/build.sh +++ b/build.sh @@ -1,3 +1,2 @@ #!/bin/bash -dotnet restore build.proj -dotnet fake run build.fsx -- build \ No newline at end of file +fake run build.fsx -- build \ No newline at end of file diff --git a/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/fake.cmd b/fake.cmd new file mode 100644 index 0000000..2f757d1 --- /dev/null +++ b/fake.cmd @@ -0,0 +1,7 @@ +SET TOOL_PATH=.fake + +IF NOT EXIST "%TOOL_PATH%\fake.exe" ( + dotnet tool install fake-cli --tool-path ./%TOOL_PATH% +) + +"%TOOL_PATH%/fake.exe" %* \ No newline at end of file diff --git a/fake.sh b/fake.sh new file mode 100644 index 0000000..4bd92af --- /dev/null +++ b/fake.sh @@ -0,0 +1,27 @@ +#!/usr/bin/env bash + +set -eu +set -o pipefail + +# liberated from https://stackoverflow.com/a/18443300/433393 +realpath() { + OURPWD=$PWD + cd "$(dirname "$1")" + LINK=$(readlink "$(basename "$1")") + while [ "$LINK" ]; do + cd "$(dirname "$LINK")" + LINK=$(readlink "$(basename "$1")") + done + REALPATH="$PWD/$(basename "$1")" + cd "$OURPWD" + echo "$REALPATH" +} + +TOOL_PATH=$(realpath .fake) +FAKE="$TOOL_PATH"/fake + +if ! [ -e "$FAKE" ] +then + dotnet tool install fake-cli --tool-path "$TOOL_PATH" +fi +"$FAKE" "$@" diff --git a/readme.md b/readme.md index be9cbd1..e1db639 100644 --- a/readme.md +++ b/readme.md @@ -1,6 +1,6 @@ Xake is a build utility that uses the full power of the F# programming language. Xake is inspired by [shake](https://github.com/ndmitchell/shake) build tool. -[![Build Status](https://travis-ci.org/xakebuild/Xake.svg?branch=dev)](https://travis-ci.org/xakebuild/Xake) +[![Build Status](https://travis-ci.org/Fakebuild/Xake.svg?branch=dev)](https://travis-ci.org/xakebuild/Xake) ## Sample script @@ -29,12 +29,13 @@ To run this script: 1. Clone the project: - ``` + ```bash git clone http://github.com/xakebuild/xake ``` + 1. Run the "Hello world" build sctipt: - ``` + ```bash cd samples dotnet restore dotnet-fake.csproj dotnet fake run gettingstarted.fsx @@ -51,8 +52,7 @@ To run this script: Once you cloned the repository you are ready to compile and test the binaries: ``` -dotnet restore build.proj -dotnet fake run build.fsx -- build test +fake run build.fsx -- build test ``` ... or use `build.cmd` (`build.sh`) in the root folder @@ -68,4 +68,3 @@ dotnet fake run build.fsx -- build test Xake requires 'pkg-config' to locate mono runtime. Pkg-config utility is deployed with mono, but it's not included in $PATH. The options available are described on [monobjc mailing list](http://www.mail-archive.com/users@lists.monobjc.net/msg00235.html) - 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/BuildDatabase.fs b/src/core/BuildDatabase.fs new file mode 100644 index 0000000..52ac726 --- /dev/null +++ b/src/core/BuildDatabase.fs @@ -0,0 +1,53 @@ +module Xake.BuildDatabase + +open Xake.Util + +module Picklers = + + open Pickler + open ExecTypes + + let file = wrap (File.make, fun a -> a.FullName) str + + let target = + alt (function + | FileTarget _ -> 0 + | PhonyAction _ -> 1) + [| wrap (File.make >> FileTarget, fun (FileTarget f | OtherwiseFail f) -> f.Name) str + wrap (PhonyAction, (fun (PhonyAction a | OtherwiseFail a) -> a)) str |] + + let step = + wrap + ((fun (n, s, o, w) -> {StepInfo.Name = n; Start = s; OwnTime = o * 1; WaitTime = w * 1}), + fun ({StepInfo.Name = n; Start = s; OwnTime = o; WaitTime = w}) -> (n, s, o / 1, w / 1)) (quad str date int int) + + // Fileset of FilesetOptions * FilesetElement list + let dependency = + alt (function + | ArtifactDep _ -> 0 + | FileDep _ -> 1 + | EnvVar _ -> 2 + | Var _ -> 3 + | AlwaysRerun _ -> 4 + | GetFiles _ -> 5) + [| wrap (ArtifactDep, fun (ArtifactDep f | OtherwiseFail f) -> f) target + wrap (FileDep, fun (FileDep(f, ts) | OtherwiseFail (f, ts)) -> (f, ts)) (pair file date) + wrap (EnvVar, fun (EnvVar(n, v) | OtherwiseFail (n,v)) -> n, v) (pair str (option str)) + wrap (Var, fun (Var(n, v)| OtherwiseFail (n,v)) -> n, v) (pair str (option str)) + wrap0 AlwaysRerun + wrap (GetFiles, fun (GetFiles(fs, fi)| OtherwiseFail (fs,fi)) -> fs, fi) (pair filesetPickler filelistPickler) |] + + let result = + wrap + ((fun (r, built, deps, steps) -> + { Targets = r + Built = built + Depends = deps + Steps = steps }), + fun r -> (r.Targets, r.Built, r.Depends, r.Steps)) + (quad (list target) date (list dependency) (list step)) + +type DatabaseApi = Database.DatabaseApi + +/// Opens the database +let openDb path loggers = Database.openDb (Picklers.target, Picklers.result) path loggers \ No newline at end of file diff --git a/src/core/Common/Database.fs b/src/core/Common/Database.fs new file mode 100644 index 0000000..3f34972 --- /dev/null +++ b/src/core/Common/Database.fs @@ -0,0 +1,133 @@ +module Xake.Database + +open Xake + +let XakeDbVersion = "0.5" + +type Database<'target,'result> when 'target: comparison + = { Status : Map<'target, 'result> } + +type DatabaseHeader = + { XakeSign : string + XakeVer : string + ScriptDate : System.DateTime } + +(* API *) + +/// Creates a new database +let newDatabase() = { Database.Status = Map.empty } + +/// Adds result to a database +let internal addResult db targets (result: 'result) = + { db with Status = targets |> List.fold (fun m i -> Map.add i result m) db.Status } + +module private impl = + open System.IO + open Pickler + + let dbHeaderPu = + wrap + ((fun (sign, ver, scriptDate) -> + { DatabaseHeader.XakeSign = sign + XakeVer = ver + ScriptDate = scriptDate }), + fun h -> (h.XakeSign, h.XakeVer, h.ScriptDate)) + (triple str str date) + + let writeHeader w = + let h = + { DatabaseHeader.XakeSign = "XAKE" + XakeVer = XakeDbVersion + ScriptDate = System.DateTime.Now } + dbHeaderPu.pickle h w + + let openDatabaseFile (targetPu: 'target PU, resultPU: 'result PU) dbpath (logger : ILogger) = + let log = logger.Log + let bkpath = dbpath + ".bak" + // if exists backup restore + if File.Exists(bkpath) then + log Level.Message "Backup file found ('%s'), restoring db" + bkpath + try + File.Delete(dbpath) + with _ -> () + File.Move(bkpath, dbpath) + let db = ref (newDatabase()) + let recordCount = ref 0 + + // read database + if File.Exists(dbpath) then + let targetListPu = list targetPu + + try + use reader = new BinaryReader(File.OpenRead(dbpath)) + let stream = reader.BaseStream + let header = dbHeaderPu.unpickle reader + if header.XakeVer < XakeDbVersion then + failwith "Database version is old." + while stream.Position < stream.Length do + let targets = targetListPu.unpickle reader + let result = resultPU.unpickle reader + db := addResult !db targets result + recordCount := !recordCount + 1 + // if fails create new + with ex -> + log Level.Error + "Failed to read database, so recreating. Got \"%s\"" + <| ex.ToString() + try + File.Delete(dbpath) + with _ -> () + // check if we can cleanup db + if !recordCount > (!db).Status.Count * 5 then + log Level.Message "Compacting database" + File.Move(dbpath, bkpath) + use writer = + new BinaryWriter(File.Open(dbpath, FileMode.CreateNew)) + writeHeader writer + (!db).Status + |> Map.toSeq + |> Seq.map snd + |> Seq.iter (fun r -> resultPU.pickle r writer) + File.Delete(bkpath) + let dbwriter = + new BinaryWriter(File.Open (dbpath, FileMode.Append, FileAccess.Write)) + if dbwriter.BaseStream.Position = 0L then writeHeader dbwriter + db, dbwriter + +type DatabaseApi<'target,'result> = + | GetResult of 'target * AsyncReplyChannel<'result option> + | Store of 'target list * 'result + | Close + | CloseWait of AsyncReplyChannel + +/// Opens database. +let openDb (targetPu: 'target Pickler.PU, resultPU: 'result Pickler.PU) dbPath (logger : ILogger) = + let db, dbWriter = impl.openDatabaseFile (targetPu, resultPU) dbPath logger + let targetListPu = Pickler.list targetPu + + MailboxProcessor.Start(fun mbox -> + let rec loop (db) = + async { + let! msg = mbox.Receive() + match msg with + | GetResult(key, chan) -> + db.Status + |> Map.tryFind key + |> chan.Reply + return! loop (db) + | Store (targets, result) -> + targetListPu.pickle targets dbWriter + resultPU.pickle result dbWriter + return! loop (addResult db targets result) + | Close -> + logger.Log Info "Closing database" + dbWriter.Dispose() + return () + | CloseWait ch -> + logger.Log Info "Closing database" + dbWriter.Dispose() + ch.Reply() + return () + } + loop (!db)) diff --git a/src/core/Env.fs b/src/core/Common/Env.fs similarity index 100% rename from src/core/Env.fs rename to src/core/Common/Env.fs diff --git a/src/core/Common/Estimate.fs b/src/core/Common/Estimate.fs new file mode 100644 index 0000000..e426895 --- /dev/null +++ b/src/core/Common/Estimate.fs @@ -0,0 +1,80 @@ +module Xake.Estimate + +open Xake.Util + +[] type Ms + +type CpuState = | BusyUntil of int +type MachineState<'T when 'T:comparison> = + { Cpu: CpuState list; Tasks: Map<'T,int>} + +module internal Impl = + /// + /// Updates the first item matching the criteria and returns the updated value. + /// + /// + /// + let rec updateFirst predicate upd = function + | [] -> None,[] + | c::list when predicate c -> + let updated = upd c in + Some updated, updated :: list + | c::list -> + let result,list = (updateFirst predicate upd list) in + result, c::list + + let ignoreFailures f a = + try + f a + with _ -> + () + +/// +/// "Executes" one task +/// +/// Initial "machine" state +/// Provide a task information to exec function +/// The task to execute +let rec exec state getDurationDeps task = + // Gets the thread that will be freed after specific moment + let nearest after = + let ready (BusyUntil x) = if x <= after then 0 else x in + List.minBy ready + + match state.Tasks |> Map.tryFind task with + | Some result -> state,result + | None -> + let duration,deps = task |> getDurationDeps + let readyAt (BusyUntil x)= x + + let mstate, endTime = execMany state getDurationDeps deps + let slot = mstate.Cpu |> nearest endTime + let (Some (BusyUntil result)|OtherwiseFail result), newState = + mstate.Cpu |> Impl.updateFirst ((=) slot) (readyAt >> max endTime >> (+) duration >> BusyUntil) + {Cpu = newState; Tasks = mstate.Tasks |> Map.add task result}, result +// |> fun r -> +// printf "after %A" task +// printf " %A\n\n" r +// r + +/// Executes multiple targers simultaneously +and execMany state getDurationDeps goals = + let machineState,endTime = + goals |> List.fold ( + fun (prevState,prevTime) t -> + let newState,time = exec prevState getDurationDeps t in + (newState, max time prevTime) + ) (state, 0) + + machineState, endTime + +/// Gets estimated execution time for several target groups. Each group start when previous group is completed and runs in parallel. +let estimateEndTime getDurationDeps threadCount groups = + let machineState = {Cpu = BusyUntil 0 |> List.replicate threadCount; Tasks = Map.empty} + + groups |> List.fold (fun (state, _) group -> + let newState, endTime = execMany state getDurationDeps group + let newState = {newState with Cpu = newState.Cpu |> List.map (fun _ -> BusyUntil endTime)} + newState, endTime + ) (machineState, 0) + |> snd diff --git a/src/core/Logging.fs b/src/core/Common/Logging.fs similarity index 99% rename from src/core/Logging.fs rename to src/core/Common/Logging.fs index a8124df..0607cdb 100644 --- a/src/core/Logging.fs +++ b/src/core/Common/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/Common/Pickler.fs b/src/core/Common/Pickler.fs new file mode 100644 index 0000000..1b3ecc2 --- /dev/null +++ b/src/core/Common/Pickler.fs @@ -0,0 +1,89 @@ +module Xake.Pickler + +open System + +/// Pickler Combinators implementation +type OutState = IO.BinaryWriter +type InState = IO.BinaryReader + +/// +/// Main pickler type. +/// +type 'a PU = { pickle: 'a -> OutState -> unit; unpickle: InState -> 'a } + +/// +/// 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} + +/// +/// '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 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} + +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) + +/// +/// 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) + } + +/// +/// 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/Progress.fs b/src/core/Common/Progress.fs similarity index 62% rename from src/core/Progress.fs rename to src/core/Common/Progress.fs index 0a5c5f8..338a0c5 100644 --- a/src/core/Progress.fs +++ b/src/core/Common/Progress.fs @@ -1,5 +1,16 @@ module Xake.Progress +open Xake.Util +open Xake.Estimate + +/// +/// A message to a progress reporter. +/// +type ProgressMessage = + | Begin of System.TimeSpan + | Progress of System.TimeSpan * int + | End + module internal WindowsProgress = open System @@ -74,86 +85,17 @@ module internal WindowsProgress = with _ -> ignore -module internal Impl = - /// - /// Updates the first item matching the criteria and returns the updated value. - /// - /// - /// - let rec updateFirst predicate upd = function - | [] -> None,[] - | c::list when predicate c -> - let updated = upd c in - Some updated, updated :: list - | c::list -> - let result,list = (updateFirst predicate upd list) in - result, c::list - - let ignoreFailures f a = - try - f a - with _ -> - () - -/// Estimate the task execution times -module Estimate = - - type CpuState = | BusyUntil of int - type MachineState<'T when 'T:comparison> = - { Cpu: CpuState list; Tasks: Map<'T,int>} - - /// - /// "Executes" one task - /// - /// Initial "machine" state - /// Provide a task information to exec function - /// The task to execute - let rec exec state getDurationDeps task = - // Gets the thread that will be freed after specific moment - let nearest after = - let ready (BusyUntil x) = if x <= after then 0 else x in - List.minBy ready - - match state.Tasks |> Map.tryFind task with - | Some result -> state,result - | None -> - let duration,deps = task |> getDurationDeps - let readyAt (BusyUntil x)= x - - let mstate, endTime = execMany state getDurationDeps deps - let slot = mstate.Cpu |> nearest endTime - let (Some (BusyUntil result)|OtherwiseFail result), newState = - mstate.Cpu |> Impl.updateFirst ((=) slot) (readyAt >> max endTime >> (+) duration >> BusyUntil) - {Cpu = newState; Tasks = mstate.Tasks |> Map.add task result}, result -// |> fun r -> -// printf "after %A" task -// printf " %A\n\n" r -// r - - /// Executes multiple targers simultaneously - and execMany state getDurationDeps goals = - let machineState,endTime = - goals |> List.fold ( - fun (prevState,prevTime) t -> - let newState,time = exec prevState getDurationDeps t in - (newState, max time prevTime) - ) (state, 0) - - machineState, endTime - /// /// Interface for progress module. /// -type ProgressReport = - | TaskStart of Target - | TaskSuspend of Target - | TaskResume of Target - | TaskComplete of Target +type ProgressReport<'TKey> when 'TKey: comparison = + | TaskStart of 'TKey + | TaskSuspend of 'TKey + | TaskResume of 'TKey + | TaskComplete of 'TKey | Refresh | Finish -open Estimate - /// /// Creates "null" progress reporter. /// @@ -168,19 +110,6 @@ let emptyProgress () = } loop ()) -/// -/// Gets estimated execution time for several target groups. Each group start when previous group is completed and runs in parallel. -/// -let estimateEndTime getDurationDeps threadCount groups = - let machineState = {Cpu = BusyUntil 0 |> List.replicate threadCount; Tasks = Map.empty} - - groups |> List.fold (fun (state, _) group -> - let newState, endTime = execMany state getDurationDeps group - let newState = {newState with Cpu = newState.Cpu |> List.map (fun _ -> BusyUntil endTime)} - newState, endTime - ) (machineState, 0) - |> snd - /// /// Creates windows taskbar progress reporter. /// @@ -190,12 +119,12 @@ let estimateEndTime getDurationDeps threadCount groups = let openProgress getDurationDeps threadCount goals toConsole = let progressBar = WindowsProgress.createTaskbarIndicator() |> Impl.ignoreFailures - let machineState = {Cpu = BusyUntil 0 |> List.replicate threadCount; Tasks = Map.empty} + let machineState = {Cpu = BusyUntil 0 |> List.replicate threadCount; Tasks = Map.empty} let _,endTime = execMany machineState getDurationDeps goals let startTime = System.DateTime.Now - progressBar <| ProgressMessage.Begin (System.TimeSpan.FromMilliseconds (float endTime)) + progressBar <| Begin (System.TimeSpan.FromMilliseconds (float endTime)) /// We track currently running tasks and subtract already passed time from task duration let getDuration2 runningTasks t = @@ -204,24 +133,24 @@ let openProgress getDurationDeps threadCount goals toConsole = let originalDuration,deps = getDurationDeps t //do printf "\nestimate %A: %A\n" t timeToComplete in - originalDuration - runningTime |> max 0, deps + originalDuration - runningTime |> max 0, deps | _ -> getDurationDeps t let reportProgress (state, runningTasks) = - let timePassed = 1 * int (System.DateTime.Now - startTime).TotalMilliseconds in + let timePassed = 1 * int (System.DateTime.Now - startTime).TotalMilliseconds in let _,leftTime = execMany state (getDuration2 runningTasks) goals //printf "progress %A to %A " timePassed endTime let percentDone = timePassed * 100 / (timePassed + leftTime) |> int - let progressData = System.TimeSpan.FromMilliseconds (leftTime/1 |> float), percentDone - do ProgressMessage.Progress progressData |> progressBar + let progressData = System.TimeSpan.FromMilliseconds (leftTime/1 |> float), percentDone + do Progress progressData |> progressBar if toConsole then do WriteConsoleProgress progressData let updTime = ref System.DateTime.Now let advanceRunningTime rt = let now = System.DateTime.Now - let increment = 1 * int (now - !updTime).TotalMilliseconds + let increment = 1 * int (now - !updTime).TotalMilliseconds updTime := now rt |> Map.map ( fun _ (cpu,isRunning) -> @@ -240,7 +169,7 @@ let openProgress getDurationDeps threadCount goals toConsole = let runningTasks = runningTasks |> advanceRunningTime match msg with - | TaskStart target -> return! loop (state, runningTasks |> Map.add target (0, true)) + | TaskStart target -> return! loop (state, runningTasks |> Map.add target (0, true)) | TaskSuspend target -> return! loop (state, runningTasks |> Map.map (suspend target)) | TaskResume target -> return! loop (state, runningTasks |> Map.map (resume target)) | Refresh _ -> @@ -248,7 +177,7 @@ let openProgress getDurationDeps threadCount goals toConsole = return! loop (state,runningTasks) | TaskComplete target -> - let newState = ({state with Tasks = state.Tasks |> Map.add target 0}, runningTasks |> Map.remove target) + let newState = ({state with Tasks = state.Tasks |> Map.add target 0}, runningTasks |> Map.remove target) reportProgress newState return! loop newState diff --git a/src/core/RecipeBuilder.fs b/src/core/Common/Recipe.fs similarity index 83% rename from src/core/RecipeBuilder.fs rename to src/core/Common/Recipe.fs index e4ed98e..11457ce 100644 --- a/src/core/RecipeBuilder.fs +++ b/src/core/Common/Recipe.fs @@ -1,23 +1,26 @@ namespace Xake -module internal A = +// expression type +type Recipe<'a,'b> = Recipe of ('a -> Async<'a * 'b>) + +module internal RecipeAlgebra = let runAction (Recipe r) = r - let returnF a = Recipe (fun (s,_) -> async {return (s,a)}) + let returnF a = Recipe (fun s -> async {return (s,a)}) - let bindF m f = Recipe (fun (s, a) -> async { - let! (s', b) = runAction m (s, a) in - return! runAction (f b) (s', a) + let bindF m f = Recipe (fun s -> async { + let! (s', b) = runAction m s in + return! runAction (f b) s' }) - let bindA m f = Recipe (fun (s, r) -> async { + let bindA m f = Recipe (fun s -> async { let! a = m in - return! runAction (f a) (s, r) + return! runAction (f a) s }) let resultFromF m = m let callF f a = bindF (returnF a) f let delayF f = callF f () - let doneF = Recipe (fun (s,_) -> async {return (s,())}) + let doneF = Recipe (fun s -> async {return (s,())}) let ignoreF p = bindF p (fun _ -> doneF) let combineF f g = bindF f (fun _ -> g) @@ -61,7 +64,7 @@ module internal A = [] module Builder = - open A + open RecipeAlgebra type RecipeBuilder() = member this.Return(c) = returnF c member this.Zero() = doneF diff --git a/src/core/Common/RecipeFunctions.fs b/src/core/Common/RecipeFunctions.fs new file mode 100644 index 0000000..9ac313f --- /dev/null +++ b/src/core/Common/RecipeFunctions.fs @@ -0,0 +1,55 @@ +[] +module Xake.Recipe + +open Xake + +/// +/// Ignores action result in case task returns the value but you don't need it. +/// +/// +let Ignore act = act |> RecipeAlgebra.ignoreF + +/// +/// Translates the recipe result. +/// +let map f (rc: Recipe<_,_>) = recipe { + let! r = rc + return f r +} + +/// Gets action context. +let getCtx() = Recipe (fun c -> async {return (c,c)}) + +/// Updates the build result +let setCtx ctx = Recipe (fun _ -> async {return (ctx,())}) + +/// Consumes the task output and in case condition is met raises the error. +let FailWhen cond err (act: Recipe<_,_>) = + recipe { + let! b = act + if cond b then failwith err + return b + } + +/// +/// Supplemental for FailWhen to verify errorlevel set by system command. +/// +let Not0 = (<>) 0 + +/// +/// Error handler verifying result of system command. +/// +/// +let CheckErrorLevel rc = rc |> FailWhen Not0 "system command returned a non-zero result" + +/// +/// 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/Common/Util.fs b/src/core/Common/Util.fs new file mode 100644 index 0000000..2495561 --- /dev/null +++ b/src/core/Common/Util.fs @@ -0,0 +1,41 @@ +module Xake.Util + +let (><) f a b = f b a +let inline (|OtherwiseFail|) _ = failwith "no choice" +let inline (|OtherwiseFailErr|) message _ = failwith message + +type 't Agent = 't MailboxProcessor + +type 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) + + +/// Memoizes the recursive function. Memoized function is passed as first argument to f. +/// * `f` - parameter of type `('a -> 'b) -> 'a -> 'b` The function to be memoized. +let memoizeRec f = + let rec fn x = f fm x + and fm = fn |> memoize + in + fm + +/// Takes n first elements from a list. +let take cnt = + if cnt > 0 then List.chunkBySize cnt >> List.head else fun _ -> List.empty diff --git a/src/core/Common/WorkerPool.fs b/src/core/Common/WorkerPool.fs new file mode 100644 index 0000000..0d4ae26 --- /dev/null +++ b/src/core/Common/WorkerPool.fs @@ -0,0 +1,45 @@ +module Xake.WorkerPool + +type ExecMessage<'target,'result> = + | Run of string * 'target list * Async<'result> * AsyncReplyChannel> + +open System.Threading +open System.Threading.Tasks + +// execution context +let create (logger:ILogger) maxThreads = + // controls how many threads are running in parallel + let throttler = new SemaphoreSlim (maxThreads) + let log = logger.Log + + throttler, MailboxProcessor.Start(fun mbox -> + let rec loop(map) = async { + match! mbox.Receive() with + | Run(_, [], _, _) -> + log Error "Empty target list" + return! loop map + | Run(title, (artifact::_ as targets), action, chnl) -> + match map |> Map.tryFind artifact with + | Some (task:Task<'a>) -> + log Never "Task found for '%s'. Status %A" title task.Status + chnl.Reply <| Async.AwaitTask task + return! loop map + + | None -> + do log Info "Task queued '%s'" title + do! throttler.WaitAsync(-1) |> Async.AwaitTask |> Async.Ignore + + let task = Async.StartAsTask <| async { + try + let! buildResult = action + do log Info "Task done '%s'" title + return buildResult + finally + throttler.Release() |> ignore + } + + chnl.Reply <| Async.AwaitTask task + let map' = List.fold (fun m t -> m |> Map.add t task) map targets + return! loop map' + } + loop(Map.empty) ) diff --git a/src/core/CommonLib.fs b/src/core/CommonLib.fs deleted file mode 100644 index 0796fac..0000000 --- a/src/core/CommonLib.fs +++ /dev/null @@ -1,57 +0,0 @@ -namespace Xake - -[] -module internal CommonLib = - - 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) - - - ///**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) - - /// - /// 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/Database.fs b/src/core/Database.fs deleted file mode 100644 index d36dca3..0000000 --- a/src/core/Database.fs +++ /dev/null @@ -1,218 +0,0 @@ -namespace Xake - -module BuildLog = - open Xake - open System - - let XakeDbVersion = "0.4" - - type Database = { Status : Map } - - (* API *) - - /// Creates a new build result - let makeResult target = - { Targets = target - Built = DateTime.Now - Depends = [] - Steps = [] } - - /// Creates a new database - let newDatabase() = { Database.Status = Map.empty } - - /// Adds result to a database - let internal addResult db result = - { db with Status = result.Targets |> List.fold (fun m i -> Map.add i result m) db.Status } - -type 't Agent = 't MailboxProcessor - -module Storage = - open Xake - open BuildLog - - module private Persist = - open Pickler - - type DatabaseHeader = - { XakeSign : string - XakeVer : string - ScriptDate : Timestamp } - - let file = wrap (File.make, fun a -> a.FullName) str - - let target = - alt (function - | FileTarget _ -> 0 - | PhonyAction _ -> 1) - [| wrap (File.make >> FileTarget, fun (FileTarget f | OtherwiseFail f) -> f.Name) str - wrap (PhonyAction, (fun (PhonyAction a | OtherwiseFail a) -> a)) str |] - - let step = - wrap - ((fun (n, s, o, w) -> {StepInfo.Name = n; Start = s; OwnTime = o * 1; WaitTime = w * 1}), - fun ({StepInfo.Name = n; Start = s; OwnTime = o; WaitTime = w}) -> (n, s, o / 1, w / 1)) (quad str date int int) - - // Fileset of FilesetOptions * FilesetElement list - let dependency = - alt (function - | ArtifactDep _ -> 0 - | FileDep _ -> 1 - | EnvVar _ -> 2 - | Var _ -> 3 - | AlwaysRerun _ -> 4 - | GetFiles _ -> 5) - [| wrap (ArtifactDep, fun (ArtifactDep f | OtherwiseFail f) -> f) target - wrap (FileDep, fun (FileDep(f, ts) | OtherwiseFail (f, ts)) -> (f, ts)) (pair file date) - wrap (EnvVar, fun (EnvVar(n, v) | OtherwiseFail (n,v)) -> n, v) (pair str (option str)) - wrap (Var, fun (Var(n, v)| OtherwiseFail (n,v)) -> n, v) (pair str (option str)) - wrap0 AlwaysRerun - wrap (GetFiles, fun (GetFiles(fs, fi)| OtherwiseFail (fs,fi)) -> fs, fi) (pair filesetPickler filelistPickler) |] - - let result = - wrap - ((fun (r, built, deps, steps) -> - { Targets = r - Built = built - Depends = deps - Steps = steps }), - fun r -> (r.Targets, r.Built, r.Depends, r.Steps)) - (quad (list target) date (list dependency) (list step)) - - let dbHeader = - wrap - ((fun (sign, ver, scriptDate) -> - { DatabaseHeader.XakeSign = sign - XakeVer = ver - ScriptDate = scriptDate }), - fun h -> (h.XakeSign, h.XakeVer, h.ScriptDate)) - (triple str str date) - - module private impl = - open System.IO - open Persist - - let writeHeader w = - let h = - { DatabaseHeader.XakeSign = "XAKE" - XakeVer = XakeDbVersion - ScriptDate = System.DateTime.Now } - Persist.dbHeader.pickle h w - - let openDatabaseFile dbpath (logger : ILogger) = - let log = logger.Log - let resultPU = Persist.result - let bkpath = dbpath <.> "bak" - // if exists backup restore - if File.Exists(bkpath) then - log Level.Message "Backup file found ('%s'), restoring db" - bkpath - try - File.Delete(dbpath) - with _ -> () - File.Move(bkpath, dbpath) - let db = ref (newDatabase()) - let recordCount = ref 0 - // read database - if File.Exists(dbpath) then - try - use reader = new BinaryReader(File.OpenRead(dbpath)) - let stream = reader.BaseStream - let header = Persist.dbHeader.unpickle reader - if header.XakeVer < XakeDbVersion then - failwith "Database version is old." - while stream.Position < stream.Length do - let result = resultPU.unpickle reader - db := result |> addResult !db - recordCount := !recordCount + 1 - // if fails create new - with ex -> - log Level.Error - "Failed to read database, so recreating. Got \"%s\"" - <| ex.ToString() - try - File.Delete(dbpath) - with _ -> () - // check if we can cleanup db - if !recordCount > (!db).Status.Count * 5 then - log Level.Message "Compacting database" - File.Move(dbpath, bkpath) - use writer = - new BinaryWriter(File.Open(dbpath, FileMode.CreateNew)) - writeHeader writer - (!db).Status - |> Map.toSeq - |> Seq.map snd - |> Seq.iter (fun r -> resultPU.pickle r writer) - File.Delete(bkpath) - let dbwriter = - new BinaryWriter(File.Open (dbpath, FileMode.Append, FileAccess.Write)) - if dbwriter.BaseStream.Position = 0L then writeHeader dbwriter - db, dbwriter - - type DatabaseApi = - | GetResult of Target * AsyncReplyChannel> - | Store of BuildResult - | Close - | CloseWait of AsyncReplyChannel - - /// - /// Build result pickler. - /// - let resultPU = Persist.result - - /// - /// Opens database. - /// - /// Full xake database file name - /// - let openDb dbpath (logger : ILogger) = - let db, dbwriter = impl.openDatabaseFile dbpath logger - MailboxProcessor.Start(fun mbox -> - let rec loop (db) = - async { - let! msg = mbox.Receive() - match msg with - | GetResult(key, chnl) -> - db.Status - |> Map.tryFind key - |> chnl.Reply - return! loop (db) - | Store result -> - Persist.result.pickle result dbwriter - return! loop (result |> addResult db) - | Close -> - logger.Log Info "Closing database" - dbwriter.Dispose() - return () - | CloseWait ch -> - logger.Log Info "Closing database" - dbwriter.Dispose() - ch.Reply() - return () - } - loop (!db)) - -/// Utility methods to manipulate build stats -module internal Step = - - type DateTime = System.DateTime - - let start name = {StepInfo.Empty with Name = name; Start = DateTime.Now} - - /// - /// Updated last (current) build step - /// - let updateLastStep fn = function - | {Steps = current :: rest} as result -> {result with Steps = (fn current) :: rest} - | result -> result - - /// - /// Adds specific amount to a wait time - /// - let updateWaitTime delta = updateLastStep (fun c -> {c with WaitTime = c.WaitTime + delta}) - let updateTotalDuration = - let durationSince (startTime: DateTime) = int (DateTime.Now - startTime).TotalMilliseconds * 1 - updateLastStep (fun c -> {c with OwnTime = (durationSince c.Start) - c.WaitTime}) - let lastStep = function - | {Steps = current :: _} -> current - | _ -> start "dummy" diff --git a/src/core/DependencyAnalysis.fs b/src/core/DependencyAnalysis.fs index 2f747b6..7d609e7 100644 --- a/src/core/DependencyAnalysis.fs +++ b/src/core/DependencyAnalysis.fs @@ -1,7 +1,10 @@ module internal Xake.DependencyAnalysis open Xake -open Storage +open Xake.Util +open Xake.Estimate + +open Database /// /// Dependency state. @@ -20,9 +23,9 @@ let TimeCompareToleranceMs = 10.0 /// /// /// -let getExecTime ctx target = - (fun ch -> Storage.GetResult(target, ch)) |> ctx.Db.PostAndReply - |> Option.fold (fun _ r -> r.Steps |> List.sumBy (fun s -> s.OwnTime)) 0 +let getExecTime ctx (target: Target) = + (fun ch -> GetResult(target, ch)) |> ctx.Db.PostAndReply + |> Option.fold (fun _ r -> r.Steps |> List.sumBy (fun s -> s.OwnTime)) 0 /// Gets single dependency state and reason of a change. let getDepState getVar getFileList (getChangedDeps: Target -> ChangeReason list) = function @@ -30,26 +33,26 @@ let getDepState getVar getFileList (getChangedDeps: Target -> ChangeReason list) let dbgInfo = File.exists a |> function | false -> "file does not exists" | _ -> sprintf "write time: %A vs %A" (File.getLastWriteTime a) wrtime - ChangeReason.FilesChanged [a.Name], Some dbgInfo + FilesChanged [a.Name], Some dbgInfo | ArtifactDep (FileTarget file) when not (File.exists file) -> - ChangeReason.DependsMissingTarget (FileTarget file), None + DependsMissingTarget (FileTarget file), None | ArtifactDep dependeeTarget -> - dependeeTarget |> getChangedDeps |> List.filter ((<>) ChangeReason.NotChanged) + dependeeTarget |> getChangedDeps |> List.filter ((<>) NotChanged) |> function | [] -> NotChanged, None |item::_ -> - ChangeReason.Depends dependeeTarget, Some (sprintf "E.g. %A..." item) + Depends dependeeTarget, Some (sprintf "E.g. %A..." item) | EnvVar (name,value) when value <> Util.getEnvVar name -> - ChangeReason.Other <| sprintf "Environment variable %s was changed from '%A' to '%A'" name value (Util.getEnvVar name), None + Other <| sprintf "Environment variable %s was changed from '%A' to '%A'" name value (Util.getEnvVar name), None | Var (name,value) when value <> getVar name -> - ChangeReason.Other <| sprintf "Global script variable %s was changed '%A'->'%A'" name value (getVar name), None + Other <| sprintf "Global script variable %s was changed '%A'->'%A'" name value (getVar name), None | AlwaysRerun -> - ChangeReason.Other <| "AlwaysRerun rule", Some "Rule indicating target has to be run regardless dependencies state" + Other <| "AlwaysRerun rule", Some "Rule indicating target has to be run regardless dependencies state" | GetFiles (fileset,files) -> let newfiles = getFileList fileset @@ -83,7 +86,7 @@ let getChangeReasons ctx getTargetDeps target = match lastBuild with | Some {BuildResult.Depends = []} -> - [ChangeReason.Other "No dependencies", Some "It means target is not \"pure\" and depends on something beyond our control (oracle)"] + [Other "No dependencies", Some "It means target is not \"pure\" and depends on something beyond our control (oracle)"] | Some {BuildResult.Depends = depends; Targets = result} -> let depState = getDepState (Util.getVar ctx.Options) (toFileList ctx.Options.ProjectRoot) getTargetDeps @@ -96,18 +99,18 @@ let getChangeReasons ctx getTargetDeps target = | [] -> match result with | targetList when targetList |> List.exists (function | FileTarget file when not (File.exists file) -> true | _ -> false) -> - [ChangeReason.Other "target file does not exist", Some "The file has to be rebuilt regardless all its dependencies were not changed"] + [Other "target file does not exist", Some "The file has to be rebuilt regardless all its dependencies were not changed"] | _ -> [] | ls -> ls | _ -> - [ChangeReason.Other "Not built yet", Some "Target was not built before or build results were cleaned so we don't know dependencies."] + [Other "Not built yet", Some "Target was not built before or build results were cleaned so we don't know dependencies."] |> List.map fst // gets task duration and list of targets it depends on. No clue why one method does both. let getDurationDeps ctx getDeps t = match getDeps t with - | [] -> 0, [] + | [] -> 0, [] | deps -> let targets = deps |> List.collect (function |Depends t |DependsMissingTarget t -> [t] | _ -> []) (getExecTime ctx t, targets) @@ -126,7 +129,7 @@ let dumpDeps (ctx: ExecContext) (target: Target list) = let rec displayNestedDeps ii = function | ArtifactDep dependeeTarget -> - printfn "%sArtifact: %A" (indent ii) dependeeTarget.FullName + printfn "%sArtifact: %A" (indent ii) (Target.fullName dependeeTarget) showTargetStatus (ii+1) dependeeTarget | _ -> () and showDepStatus ii (d: Dependency) = @@ -158,7 +161,7 @@ let dumpDeps (ctx: ExecContext) (target: Target list) = if not <| doneTargets.ContainsKey(target) then doneTargets.Add(target, 1) - printfn "%sTarget %A" (indent ii) target.ShortName + printfn "%sTarget %A" (indent ii) (Target.shortName target) let lastResult = (fun ch -> GetResult(target, ch)) |> ctx.Db.PostAndReply match lastResult with diff --git a/src/core/ExecCore.fs b/src/core/ExecCore.fs index 2e50fe8..9db5ee8 100644 --- a/src/core/ExecCore.fs +++ b/src/core/ExecCore.fs @@ -1,381 +1,363 @@ -namespace Xake +module internal Xake.ExecCore + +open System.Text.RegularExpressions + +open Xake +open Xake.Util +open DependencyAnalysis +open Database + +/// Writes the message with formatting to a log +let traceLog (level:Logging.Level) fmt = + let write s = recipe { + 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) -module internal ExecCore = + |PhonyRule (name,_), PhonyAction phony when phony = name -> + // writeLog Verbose "Found phony pattern '%s'" name + Some (rule, [], [target]) - open System.Text.RegularExpressions - open DependencyAnalysis + | _ -> None - /// Default options - [] - let XakeOptions = ExecOptions.Default + rules |> List.tryPick matchRule - open WorkerPool - open Storage +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 - /// 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 - } +let raiseError ctx error details = + do reportError ctx error details + raise (XakeException(sprintf "Script failed (error code: %A)\n%A" error details)) - // 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 = +// 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 (Recipe action) targets = + let primaryTarget = targets |> List.head async { - let primaryTarget = ctx.Targets |> List.head - primaryTarget |> (Progress.TaskSuspend >> ctx.Progress.Post) + match ctx.NeedRebuild targets with + | true -> + let taskContext = newTaskContext targets ruleMatches ctx + do ctx.Logger.Log Command "Started %s as task %i" (Target.shortName primaryTarget) taskContext.Ordinal - do ctx.Throttler.Release() |> ignore - let! statuses = targets |> execParallel ctx - do! ctx.Throttler.WaitAsync(-1) |> Async.AwaitTask |> Async.Ignore + do Progress.TaskStart primaryTarget |> ctx.Progress.Post - primaryTarget |> (Progress.TaskResume >> ctx.Progress.Post) + let startResult = {BuildResult.makeResult targets with Steps = [BuildResult.startStep "all"]} + let! ({Result = result},_) = action { taskContext with Result = startResult } + let result = BuildResult.updateTotalDuration result - 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 + Store (result.Targets, result) |> ctx.Db.Post + + do Progress.TaskComplete primaryTarget |> ctx.Progress.Post + do ctx.Logger.Log Command "Completed %s in %A ms (wait %A ms)" (Target.shortName primaryTarget) (BuildResult.lastStep result).OwnTime (BuildResult.lastStep result).WaitTime + return Succeed + | false -> + do ctx.Logger.Log Command "Skipped %s (up to date)" (Target.shortName primaryTarget) + return Skipped } - /// 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 + let getAction = function + | FileRule (_, a) + | FileConditionRule (_, a) + | MultiFileRule (_, a) + | PhonyRule (_, a) -> a - // 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 = - 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 + // result expression is... + match target |> locateRule ctx.Rules ctx.Options.ProjectRoot with + | Some(rule,groups,targets) -> + let groupsMap = groups |> Map.ofSeq + async { + let taskTitle = Target.shortName target + let! waitTask = (fun channel -> WorkerPool.Run(taskTitle, target::targets, run groupsMap (getAction rule) targets, channel)) |> ctx.Workers.PostAndAsyncReply + let! status = waitTask + return target, status, ArtifactDep target } + | 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 target) "" + +/// Executes several artifacts in parallel. +and execParallel ctx = List.map (execOne ctx) >> Seq.ofList >> Async.Parallel + +/// Gets the status of dependency artifacts (obtained from 'need' calls). +/// +/// ExecStatus.Succeed,... in case at least one dependency was rebuilt +/// +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) (Target.shortName t) + | DependsMissingTarget t -> print "%sDepends on '%s' - missing target" (indent ii) (Target.shortName t) + | FilesChanged (file:: rest) -> print "%sFile is changed '%s' %s" (indent ii) file (if List.isEmpty rest then "" else sprintf " and %d more file(s)" <| List.length rest) + | reasons -> print "%sSome reason %A" (indent ii) reasons + + let rec displayNestedDeps ii = + function + | DependsMissingTarget t + | 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 target) 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 = Estimate.estimateEndTime (getDurationDeps ctx getDeps) options.Threads targetGroups |> toSec + + targetGroups |> List.collect id |> List.iter (showTargetStatus 0) + match targetGroups |> List.collect id |> List.collect getDeps with + | [] -> + ctx.Logger.Log Message "\n\n\tNo changed dependencies. Nothing to do.\n" + | _ -> + let parallelismMsg = + let endTimeTotal = Estimate.estimateEndTime (getDurationDeps ctx getDeps) 1 targetGroups |> toSec + if options.Threads > 1 && endTimeTotal > endTime * 1.05 then + sprintf "\n\tTotal tasks duration is (estimate) in %As\n\tParallelism degree: %.2f" endTimeTotal (endTimeTotal / endTime) + else "" + 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 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 + + let needRebuild (target: Target) = + getDeps >> + function + | [] -> false, "" + | Other reason::_ -> true, reason + | Depends t ::_ -> true, "Depends on target " + (Target.shortName t) + | DependsMissingTarget t ::_ -> true, sprintf "Depends on target %s (missing)" (Target.shortName t) + | FilesChanged (file::_) ::_ -> true, "File(s) changed " + file + | reasons -> true, sprintf "Some reason %A" reasons + >> + function + | false, _ -> false + | true, reason -> + do ctx.Logger.Log Info "Rebuild %A: %s" (Target.shortName target) reason + true + <| target + // todo improve output by printing primary target - 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) + 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 = BuildDatabase.openDb (options.ProjectRoot options.DbFileName) logger + + let ctx = { + Ordinal = 0 + Workers = pool; Throttler = throttler + Options = options; Rules = rules + Logger = logger; RootLogger = logger; Db = db + Progress = Progress.emptyProgress() + NeedRebuild = fun _ -> false + Targets = [] + RuleMatches = Map.empty + Result = BuildResult.makeResult [] } + + 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) + FlushLogs() + exit 2 + finally + db.PostAndReply Database.CloseWait + FlushLogs() + +/// "need" implementation +let need targets = recipe { + let startTime = System.DateTime.Now + + let! ctx = getCtx() + let! _,deps = targets |> execNeed ctx + + let totalDuration = int (System.DateTime.Now - startTime).TotalMilliseconds * 1 + let result' = {ctx.Result with Depends = ctx.Result.Depends @ deps} |> (BuildResult.updateWaitTime totalDuration) + do! setCtx { ctx with Result = result' } +} \ No newline at end of file diff --git a/src/core/ExecTypes.fs b/src/core/ExecTypes.fs index 5f87557..7aeaf55 100644 --- a/src/core/ExecTypes.fs +++ b/src/core/ExecTypes.fs @@ -1,6 +1,11 @@ -namespace Xake +[] +module Xake.ExecTypes open System.Threading +open Xake.Database + +type internal 't Agent = 't MailboxProcessor +[] type Ms = Estimate.Ms /// Script execution options type ExecOptions = { @@ -45,8 +50,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,33 +66,91 @@ 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> +type Timestamp = System.DateTime + +type Dependency = + | FileDep of File * Timestamp // regular file (such as source code file), triggers when file date/time is changed + | ArtifactDep of Target // other target (triggers when target is rebuilt) + | EnvVar of string * string option // environment variable + | Var of string * string option // any other data such as compiler version (not used yet) + | AlwaysRerun // trigger always + | GetFiles of Fileset * Filelist // depends on set of files. Triggers when resulting filelist is changed + +type StepInfo = + { Name: string; Start: System.DateTime; OwnTime: int; WaitTime: int } + with static member Empty = {Name = ""; Start = new System.DateTime(1900,1,1); OwnTime = 0; WaitTime = 0} + +type BuildResult = + { Targets : Target list + Built : Timestamp + Depends : Dependency list + Steps : StepInfo list } + +type 'ctx Rule = + | FileRule of string * Recipe<'ctx,unit> + | MultiFileRule of string list * Recipe<'ctx,unit> + | PhonyRule of string * Recipe<'ctx,unit> + | FileConditionRule of (string -> bool) * Recipe<'ctx,unit> +type 'ctx Rules = Rules of 'ctx Rule list /// Script execution context type ExecContext = { - TaskPool: TaskPool - Db: Agent + Workers: TaskPool + Db: Agent> Throttler: SemaphoreSlim Options: ExecOptions Rules: Rules Logger: ILogger RootLogger: ILogger - Progress: Agent + Progress: Agent> Targets: Target list RuleMatches: Map Ordinal: int NeedRebuild: Target list -> bool + Result: BuildResult } -module internal Util = +/// Defines common exception type +exception XakeException of string + +module internal Util = // TODO rename to an ExecOptions let private nullableToOption = function | null -> None | s -> Some s let getEnvVar = System.Environment.GetEnvironmentVariable >> nullableToOption let private valueByName variableName = function |name,value when name = variableName -> Some value | _ -> None let getVar (options: ExecOptions) name = options.Vars |> List.tryPick (valueByName name) + +[] +module BuildResult = + open System + + /// Creates a new build result + let makeResult targets = { Targets = targets; Built = DateTime.Now; Depends = []; Steps = [] } + + /// Start a new step + let startStep name = {StepInfo.Empty with Name = name; Start = DateTime.Now} + + /// Updated last (current) build step + let updateLastStep fn = function + | {Steps = current :: rest} as result -> {result with Steps = (fn current) :: rest} + | result -> result + + /// Adds specific amount to a wait time + let updateWaitTime delta = updateLastStep (fun c -> {c with WaitTime = c.WaitTime + delta}) + + /// Updates total duration of the build (adds to last step) + let updateTotalDuration = + let durationSince (startTime: DateTime) = int (DateTime.Now - startTime).TotalMilliseconds * 1 + updateLastStep (fun c -> {c with OwnTime = (durationSince c.Start) - c.WaitTime}) + + /// Gets the last (current) step + let lastStep = function + | {Steps = current :: _} -> current + | _ -> startStep "dummy" + \ No newline at end of file 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..20f1a64 100644 --- a/src/core/Fileset.fs +++ b/src/core/Fileset.fs @@ -1,297 +1,296 @@ -namespace Xake +[] +module Xake.Fileset -[] -module Fileset = +open System.IO +open Xake +open Xake.Util - 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/Path.fs b/src/core/Path.fs index f85ef95..4e6d386 100644 --- a/src/core/Path.fs +++ b/src/core/Path.fs @@ -1,258 +1,242 @@ -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 +open Xake.Util - | 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 deleted file mode 100644 index c6560d8..0000000 --- a/src/core/Pickler.fs +++ /dev/null @@ -1,91 +0,0 @@ -namespace Xake - -open System - -/// Pickler Combinators implementation -module Pickler = - - type OutState = System.IO.BinaryWriter - type InState = System.IO.BinaryReader - - /// - /// Main pickler type. - /// - type 'a PU = { pickle: 'a -> OutState -> unit; unpickle: InState -> 'a } - - /// - /// 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} - - /// - /// '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 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} - - 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) - - /// - /// 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) - } - - /// - /// 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/Prelude.fs b/src/core/Prelude.fs deleted file mode 100644 index d7fc990..0000000 --- a/src/core/Prelude.fs +++ /dev/null @@ -1,6 +0,0 @@ -[] -module Prelude - -let (><) f a b = f b a -let inline (|OtherwiseFail|) _ = failwith "no choice" -let inline (|OtherwiseFailErr|) message _ = failwith message diff --git a/src/core/ProcessExec.fs b/src/core/ProcessExec.fs deleted file mode 100644 index 5e53c39..0000000 --- a/src/core/ProcessExec.fs +++ /dev/null @@ -1,42 +0,0 @@ -// 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 - } diff --git a/src/core/RecipeFunctions.fs b/src/core/RecipeFunctions.fs deleted file mode 100644 index d2028c9..0000000 --- a/src/core/RecipeFunctions.fs +++ /dev/null @@ -1,88 +0,0 @@ -namespace Xake - -[] -module Recipe = - - open Xake - - /// - /// 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 - } - - /// - /// 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)}) - - /// - /// Updates the build result - /// - /// - let setResult s' = Recipe (fun (_,_) -> async {return (s',())}) - - /// - /// Finalizes current build step and starts a new one - /// - /// New step name - let newstep name = - Recipe (fun (r,_) -> - async { - let r' = Step.updateTotalDuration r - let r'' = {r' with Steps = (Step.start name) :: r'.Steps} - return (r'',()) - }) - - /// - /// 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 - } - - /// - /// Supplemental for FailWhen to verify errorlevel set by system command. - /// - let Not0 = (<>) 0 - - /// - /// Error handler verifying result of system command. - /// - /// - let CheckErrorLevel rc = rc |> FailWhen Not0 "system command returned a non-zero result" - - /// - /// 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 - } - -[] -module Action = - - let Ignore = Recipe.Ignore diff --git a/src/core/ScriptFuncs.fs b/src/core/ScriptFuncs.fs index 3f09e14..7e7474d 100644 --- a/src/core/ScriptFuncs.fs +++ b/src/core/ScriptFuncs.fs @@ -1,151 +1,125 @@ -namespace Xake +[] +module Xake.ScriptFuncs -[] -module ScriptFuncs = +open Xake.Util - open XakeScript +/// Gets the script options. +let getCtxOptions () = recipe { + let! (ctx: ExecContext) = getCtx() + return ctx.Options +} - /// - /// Gets the script options. - /// - let getCtxOptions () = recipe { - let! (ctx: ExecContext) = getCtx() - return ctx.Options - } - - /// - /// Executes and awaits specified artifacts. - /// - /// - let need targets = - action { - let! ctx = getCtx() - let t' = targets |> (List.map (ExecCore.makeTarget ctx)) - do! ExecCore.need t' - } - - let needFiles (Filelist files) = - files |> List.map FileTarget |> ExecCore.need - - let private record d = recipe { - let! result = getResult() - do! setResult { result with Depends = d :: result.Depends } - } - - /// - /// Instructs Xake to rebuild the target even if dependencies are not changed. - /// - let alwaysRerun() = AlwaysRerun |> record - - /// - /// Gets the environment variable. - /// - /// - let getEnv variableName = - let value = Util.getEnvVar variableName - action { - do! EnvVar (variableName,value) |> record - return value - } - - /// - /// Gets the global (options) variable. - /// - /// - let getVar variableName = recipe { - let! ctx = getCtx() - let value = Util.getVar ctx.Options variableName - - do! Var (variableName,value) |> record - return value - } - - /// - /// Gets the list of files matching specified fileset. - /// - /// - let getFiles fileset = recipe { - let! ctx = getCtx() - let files = fileset |> toFileList ctx.Options.ProjectRoot - do! GetFiles (fileset,files) |> record - - return files - } - - /// - /// Gets current target file - /// - let getTargetFile() = recipe { +/// Executes and awaits specified artifacts. +let need targets = + recipe { let! ctx = getCtx() - return ctx.Targets - |> function - | FileTarget file::_ -> file - | _ -> failwith "getTargetFile is not available for phony actions" + let t' = targets |> (List.map (ExecCore.makeTarget ctx)) + do! ExecCore.need t' } - /// - /// Gets current target file - /// - let getTargetFiles() : Recipe = recipe { - let! ctx = getCtx() - return ctx.Targets |> List.collect (function |FileTarget file -> [file] |_ -> failwith "Expected only a file targets"; []) - } - - /// - /// Gets current target file name with path - /// - let getTargetFullName() = recipe { - let! file = getTargetFile() - return File.getFullName file - } - - let getRuleMatches () = recipe { - let! ctx = getCtx() - return ctx.RuleMatches - } - - /// - /// Gets group (part of the name) by its name. - /// - let getRuleMatch key = action { - let! groups = getRuleMatches() - return groups |> Map.tryFind key |> function |Some v -> v | None -> "" +let needFiles (Filelist files) = + files |> List.map FileTarget |> ExecCore.need + +let private record d = recipe { + let! ctx = getCtx() + do! setCtx { ctx with Result = { ctx.Result with Depends = d :: ctx.Result.Depends } } +} + +/// +/// Instructs Xake to rebuild the target even if dependencies are not changed. +/// +let alwaysRerun() = AlwaysRerun |> record + +/// +/// Gets the environment variable. +/// +/// +let getEnv variableName = + let value = Util.getEnvVar variableName + recipe { + do! EnvVar (variableName,value) |> record + return value } - - /// - /// Writes a message to a log. - /// - let trace = ExecCore.traceLog - - /// Defines a rule that demands specified targets - /// e.g. "main" ==> ["build-release"; "build-debug"; "unit-test"] - let (<==) name targets = PhonyRule (name, recipe { - do! need targets - do! alwaysRerun() // always check demanded dependencies. Otherwise it wan't check any target is available - }) +/// +/// Gets the global (options) variable. +/// +/// +let getVar variableName = recipe { + let! ctx = getCtx() + let value = Util.getVar ctx.Options variableName + + do! Var (variableName,value) |> record + return value +} + +/// +/// Gets the list of files matching specified fileset. +/// +/// +let getFiles fileset = recipe { + let! ctx = getCtx() + let files = fileset |> toFileList ctx.Options.ProjectRoot + do! GetFiles (fileset,files) |> record + + return files +} + +let private takeFile (FileTarget file | OtherwiseFailErr "Expected only a file targets" file) = Some file + +/// Gets current target file +let getTargetFile() = recipe { + let! ctx = getCtx() + return ctx.Targets |> List.choose takeFile |> List.head +} + +/// Gets current target file +let getTargetFiles() = recipe { + let! (ctx: ExecContext) = getCtx() + return ctx.Targets |> List.choose takeFile +} + +/// +/// Gets current target file name with path +/// +let getTargetFullName() = recipe { + let! file = getTargetFile() + return File.getFullName file +} + +let getRuleMatches () = recipe { + let! ctx = getCtx() + return ctx.RuleMatches +} + +/// Gets group (part of the name) by its name. +let getRuleMatch key = action { + let! groups = getRuleMatches() + return groups |> Map.tryFind key |> function |Some v -> v | None -> "" +} + +/// Writes a message to a log. +let trace = ExecCore.traceLog + +/// Defines a rule that demands specified targets +/// e.g. "main" ==> ["build-release"; "build-debug"; "unit-test"] +let (<==) name targets = PhonyRule (name, recipe { + do! need targets + do! alwaysRerun() // always check demanded dependencies. Otherwise it wan't check any target is available +}) + +/// Finalizes current build step and starts a new one // TODO put it somewhere +let newstep name = recipe { + let! c = getCtx() + let r' = BuildResult.updateTotalDuration c.Result + let r'' = {r' with Steps = (BuildResult.startStep name) :: r'.Steps} + do! setCtx { c with Result = r''} +} - [] - 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. - let (<<<) name targets = PhonyRule (name, recipe { - for t in targets do - do! need [t] - 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 -> "" - +/// Defines a rule which demands the other targets to be sequentially built. +/// Unlike '<==' operator, this one waits the completion of one before issuing another rule. +let (<<<) name targets = PhonyRule (name, recipe { + for t in targets do + do! need [t] + do! alwaysRerun() +}) diff --git a/src/core/Target.fs b/src/core/Target.fs new file mode 100644 index 0000000..11d1272 --- /dev/null +++ b/src/core/Target.fs @@ -0,0 +1,40 @@ +[] +module Xake.Target + +let private stringCompare = if Env.isUnix then System.StringComparer.Ordinal else System.StringComparer.OrdinalIgnoreCase + +[] +type Target = + | FileTarget of Xake.File + | PhonyAction of string + +with + member private this.FullName = + match this with + | FileTarget file -> file.FullName + | PhonyAction name -> name + + override x.Equals(yobj) = + match yobj with + | :? Target as y -> stringCompare.Equals (x.FullName, y.FullName) + | _ -> false + + override x.GetHashCode() = stringCompare.GetHashCode x.FullName + interface System.IComparable with + member x.CompareTo y = + match y with + | :? Target as y -> stringCompare.Compare(x.FullName, y.FullName) + | _ -> invalidArg "y" "cannot compare target to different types" + +[] +module Target = + + /// Gets short (user friendly) target name + let shortName = function + | FileTarget file -> file.Name + | PhonyAction name -> name + + // Get fully qualifying target name + let fullName = function + | FileTarget file -> file.FullName + | PhonyAction name -> name diff --git a/src/core/Tasks/Cp.fs b/src/core/Tasks/Cp.fs index 6831985..c3a07f3 100644 --- a/src/core/Tasks/Cp.fs +++ b/src/core/Tasks/Cp.fs @@ -2,7 +2,6 @@ namespace Xake.Tasks open Xake open System.IO -open Xake.FileTasksImpl [] module CpImpl = diff --git a/src/core/Tasks/ProcessExec.fs b/src/core/Tasks/ProcessExec.fs new file mode 100644 index 0000000..e4e4fa4 --- /dev/null +++ b/src/core/Tasks/ProcessExec.fs @@ -0,0 +1,41 @@ +// common tasks +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 not (isNull e.Data) then handleErr e.Data) + proc.OutputDataReceived.Add(fun e -> if not (isNull e.Data) then handleStd e.Data) + + do proc.Start() |> ignore + + 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/Types.fs b/src/core/Types.fs deleted file mode 100644 index d0665ba..0000000 --- a/src/core/Types.fs +++ /dev/null @@ -1,80 +0,0 @@ -namespace Xake - -[] -module DomainTypes = - - let private stringCompare = if Env.isUnix then System.StringComparer.Ordinal else System.StringComparer.OrdinalIgnoreCase - - [] - type Target = - | FileTarget of File - | PhonyAction of string - - with - member internal this.ShortName = - match this with - | FileTarget file -> file.Name - | PhonyAction name -> name - member internal this.FullName = - match this with - | FileTarget file -> file.FullName - | PhonyAction name -> name - - override x.Equals(yobj) = - match yobj with - | :? Target as y -> stringCompare.Equals (x.FullName, y.FullName) - | _ -> false - - override x.GetHashCode() = stringCompare.GetHashCode x.FullName - interface System.IComparable with - member x.CompareTo y = - match y with - | :? Target as y -> stringCompare.Compare(x.FullName, y.FullName) - | _ -> invalidArg "y" "cannot compare target to different types" - - // structures, database processor and store - type Timestamp = System.DateTime - - [] - type ms - - type Dependency = - | FileDep of File * Timestamp // regular file (such as source code file), triggers when file date/time is changed - | ArtifactDep of Target // other target (triggers when target is rebuilt) - | EnvVar of string * string option // environment variable - | Var of string * string option // any other data such as compiler version (not used yet) - | AlwaysRerun // trigger always - | GetFiles of Fileset * Filelist // depends on set of files. Triggers when resulting filelist is changed - - type StepInfo = - { Name: string; Start: System.DateTime; OwnTime: int; WaitTime: int } - with static member Empty = {Name = ""; Start = new System.DateTime(1900,1,1); OwnTime = 0; WaitTime = 0} - - type BuildResult = - { Targets : Target list - Built : Timestamp - Depends : Dependency list - Steps : StepInfo list } - - // expression type - type Recipe<'a,'b> = Recipe of (BuildResult * 'a -> Async) - - /// Data type for action's out parameter. Defined target file and named groups in pattern - - type 'ctx Rule = - | FileRule of string * Recipe<'ctx,unit> - | MultiFileRule of string list * Recipe<'ctx,unit> - | PhonyRule of string * Recipe<'ctx,unit> - | FileConditionRule of (string -> bool) * Recipe<'ctx,unit> - type 'ctx Rules = Rules of 'ctx Rule list - - /// Defines common exception type - exception XakeException of string - -/// -/// A message to a progress reporter. -/// -type ProgressMessage = - | Begin of System.TimeSpan - | Progress of System.TimeSpan * int - | End diff --git a/src/core/WorkerPool.fs b/src/core/WorkerPool.fs deleted file mode 100644 index f8f2494..0000000 --- a/src/core/WorkerPool.fs +++ /dev/null @@ -1,53 +0,0 @@ -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) ) diff --git a/src/core/Xake.fsproj b/src/core/Xake.fsproj index 3a31364..b4e2db2 100644 --- a/src/core/Xake.fsproj +++ b/src/core/Xake.fsproj @@ -3,44 +3,43 @@ Xake Library - net46;netstandard2.0 - (c) OlegZee 2014-2018 + netstandard2.0 + (c) OlegZee 2014-2019 - https://github.com/xakebuild/Xake - https://github.com/xakebuild/Xake/raw/dev/Icon.png + https://github.com/Fakebuild/Xake + https://github.com/Fakebuild/Xake/raw/dev/Icon.png Xake build tool, the engine - - - - + + + + + + + + + + + - - - - - - - + + - + - - - diff --git a/src/core/XakeScript.fs b/src/core/XakeScript.fs index 8379b86..2a2d552 100644 --- a/src/core/XakeScript.fs +++ b/src/core/XakeScript.fs @@ -1,84 +1,82 @@ -namespace Xake +[] +module Xake.XakeScript -[] -module XakeScript = +/// Creates the rule for specified file pattern. +let ( ..?> ) fn fnRule = FileConditionRule (fn, fnRule) - /// Creates the rule for specified file pattern. - let ( ..?> ) fn fnRule = FileConditionRule (fn, fnRule) +let ( ..> ) pattern actionBody = FileRule (pattern, actionBody) - let ( ..> ) pattern actionBody = FileRule (pattern, actionBody) +let ( *..> ) (patterns: #seq) actionBody = + MultiFileRule (patterns |> List.ofSeq, actionBody) - let ( *..> ) (patterns: #seq) actionBody = - MultiFileRule (patterns |> List.ofSeq, actionBody) +/// Creates phony action (check if I can unify the operator name) +let (=>) name action = PhonyRule (name, action) - /// Creates phony action (check if I can unify the operator name) - let (=>) name action = PhonyRule (name, action) +/// Main type. +type XakeScript = XakeScript of ExecOptions * Rules - /// Main type. - type XakeScript = XakeScript of ExecOptions * Rules +/// Script builder. +type RulesBuilder(options) = - /// Script builder. - type RulesBuilder(options) = + let updRules (XakeScript (options,rules)) f = XakeScript (options, f(rules)) + let updTargets (XakeScript (options,rules)) f = XakeScript ({options with Targets = f(options.Targets)}, rules) + let addRule rule (Rules rules) :Rules<_> = Rules (rule :: rules) - let updRules (XakeScript (options,rules)) f = XakeScript (options, f(rules)) - let updTargets (XakeScript (options,rules)) f = XakeScript ({options with Targets = f(options.Targets)}, rules) - let addRule rule (Rules rules) :Rules<_> = Rules (rule :: rules) + let updateVar (key: string) (value: string) = + List.filter(fst >> ((<>) key)) >> ((@) [key, value]) - let updateVar (key: string) (value: string) = - List.filter(fst >> ((<>) key)) >> ((@) [key, value]) + member __.Zero() = XakeScript (options, Rules []) + member this.Yield(()) = this.Zero() - member __.Zero() = XakeScript (options, Rules []) - member this.Yield(()) = this.Zero() + member __.Run(XakeScript (options,rules)) = + ExecCore.runScript options rules - member __.Run(XakeScript (options,rules)) = - ExecCore.runScript options rules + [] + member __.DryRun(XakeScript (options, rules)) = + + XakeScript ({options with DryRun = true}, rules) - [] - member __.DryRun(XakeScript (options, rules)) = - - XakeScript ({options with DryRun = true}, rules) + [] + member __.AddVar(XakeScript (options, rules), name, value) = - [] - member __.AddVar(XakeScript (options, rules), name, value) = + XakeScript ({options with Vars = options.Vars |> updateVar name value }, rules) - XakeScript ({options with Vars = options.Vars |> updateVar name value }, rules) + [] + member __.FileLog(XakeScript (options, rules), filename, ?loglevel) = - [] - member __.FileLog(XakeScript (options, rules), filename, ?loglevel) = + let loglevel = defaultArg loglevel Verbosity.Chatty in + XakeScript ({options with FileLog = filename; FileLogLevel = loglevel}, rules) - let loglevel = defaultArg loglevel Verbosity.Chatty in - XakeScript ({options with FileLog = filename; FileLogLevel = loglevel}, rules) + [] + member __.ConLog(XakeScript (options, rules), ?loglevel) = - [] - member __.ConLog(XakeScript (options, rules), ?loglevel) = + let loglevel = defaultArg loglevel Verbosity.Chatty in + XakeScript ({options with ConLogLevel =loglevel}, rules) - let loglevel = defaultArg loglevel Verbosity.Chatty in - XakeScript ({options with ConLogLevel =loglevel}, rules) + [] + member __.Rule(script, rule) = + + updRules script (addRule rule) - [] - member __.Rule(script, rule) = - - updRules script (addRule rule) + // [] member this.AddRule(script, pattern, action) + // = updRules script (pattern *> action |> addRule) - // [] member this.AddRule(script, pattern, action) - // = updRules script (pattern *> action |> addRule) + [] + member __.Phony(script, name, action) = - [] - member __.Phony(script, name, action) = + updRules script (name => action |> addRule) - updRules script (name => action |> addRule) + [] + member __.Rules(script, rules: #seq) = + + (rules |> Seq.map addRule |> Seq.fold (>>) id) |> updRules script - [] - member __.Rules(script, rules: #seq) = - - (rules |> Seq.map addRule |> Seq.fold (>>) id) |> updRules script + [] + member __.Want(script, targets) = + + updTargets script (function |[] -> targets |x -> x) // Options override script! - [] - member __.Want(script, targets) = - - updTargets script (function |[] -> targets |x -> x) // Options override script! - - [] - member __.WantOverride(script,targets) = - - updTargets script (fun _ -> targets) + [] + member __.WantOverride(script,targets) = + + updTargets script (fun _ -> targets) diff --git a/src/tests/ProgressTests.fs b/src/tests/ProgressTests.fs index 5682714..db52e48 100644 --- a/src/tests/ProgressTests.fs +++ b/src/tests/ProgressTests.fs @@ -1,18 +1,19 @@ module ``Progress estimator`` open NUnit.Framework -open Xake.DomainTypes -open Xake.Progress.Estimate + +open Xake +open Xake.Estimate type TaskDeps = string list -type Task = | Task of string * int * TaskDeps +type Task = | Task of string * int * TaskDeps let internal estimate threadCount completed_tasks tasks goals = let getTaskName (Task (name,_,_)) = name - let tasks_map = completed_tasks |> List.map (fun t -> (t, 0)) |> Map.ofList - let machine_state = {Cpu = BusyUntil 0 |> List.replicate threadCount; Tasks = tasks_map} + let tasks_map = completed_tasks |> List.map (fun t -> (t, 0)) |> Map.ofList + let machine_state = {Cpu = BusyUntil 0 |> List.replicate threadCount; Tasks = tasks_map} let taskMap = tasks |> List.map (fun task -> getTaskName task, task) |> Map.ofList let taskByName name = Map.find name taskMap @@ -21,63 +22,63 @@ let internal estimate threadCount completed_tasks tasks goals = in endTime -[)>] -[)>] +[)>] +[)>] let Test1(threads) = let tasks1 = [ - Task ("build", 1, ["link"]) - Task ("link", 2, ["compile"]) - Task ("compile", 5, []) + Task ("build", 1, ["link"]) + Task ("link", 2, ["compile"]) + Task ("compile", 5, []) ] estimate threads [] tasks1 ["build"] -[)>] -[)>] +[)>] +[)>] let TestPara(threads) = let tasks1 = [ - Task ("build", 1, ["link1"; "link2"]) - Task ("link1", 2, ["compile"]) - Task ("link2", 2, ["compile"]) - Task ("compile", 7, []) + Task ("build", 1, ["link1"; "link2"]) + Task ("link1", 2, ["compile"]) + Task ("link2", 2, ["compile"]) + Task ("compile", 7, []) ] estimate threads [] tasks1 ["build"] -[)>] -[)>] +[)>] +[)>] let ComplexCase(threads) = let tasks1 = [ - Task ("build", 1, ["compile"]) - Task ("compile", 5, + Task ("build", 1, ["compile"]) + Task ("compile", 5, [ "version.h" "commonheader.h" "resources" "resources-ru" ]) - Task ("version.h", 4, []) - Task ("commonheader.h", 4, []) - Task ("resources", 2, ["strings"]) - Task ("resources-ru", 3, ["strings"]) - Task ("strings", 2, []) + Task ("version.h", 4, []) + Task ("commonheader.h", 4, []) + Task ("resources", 2, ["strings"]) + Task ("resources-ru", 3, ["strings"]) + Task ("strings", 2, []) ] estimate threads [] tasks1 ["build"] -[)>] -[)>] +[)>] +[)>] let TestPara2(threads) = let tasks1 = [ - Task ("main", 0, ["t1"; "t2"]) - Task ("t1", 4, []) - Task ("t2", 5, []) + Task ("main", 0, ["t1"; "t2"]) + Task ("t1", 4, []) + Task ("t2", 5, []) ] estimate threads [] tasks1 ["main"] diff --git a/src/tests/StorageTests.fs b/src/tests/StorageTests.fs index b2f37b1..8f39ea6 100644 --- a/src/tests/StorageTests.fs +++ b/src/tests/StorageTests.fs @@ -4,8 +4,9 @@ open System.IO open NUnit.Framework open Xake -open Xake.BuildLog -open Xake.Storage +open Xake.Util +open Xake.Database +open Xake.BuildDatabase type Bookmark = | Bookmark of string * string @@ -17,7 +18,7 @@ module private impl = let mkFileTarget = File.make >> FileTarget let newStepInfo (name, duration) = { StepInfo.Empty with Name = name - OwnTime = duration * 1 } + OwnTime = duration * 1 } // stores object to a binary stream and immediately reads it let writeAndRead (pu : Pickler.PU<_>) testee = @@ -31,15 +32,19 @@ module private impl = let logger = ConsoleLogger Verbosity.Diag let createResult name = - { ([name - |> File.make - |> FileTarget] - |> makeResult) with Depends = - [ "abc.c" |> mkFileTarget |> ArtifactDep - Var("DEBUG", Some "false") ] - Steps = [ newStepInfo ("compile", 217) ] } - + let targets = [name |> File.make |> FileTarget ] + targets, { + (BuildResult.makeResult targets) with + Depends = [ "abc.c" |> mkFileTarget |> ArtifactDep + Var("DEBUG", Some "false") ] + Steps = [ newStepInfo ("compile", 217) ] } + let (<-*) (a : Agent) t = a.PostAndReply(fun ch -> GetResult(t, ch)) + + let inline (<--) (agent : ^a) (msg : 'b) = + (^a : (member Post : 'b -> unit) (agent, msg)) + agent + // Is.Any predicate for assertions let IsAny() = Is.Not.All.Not @@ -55,7 +60,7 @@ let Setup() = [] let ``persists simple data``() = - let testee = makeResult <| [mkFileTarget "abc.exe"] + let testee = BuildResult.makeResult <| [mkFileTarget "abc.exe"] let testee = { testee with @@ -71,7 +76,7 @@ let ``persists simple data``() = newStepInfo ("compile", 217) newStepInfo ("link", 471) ] } - let (buf, repl) = writeAndRead Storage.resultPU testee + let (buf, repl) = writeAndRead BuildDatabase.Picklers.result testee printfn "size is %A" buf.Length printfn "src %A" testee printfn "repl %A" repl @@ -79,15 +84,12 @@ let ``persists simple data``() = [] let ``persists build data in Xake db``() = - let inline (<--) (agent : ^a) (msg : 'b) = - (^a : (member Post : 'b -> unit) (agent, msg)) - agent - use testee = Storage.openDb dbname logger + use testee = BuildDatabase.openDb dbname logger testee <-- Store(createResult "abc.exe") <-- Store(createResult "def.exe") <-- Store(createResult "fgh.exe") |> ignore testee.PostAndReply CloseWait - use testee = Storage.openDb dbname logger + use testee = BuildDatabase.openDb dbname logger let abc = testee <-* (mkFileTarget "abc.exe") Assert.IsTrue(Option.isSome abc) let def = testee <-* (mkFileTarget "def.exe") @@ -106,14 +108,14 @@ let ``compresses database when limit is reached``() = (^a : (member Post : 'b -> unit) (agent, msg)) agent - use testee = Storage.openDb dbname logger + use testee = BuildDatabase.openDb dbname logger for _ in seq { 1..20 } do for i in seq { 1..20 } do let name = sprintf "a%A.exe" i testee <-- Store(createResult name) |> ignore testee.PostAndReply CloseWait let oldLen = (FileInfo dbname).Length - use testee = Storage.openDb dbname logger + use testee = BuildDatabase.openDb dbname logger testee.PostAndReply CloseWait let newLen = (FileInfo dbname).Length printfn "old size: %A, new size: %A" oldLen newLen @@ -126,13 +128,13 @@ let ``updates data in file storage``() = (^a : (member Post : 'b -> unit) (agent, msg)) agent - use testee = Storage.openDb dbname logger - let result = createResult "abc" - testee <-- Store result |> ignore + use testee = BuildDatabase.openDb dbname logger + let targets, result = createResult "abc" + testee <-- Store (targets, result) |> ignore let updatedResult = { result with Depends = [ Var("DEBUG", Some "true") ] } - testee <-- Store updatedResult |> ignore + testee <-- Store (targets, updatedResult) |> ignore testee.PostAndReply CloseWait - use testee = Storage.openDb dbname logger + use testee = BuildDatabase.openDb dbname logger match testee <-* (mkFileTarget "abc") with | Some read -> testee.PostAndReply CloseWait @@ -150,13 +152,13 @@ let ``restores db in case write failed``() = (^a : (member Post : 'b -> unit) (agent, msg)) agent - use testee = Storage.openDb dbname logger + use testee = BuildDatabase.openDb dbname logger testee <-- Store(createResult "abc") |> ignore testee.PostAndReply CloseWait let bkdb = "." ".xake" <.> "bak" File.Move(dbname, bkdb) File.WriteAllText(dbname, "dummy text") - use testee = Storage.openDb dbname logger + use testee = BuildDatabase.openDb dbname logger let read = testee <-* (mkFileTarget "abc") Assert.IsTrue(Option.isSome read) testee.PostAndReply CloseWait @@ -171,7 +173,7 @@ let ``repairs (cleans) broken db``() = (^a : (member Post : 'b -> unit) (agent, msg)) agent File.WriteAllText(dbname, "dummy text") - use testee = Storage.openDb dbname logger + use testee = BuildDatabase.openDb dbname logger testee <-- Store(createResult "abc") |> ignore let read = testee <-* mkFileTarget "abc" Assert.IsTrue(Option.isSome read) diff --git a/src/tests/XakeScriptTests.fs b/src/tests/XakeScriptTests.fs index d07609e..523640f 100644 --- a/src/tests/XakeScriptTests.fs +++ b/src/tests/XakeScriptTests.fs @@ -4,8 +4,9 @@ open System.IO open NUnit.Framework open Xake +open Xake.Util +open Xake.BuildDatabase open Xake.Tasks -open Storage type Runtime = {Ver: string; Folder: string} @@ -456,7 +457,7 @@ type ``XakeScript tests``() = ] } - use testee = Storage.openDb "./.xake" (ConsoleLogger Verbosity.Diag) + use testee = openDb "./.xake" (ConsoleLogger Verbosity.Diag) try match testee.PostAndReply <| fun ch -> DatabaseApi.GetResult ((PhonyAction "test"), ch) with | Some { @@ -507,10 +508,9 @@ type ``XakeScript tests``() = ] } - let (<-*) (a:Agent) t = a.PostAndReply(fun ch -> GetResult (t,ch)) - let logger = ConsoleLogger Verbosity.Diag + let (<-*) (a:Agent) t = a.PostAndReply(fun ch -> DatabaseApi.GetResult (t,ch)) - use db = Storage.openDb "./.xake" logger + use db = BuildDatabase.openDb "./.xake" (ConsoleLogger Diag) try match db <-* (PhonyAction "main") with | Some {Steps = step1::_} -> @@ -519,7 +519,7 @@ type ``XakeScript tests``() = printfn "%A" raaa |_ -> Assert.Fail "no results from db" finally - db.PostAndReply CloseWait + db.PostAndReply DatabaseApi.CloseWait [] member x.``dryrun for not executing``() = diff --git a/src/tests/tests.fsproj b/src/tests/tests.fsproj index 5b6228b..2a4d8ad 100644 --- a/src/tests/tests.fsproj +++ b/src/tests/tests.fsproj @@ -1,7 +1,7 @@  - net46;netcoreapp2.0 + netcoreapp3.0 false @@ -26,11 +26,8 @@ - - - - - - + + + \ No newline at end of file