diff --git a/.gitignore b/.gitignore index 4ca2aa69e1..5bdbb3b811 100644 --- a/.gitignore +++ b/.gitignore @@ -12,6 +12,7 @@ config/local rundir/ # F# / dotnet +backend/src/Language/package-ref-hashes.txt backend/src/LibExecution/package-ref-hashes.txt backend/packages/ backend/paket-files/ diff --git a/.vscode/tasks.json b/.vscode/tasks.json index f8f79c1496..8a191201a1 100644 --- a/.vscode/tasks.json +++ b/.vscode/tasks.json @@ -55,6 +55,22 @@ "runOptions": { "runOn": "folderOpen" } + }, + { + "label": "Watch & rebuild backend", + "type": "shell", + "command": "./scripts/build/_build-server --watch >> rundir/logs/build-server.log 2>&1", + "isBackground": true, + "presentation": { + "echo": true, + "reveal": "never", + "focus": false, + "panel": "dedicated" + }, + "runOptions": { + "runOn": "folderOpen" + }, + "problemMatcher": [] } ] } diff --git a/backend/Directory.Build.props b/backend/Directory.Build.props index a4fd2fb178..8d9f5c32e0 100644 --- a/backend/Directory.Build.props +++ b/backend/Directory.Build.props @@ -17,6 +17,11 @@ $(OtherFlags) --test:GraphBasedChecking --test:ParallelOptimization --test:ParallelIlxGen - $(OtherFlags) --warnaserror --warnon:1182,3387,3366 + + + + + + $(OtherFlags) --warnaserror --warnon:1182,3387,3366 --nowarn:3511 diff --git a/backend/fsdark.sln b/backend/fsdark.sln index 8b54259134..dc384b07dd 100644 --- a/backend/fsdark.sln +++ b/backend/fsdark.sln @@ -23,6 +23,12 @@ EndProject # Core projects Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "Prelude", "src\Prelude\Prelude.fsproj", "{5FD0E378-FD88-45E5-9963-BFF2921E6A6A}" EndProject +Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "Language", "src\Language\Language.fsproj", "{A1B2C3D4-0001-4001-8001-000000000001}" +EndProject +Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "Runtime", "src\Runtime\Runtime.fsproj", "{A1B2C3D4-0002-4002-8002-000000000002}" +EndProject +Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "DarkTypes", "src\DarkTypes\DarkTypes.fsproj", "{A1B2C3D4-0003-4003-8003-000000000003}" +EndProject Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "LibExecution", "src\LibExecution\LibExecution.fsproj", "{D8ECA989-4383-47D3-B443-4D7BFF1F05E7}" EndProject Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "LibTreeSitter", "src\LibTreeSitter\LibTreeSitter.fsproj", "{625B113A-D5DC-40A5-B833-4BA342AB4936}" @@ -53,8 +59,9 @@ Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "LibCloud", "src\LibCloud\Li EndProject Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "LibHttpMiddleware", "src\LibHttpMiddleware\LibHttpMiddleware.fsproj", "{DAE2B2E9-40AF-4D99-A5B0-79678F94BFDA}" EndProject -Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "BwdServer", "src\BwdServer\BwdServer.fsproj", "{B56110F0-2D27-4718-8C80-E7FDE3439A63}" -EndProject +# BwdServer disabled — kept on disk; restore when HTTP server functionality returns. +# Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "BwdServer", "src\BwdServer\BwdServer.fsproj", "{B56110F0-2D27-4718-8C80-E7FDE3439A63}" +# EndProject # CLI stuff Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "Cli", "src\Cli\Cli.fsproj", "{DF812CBE-894C-4C90-9EDC-4558983CCDEA}" EndProject @@ -86,14 +93,27 @@ Global EndGlobalSection GlobalSection(ProjectConfigurationPlatforms) = postSolution - {B56110F0-2D27-4718-8C80-E7FDE3439A63}.Debug|Any CPU.ActiveCfg = Debug|Any CPU - {B56110F0-2D27-4718-8C80-E7FDE3439A63}.Debug|Any CPU.Build.0 = Debug|Any CPU - {B56110F0-2D27-4718-8C80-E7FDE3439A63}.Release|Any CPU.ActiveCfg = Release|Any CPU - {B56110F0-2D27-4718-8C80-E7FDE3439A63}.Release|Any CPU.Build.0 = Release|Any CPU + # BwdServer disabled + # {B56110F0-2D27-4718-8C80-E7FDE3439A63}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + # {B56110F0-2D27-4718-8C80-E7FDE3439A63}.Debug|Any CPU.Build.0 = Debug|Any CPU + # {B56110F0-2D27-4718-8C80-E7FDE3439A63}.Release|Any CPU.ActiveCfg = Release|Any CPU + # {B56110F0-2D27-4718-8C80-E7FDE3439A63}.Release|Any CPU.Build.0 = Release|Any CPU {D8ECA989-4383-47D3-B443-4D7BFF1F05E7}.Debug|Any CPU.ActiveCfg = Debug|Any CPU {D8ECA989-4383-47D3-B443-4D7BFF1F05E7}.Debug|Any CPU.Build.0 = Debug|Any CPU {D8ECA989-4383-47D3-B443-4D7BFF1F05E7}.Release|Any CPU.ActiveCfg = Release|Any CPU {D8ECA989-4383-47D3-B443-4D7BFF1F05E7}.Release|Any CPU.Build.0 = Release|Any CPU + {A1B2C3D4-0001-4001-8001-000000000001}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {A1B2C3D4-0001-4001-8001-000000000001}.Debug|Any CPU.Build.0 = Debug|Any CPU + {A1B2C3D4-0001-4001-8001-000000000001}.Release|Any CPU.ActiveCfg = Release|Any CPU + {A1B2C3D4-0001-4001-8001-000000000001}.Release|Any CPU.Build.0 = Release|Any CPU + {A1B2C3D4-0002-4002-8002-000000000002}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {A1B2C3D4-0002-4002-8002-000000000002}.Debug|Any CPU.Build.0 = Debug|Any CPU + {A1B2C3D4-0002-4002-8002-000000000002}.Release|Any CPU.ActiveCfg = Release|Any CPU + {A1B2C3D4-0002-4002-8002-000000000002}.Release|Any CPU.Build.0 = Release|Any CPU + {A1B2C3D4-0003-4003-8003-000000000003}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {A1B2C3D4-0003-4003-8003-000000000003}.Debug|Any CPU.Build.0 = Debug|Any CPU + {A1B2C3D4-0003-4003-8003-000000000003}.Release|Any CPU.ActiveCfg = Release|Any CPU + {A1B2C3D4-0003-4003-8003-000000000003}.Release|Any CPU.Build.0 = Release|Any CPU {DB61305F-4CA9-4D92-82A5-503495F515E8}.Debug|Any CPU.ActiveCfg = Debug|Any CPU {DB61305F-4CA9-4D92-82A5-503495F515E8}.Debug|Any CPU.Build.0 = Debug|Any CPU {DB61305F-4CA9-4D92-82A5-503495F515E8}.Release|Any CPU.ActiveCfg = Release|Any CPU @@ -187,11 +207,15 @@ Global # Notes of what projects being in which folders GlobalSection(NestedProjects) = preSolution # in /src + {A1B2C3D4-0001-4001-8001-000000000001} = {F84DCF8A-FC1A-4677-AF4D-616AD7DB3470} + {A1B2C3D4-0002-4002-8002-000000000002} = {F84DCF8A-FC1A-4677-AF4D-616AD7DB3470} + {A1B2C3D4-0003-4003-8003-000000000003} = {F84DCF8A-FC1A-4677-AF4D-616AD7DB3470} {D8ECA989-4383-47D3-B443-4D7BFF1F05E7} = {F84DCF8A-FC1A-4677-AF4D-616AD7DB3470} {5FD0E378-FD88-45E5-9963-BFF2921E6A6A} = {F84DCF8A-FC1A-4677-AF4D-616AD7DB3470} {BBFC824F-A0DE-4A28-B82F-49C04EBA7475} = {F84DCF8A-FC1A-4677-AF4D-616AD7DB3470} {625B113A-D5DC-40A5-B833-4BA342AB4936} = {F84DCF8A-FC1A-4677-AF4D-616AD7DB3470} - {B56110F0-2D27-4718-8C80-E7FDE3439A63} = {F84DCF8A-FC1A-4677-AF4D-616AD7DB3470} + # BwdServer disabled + # {B56110F0-2D27-4718-8C80-E7FDE3439A63} = {F84DCF8A-FC1A-4677-AF4D-616AD7DB3470} {3FC57943-9D51-49AE-9FBD-4A112B4F68D6} = {F84DCF8A-FC1A-4677-AF4D-616AD7DB3470} {824DD2A5-7F01-4A8A-9ABD-9F91F52582AD} = {F84DCF8A-FC1A-4677-AF4D-616AD7DB3470} {524e142b-bfb1-4f4b-8e67-bfe82301f7c6} = {F84DCF8A-FC1A-4677-AF4D-616AD7DB3470} diff --git a/backend/paket.dependencies b/backend/paket.dependencies index 9daca539b5..e19638cdfd 100644 --- a/backend/paket.dependencies +++ b/backend/paket.dependencies @@ -5,7 +5,6 @@ framework: net10.0 storage: none // Basics -nuget Ply = 0.3.1 nuget FSharpPlus = 1.5.0 nuget FsRegEx = 0.7.2 nuget FSharpx.Extras = 3.1.0 diff --git a/backend/paket.lock b/backend/paket.lock index e8e13bf5fa..38c4aee5d3 100644 --- a/backend/paket.lock +++ b/backend/paket.lock @@ -109,9 +109,6 @@ NUGET Microsoft.Extensions.Logging (>= 2.0) Microsoft.Extensions.Logging.Configuration (>= 2.0) Microsoft.Extensions.Options.ConfigurationExtensions (>= 2.0) - Ply (0.3.1) - FSharp.Core (>= 4.6.2) - System.Threading.Tasks.Extensions (>= 4.5.4) SimpleBase (4.0) System.Memory (>= 4.5.5) Sodium.Core (1.3.4) @@ -135,4 +132,3 @@ NUGET System.Runtime.CompilerServices.Unsafe (6.1.2) System.Text.Json (10.0) System.Threading.Channels (10.0.5) - System.Threading.Tasks.Extensions (4.6.3) diff --git a/backend/src/BuiltinCli/Libs/Directory.fs b/backend/src/BuiltinCli/Libs/Directory.fs index af4d162795..8037315c69 100644 --- a/backend/src/BuiltinCli/Libs/Directory.fs +++ b/backend/src/BuiltinCli/Libs/Directory.fs @@ -2,7 +2,6 @@ module BuiltinCli.Libs.Directory open System.Threading.Tasks -open FSharp.Control.Tasks open Prelude open LibExecution.RuntimeTypes @@ -21,10 +20,8 @@ let fns () : List = fn = (function | _, _, _, [ DUnit ] -> - uply { - let contents = System.IO.Directory.GetCurrentDirectory() - return DString contents - } + let contents = System.IO.Directory.GetCurrentDirectory() + DString contents |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -38,8 +35,8 @@ let fns () : List = description = "Creates a new directory at the specified . If the directory already exists, no action is taken. Returns a Result type indicating success or failure." fn = - let resultOk r = Dval.resultOk KTUnit KTString r |> Ply - let resultError r = Dval.resultError KTUnit KTString r |> Ply + let resultOk r = Dval.resultOk KTUnit KTString r |> Task.FromResult + let resultError r = Dval.resultError KTUnit KTString r |> Task.FromResult (function | _, _, _, [ DString path ] -> try @@ -61,8 +58,8 @@ let fns () : List = description = "Deletes the directory at the specified . If is set to true, it will delete the directory and its contents. If set to false (default), it will only delete an empty directory. Returns a Result type indicating success or failure." fn = - let resultOk r = Dval.resultOk KTUnit KTString r |> Ply - let resultError r = Dval.resultError KTUnit KTString r |> Ply + let resultOk r = Dval.resultOk KTUnit KTString r |> Task.FromResult + let resultError r = Dval.resultError KTUnit KTString r |> Task.FromResult (function | _, _, _, [ DString path ] -> try @@ -84,16 +81,14 @@ let fns () : List = fn = (function | _, _, _, [ DString path ] -> - uply { - // TODO make async - let contents = - try - System.IO.Directory.EnumerateFileSystemEntries path |> Seq.toList - with _ -> - [] + // TODO make async + let contents = + try + System.IO.Directory.EnumerateFileSystemEntries path |> Seq.toList + with _ -> + [] - return DList(VT.string, List.map DString contents) - } + DList(VT.string, List.map DString contents) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -108,11 +103,9 @@ let fns () : List = fn = (function | _, _, _, [ DUnit ] -> - uply { - let exePath = - System.Diagnostics.Process.GetCurrentProcess().MainModule.FileName - return DString exePath - } + let exePath = + System.Diagnostics.Process.GetCurrentProcess().MainModule.FileName + DString exePath |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure diff --git a/backend/src/BuiltinCli/Libs/Environment.fs b/backend/src/BuiltinCli/Libs/Environment.fs index d60924fd80..796d44b760 100644 --- a/backend/src/BuiltinCli/Libs/Environment.fs +++ b/backend/src/BuiltinCli/Libs/Environment.fs @@ -2,7 +2,6 @@ module BuiltinCli.Libs.Environment open System.Threading.Tasks -open FSharp.Control.Tasks open Prelude open LibExecution.RuntimeTypes @@ -26,9 +25,9 @@ let fns () : List = let envValue = System.Environment.GetEnvironmentVariable(varName) if isNull envValue then - Dval.optionNone KTString |> Ply + Dval.optionNone KTString |> Task.FromResult else - Dval.optionSome KTString (DString envValue) |> Ply + Dval.optionSome KTString (DString envValue) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -53,7 +52,7 @@ let fns () : List = |> Seq.toList |> Dval.dict KTString - Ply(envMap) + Task.FromResult(envMap) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -67,7 +66,7 @@ let fns () : List = description = "Returns the git hash of the current CLI build" fn = function - | _, _, [], [ DUnit ] -> uply { return DString LibConfig.Config.buildHash } + | _, _, [], [ DUnit ] -> Task.FromResult(DString LibConfig.Config.buildHash) | _ -> incorrectArgs () sqlSpec = NotQueryable previewable = Impure diff --git a/backend/src/BuiltinCli/Libs/Execution.fs b/backend/src/BuiltinCli/Libs/Execution.fs index 4293e274cf..e1e5bfcbe7 100644 --- a/backend/src/BuiltinCli/Libs/Execution.fs +++ b/backend/src/BuiltinCli/Libs/Execution.fs @@ -2,7 +2,6 @@ module BuiltinCli.Libs.Execution open System.Threading.Tasks -open FSharp.Control.Tasks open System.Collections.Concurrent open System.IO open System.Threading @@ -181,7 +180,7 @@ let fns () : List = p.WaitForExit() - createExecutionOutcome p.ExitCode stdout stderr |> Ply + createExecutionOutcome p.ExitCode stdout stderr |> Task.FromResult | _ -> incorrectArgs () sqlSpec = NotQueryable previewable = Impure @@ -202,13 +201,13 @@ let fns () : List = let resultError = Dval.resultError osTypeRef KTString if RuntimeInformation.IsOSPlatform OSPlatform.Windows then - OS.Windows |> OS.toDT |> resultOk |> Ply + OS.Windows |> OS.toDT |> resultOk |> Task.FromResult else if RuntimeInformation.IsOSPlatform OSPlatform.Linux then - OS.Linux |> OS.toDT |> resultOk |> Ply + OS.Linux |> OS.toDT |> resultOk |> Task.FromResult else if RuntimeInformation.IsOSPlatform OSPlatform.OSX then - OS.OSX |> OS.toDT |> resultOk |> Ply + OS.OSX |> OS.toDT |> resultOk |> Task.FromResult else - "Unsupported OS" |> DString |> resultError |> Ply + "Unsupported OS" |> DString |> resultError |> Task.FromResult | _ -> incorrectArgs () sqlSpec = NotQueryable @@ -254,7 +253,7 @@ let fns () : List = ErrorBuffer = "" } processHandles.TryAdd(processId, processInfo) |> ignore - DInt64 processId |> Ply + DInt64 processId |> Task.FromResult | _ -> incorrectArgs () sqlSpec = NotQueryable previewable = Impure @@ -356,11 +355,13 @@ let fns () : List = else 0 createExecutionOutcome exitCode (stdout.ToString()) (stderr.ToString()) - |> Ply + |> Task.FromResult with ex -> - createExecutionOutcome -1L "" $"Process IO error: {ex.Message}" |> Ply + createExecutionOutcome -1L "" $"Process IO error: {ex.Message}" + |> Task.FromResult | _ -> - createExecutionOutcome -1L "" "Process not found or has exited" |> Ply + createExecutionOutcome -1L "" "Process not found or has exited" + |> Task.FromResult | _ -> incorrectArgs () sqlSpec = NotQueryable previewable = Impure @@ -405,15 +406,17 @@ let fns () : List = processHandles.TryRemove processId |> ignore - createExecutionOutcome exitCode finalStdout finalStderr |> Ply + createExecutionOutcome exitCode finalStdout finalStderr + |> Task.FromResult with ex -> processHandles.TryRemove processId |> ignore createExecutionOutcome -1L "" $"Process termination error: {ex.Message}" - |> Ply - | false, _ -> createExecutionOutcome -1L "" "Process not found" |> Ply + |> Task.FromResult + | false, _ -> + createExecutionOutcome -1L "" "Process not found" |> Task.FromResult | _ -> incorrectArgs () sqlSpec = NotQueryable previewable = Impure diff --git a/backend/src/BuiltinCli/Libs/File.fs b/backend/src/BuiltinCli/Libs/File.fs index 6bde2cde49..3a446bb34f 100644 --- a/backend/src/BuiltinCli/Libs/File.fs +++ b/backend/src/BuiltinCli/Libs/File.fs @@ -2,7 +2,6 @@ module BuiltinCli.Libs.File open System.Threading.Tasks -open FSharp.Control.Tasks open Prelude open LibExecution.RuntimeTypes @@ -24,7 +23,7 @@ let fns () : List = let resultError = Dval.resultError KTBlob KTString (function | state, _, _, [ DString path ] -> - uply { + task { try let path = path.Replace( @@ -37,6 +36,7 @@ let fns () : List = with e -> return resultError (DString($"Error reading file: {e.Message}")) } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -54,7 +54,7 @@ let fns () : List = let resultError = Dval.resultError KTUnit KTString (function | state, _, _, [ DBlob ref; DString path ] -> - uply { + task { try let path = path.Replace( @@ -68,6 +68,7 @@ let fns () : List = with e -> return resultError (DString($"Error writing file: {e.Message}")) } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -82,17 +83,15 @@ let fns () : List = fn = (function | _, _, _, [ DString path ] -> - uply { - try - System.IO.File.Delete path - return Dval.resultOk KTUnit KTString DUnit - with e -> - return - Dval.resultError - KTUnit - KTString - (DString $"Error deleting file: {e.Message}") - } + try + System.IO.File.Delete path + Dval.resultOk KTUnit KTString DUnit |> Task.FromResult + with e -> + Dval.resultError + KTUnit + KTString + (DString $"Error deleting file: {e.Message}") + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -110,13 +109,14 @@ let fns () : List = let resultError = Dval.resultError KTUnit KTString (function | _, _, _, [ DString path; DString content ] -> - uply { + task { try do! System.IO.File.AppendAllTextAsync(path, content) return resultOk DUnit with e -> return resultError (DString e.Message) } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -130,8 +130,8 @@ let fns () : List = description = "Creates a new temporary file with a unique name in the system's temporary directory. Returns a Result type containing the temporary file path or an error if the creation fails." fn = - let resultOk r = Dval.resultOk KTString KTString r |> Ply - let resultError r = Dval.resultError KTString KTString r |> Ply + let resultOk r = Dval.resultOk KTString KTString r |> Task.FromResult + let resultError r = Dval.resultError KTString KTString r |> Task.FromResult (function | _, _, _, [ DUnit ] -> try @@ -154,14 +154,12 @@ let fns () : List = fn = (function | _, _, _, [ DString path ] -> - uply { - try - let attrs = System.IO.File.GetAttributes(path) - let isDir = attrs.HasFlag(System.IO.FileAttributes.Directory) - return DBool isDir - with _ -> - return DBool false - } + try + let attrs = System.IO.File.GetAttributes(path) + let isDir = attrs.HasFlag(System.IO.FileAttributes.Directory) + DBool isDir |> Task.FromResult + with _ -> + DBool false |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -177,16 +175,14 @@ let fns () : List = fn = (function | _, _, _, [ DString path ] -> - uply { - try - let attrs = System.IO.File.GetAttributes(path) - let isDir = attrs.HasFlag(System.IO.FileAttributes.Directory) - let exists = - System.IO.File.Exists(path) || System.IO.Directory.Exists(path) - return DBool(exists && not isDir) - with _ -> - return DBool false - } + try + let attrs = System.IO.File.GetAttributes(path) + let isDir = attrs.HasFlag(System.IO.FileAttributes.Directory) + let exists = + System.IO.File.Exists(path) || System.IO.Directory.Exists(path) + DBool(exists && not isDir) |> Task.FromResult + with _ -> + DBool false |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -202,14 +198,12 @@ let fns () : List = fn = (function | _, _, _, [ DString path ] -> - uply { - try - let exists = - System.IO.File.Exists(path) || System.IO.Directory.Exists(path) - return DBool exists - with _ -> - return DBool false - } + try + let exists = + System.IO.File.Exists(path) || System.IO.Directory.Exists(path) + DBool exists |> Task.FromResult + with _ -> + DBool false |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -223,8 +217,8 @@ let fns () : List = description = "Returns the size of the file at the specified in bytes, or an error if the file does not exist or an error occurs" fn = - let resultOk r = Dval.resultOk KTInt64 KTString r |> Ply - let resultError r = Dval.resultError KTInt64 KTString r |> Ply + let resultOk r = Dval.resultOk KTInt64 KTString r |> Task.FromResult + let resultError r = Dval.resultError KTInt64 KTString r |> Task.FromResult (function | _, _, _, [ DString path ] -> try diff --git a/backend/src/BuiltinCli/Libs/Output.fs b/backend/src/BuiltinCli/Libs/Output.fs index 08fe75856d..a081da02d4 100644 --- a/backend/src/BuiltinCli/Libs/Output.fs +++ b/backend/src/BuiltinCli/Libs/Output.fs @@ -3,7 +3,6 @@ module BuiltinCli.Libs.Output open System.Threading.Tasks -open FSharp.Control.Tasks open Prelude open LibExecution.RuntimeTypes @@ -23,7 +22,7 @@ let fns () : List = (function | _, _, _, [ DString str ] -> print str - Ply DUnit + Task.FromResult DUnit | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -39,7 +38,7 @@ let fns () : List = (function | _, _, _, [ DString str ] -> printInline str - Ply DUnit + Task.FromResult DUnit | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -58,7 +57,7 @@ let fns () : List = System.Console.Clear() else System.Console.Write("\u001b[2J\u001b[H") // ANSI escape for non-Windows - Ply DUnit + Task.FromResult DUnit | _ -> incorrectArgs () sqlSpec = NotQueryable previewable = Impure diff --git a/backend/src/BuiltinCli/Libs/Posix.fs b/backend/src/BuiltinCli/Libs/Posix.fs index e2571c28d1..5b423f4500 100644 --- a/backend/src/BuiltinCli/Libs/Posix.fs +++ b/backend/src/BuiltinCli/Libs/Posix.fs @@ -16,6 +16,7 @@ module PackageRefs = LibExecution.PackageRefs module NR = LibExecution.RuntimeTypes.NameResolution module Blob = LibExecution.Blob open Builtin.Shortcuts +open System.Threading.Tasks // ===================================================================== @@ -489,9 +490,11 @@ let fns () : List = (function | _, _, _, [ DUnit ] -> match Libc.getcwd () with - | Ok cwd -> Dval.resultOk KTString (posixErrorKT ()) (DString cwd) |> Ply + | Ok cwd -> + Dval.resultOk KTString (posixErrorKT ()) (DString cwd) |> Task.FromResult | Error e -> - Dval.resultError KTString (posixErrorKT ()) (dPosixError e) |> Ply + Dval.resultError KTString (posixErrorKT ()) (dPosixError e) + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -507,9 +510,10 @@ let fns () : List = (function | _, _, _, [ DString path ] -> match Libc.chdir path with - | Ok() -> Dval.resultOk KTUnit (posixErrorKT ()) DUnit |> Ply + | Ok() -> Dval.resultOk KTUnit (posixErrorKT ()) DUnit |> Task.FromResult | Error e -> - Dval.resultError KTUnit (posixErrorKT ()) (dPosixError e) |> Ply + Dval.resultError KTUnit (posixErrorKT ()) (dPosixError e) + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -527,9 +531,10 @@ let fns () : List = (function | _, _, _, [ DString name; DString value ] -> match Libc.setenv name value with - | Ok() -> Dval.resultOk KTUnit (posixErrorKT ()) DUnit |> Ply + | Ok() -> Dval.resultOk KTUnit (posixErrorKT ()) DUnit |> Task.FromResult | Error e -> - Dval.resultError KTUnit (posixErrorKT ()) (dPosixError e) |> Ply + Dval.resultError KTUnit (posixErrorKT ()) (dPosixError e) + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -545,9 +550,10 @@ let fns () : List = (function | _, _, _, [ DString name ] -> match Libc.unsetenv name with - | Ok() -> Dval.resultOk KTUnit (posixErrorKT ()) DUnit |> Ply + | Ok() -> Dval.resultOk KTUnit (posixErrorKT ()) DUnit |> Task.FromResult | Error e -> - Dval.resultError KTUnit (posixErrorKT ()) (dPosixError e) |> Ply + Dval.resultError KTUnit (posixErrorKT ()) (dPosixError e) + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -565,9 +571,10 @@ let fns () : List = (function | _, _, _, [ DString path; DInt64 mode ] -> match Libc.mkdir path (int mode) with - | Ok() -> Dval.resultOk KTUnit (posixErrorKT ()) DUnit |> Ply + | Ok() -> Dval.resultOk KTUnit (posixErrorKT ()) DUnit |> Task.FromResult | Error e -> - Dval.resultError KTUnit (posixErrorKT ()) (dPosixError e) |> Ply + Dval.resultError KTUnit (posixErrorKT ()) (dPosixError e) + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -583,9 +590,10 @@ let fns () : List = (function | _, _, _, [ DString path ] -> match Libc.rmdir path with - | Ok() -> Dval.resultOk KTUnit (posixErrorKT ()) DUnit |> Ply + | Ok() -> Dval.resultOk KTUnit (posixErrorKT ()) DUnit |> Task.FromResult | Error e -> - Dval.resultError KTUnit (posixErrorKT ()) (dPosixError e) |> Ply + Dval.resultError KTUnit (posixErrorKT ()) (dPosixError e) + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -601,9 +609,10 @@ let fns () : List = (function | _, _, _, [ DString path ] -> match Libc.unlink path with - | Ok() -> Dval.resultOk KTUnit (posixErrorKT ()) DUnit |> Ply + | Ok() -> Dval.resultOk KTUnit (posixErrorKT ()) DUnit |> Task.FromResult | Error e -> - Dval.resultError KTUnit (posixErrorKT ()) (dPosixError e) |> Ply + Dval.resultError KTUnit (posixErrorKT ()) (dPosixError e) + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -621,9 +630,10 @@ let fns () : List = (function | _, _, _, [ DString oldpath; DString newpath ] -> match Libc.rename oldpath newpath with - | Ok() -> Dval.resultOk KTUnit (posixErrorKT ()) DUnit |> Ply + | Ok() -> Dval.resultOk KTUnit (posixErrorKT ()) DUnit |> Task.FromResult | Error e -> - Dval.resultError KTUnit (posixErrorKT ()) (dPosixError e) |> Ply + Dval.resultError KTUnit (posixErrorKT ()) (dPosixError e) + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -641,9 +651,10 @@ let fns () : List = (function | _, _, _, [ DString path; DInt64 mode ] -> match Libc.chmod path (int mode) with - | Ok() -> Dval.resultOk KTUnit (posixErrorKT ()) DUnit |> Ply + | Ok() -> Dval.resultOk KTUnit (posixErrorKT ()) DUnit |> Task.FromResult | Error e -> - Dval.resultError KTUnit (posixErrorKT ()) (dPosixError e) |> Ply + Dval.resultError KTUnit (posixErrorKT ()) (dPosixError e) + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -659,9 +670,10 @@ let fns () : List = (function | _, _, _, [ DString path ] -> match Libc.utimesNow path with - | Ok() -> Dval.resultOk KTUnit (posixErrorKT ()) DUnit |> Ply + | Ok() -> Dval.resultOk KTUnit (posixErrorKT ()) DUnit |> Task.FromResult | Error e -> - Dval.resultError KTUnit (posixErrorKT ()) (dPosixError e) |> Ply + Dval.resultError KTUnit (posixErrorKT ()) (dPosixError e) + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -679,9 +691,10 @@ let fns () : List = (function | _, _, _, [ DString target; DString linkpath ] -> match Libc.symlink target linkpath with - | Ok() -> Dval.resultOk KTUnit (posixErrorKT ()) DUnit |> Ply + | Ok() -> Dval.resultOk KTUnit (posixErrorKT ()) DUnit |> Task.FromResult | Error e -> - Dval.resultError KTUnit (posixErrorKT ()) (dPosixError e) |> Ply + Dval.resultError KTUnit (posixErrorKT ()) (dPosixError e) + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -698,9 +711,11 @@ let fns () : List = | _, _, _, [ DString path ] -> match Libc.readlink path with | Ok target -> - Dval.resultOk KTString (posixErrorKT ()) (DString target) |> Ply + Dval.resultOk KTString (posixErrorKT ()) (DString target) + |> Task.FromResult | Error e -> - Dval.resultError KTString (posixErrorKT ()) (dPosixError e) |> Ply + Dval.resultError KTString (posixErrorKT ()) (dPosixError e) + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -727,8 +742,8 @@ let fns () : List = Dval.resultError (KTTuple(VT.int64, VT.string, [])) (posixErrorKT ()) match Libc.mkstemp prefix with | Ok(fd, path) -> - resultOk (DTuple(DInt64(int64 fd), DString path, [])) |> Ply - | Error e -> resultError (dPosixError e) |> Ply + resultOk (DTuple(DInt64(int64 fd), DString path, [])) |> Task.FromResult + | Error e -> resultError (dPosixError e) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -749,9 +764,12 @@ let fns () : List = (function | _, _, _, [ DString prefix ] -> match Libc.mkdtemp prefix with - | Ok path -> Dval.resultOk KTString (posixErrorKT ()) (DString path) |> Ply + | Ok path -> + Dval.resultOk KTString (posixErrorKT ()) (DString path) + |> Task.FromResult | Error e -> - Dval.resultError KTString (posixErrorKT ()) (dPosixError e) |> Ply + Dval.resultError KTString (posixErrorKT ()) (dPosixError e) + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -774,8 +792,8 @@ let fns () : List = match Libc.listDir path with | Ok entries -> let dvals = entries |> List.map DString - resultOk (DList(ValueType.Known KTString, dvals)) |> Ply - | Error e -> resultError (dPosixError e) |> Ply + resultOk (DList(ValueType.Known KTString, dvals)) |> Task.FromResult + | Error e -> resultError (dPosixError e) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -791,8 +809,8 @@ let fns () : List = (function | _, _, _, [ DString name ] -> match Libc.getenv name with - | Some v -> Dval.optionSome KTString (DString v) |> Ply - | None -> Dval.optionNone KTString |> Ply + | Some v -> Dval.optionSome KTString (DString v) |> Task.FromResult + | None -> Dval.optionNone KTString |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -832,8 +850,8 @@ let fns () : List = resultOk ( DTuple(DInt64(int64 exitCode), DString stdout, [ DString stderr ]) ) - |> Ply - | Error e -> resultError (dPosixError e) |> Ply + |> Task.FromResult + | Error e -> resultError (dPosixError e) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -874,8 +892,8 @@ let fns () : List = resultOk ( DTuple(DInt64(int64 exitCode), DString stdout, [ DString stderr ]) ) - |> Ply - | Error e -> resultError (dPosixError e) |> Ply + |> Task.FromResult + | Error e -> resultError (dPosixError e) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -896,9 +914,10 @@ let fns () : List = (function | _, _, _, [ DInt64 pid; DInt64 signal ] -> match Libc.kill (int pid) (int signal) with - | Ok() -> Dval.resultOk KTUnit (posixErrorKT ()) DUnit |> Ply + | Ok() -> Dval.resultOk KTUnit (posixErrorKT ()) DUnit |> Task.FromResult | Error e -> - Dval.resultError KTUnit (posixErrorKT ()) (dPosixError e) |> Ply + Dval.resultError KTUnit (posixErrorKT ()) (dPosixError e) + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -919,8 +938,8 @@ let fns () : List = let resultOk = Dval.resultOk KTBlob (posixErrorKT ()) let resultError = Dval.resultError KTBlob (posixErrorKT ()) match Libc.fdRead (int fd) (int count) with - | Ok bytes -> resultOk (Blob.newEphemeral state bytes) |> Ply - | Error e -> resultError (dPosixError e) |> Ply + | Ok bytes -> resultOk (Blob.newEphemeral state bytes) |> Task.FromResult + | Error e -> resultError (dPosixError e) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -937,7 +956,7 @@ let fns () : List = fn = (function | state, _, _, [ DInt64 fd; DBlob ref ] -> - uply { + task { let! bytes = Blob.readBytes state ref match Libc.fdWrite (int fd) bytes with | Ok n -> @@ -945,6 +964,7 @@ let fns () : List = | Error e -> return Dval.resultError KTInt64 (posixErrorKT ()) (dPosixError e) } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -960,9 +980,10 @@ let fns () : List = (function | _, _, _, [ DInt64 fd ] -> match Libc.fdClose (int fd) with - | Ok() -> Dval.resultOk KTUnit (posixErrorKT ()) DUnit |> Ply + | Ok() -> Dval.resultOk KTUnit (posixErrorKT ()) DUnit |> Task.FromResult | Error e -> - Dval.resultError KTUnit (posixErrorKT ()) (dPosixError e) |> Ply + Dval.resultError KTUnit (posixErrorKT ()) (dPosixError e) + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -985,9 +1006,11 @@ let fns () : List = | _, _, _, [ DString path; DInt64 flags; DInt64 mode ] -> match Libc.openFile path (int flags) (int mode) with | Ok fd -> - Dval.resultOk KTInt64 (posixErrorKT ()) (DInt64(int64 fd)) |> Ply + Dval.resultOk KTInt64 (posixErrorKT ()) (DInt64(int64 fd)) + |> Task.FromResult | Error e -> - Dval.resultError KTInt64 (posixErrorKT ()) (dPosixError e) |> Ply + Dval.resultError KTInt64 (posixErrorKT ()) (dPosixError e) + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -1001,7 +1024,7 @@ let fns () : List = description = "Returns the O_RDONLY flag for open()" fn = (function - | _, _, _, [ DUnit ] -> DInt64(int64 Libc.O_RDONLY) |> Ply + | _, _, _, [ DUnit ] -> DInt64(int64 Libc.O_RDONLY) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -1015,7 +1038,7 @@ let fns () : List = description = "Returns the O_WRONLY flag for open()" fn = (function - | _, _, _, [ DUnit ] -> DInt64(int64 Libc.O_WRONLY) |> Ply + | _, _, _, [ DUnit ] -> DInt64(int64 Libc.O_WRONLY) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -1029,7 +1052,7 @@ let fns () : List = description = "Returns the O_RDWR flag for open()" fn = (function - | _, _, _, [ DUnit ] -> DInt64(int64 Libc.O_RDWR) |> Ply + | _, _, _, [ DUnit ] -> DInt64(int64 Libc.O_RDWR) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -1043,7 +1066,7 @@ let fns () : List = description = "Returns the O_CREAT flag for open() (platform-aware)" fn = (function - | _, _, _, [ DUnit ] -> DInt64(int64 Libc.O_CREAT) |> Ply + | _, _, _, [ DUnit ] -> DInt64(int64 Libc.O_CREAT) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -1057,7 +1080,7 @@ let fns () : List = description = "Returns the O_TRUNC flag for open() (platform-aware)" fn = (function - | _, _, _, [ DUnit ] -> DInt64(int64 Libc.O_TRUNC) |> Ply + | _, _, _, [ DUnit ] -> DInt64(int64 Libc.O_TRUNC) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -1071,7 +1094,7 @@ let fns () : List = description = "Returns the O_APPEND flag for open() (platform-aware)" fn = (function - | _, _, _, [ DUnit ] -> DInt64(int64 Libc.O_APPEND) |> Ply + | _, _, _, [ DUnit ] -> DInt64(int64 Libc.O_APPEND) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -1100,8 +1123,8 @@ let fns () : List = match Libc.stat path with | Ok(mode, size, mtimeSec) -> resultOk (DTuple(DInt64(int64 mode), DInt64 size, [ DInt64 mtimeSec ])) - |> Ply - | Error e -> resultError (dPosixError e) |> Ply + |> Task.FromResult + | Error e -> resultError (dPosixError e) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -1130,8 +1153,8 @@ let fns () : List = match Libc.uname () with | Ok(sysname, nodename, machine) -> resultOk (DTuple(DString sysname, DString nodename, [ DString machine ])) - |> Ply - | Error e -> resultError (dPosixError e) |> Ply + |> Task.FromResult + | Error e -> resultError (dPosixError e) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -1145,7 +1168,7 @@ let fns () : List = description = "Returns the current process ID via libc getpid()" fn = (function - | _, _, _, [ DUnit ] -> DInt64(int64 (Libc.getpid ())) |> Ply + | _, _, _, [ DUnit ] -> DInt64(int64 (Libc.getpid ())) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -1159,7 +1182,7 @@ let fns () : List = description = "Returns the current user ID via libc getuid()" fn = (function - | _, _, _, [ DUnit ] -> DInt64(int64 (Libc.getuid ())) |> Ply + | _, _, _, [ DUnit ] -> DInt64(int64 (Libc.getuid ())) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -1177,8 +1200,8 @@ let fns () : List = | _, _, _, [ DUnit ] -> let uid = Libc.getuid () match Libc.getUserName (uint32 uid) with - | Some name -> Dval.optionSome KTString (DString name) |> Ply - | None -> Dval.optionNone KTString |> Ply + | Some name -> Dval.optionSome KTString (DString name) |> Task.FromResult + | None -> Dval.optionNone KTString |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -1192,7 +1215,7 @@ let fns () : List = description = "Returns the number of online CPUs via sysconf()" fn = (function - | _, _, _, [ DUnit ] -> DInt64(Libc.cpuCount ()) |> Ply + | _, _, _, [ DUnit ] -> DInt64(Libc.cpuCount ()) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -1209,8 +1232,8 @@ let fns () : List = (function | _, _, _, [ DUnit ] -> match Libc.getHomeDir () with - | Some dir -> Dval.optionSome KTString (DString dir) |> Ply - | None -> Dval.optionNone KTString |> Ply + | Some dir -> Dval.optionSome KTString (DString dir) |> Task.FromResult + | None -> Dval.optionNone KTString |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -1229,7 +1252,7 @@ let fns () : List = (function | _, _, _, [ DString pattern; DString str; DBool pathMode ] -> let flags = if pathMode then Libc.FNM_PATHNAME else 0 - DBool(Libc.fnmatch pattern str flags) |> Ply + DBool(Libc.fnmatch pattern str flags) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -1248,9 +1271,10 @@ let fns () : List = | _, _, _, [ DInt64 fd; DBool exclusive ] -> let op = if exclusive then Libc.LOCK_EX else Libc.LOCK_UN match Libc.flock (int fd) op with - | Ok() -> Dval.resultOk KTUnit (posixErrorKT ()) DUnit |> Ply + | Ok() -> Dval.resultOk KTUnit (posixErrorKT ()) DUnit |> Task.FromResult | Error e -> - Dval.resultError KTUnit (posixErrorKT ()) (dPosixError e) |> Ply + Dval.resultError KTUnit (posixErrorKT ()) (dPosixError e) + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -1266,9 +1290,12 @@ let fns () : List = (function | _, _, _, [ DString path ] -> match Libc.fileOwner path with - | Ok name -> Dval.resultOk KTString (posixErrorKT ()) (DString name) |> Ply + | Ok name -> + Dval.resultOk KTString (posixErrorKT ()) (DString name) + |> Task.FromResult | Error e -> - Dval.resultError KTString (posixErrorKT ()) (dPosixError e) |> Ply + Dval.resultError KTString (posixErrorKT ()) (dPosixError e) + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure diff --git a/backend/src/BuiltinCli/Libs/Process.fs b/backend/src/BuiltinCli/Libs/Process.fs index 76dc76bfbc..92c8569c96 100644 --- a/backend/src/BuiltinCli/Libs/Process.fs +++ b/backend/src/BuiltinCli/Libs/Process.fs @@ -2,7 +2,6 @@ module BuiltinCli.Libs.Process open System.Threading.Tasks -open FSharp.Control.Tasks open Prelude open LibExecution.RuntimeTypes @@ -22,49 +21,48 @@ let fns () : List = fn = (function | _state, _, _, [ DList(_vtTODO, args) ] -> - uply { - try - let argStrings = - args - |> List.map (fun arg -> - match arg with - | DString s -> s - | _ -> Exception.raiseInternal "Expected string arguments" []) - - // Get the current executable path - let currentExe = - System.Diagnostics.Process.GetCurrentProcess().MainModule.FileName - - let psi = System.Diagnostics.ProcessStartInfo() - psi.FileName <- currentExe - psi.UseShellExecute <- false - psi.CreateNoWindow <- true - // Redirect to prevent inheriting parent's streams - psi.RedirectStandardOutput <- true - psi.RedirectStandardError <- true - psi.RedirectStandardInput <- true - - // Add arguments - for arg in argStrings do - psi.ArgumentList.Add(arg) - - let proc = System.Diagnostics.Process.Start(psi) - - if isNull proc then - return - Dval.resultError - KTInt64 - KTString - (DString "Failed to start background process") - else - return Dval.resultOk KTInt64 KTString (DInt64(int64 proc.Id)) - with ex -> - return - Dval.resultError - KTInt64 - KTString - (DString $"Error spawning process: {ex.Message}") - } + try + let argStrings = + args + |> List.map (fun arg -> + match arg with + | DString s -> s + | _ -> Exception.raiseInternal "Expected string arguments" []) + + // Get the current executable path + let currentExe = + System.Diagnostics.Process.GetCurrentProcess().MainModule.FileName + + let psi = System.Diagnostics.ProcessStartInfo() + psi.FileName <- currentExe + psi.UseShellExecute <- false + psi.CreateNoWindow <- true + // Redirect to prevent inheriting parent's streams + psi.RedirectStandardOutput <- true + psi.RedirectStandardError <- true + psi.RedirectStandardInput <- true + + // Add arguments + for arg in argStrings do + psi.ArgumentList.Add(arg) + + let proc = System.Diagnostics.Process.Start(psi) + + if isNull proc then + Dval.resultError + KTInt64 + KTString + (DString "Failed to start background process") + |> Task.FromResult + else + Dval.resultOk KTInt64 KTString (DInt64(int64 proc.Id)) + |> Task.FromResult + with ex -> + Dval.resultError + KTInt64 + KTString + (DString $"Error spawning process: {ex.Message}") + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Impure @@ -79,18 +77,15 @@ let fns () : List = fn = (function | _, _, _, [ DInt64 pid ] -> - uply { - try - let proc = System.Diagnostics.Process.GetProcessById(int pid) - let isRunning = not proc.HasExited - return DBool isRunning - with - | :? System.ArgumentException - - | :? System.InvalidOperationException -> - // Process doesn't exist or has exited - return DBool false - } + try + let proc = System.Diagnostics.Process.GetProcessById(int pid) + let isRunning = not proc.HasExited + DBool isRunning |> Task.FromResult + with + | :? System.ArgumentException + | :? System.InvalidOperationException -> + // Process doesn't exist or has exited + DBool false |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Impure @@ -106,22 +101,21 @@ let fns () : List = fn = (function | _state, _, _, [ DInt64 pid ] -> - uply { - try - let proc = System.Diagnostics.Process.GetProcessById(int pid) - proc.Kill() - proc.WaitForExit(5000) |> ignore - return Dval.resultOk KTUnit KTString DUnit - with - | :? System.ArgumentException -> - return Dval.resultError KTUnit KTString (DString "Process not found") - | ex -> - return - Dval.resultError - KTUnit - KTString - (DString $"Error killing process: {ex.Message}") - } + try + let proc = System.Diagnostics.Process.GetProcessById(int pid) + proc.Kill() + proc.WaitForExit(5000) |> ignore + Dval.resultOk KTUnit KTString DUnit |> Task.FromResult + with + | :? System.ArgumentException -> + Dval.resultError KTUnit KTString (DString "Process not found") + |> Task.FromResult + | ex -> + Dval.resultError + KTUnit + KTString + (DString $"Error killing process: {ex.Message}") + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Impure diff --git a/backend/src/BuiltinCli/Libs/Stdin.fs b/backend/src/BuiltinCli/Libs/Stdin.fs index c7256afa79..4ef8ee5696 100644 --- a/backend/src/BuiltinCli/Libs/Stdin.fs +++ b/backend/src/BuiltinCli/Libs/Stdin.fs @@ -11,6 +11,7 @@ module PackageRefs = LibExecution.PackageRefs module NR = LibExecution.RuntimeTypes.NameResolution open Builtin.Shortcuts +open System.Threading.Tasks /// Drain any buffered input characters that arrived in a burst /// (e.g. mouse wheel scroll generates many escape sequences at once). @@ -229,7 +230,7 @@ let fns () : List = Map [ "key", key; "modifiers", modifiers; "keyChar", keyChar ] ) - Ply(keyRead) + Task.FromResult(keyRead) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -245,7 +246,10 @@ let fns () : List = (function | _, _, _, [ DUnit ] -> let input = System.Console.ReadLine() - if input = null then Ply(DString "") else Ply(DString input) + if input = null then + Task.FromResult(DString "") + else + Task.FromResult(DString input) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -262,7 +266,7 @@ let fns () : List = | _, _, _, [ DUnit ] -> (not Console.IsInputRedirected || not Console.IsOutputRedirected) |> DBool - |> Ply + |> Task.FromResult | _ -> incorrectArgs () sqlSpec = NotQueryable previewable = Impure @@ -283,7 +287,7 @@ let fns () : List = let buffer = Array.zeroCreate (int length) let bytesRead = System.Console.In.Read(buffer, 0, (int length)) let input = System.String(buffer, 0, bytesRead) - Ply(DString input) + Task.FromResult(DString input) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -301,7 +305,7 @@ let fns () : List = (function | _, _, _, [ DUnit ] -> let input = System.Console.In.ReadToEnd() - Ply(DString input) + Task.FromResult(DString input) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure diff --git a/backend/src/BuiltinCli/Libs/Terminal.fs b/backend/src/BuiltinCli/Libs/Terminal.fs index c4dc22460d..26d4326905 100644 --- a/backend/src/BuiltinCli/Libs/Terminal.fs +++ b/backend/src/BuiltinCli/Libs/Terminal.fs @@ -1,7 +1,6 @@ module BuiltinCli.Libs.Terminal open System.Threading.Tasks -open FSharp.Control.Tasks open Prelude open LibExecution.RuntimeTypes @@ -99,7 +98,7 @@ let fns () : List = 24 &cachedHeight ) - |> Ply + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -122,7 +121,7 @@ let fns () : List = 80 &cachedWidth ) - |> Ply + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -136,7 +135,7 @@ let fns () : List = description = "Returns the absolute path to the CLI log directory" fn = (function - | _, _, [], [ DUnit ] -> DString(LibConfig.Config.logDir) |> Ply + | _, _, [], [ DUnit ] -> DString(LibConfig.Config.logDir) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure diff --git a/backend/src/BuiltinCli/Libs/Time.fs b/backend/src/BuiltinCli/Libs/Time.fs index a7cd9101a5..b553705d5a 100644 --- a/backend/src/BuiltinCli/Libs/Time.fs +++ b/backend/src/BuiltinCli/Libs/Time.fs @@ -2,7 +2,6 @@ module BuiltinCli.Libs.Time open System.Threading.Tasks -open FSharp.Control.Tasks open Prelude open LibExecution.RuntimeTypes @@ -19,11 +18,12 @@ let fns () : List = fn = (function | _, _, _, [ DFloat delay ] -> - uply { + task { let delay = System.TimeSpan.FromMilliseconds delay do! Task.Delay(delay) return DUnit } + | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Impure @@ -42,7 +42,7 @@ let fns () : List = | _, _, _, [ DUnit ] -> let ts = System.Diagnostics.Stopwatch.GetTimestamp() let ms = ts * 1000L / System.Diagnostics.Stopwatch.Frequency - DInt64 ms |> Ply + DInt64 ms |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Impure @@ -58,7 +58,7 @@ let fns () : List = | _, vm, _, [ DUnit ] -> vm.stats.reset () vm.stats.enabled <- true - DUnit |> Ply + DUnit |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Impure @@ -120,7 +120,7 @@ let fns () : List = sb.Append("}") |> ignore sb.Append("}") |> ignore - DString(sb.ToString()) |> Ply + DString(sb.ToString()) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Impure @@ -138,7 +138,7 @@ let fns () : List = | _, vm, _, [ DBool enabled ] -> vm.stats.enabled <- true vm.stats.detailedTiming <- enabled - DUnit |> Ply + DUnit |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Impure diff --git a/backend/src/BuiltinCli/paket.references b/backend/src/BuiltinCli/paket.references index 4b5bc5d60f..0dec7672bd 100644 --- a/backend/src/BuiltinCli/paket.references +++ b/backend/src/BuiltinCli/paket.references @@ -1,3 +1,2 @@ -Ply FSharp.Core FSharpPlus \ No newline at end of file diff --git a/backend/src/BuiltinCliHost/Libs/Canvas.fs b/backend/src/BuiltinCliHost/Libs/Canvas.fs index a9004d8c8d..65b03a4443 100644 --- a/backend/src/BuiltinCliHost/Libs/Canvas.fs +++ b/backend/src/BuiltinCliHost/Libs/Canvas.fs @@ -1,6 +1,7 @@ /// Builtin functions for canvas and DB operations in the CLI module BuiltinCliHost.Libs.Canvas +open System.Threading.Tasks open Prelude open LibExecution.RuntimeTypes open LibExecution.Builtin.Shortcuts @@ -34,7 +35,7 @@ let fns () : List = (function | _, _, _, [ DUuid canvasID; DString dbName; typeHashDval ] -> let typeHash = PT2DT.Hash.fromDT typeHashDval - uply { + task { // Check for existing DB with the same name let! existing = Sql.query @@ -70,6 +71,7 @@ let fns () : List = do! Canvas.saveTLIDs canvasID [ (toplevel, Serialize.NotDeleted) ] return Dval.resultOk KTUInt64 KTString (DUInt64 tlid) } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -87,10 +89,11 @@ let fns () : List = fn = (function | _, _, _, [ DUuid accountID; DString domain ] -> - uply { + task { let! canvasID = Canvas.getOrCreateForAccount accountID domain return DUuid canvasID } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -108,29 +111,30 @@ let fns () : List = fn = (function | _, _, _, [ DUuid canvasID; DUuid branchId ] -> - uply { + task { let! canvas = Canvas.loadAllDBs canvasID let pm = LibPackageManager.PackageManager.pt let! dbs = canvas.dbs |> Map.values - |> Ply.List.mapSequentially (fun (db : PT.DB.T) -> - uply { + |> Task.mapSequentially (fun (db : PT.DB.T) -> + task { let! typeName = match db.typ with | PT.TypeReference.TCustomType({ resolved = Ok(PT.FQTypeName.Package typeID) }, _) -> - uply { + task { let! locs = pm.getTypeLocations branchId typeID match locs with | location :: _ -> return PackageLocation.toFQN location | [] -> return typeID.ToString() } - | _ -> Ply "unknown" + | _ -> Task.FromResult "unknown" return DTuple(DString db.name, DString typeName, []) }) return Dval.list (KTTuple(VT.string, VT.string, [])) dbs } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -148,7 +152,7 @@ let fns () : List = fn = (function | _, _, _, [ DUuid canvasID; DString dbName ] -> - uply { + task { let! matchingTlids = Sql.query "SELECT tlid FROM toplevels_v0 @@ -184,6 +188,7 @@ let fns () : List = |> Sql.executeStatementAsync) return Dval.resultOk KTUnit KTString DUnit } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -199,12 +204,13 @@ let fns () : List = fn = (function | _, _, _, [ DString name ] -> - uply { + task { let! result = Account.getUserByName name match result with | Some userID -> return Dval.optionSome KTUuid (DUuid userID) | None -> return Dval.optionNone KTUuid } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure diff --git a/backend/src/BuiltinCliHost/Libs/Cli.fs b/backend/src/BuiltinCliHost/Libs/Cli.fs index 98bdc9b033..7221a4824e 100644 --- a/backend/src/BuiltinCliHost/Libs/Cli.fs +++ b/backend/src/BuiltinCliHost/Libs/Cli.fs @@ -3,7 +3,6 @@ module BuiltinCliHost.Libs.Cli open System.Threading.Tasks -open FSharp.Control.Tasks open Prelude @@ -32,8 +31,8 @@ module Tracing = LibCloud.Tracing // Load canvas ID and DBs for an account let loadCanvasAndDBs (accountID : Option) - : Ply * Map> = - uply { + : Task * Map> = + task { match accountID with | None -> return (None, Map.empty) | Some accID -> @@ -74,8 +73,8 @@ let parseCliScript (owner : string) (scriptName : string) (code : string) - : Ply> = - uply { + : Task> = + task { let args = NEList.ofList (DUuid branchId) @@ -143,8 +142,8 @@ let execute (canvasID : Option) (dbs : Map) (traceSource : CliTraceSource) - : Ply = - uply { + : Task = + task { let resolvedCanvasID = canvasID |> Option.defaultValue (System.Guid.NewGuid()) let (program : Program) = @@ -272,7 +271,7 @@ let fns () : List = DString code DList(_vtTODO, scriptArgs) DBool allowHarmful ] -> - uply { + task { let accountID = C2DT.Option.fromDT D.uuid accountIDDval // Use branch-specific state for parsing so name resolution uses the right branch let branchState = createBranchState exeState branchId allowHarmful @@ -309,6 +308,7 @@ let fns () : List = with e -> return createExceptionError e |> RT2DT.RuntimeError.toDT |> resultError } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -336,7 +336,7 @@ let fns () : List = _, [], [ accountIDDval; DUuid branchId; DString expression; DBool allowHarmful ] -> - uply { + task { let accountID = C2DT.Option.fromDT D.uuid accountIDDval // Use branch-specific state for parsing so name resolution uses the right branch let branchState = createBranchState exeState branchId allowHarmful @@ -377,6 +377,7 @@ let fns () : List = with e -> return createExceptionError e |> RT2DT.RuntimeError.toDT |> resultError } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure diff --git a/backend/src/BuiltinCliHost/Libs/Traces.fs b/backend/src/BuiltinCliHost/Libs/Traces.fs index 7a3e2b6751..ed7887624c 100644 --- a/backend/src/BuiltinCliHost/Libs/Traces.fs +++ b/backend/src/BuiltinCliHost/Libs/Traces.fs @@ -2,6 +2,7 @@ module BuiltinCliHost.Libs.Traces open System.Text.Json +open System.Threading.Tasks open Prelude open LibExecution.RuntimeTypes @@ -39,10 +40,10 @@ let private parseArgsJson (argsJson : string) : List = /// Args/result are stored as JSON inline; parse them per row. The display /// name was resolved at write time and lives in fn_hash, so reads are a /// flat SELECT — lambdas have NULL fn_hash and render as "(lambda)". -let private loadFnCalls (traceId : string) : Ply = +let private loadFnCalls (traceId : string) : Task = let typeName = fnCallTypeName () let dvalKT = KTCustomType(dvalTypeName (), []) - uply { + task { let! events = Sql.query "SELECT call_id, parent_call_id, kind, fn_hash, lambda_expr_id, @@ -102,7 +103,7 @@ let fns () : List = fn = (function | _, _, _, [ DInt64 limit ] -> - uply { + task { let typeName = traceSummaryTypeName () let! rows = Sql.query @@ -127,6 +128,7 @@ let fns () : List = DRecord(typeName, typeName, [], fields)) |> Dval.list (KTCustomType(typeName, [])) } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -142,7 +144,7 @@ let fns () : List = fn = (function | _, _, _, [ DString traceID ] -> - uply { + task { // One SELECT covers metadata + input — both live on the trace row. let! row = Sql.query @@ -181,6 +183,7 @@ let fns () : List = |> Dval.optionSome (KTCustomType(typeName, [])) | None -> return Dval.optionNone (KTCustomType(typeName, [])) } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -197,7 +200,7 @@ let fns () : List = fn = (function | _, _, _, [ DString fnName; DInt64 limit ] -> - uply { + task { // Both builtins and package fns store their display name in // fn_hash (resolved at write time), so one LIKE matches either. let typeName = traceSummaryTypeName () @@ -228,6 +231,7 @@ let fns () : List = DRecord(typeName, typeName, [], fields)) |> Dval.list (KTCustomType(typeName, [])) } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -242,7 +246,7 @@ let fns () : List = fn = (function | _, _, _, [ DString traceID ] -> - uply { + task { let! row = Sql.query "SELECT input_value_json FROM traces WHERE id = @traceId" |> Sql.parameters [ "traceId", Sql.string traceID ] @@ -261,6 +265,7 @@ let fns () : List = print $"[traces] Failed to parse input for replay: {ex.Message}" return Dval.optionNone KTString } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -275,7 +280,7 @@ let fns () : List = fn = (function | _, _, _, [ DUnit ] -> - uply { + task { let! count = Sql.query "SELECT COUNT(*) as c FROM traces" |> Sql.executeRowAsync (fun read -> read.int64 "c") @@ -283,6 +288,7 @@ let fns () : List = do! Sql.query "DELETE FROM traces" |> Sql.executeStatementAsync return DInt64 count } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure diff --git a/backend/src/BuiltinCliHost/paket.references b/backend/src/BuiltinCliHost/paket.references index ef6c97ff23..6f9a475af2 100644 --- a/backend/src/BuiltinCliHost/paket.references +++ b/backend/src/BuiltinCliHost/paket.references @@ -1,4 +1,3 @@ -Ply FSharp.Core Microsoft.Data.Sqlite Fumble \ No newline at end of file diff --git a/backend/src/BuiltinCloudExecution/Libs/DB.fs b/backend/src/BuiltinCloudExecution/Libs/DB.fs index bfd2412129..2c39fa9fca 100644 --- a/backend/src/BuiltinCloudExecution/Libs/DB.fs +++ b/backend/src/BuiltinCloudExecution/Libs/DB.fs @@ -4,6 +4,7 @@ module BuiltinCloudExecution.Libs.DB open Prelude open LibExecution.RuntimeTypes open LibExecution.Builtin.Shortcuts +open System.Threading.Tasks module VT = LibExecution.ValueType module Dval = LibExecution.Dval @@ -38,8 +39,8 @@ let queryFilterParam v = let resolveLoadValues (exeState : ExecutionState) (lambdaImpl : LambdaImpl) - : Ply.Ply> = - uply { + : Task> = + task { // Collect all value references from LoadValue instructions let valueRefs = lambdaImpl.instructions.instructions @@ -51,8 +52,8 @@ let resolveLoadValues // Resolve each value let! resolved = valueRefs - |> Ply.List.mapSequentially (fun valueName -> - uply { + |> Task.mapSequentially (fun valueName -> + task { match valueName with | FQValueName.Builtin builtinName -> // Builtin values - look up in builtIn values @@ -83,8 +84,8 @@ let lookupLambdaImpl (exeState : ExecutionState) (exprId : id) : LambdaImpl = let compileQueryLambda (exeState : ExecutionState) (appLambda : ApplicableLambda) - : Ply.Ply = - uply { + : Task = + task { let lambdaImpl = lookupLambdaImpl exeState appLambda.exprId let! resolvedValues = resolveLoadValues exeState lambdaImpl @@ -127,7 +128,7 @@ let fns () : List = fn = (function | exeState, vm, _, [ value; DString key; DDB dbname ] -> - uply { + task { let db = exeState.program.dbs[dbname] let! id = UserDB.set exeState vm.threadID true db key value @@ -136,6 +137,7 @@ let fns () : List = | Ok _id -> return value | Error rte -> return raiseUntargetedRTE rte } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -150,11 +152,12 @@ let fns () : List = fn = (function | exeState, vm, _, [ DString key; DDB dbname ] -> - uply { + task { let db = exeState.program.dbs[dbname] let! result = UserDB.getOption exeState vm.threadID db key return TypeChecker.DvalCreator.option vm.threadID VT.unknownDbTODO result } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -172,7 +175,7 @@ let fns () : List = let optType = KTList valueType (function | exeState, vm, _, [ DList(_, keys); DDB dbname ] -> - uply { + task { let db = exeState.program.dbs[dbname] let tst = Map.empty // TODO idk if this is reasonable @@ -192,6 +195,7 @@ let fns () : List = else return Dval.optionNone optType } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -207,7 +211,7 @@ let fns () : List = fn = (function | exeState, vm, _, [ DList(_, keys); DDB dbname ] -> - uply { + task { let db = exeState.program.dbs[dbname] let tst = Map.empty // TODO idk if this is reasonable @@ -221,6 +225,7 @@ let fns () : List = return result |> TypeChecker.DvalCreator.list vm.threadID VT.unknownDbTODO } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -236,7 +241,7 @@ let fns () : List = fn = (function | exeState, vm, _, [ DList(_, keys); DDB dbname ] -> - uply { + task { let db = exeState.program.dbs[dbname] let tst = Map.empty // TODO idk if this is reasonable @@ -249,6 +254,7 @@ let fns () : List = |> UserDB.getManyWithKeys exeState vm.threadID tst db return TypeChecker.DvalCreator.dict vm.threadID VT.unknownDbTODO result } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -263,11 +269,12 @@ let fns () : List = fn = (function | exeState, _, _, [ DString key; DDB dbname ] -> - uply { + task { let db = exeState.program.dbs[dbname] do! UserDB.delete exeState db key return DUnit } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -282,11 +289,12 @@ let fns () : List = fn = (function | exeState, _, _, [ DDB dbname ] -> - uply { + task { let db = exeState.program.dbs[dbname] do! UserDB.deleteAll exeState db return DUnit } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -301,7 +309,7 @@ let fns () : List = fn = (function | exeState, vm, _, [ DDB dbname ] -> - uply { + task { let db = exeState.program.dbs[dbname] let tst = Map.empty // TODO idk if this is reasonable let! results = UserDB.getAll exeState vm.threadID tst db @@ -310,6 +318,7 @@ let fns () : List = |> List.map snd |> TypeChecker.DvalCreator.list vm.threadID VT.unknownDbTODO } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -325,12 +334,13 @@ let fns () : List = fn = (function | exeState, vm, _, [ DDB dbname ] -> - uply { + task { let db = exeState.program.dbs[dbname] let tst = Map.empty // TODO idk if this is reasonable let! result = UserDB.getAll exeState vm.threadID tst db return TypeChecker.DvalCreator.dict vm.threadID VT.unknownDbTODO result } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -345,11 +355,12 @@ let fns () : List = fn = (function | exeState, _, _, [ DDB dbname ] -> - uply { + task { let db = exeState.program.dbs[dbname] let! (count : int) = UserDB.count exeState db return count |> int64 |> DInt64 } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -363,7 +374,8 @@ let fns () : List = description = "Returns a random key suitable for use as a DB key" fn = (function - | _, _, _, [ DUnit ] -> System.Guid.NewGuid() |> string |> DString |> Ply + | _, _, _, [ DUnit ] -> + System.Guid.NewGuid() |> string |> DString |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -379,11 +391,12 @@ let fns () : List = fn = (function | exeState, _, _, [ DDB dbname ] -> - uply { + task { let db = exeState.program.dbs[dbname] let! results = UserDB.getAllKeys exeState db return results |> List.map DString |> Dval.list KTString } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -401,7 +414,7 @@ let fns () : List = fn = (function | exeState, vm, _, [ DDB dbname; DApplicable(AppLambda appLambda) ] -> - uply { + task { let db = exeState.program.dbs[dbname] let! compiled = compileQueryLambda exeState appLambda return! @@ -412,7 +425,9 @@ let fns () : List = UserDB.DBQueryAll compiled.sql compiled.paramValues + } + | _ -> incorrectArgs ()) sqlSpec = QueryFunction previewable = Impure @@ -428,7 +443,7 @@ let fns () : List = fn = (function | exeState, vm, _, [ DDB dbname; DApplicable(AppLambda appLambda) ] -> - uply { + task { let db = exeState.program.dbs[dbname] let! compiled = compileQueryLambda exeState appLambda return! @@ -439,7 +454,9 @@ let fns () : List = UserDB.DBQueryWithKey compiled.sql compiled.paramValues + } + | _ -> incorrectArgs ()) sqlSpec = QueryFunction previewable = Impure @@ -455,7 +472,7 @@ let fns () : List = fn = (function | exeState, vm, _, [ DDB dbname; DApplicable(AppLambda appLambda) ] -> - uply { + task { let db = exeState.program.dbs[dbname] let! compiled = compileQueryLambda exeState appLambda return! @@ -466,7 +483,9 @@ let fns () : List = UserDB.DBQueryOne compiled.sql compiled.paramValues + } + | _ -> incorrectArgs ()) sqlSpec = QueryFunction previewable = Impure @@ -482,7 +501,7 @@ let fns () : List = fn = (function | exeState, vm, _, [ DDB dbname; DApplicable(AppLambda appLambda) ] -> - uply { + task { let db = exeState.program.dbs[dbname] let! compiled = compileQueryLambda exeState appLambda return! @@ -493,7 +512,9 @@ let fns () : List = UserDB.DBQueryCount compiled.sql compiled.paramValues + } + | _ -> incorrectArgs ()) sqlSpec = QueryFunction previewable = Impure diff --git a/backend/src/BuiltinDarkInternal/Builtin.fs b/backend/src/BuiltinDarkInternal/Builtin.fs index c100a63771..fdaf958f29 100644 --- a/backend/src/BuiltinDarkInternal/Builtin.fs +++ b/backend/src/BuiltinDarkInternal/Builtin.fs @@ -19,7 +19,7 @@ let fnRenames : Builtin.FnRenames = // only accessible to the LibCloud.Config.allowedDarkInternalCanvasID canvas let internalFn (f : BuiltInFnSig) : BuiltInFnSig = (fun (exeState, vmState, typeArgs, args) -> - uply { + task { if exeState.program.internalFnsAllowed then return! f (exeState, vmState, typeArgs, args) else diff --git a/backend/src/BuiltinDarkInternal/Libs/Canvases.fs b/backend/src/BuiltinDarkInternal/Libs/Canvases.fs index 9ff1e85c9e..f6968484aa 100644 --- a/backend/src/BuiltinDarkInternal/Libs/Canvases.fs +++ b/backend/src/BuiltinDarkInternal/Libs/Canvases.fs @@ -25,7 +25,7 @@ let fns () : List = fn = (function | _, _, _, [ DUnit ] -> - uply { + task { let! hosts = Canvas.allCanvasIDs () return DList(VT.uuid, List.map DUuid hosts) } @@ -43,7 +43,7 @@ let fns () : List = fn = (function | _, _, _, [ DString name ] -> - uply { + task { let! canvasID = Canvas.create None name return DUuid canvasID } @@ -65,7 +65,7 @@ let fns () : List = fn = (function | _, _, _, [ DUuid canvasID; DUInt64 tlid ] -> - uply { + task { let tlid = uint64 tlid let! c = Canvas.loadFrom canvasID [ tlid ] if @@ -102,7 +102,7 @@ let fns () : List = fn = (function | _, _, _, [ DUuid canvasID ] -> - uply { + task { let! _canvas = Canvas.loadAll canvasID // let dbs = diff --git a/backend/src/BuiltinDarkInternal/Libs/DBs.fs b/backend/src/BuiltinDarkInternal/Libs/DBs.fs index c195846057..b465c23f5d 100644 --- a/backend/src/BuiltinDarkInternal/Libs/DBs.fs +++ b/backend/src/BuiltinDarkInternal/Libs/DBs.fs @@ -20,7 +20,7 @@ let fns () : List = fn = (function | _, _, _, [ DUuid canvasID ] -> - uply { + task { let! tlids = UserDB.all canvasID return tlids |> List.map uint64 |> List.map DUInt64 |> Dval.list KTUInt64 } @@ -38,7 +38,7 @@ let fns () : List = fn = (function | _, _, _, [ DUuid canvasID ] -> - uply { + task { let! unlocked = UserDB.unlocked canvasID return unlocked |> List.map int64 |> List.map DInt64 |> Dval.list KTInt64 } diff --git a/backend/src/BuiltinDarkInternal/Libs/Domains.fs b/backend/src/BuiltinDarkInternal/Libs/Domains.fs index 3300185e18..89ef8c36e2 100644 --- a/backend/src/BuiltinDarkInternal/Libs/Domains.fs +++ b/backend/src/BuiltinDarkInternal/Libs/Domains.fs @@ -20,7 +20,7 @@ let fns () : List = fn = (function | _, _, _, [ DUuid canvasID ] -> - uply { + task { let! name = Canvas.domainsForCanvasID canvasID return name |> List.map DString |> Dval.list KTString } @@ -40,7 +40,7 @@ let fns () : List = let resultError = Dval.resultError KTUuid KTString (function | _, _, _, [ DString domain ] -> - uply { + task { let! name = Canvas.canvasIDForDomain domain match name with | Some name -> return resultOk (DUuid name) diff --git a/backend/src/BuiltinDarkInternal/Libs/Infra.fs b/backend/src/BuiltinDarkInternal/Libs/Infra.fs index b260e90428..9c538e18a4 100644 --- a/backend/src/BuiltinDarkInternal/Libs/Infra.fs +++ b/backend/src/BuiltinDarkInternal/Libs/Infra.fs @@ -4,6 +4,7 @@ module BuiltinDarkInternal.Libs.Infra open Prelude open LibExecution.RuntimeTypes open LibExecution.Builtin.Shortcuts +open System.Threading.Tasks module Dval = LibExecution.Dval module PackageRefs = LibExecution.PackageRefs @@ -29,7 +30,7 @@ let fns () : List = fn = (function | _, _, _, [ DUnit ] -> - uply { + task { let! tableStats = LibDB.Db.tableStats () let typeName = @@ -60,7 +61,8 @@ let fns () : List = description = "Returns the git hash of the server's current deploy" fn = (function - | _, _, _, [ DUnit ] -> LibService.Config.buildHash |> DString |> Ply + | _, _, _, [ DUnit ] -> + LibService.Config.buildHash |> DString |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure diff --git a/backend/src/BuiltinDarkInternal/Libs/Users.fs b/backend/src/BuiltinDarkInternal/Libs/Users.fs index bc1b65be43..4e584714d7 100644 --- a/backend/src/BuiltinDarkInternal/Libs/Users.fs +++ b/backend/src/BuiltinDarkInternal/Libs/Users.fs @@ -22,7 +22,7 @@ let fns () : List = let resultError = Dval.resultError KTUuid KTString (function | _, _, _, [ DString name ] -> - uply { + task { let! result = LibCloud.Account.createUser name match result with | Ok userID -> return resultOk (DUuid userID) diff --git a/backend/src/BuiltinExecution/Libs/AltJson.fs b/backend/src/BuiltinExecution/Libs/AltJson.fs index 213a452bea..b2c2e36c67 100644 --- a/backend/src/BuiltinExecution/Libs/AltJson.fs +++ b/backend/src/BuiltinExecution/Libs/AltJson.fs @@ -5,6 +5,7 @@ open System.Text.Json open Prelude open LibExecution.RuntimeTypes open LibExecution.Builtin.Shortcuts +open System.Threading.Tasks module VT = LibExecution.ValueType module Dval = LibExecution.Dval @@ -191,7 +192,7 @@ let fns () : List = | _, _, [], [ jtDval ] -> let jt = Json.fromDT jtDval let jsonString = Serialize.writeJson (fun w -> Serialize.writeToken w jt) - Ply(DString jsonString) + Task.FromResult(DString jsonString) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -209,8 +210,8 @@ let fns () : List = (function | _, _, [], [ DString jsonString ] -> match Parsing.parse jsonString with - | Ok jt -> jt |> Json.toDT |> Ok |> result |> Ply - | Error e -> e |> ParseError.toDT |> Error |> result |> Ply + | Ok jt -> jt |> Json.toDT |> Ok |> result |> Task.FromResult + | Error e -> e |> ParseError.toDT |> Error |> result |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure diff --git a/backend/src/BuiltinExecution/Libs/Base64.fs b/backend/src/BuiltinExecution/Libs/Base64.fs index 54c9bd7f2d..70ef4a9be7 100644 --- a/backend/src/BuiltinExecution/Libs/Base64.fs +++ b/backend/src/BuiltinExecution/Libs/Base64.fs @@ -6,6 +6,7 @@ open System.Text.RegularExpressions open Prelude open LibExecution.RuntimeTypes open LibExecution.Builtin.Shortcuts +open System.Threading.Tasks module VT = LibExecution.ValueType module Dval = LibExecution.Dval @@ -23,8 +24,8 @@ let fns () : List = sections [4](https://www.rfc-editor.org/rfc/rfc4648.html#section-4) and [5](https://www.rfc-editor.org/rfc/rfc4648.html#section-5)." fn = - let resultOk r = Dval.resultOk KTBlob KTString r |> Ply - let resultError r = Dval.resultError KTBlob KTString r |> Ply + let resultOk r = Dval.resultOk KTBlob KTString r |> Task.FromResult + let resultError r = Dval.resultError KTBlob KTString r |> Task.FromResult (function | state, _, _, [ DString s ] -> let base64FromUrlEncoded (str : string) : string = @@ -64,10 +65,11 @@ let fns () : List = fn = (function | state, _, _, [ DBlob ref ] -> - uply { + task { let! bytes = Blob.readBytes state ref return DString(System.Convert.ToBase64String(bytes)) } + | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -85,7 +87,7 @@ let fns () : List = fn = (function | state, _, _, [ DBlob ref ] -> - uply { + task { let! bytes = Blob.readBytes state ref // Differs from Base64.encodeToUrlSafe as this version has padding let encoded = @@ -95,6 +97,7 @@ let fns () : List = .Replace('/', '_') return DString encoded } + | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure diff --git a/backend/src/BuiltinExecution/Libs/Blob.fs b/backend/src/BuiltinExecution/Libs/Blob.fs index f487323179..0cd9af9caf 100644 --- a/backend/src/BuiltinExecution/Libs/Blob.fs +++ b/backend/src/BuiltinExecution/Libs/Blob.fs @@ -5,6 +5,7 @@ open System.Text open Prelude open LibExecution.RuntimeTypes open LibExecution.Builtin.Shortcuts +open System.Threading.Tasks module VT = LibExecution.ValueType module Dval = LibExecution.Dval @@ -22,10 +23,11 @@ let fns () : List = fn = (function | state, _, _, [ DBlob ref ] -> - uply { + task { let! bs = Blob.readBytes state ref return DInt64(int64 bs.Length) } + | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -41,7 +43,7 @@ let fns () : List = (function | state, _, _, [ DString s ] -> let bs = System.Text.Encoding.UTF8.GetBytes(s) - Blob.newEphemeral state bs |> Ply + Blob.newEphemeral state bs |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -59,7 +61,7 @@ let fns () : List = let err r = Dval.resultError KTString KTString r (function | state, _, _, [ DBlob ref ] -> - uply { + task { let! bs = Blob.readBytes state ref try let s = (new System.Text.UTF8Encoding(false, true)).GetString(bs) @@ -67,6 +69,7 @@ let fns () : List = with e -> return err (DString($"Invalid UTF-8: {e.Message}")) } + | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -83,10 +86,11 @@ let fns () : List = fn = (function | state, _, _, [ DBlob ref ] -> - uply { + task { let! bs = Blob.readBytes state ref return DString(System.Convert.ToHexString(bs)) } + | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -106,9 +110,9 @@ let fns () : List = | state, _, _, [ DString s ] -> try let bs = System.Convert.FromHexString(s) - ok (Blob.newEphemeral state bs) |> Ply + ok (Blob.newEphemeral state bs) |> Task.FromResult with e -> - err $"Invalid hex string: {e.Message}" |> Ply + err $"Invalid hex string: {e.Message}" |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -124,10 +128,11 @@ let fns () : List = fn = (function | state, _, _, [ DBlob ref ] -> - uply { + task { let! bs = Blob.readBytes state ref return DString(System.Convert.ToBase64String(bs)) } + | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -155,9 +160,9 @@ let fns () : List = | _ -> base0 try let bs = System.Convert.FromBase64String(normalized) - ok (Blob.newEphemeral state bs) |> Ply + ok (Blob.newEphemeral state bs) |> Task.FromResult with e -> - err $"Invalid base64 string: {e.Message}" |> Ply + err $"Invalid base64 string: {e.Message}" |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -173,7 +178,7 @@ let fns () : List = fn = (function | state, _, _, [ DList(_, items) ] -> - uply { + task { use collected = new System.IO.MemoryStream() for item in items do match item with @@ -181,12 +186,10 @@ let fns () : List = let! bs = Blob.readBytes state ref collected.Write(bs, 0, bs.Length) | _ -> - return - Exception.raiseInternal - "blobConcat: expected DBlob" - [ "item", item ] + Exception.raiseInternal "blobConcat: expected DBlob" [ "item", item ] return Blob.newEphemeral state (collected.ToArray()) } + | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -209,7 +212,7 @@ let fns () : List = fn = (function | state, _, _, [ DBlob ref; DInt64 startL; DInt64 lenL ] -> - uply { + task { let! bs = Blob.readBytes state ref let len64 = int64 bs.Length let safeStart = max 0L (min startL len64) @@ -219,6 +222,7 @@ let fns () : List = System.Array.Copy(bs, int safeStart, slice, 0, int safeLen) return Blob.newEphemeral state slice } + | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -234,10 +238,11 @@ let fns () : List = fn = (function | state, _, _, [ DBlob ref ] -> - uply { + task { let! bs = Blob.readBytes state ref return Dval.byteArrayToDvalList bs } + | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -254,7 +259,7 @@ let fns () : List = (function | state, _, _, [ DList(_, items) ] -> let bs = Dval.dlistToByteArray items - Blob.newEphemeral state bs |> Ply + Blob.newEphemeral state bs |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure diff --git a/backend/src/BuiltinExecution/Libs/Bool.fs b/backend/src/BuiltinExecution/Libs/Bool.fs index aac46f9c63..64b119e3dd 100644 --- a/backend/src/BuiltinExecution/Libs/Bool.fs +++ b/backend/src/BuiltinExecution/Libs/Bool.fs @@ -1,7 +1,6 @@ module BuiltinExecution.Libs.Bool open System.Threading.Tasks -open FSharp.Control.Tasks open Prelude open LibExecution.RuntimeTypes open LibExecution.Builtin.Shortcuts @@ -19,7 +18,7 @@ let fns () : List = and {{false}} if is {{true}}" fn = (function - | _, _, _, [ DBool b ] -> Ply(DBool(not b)) + | _, _, _, [ DBool b ] -> Task.FromResult(DBool(not b)) | _ -> incorrectArgs ()) sqlSpec = SqlFunction "not" previewable = Pure diff --git a/backend/src/BuiltinExecution/Libs/Builtins.fs b/backend/src/BuiltinExecution/Libs/Builtins.fs index 852dc743aa..2cd3a1e21c 100644 --- a/backend/src/BuiltinExecution/Libs/Builtins.fs +++ b/backend/src/BuiltinExecution/Libs/Builtins.fs @@ -3,6 +3,7 @@ module BuiltinExecution.Libs.Builtins open Prelude open LibExecution.RuntimeTypes open LibExecution.Builtin.Shortcuts +open System.Threading.Tasks module Dval = LibExecution.Dval module PackageRefs = LibExecution.PackageRefs @@ -67,23 +68,21 @@ let fns () : List = fn = (function | exeState, _, [], [ DUnit ] -> - uply { - let fns = - exeState.fns.builtIn - |> Map.values - |> List.filter (fun fn -> - match fn.deprecated with - | NotDeprecated -> true - | _ -> false) - |> List.sortBy (fun fn -> fn.name.name) + let fns = + exeState.fns.builtIn + |> Map.values + |> List.filter (fun fn -> + match fn.deprecated with + | NotDeprecated -> true + | _ -> false) + |> List.sortBy (fun fn -> fn.name.name) - let builtins = - fns - |> List.map ToDarkTypes.FunctionInfo.toDT - |> Dval.list (KTCustomType(ToDarkTypes.FunctionInfo.typeName (), [])) + let builtins = + fns + |> List.map ToDarkTypes.FunctionInfo.toDT + |> Dval.list (KTCustomType(ToDarkTypes.FunctionInfo.typeName (), [])) - return builtins - } + Task.FromResult builtins | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure diff --git a/backend/src/BuiltinExecution/Libs/Char.fs b/backend/src/BuiltinExecution/Libs/Char.fs index d08d1a6e6d..46d7366cbb 100644 --- a/backend/src/BuiltinExecution/Libs/Char.fs +++ b/backend/src/BuiltinExecution/Libs/Char.fs @@ -3,6 +3,7 @@ module BuiltinExecution.Libs.Char open Prelude open LibExecution.RuntimeTypes open LibExecution.Builtin.Shortcuts +open System.Threading.Tasks module VT = LibExecution.ValueType module Dval = LibExecution.Dval @@ -18,7 +19,7 @@ let fns () : List = If does not have an uppercase value, returns " fn = function - | _, _, _, [ DChar c ] -> Ply(DChar(c.ToUpper())) + | _, _, _, [ DChar c ] -> Task.FromResult(DChar(c.ToUpper())) | _ -> incorrectArgs () sqlSpec = NotYetImplemented previewable = Pure @@ -34,7 +35,7 @@ let fns () : List = If does not have a lowercase value, returns " fn = function - | _, _, _, [ DChar c ] -> Ply(DChar(c.ToLower())) + | _, _, _, [ DChar c ] -> Task.FromResult(DChar(c.ToLower())) | _ -> incorrectArgs () sqlSpec = NotYetImplemented previewable = Pure @@ -52,9 +53,9 @@ let fns () : List = | _, _, _, [ DChar c ] -> let charValue = int c[0] if charValue >= 0 && charValue < 256 then - Dval.optionSome KTInt64 (DInt64 charValue) |> Ply + Dval.optionSome KTInt64 (DInt64 charValue) |> Task.FromResult else - Dval.optionNone KTInt64 |> Ply + Dval.optionNone KTInt64 |> Task.FromResult | _ -> incorrectArgs () sqlSpec = NotYetImplemented previewable = Pure @@ -68,7 +69,7 @@ let fns () : List = description = "Return whether is less than " fn = function - | _, _, _, [ DChar c1; DChar c2 ] -> (c1 < c2) |> DBool |> Ply + | _, _, _, [ DChar c1; DChar c2 ] -> (c1 < c2) |> DBool |> Task.FromResult | _ -> incorrectArgs () sqlSpec = NotYetImplemented previewable = Pure @@ -82,7 +83,7 @@ let fns () : List = description = "Return whether is less than " fn = function - | _, _, _, [ DChar c1; DChar c2 ] -> (c1 <= c2) |> DBool |> Ply + | _, _, _, [ DChar c1; DChar c2 ] -> (c1 <= c2) |> DBool |> Task.FromResult | _ -> incorrectArgs () sqlSpec = NotYetImplemented previewable = Pure @@ -96,7 +97,7 @@ let fns () : List = description = "Return whether is greater than " fn = function - | _, _, _, [ DChar c1; DChar c2 ] -> (c1 > c2) |> DBool |> Ply + | _, _, _, [ DChar c1; DChar c2 ] -> (c1 > c2) |> DBool |> Task.FromResult | _ -> incorrectArgs () sqlSpec = NotYetImplemented previewable = Pure @@ -110,7 +111,7 @@ let fns () : List = description = "Return whether is greater than " fn = function - | _, _, _, [ DChar c1; DChar c2 ] -> (c1 >= c2) |> DBool |> Ply + | _, _, _, [ DChar c1; DChar c2 ] -> (c1 >= c2) |> DBool |> Task.FromResult | _ -> incorrectArgs () sqlSpec = NotYetImplemented previewable = Pure @@ -124,7 +125,7 @@ let fns () : List = description = "Stringify " fn = (function - | _, _, _, [ DChar c ] -> Ply(DString c) + | _, _, _, [ DChar c ] -> Task.FromResult(DString c) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure diff --git a/backend/src/BuiltinExecution/Libs/Crypto.fs b/backend/src/BuiltinExecution/Libs/Crypto.fs index f155899363..df670a48f3 100644 --- a/backend/src/BuiltinExecution/Libs/Crypto.fs +++ b/backend/src/BuiltinExecution/Libs/Crypto.fs @@ -25,11 +25,12 @@ let fns () : List = fn = (function | state, _, _, [ DBlob ref ] -> - uply { + task { let! data = Blob.readBytes state ref let hash = SHA256.HashData(System.ReadOnlySpan(data)) return Blob.newEphemeral state hash } + | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -44,11 +45,12 @@ let fns () : List = fn = (function | state, _, _, [ DBlob ref ] -> - uply { + task { let! data = Blob.readBytes state ref let hash = SHA384.HashData(System.ReadOnlySpan data) return Blob.newEphemeral state hash } + | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -64,11 +66,12 @@ let fns () : List = fn = (function | state, _, _, [ DBlob ref ] -> - uply { + task { let! data = Blob.readBytes state ref let hash = MD5.HashData(System.ReadOnlySpan data) return Blob.newEphemeral state hash } + | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = ImpurePreviewable @@ -84,13 +87,14 @@ let fns () : List = fn = (function | state, _, _, [ DBlob keyRef; DBlob dataRef ] -> - uply { + task { let! key = Blob.readBytes state keyRef let! data = Blob.readBytes state dataRef use hmac = new HMACSHA256(key) let hash = hmac.ComputeHash(data) return Blob.newEphemeral state hash } + | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = ImpurePreviewable @@ -106,13 +110,14 @@ let fns () : List = fn = (function | state, _, _, [ DBlob keyRef; DBlob dataRef ] -> - uply { + task { let! key = Blob.readBytes state keyRef let! data = Blob.readBytes state dataRef use hmac = new HMACSHA1(key) let hash = hmac.ComputeHash(data) return Blob.newEphemeral state hash } + | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = ImpurePreviewable diff --git a/backend/src/BuiltinExecution/Libs/DateTime.fs b/backend/src/BuiltinExecution/Libs/DateTime.fs index 146ba422cf..804cacf3c6 100644 --- a/backend/src/BuiltinExecution/Libs/DateTime.fs +++ b/backend/src/BuiltinExecution/Libs/DateTime.fs @@ -5,6 +5,7 @@ type Instant = NodaTime.Instant open Prelude open LibExecution.RuntimeTypes open LibExecution.Builtin.Shortcuts +open System.Threading.Tasks module VT = LibExecution.ValueType module Dval = LibExecution.Dval module DarkDateTime = LibExecution.DarkDateTime @@ -46,7 +47,7 @@ let fns () : List = |> Result.map DDateTime |> Result.mapError (fun () -> DString "Invalid date format") |> Dval.result KTDateTime KTString - |> Ply + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -73,7 +74,7 @@ let fns () : List = dt.ToString("s", System.Globalization.CultureInfo.InvariantCulture) + "Z" - str |> DString |> Ply + str |> DString |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -91,7 +92,7 @@ let fns () : List = | _, _, _, [ DDateTime d ] -> (DarkDateTime.toDateTimeUtc d).ToString("yyyyMMddTHHmmssZ") |> DString - |> Ply + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -106,7 +107,9 @@ let fns () : List = fn = (function | _, _, _, [ DDateTime d ] -> - (DarkDateTime.toDateTimeUtc d).ToString("yyyyMMdd") |> DString |> Ply + (DarkDateTime.toDateTimeUtc d).ToString("yyyyMMdd") + |> DString + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -121,7 +124,7 @@ let fns () : List = fn = (function | _, _, _, [ DUnit ] -> - Instant.now () |> DarkDateTime.fromInstant |> DDateTime |> Ply + Instant.now () |> DarkDateTime.fromInstant |> DDateTime |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -137,7 +140,9 @@ let fns () : List = (function | _, _, _, [ DUnit ] -> let now = DarkDateTime.fromInstant (Instant.now ()) - Ply(DDateTime(DarkDateTime.T(now.Year, now.Month, now.Day, 0, 0, 0))) + Task.FromResult( + DDateTime(DarkDateTime.T(now.Year, now.Month, now.Day, 0, 0, 0)) + ) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -153,7 +158,7 @@ let fns () : List = fn = (function | _, _, _, [ DDateTime d; DInt64 s ] -> - d + (NodaTime.Period.FromSeconds s) |> DDateTime |> Ply + d + (NodaTime.Period.FromSeconds s) |> DDateTime |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = SqlBinOp "+" previewable = Pure @@ -174,7 +179,7 @@ let fns () : List = fn = (function | _, _, _, [ DDateTime d; DInt64 s ] -> - d - (NodaTime.Period.FromSeconds s) |> DDateTime |> Ply + d - (NodaTime.Period.FromSeconds s) |> DDateTime |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = SqlBinOp "-" previewable = Pure @@ -188,7 +193,7 @@ let fns () : List = description = "Returns whether {{ > }}" fn = (function - | _, _, _, [ DDateTime d1; DDateTime d2 ] -> Ply(DBool(d1 > d2)) + | _, _, _, [ DDateTime d1; DDateTime d2 ] -> Task.FromResult(DBool(d1 > d2)) | _ -> incorrectArgs ()) sqlSpec = SqlBinOp ">" previewable = Pure @@ -202,7 +207,7 @@ let fns () : List = description = "Returns whether {{ < }}" fn = (function - | _, _, _, [ DDateTime d1; DDateTime d2 ] -> Ply(DBool(d1 < d2)) + | _, _, _, [ DDateTime d1; DDateTime d2 ] -> Task.FromResult(DBool(d1 < d2)) | _ -> incorrectArgs ()) sqlSpec = SqlBinOp "<" previewable = Pure @@ -216,7 +221,7 @@ let fns () : List = description = "Returns whether {{ >= }}" fn = (function - | _, _, _, [ DDateTime d1; DDateTime d2 ] -> Ply(DBool(d1 >= d2)) + | _, _, _, [ DDateTime d1; DDateTime d2 ] -> Task.FromResult(DBool(d1 >= d2)) | _ -> incorrectArgs ()) sqlSpec = SqlBinOp ">=" previewable = Pure @@ -230,7 +235,7 @@ let fns () : List = description = "Returns whether {{ <= }}" fn = (function - | _, _, _, [ DDateTime d1; DDateTime d2 ] -> Ply(DBool(d1 <= d2)) + | _, _, _, [ DDateTime d1; DDateTime d2 ] -> Task.FromResult(DBool(d1 <= d2)) | _ -> incorrectArgs ()) sqlSpec = SqlBinOp "<=" previewable = Pure @@ -246,7 +251,7 @@ let fns () : List = fn = (function | _, _, _, [ DDateTime d ] -> - (DarkDateTime.toInstant d).ToUnixTimeSeconds() |> DInt64 |> Ply + (DarkDateTime.toInstant d).ToUnixTimeSeconds() |> DInt64 |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -266,7 +271,7 @@ let fns () : List = |> Instant.FromUnixTimeSeconds |> DarkDateTime.fromInstant |> DDateTime - |> Ply + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -280,7 +285,8 @@ let fns () : List = description = "Returns the year portion of as an " fn = (function - | _, _, _, [ DDateTime d ] -> d.Year |> int64 |> Dval.int64 |> Ply + | _, _, _, [ DDateTime d ] -> + d.Year |> int64 |> Dval.int64 |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = SqlFunctionWithPrefixArgs("date_part", [ "'year'" ]) previewable = Pure @@ -295,7 +301,8 @@ let fns () : List = "Returns the month portion of as an between {{1}} and {{12}}" fn = (function - | _, _, _, [ DDateTime d ] -> d.Month |> int64 |> Dval.int64 |> Ply + | _, _, _, [ DDateTime d ] -> + d.Month |> int64 |> Dval.int64 |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = SqlFunctionWithPrefixArgs("date_part", [ "'month'" ]) previewable = Pure @@ -309,7 +316,7 @@ let fns () : List = description = "Returns the day portion of as an " fn = (function - | _, _, _, [ DDateTime d ] -> d.Day |> int64 |> Dval.int64 |> Ply + | _, _, _, [ DDateTime d ] -> d.Day |> int64 |> Dval.int64 |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = SqlFunctionWithPrefixArgs("date_part", [ "'day'" ]) previewable = Pure @@ -325,7 +332,8 @@ let fns () : List = Monday = {{1}}, Tuesday = {{2}}, ... Sunday = {{7}} (in accordance with ISO 8601)" fn = (function - | _, _, _, [ DDateTime d ] -> d.DayOfWeek |> int64 |> DInt64 |> Ply + | _, _, _, [ DDateTime d ] -> + d.DayOfWeek |> int64 |> DInt64 |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -339,7 +347,7 @@ let fns () : List = description = "Returns the hour portion of as an " fn = (function - | _, _, _, [ DDateTime d ] -> Ply(Dval.int64 d.Hour) + | _, _, _, [ DDateTime d ] -> Task.FromResult(Dval.int64 d.Hour) | _ -> incorrectArgs ()) sqlSpec = SqlFunctionWithPrefixArgs("date_part", [ "'hour'" ]) previewable = Pure @@ -353,7 +361,7 @@ let fns () : List = description = "Returns the minute portion of as an " fn = (function - | _, _, _, [ DDateTime d ] -> Ply(Dval.int64 d.Minute) + | _, _, _, [ DDateTime d ] -> Task.FromResult(Dval.int64 d.Minute) | _ -> incorrectArgs ()) sqlSpec = SqlFunctionWithPrefixArgs("date_part", [ "'minute'" ]) previewable = Pure @@ -367,7 +375,7 @@ let fns () : List = description = "Returns the second portion of as an " fn = (function - | _, _, _, [ DDateTime d ] -> Ply(Dval.int64 d.Second) + | _, _, _, [ DDateTime d ] -> Task.FromResult(Dval.int64 d.Second) | _ -> incorrectArgs ()) sqlSpec = SqlFunctionWithPrefixArgs("date_part", [ "'second'" ]) previewable = Pure @@ -382,7 +390,9 @@ let fns () : List = fn = (function | _, _, _, [ DDateTime d ] -> - DarkDateTime.T(d.Year, d.Month, d.Day, 0, 0, 0) |> DDateTime |> Ply + DarkDateTime.T(d.Year, d.Month, d.Day, 0, 0, 0) + |> DDateTime + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = SqlFunctionWithPrefixArgs("date_trunc", [ "'day'" ]) previewable = Pure @@ -404,7 +414,11 @@ let fns () : List = | _, _, _, [ DDateTime endDate; DDateTime startDate ] -> let diff = (DarkDateTime.toInstant endDate) - (DarkDateTime.toInstant startDate) - diff.TotalSeconds |> System.Math.Round |> int64 |> DInt64 |> Ply + diff.TotalSeconds + |> System.Math.Round + |> int64 + |> DInt64 + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -420,7 +434,9 @@ let fns () : List = fn = (function | _, _, _, [ DDateTime d ] -> - (DarkDateTime.toInstant d).ToUnixTimeMilliseconds() |> DInt64 |> Ply + (DarkDateTime.toInstant d).ToUnixTimeMilliseconds() + |> DInt64 + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -440,7 +456,7 @@ let fns () : List = |> Instant.FromUnixTimeMilliseconds |> DarkDateTime.fromInstant |> DDateTime - |> Ply + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -457,7 +473,7 @@ let fns () : List = fn = (function | _, _, _, [ DDateTime d; DInt64 ms ] -> - d + (NodaTime.Period.FromMilliseconds ms) |> DDateTime |> Ply + d + (NodaTime.Period.FromMilliseconds ms) |> DDateTime |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -474,7 +490,7 @@ let fns () : List = fn = (function | _, _, _, [ DDateTime d; DInt64 ms ] -> - d - (NodaTime.Period.FromMilliseconds ms) |> DDateTime |> Ply + d - (NodaTime.Period.FromMilliseconds ms) |> DDateTime |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -489,7 +505,8 @@ let fns () : List = "Returns the millisecond portion of as an between {{0}} and {{999}}" fn = (function - | _, _, _, [ DDateTime d ] -> d.Millisecond |> int64 |> Dval.int64 |> Ply + | _, _, _, [ DDateTime d ] -> + d.Millisecond |> int64 |> Dval.int64 |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -507,7 +524,11 @@ let fns () : List = let diff = (DarkDateTime.toInstant endDate) - (DarkDateTime.toInstant startDate) - diff.TotalMilliseconds |> System.Math.Round |> int64 |> DInt64 |> Ply + diff.TotalMilliseconds + |> System.Math.Round + |> int64 + |> DInt64 + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure diff --git a/backend/src/BuiltinExecution/Libs/Dict.fs b/backend/src/BuiltinExecution/Libs/Dict.fs index 0d76191215..176eb2b4f1 100644 --- a/backend/src/BuiltinExecution/Libs/Dict.fs +++ b/backend/src/BuiltinExecution/Libs/Dict.fs @@ -3,6 +3,7 @@ module BuiltinExecution.Libs.Dict open Prelude open LibExecution.RuntimeTypes open LibExecution.Builtin.Shortcuts +open System.Threading.Tasks module TypeChecker = LibExecution.TypeChecker module VT = LibExecution.ValueType @@ -22,7 +23,8 @@ let fns () : List = description = "Returns the number of entries in " fn = (function - | _, _, _, [ DDict(_vtTODO, o) ] -> Ply(DInt64(int64 (Map.count o))) + | _, _, _, [ DDict(_vtTODO, o) ] -> + Task.FromResult(DInt64(int64 (Map.count o))) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -39,7 +41,12 @@ let fns () : List = (function | _, _, _, [ DDict(_, o) ] -> // CLEANUP follow up here if/when `key` type is dynamic (not just String) - o |> Map.keys |> Seq.map DString |> Seq.toList |> Dval.list KTString |> Ply + o + |> Map.keys + |> Seq.map DString + |> Seq.toList + |> Dval.list KTString + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -55,7 +62,10 @@ let fns () : List = fn = (function | _, _, _, [ DDict(valueType, o) ] -> - o |> Map.values |> Seq.toList |> (fun vs -> DList(valueType, vs) |> Ply) + o + |> Map.values + |> Seq.toList + |> (fun vs -> DList(valueType, vs) |> Task.FromResult) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -75,7 +85,7 @@ let fns () : List = let f k v acc = DTuple(DString k, v, []) :: acc Map.foldBack f o [] |> fun pairs -> DList(VT.tuple VT.string valueType [], pairs) - |> Ply + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -97,7 +107,8 @@ let fns () : List = This function is the opposite of ." fn = (function - | _, _, _, [ DList(_, []) ] -> DDict(VT.unknown, Map.empty) |> Ply + | _, _, _, [ DList(_, []) ] -> + DDict(VT.unknown, Map.empty) |> Task.FromResult | _, vm, _, [ DList(ValueType.Known(KTTuple(_keyType, valueType, [])), l) ] -> let f (accType, accMap) dv = @@ -115,7 +126,7 @@ let fns () : List = [ "dval", dv ] let (typ, map) = List.fold f (valueType, Map.empty) l - DDict(typ, map) |> Ply + DDict(typ, map) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -155,8 +166,8 @@ let fns () : List = | Some entries -> DDict(dictType, entries) |> TypeChecker.DvalCreator.optionSome vmState.threadID optType - |> Ply - | None -> TypeChecker.DvalCreator.optionNone optType |> Ply + |> Task.FromResult + | None -> TypeChecker.DvalCreator.optionNone optType |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -175,7 +186,7 @@ let fns () : List = | _, vm, _, [ DDict(_vtTODO, o); DString s ] -> Map.find s o |> TypeChecker.DvalCreator.option vm.threadID VT.unknownTODO - |> Ply + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -191,7 +202,8 @@ let fns () : List = {{false}} otherwise" fn = (function - | _, _, _, [ DDict(_, o); DString s ] -> Ply(DBool(Map.containsKey s o)) + | _, _, _, [ DDict(_, o); DString s ] -> + Task.FromResult(DBool(Map.containsKey s o)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -214,7 +226,7 @@ let fns () : List = | Ok mergedType -> let f accMap k v = Map.add k v accMap let mergedMap = Map.fold f intoMap fromMap - DDict(mergedType, mergedMap) |> Ply + DDict(mergedType, mergedMap) |> Task.FromResult | Error() -> Exception.raiseInternal "Builtin.dictMerge input dicts somehow bypassed fn-arg type-checking" @@ -245,7 +257,7 @@ let fns () : List = o (k, v) TypeChecker.ThrowIfDuplicate - DDict(typ, map) |> Ply + DDict(typ, map) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -272,7 +284,7 @@ let fns () : List = o (k, v) TypeChecker.ReplaceValue - DDict(typ, map) |> Ply + DDict(typ, map) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -287,7 +299,8 @@ let fns () : List = "If the contains , returns a copy of with and its associated value removed. Otherwise, returns unchanged." fn = (function - | _, _, _, [ DDict(vt, o); DString k ] -> DDict(vt, Map.remove k o) |> Ply + | _, _, _, [ DDict(vt, o); DString k ] -> + DDict(vt, Map.remove k o) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure diff --git a/backend/src/BuiltinExecution/Libs/Float.fs b/backend/src/BuiltinExecution/Libs/Float.fs index 245ef06303..d71a8aac15 100644 --- a/backend/src/BuiltinExecution/Libs/Float.fs +++ b/backend/src/BuiltinExecution/Libs/Float.fs @@ -3,6 +3,7 @@ module BuiltinExecution.Libs.Float open Prelude open LibExecution.RuntimeTypes open LibExecution.Builtin.Shortcuts +open System.Threading.Tasks module VT = LibExecution.ValueType module Dval = LibExecution.Dval @@ -29,7 +30,8 @@ let fns () : List = description = "Round up to an integer value" fn = (function - | _, _, _, [ DFloat a ] -> a |> System.Math.Ceiling |> int64 |> DInt64 |> Ply + | _, _, _, [ DFloat a ] -> + a |> System.Math.Ceiling |> int64 |> DInt64 |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -43,7 +45,8 @@ let fns () : List = description = "Round up to an integer value" fn = (function - | _, _, _, [ DFloat a ] -> a |> System.Math.Ceiling |> int64 |> DInt64 |> Ply + | _, _, _, [ DFloat a ] -> + a |> System.Math.Ceiling |> int64 |> DInt64 |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -62,7 +65,8 @@ let fns () : List = but {{Float.truncate -1.9 == -1.0}}" fn = (function - | _, _, _, [ DFloat a ] -> a |> System.Math.Floor |> int64 |> DInt64 |> Ply + | _, _, _, [ DFloat a ] -> + a |> System.Math.Floor |> int64 |> DInt64 |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -82,7 +86,8 @@ let fns () : List = fn = (function - | _, _, _, [ DFloat a ] -> a |> System.Math.Floor |> int64 |> DInt64 |> Ply + | _, _, _, [ DFloat a ] -> + a |> System.Math.Floor |> int64 |> DInt64 |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -96,7 +101,8 @@ let fns () : List = description = "Round to the nearest integer value" fn = (function - | _, _, _, [ DFloat a ] -> a |> System.Math.Round |> int64 |> DInt64 |> Ply + | _, _, _, [ DFloat a ] -> + a |> System.Math.Round |> int64 |> DInt64 |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -112,7 +118,7 @@ let fns () : List = fn = (function | _, _, _, [ DFloat a ] -> - a |> System.Math.Truncate |> int64 |> DInt64 |> Ply + a |> System.Math.Truncate |> int64 |> DInt64 |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -126,7 +132,7 @@ let fns () : List = description = "Get the square root of a float" fn = (function - | _, _, _, [ DFloat a ] -> Ply(DFloat(System.Math.Sqrt a)) + | _, _, _, [ DFloat a ] -> Task.FromResult(DFloat(System.Math.Sqrt a)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -140,7 +146,8 @@ let fns () : List = description = "Returns raised to the power of " fn = (function - | _, _, _, [ DFloat base_; DFloat exp ] -> Ply(DFloat(base_ ** exp)) + | _, _, _, [ DFloat base_; DFloat exp ] -> + Task.FromResult(DFloat(base_ ** exp)) | _ -> incorrectArgs ()) sqlSpec = SqlFunction "POWER" previewable = Pure @@ -154,7 +161,7 @@ let fns () : List = description = "Divide by " fn = (function - | _, _, _, [ DFloat a; DFloat b ] -> Ply(DFloat(a / b)) + | _, _, _, [ DFloat a; DFloat b ] -> Task.FromResult(DFloat(a / b)) | _ -> incorrectArgs ()) sqlSpec = SqlBinOp "/" previewable = Pure @@ -168,7 +175,7 @@ let fns () : List = description = "Add to " fn = (function - | _, _, _, [ DFloat a; DFloat b ] -> Ply(DFloat(a + b)) + | _, _, _, [ DFloat a; DFloat b ] -> Task.FromResult(DFloat(a + b)) | _ -> incorrectArgs ()) sqlSpec = SqlBinOp "+" previewable = Pure @@ -182,7 +189,7 @@ let fns () : List = description = "Multiply by " fn = (function - | _, _, _, [ DFloat a; DFloat b ] -> Ply(DFloat(a * b)) + | _, _, _, [ DFloat a; DFloat b ] -> Task.FromResult(DFloat(a * b)) | _ -> incorrectArgs ()) sqlSpec = SqlBinOp "*" previewable = Pure @@ -196,7 +203,7 @@ let fns () : List = description = "Subtract from " fn = (function - | _, _, _, [ DFloat a; DFloat b ] -> Ply(DFloat(a - b)) + | _, _, _, [ DFloat a; DFloat b ] -> Task.FromResult(DFloat(a - b)) | _ -> incorrectArgs ()) sqlSpec = SqlBinOp "-" previewable = Pure @@ -210,7 +217,7 @@ let fns () : List = description = "Returns true if a is greater than b" fn = (function - | _, _, _, [ DFloat a; DFloat b ] -> Ply(DBool(a > b)) + | _, _, _, [ DFloat a; DFloat b ] -> Task.FromResult(DBool(a > b)) | _ -> incorrectArgs ()) sqlSpec = SqlBinOp ">" previewable = Pure @@ -224,7 +231,7 @@ let fns () : List = description = "Returns true if a is greater than or equal to b" fn = (function - | _, _, _, [ DFloat a; DFloat b ] -> Ply(DBool(a >= b)) + | _, _, _, [ DFloat a; DFloat b ] -> Task.FromResult(DBool(a >= b)) | _ -> incorrectArgs ()) sqlSpec = SqlBinOp ">=" previewable = Pure @@ -238,7 +245,7 @@ let fns () : List = description = "Returns true if a is less than b" fn = (function - | _, _, _, [ DFloat a; DFloat b ] -> Ply(DBool(a < b)) + | _, _, _, [ DFloat a; DFloat b ] -> Task.FromResult(DBool(a < b)) | _ -> incorrectArgs ()) sqlSpec = SqlBinOp "<" previewable = Pure @@ -252,7 +259,7 @@ let fns () : List = description = "Returns true if a is less than or equal to b" fn = (function - | _, _, _, [ DFloat a; DFloat b ] -> Ply(DBool(a <= b)) + | _, _, _, [ DFloat a; DFloat b ] -> Task.FromResult(DBool(a <= b)) | _ -> incorrectArgs ()) sqlSpec = SqlBinOp "<=" previewable = Pure @@ -268,7 +275,7 @@ let fns () : List = fn = (function | _, _, _, [ DFloat a ] -> - a |> System.Math.Truncate |> int64 |> DInt64 |> Ply + a |> System.Math.Truncate |> int64 |> DInt64 |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -297,9 +304,9 @@ let fns () : List = (function | _, _, _, [ DString s ] -> try - float (s) |> DFloat |> resultOk |> Ply + float (s) |> DFloat |> resultOk |> Task.FromResult with :? System.FormatException -> - ParseError.BadFormat |> ParseError.toDT |> resultError |> Ply + ParseError.BadFormat |> ParseError.toDT |> resultError |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -325,7 +332,7 @@ let fns () : List = else let result = sprintf "%.12g" f if result.Contains "." then result else $"{result}.0" - Ply(DString result) + Task.FromResult(DString result) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -339,7 +346,7 @@ let fns () : List = description = "Returns true if is NaN" fn = (function - | _, _, _, [ DFloat f ] -> Ply(DBool(System.Double.IsNaN f)) + | _, _, _, [ DFloat f ] -> Task.FromResult(DBool(System.Double.IsNaN f)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure diff --git a/backend/src/BuiltinExecution/Libs/HttpClient.fs b/backend/src/BuiltinExecution/Libs/HttpClient.fs index 118a7997fb..d7ed234ea5 100644 --- a/backend/src/BuiltinExecution/Libs/HttpClient.fs +++ b/backend/src/BuiltinExecution/Libs/HttpClient.fs @@ -52,7 +52,6 @@ open System.IO open System.Net.Http open System.Threading.Tasks -open FSharp.Control.Tasks open Prelude open LibExecution @@ -188,27 +187,29 @@ module BaseClient = (context : SocketsHttpConnectionContext) (cancellationToken : System.Threading.CancellationToken) : ValueTask = - vtask { - try - // While this DNS call is expensive, it should be cached - let ips = System.Net.Dns.GetHostAddresses context.DnsEndPoint.Host - - if not (Array.forall config.allowedIP ips) then - // Use this to hide more specific errors when looking at loopback - Exception.raiseInternal "Could not connect" [] - - let socket = - new System.Net.Sockets.Socket( - System.Net.Sockets.SocketType.Stream, - System.Net.Sockets.ProtocolType.Tcp - ) - socket.NoDelay <- true - - do! socket.ConnectAsync(context.DnsEndPoint, cancellationToken) - return new System.Net.Sockets.NetworkStream(socket, true) - with :? System.ArgumentException -> - return Exception.raiseInternal "Could not connect" [] - } + let inner = + task { + try + // While this DNS call is expensive, it should be cached + let ips = System.Net.Dns.GetHostAddresses context.DnsEndPoint.Host + + if not (Array.forall config.allowedIP ips) then + // Use this to hide more specific errors when looking at loopback + Exception.raiseInternal "Could not connect" [] + + let socket = + new System.Net.Sockets.Socket( + System.Net.Sockets.SocketType.Stream, + System.Net.Sockets.ProtocolType.Tcp + ) + socket.NoDelay <- true + + do! socket.ConnectAsync(context.DnsEndPoint, cancellationToken) + return new System.Net.Sockets.NetworkStream(socket, true) :> Stream + with :? System.ArgumentException -> + return Exception.raiseInternal "Could not connect" [] + } + ValueTask(inner) new SocketsHttpHandler( // Avoid DNS problems PooledConnectionIdleTimeout = System.TimeSpan.FromMinutes 5.0, @@ -560,12 +561,12 @@ let fns (config : Configuration) : List = vm, _, [ DString method; DString uri; DList(_, reqHeaders); DBlob bodyRef ] -> - uply { + task { let! reqBodyBytes = Blob.readBytes state bodyRef let! (reqHeaders : Result, BadHeader.BadHeader>) = reqHeaders - |> Ply.List.mapSequentially (fun item -> - uply { + |> Task.mapSequentially (fun item -> + task { match item with | DTuple(DString k, DString v, []) -> let k = String.trim k @@ -591,7 +592,7 @@ let fns (config : Configuration) : List = |> raiseRTE vm.threadID }) - |> Ply.map Result.collect + |> Task.map Result.collect let method = try @@ -600,7 +601,7 @@ let fns (config : Configuration) : List = None let! (result : Result) = - uply { + task { match reqHeaders, method with | Ok reqHeaders, Some method -> let request = @@ -646,6 +647,7 @@ let fns (config : Configuration) : List = | Ok result -> return result | Error err -> return resultError (RequestError.toDT err) } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -692,11 +694,11 @@ let fns (config : Configuration) : List = let resultError = Dval.resultError streamTypeOk streamTypeErr (function | _, vm, _, [ DString method; DString uri; DList(_, reqHeaders) ] -> - uply { + task { let! (reqHeaders : Result, BadHeader.BadHeader>) = reqHeaders - |> Ply.List.mapSequentially (fun item -> - uply { + |> Task.mapSequentially (fun item -> + task { match item with | DTuple(DString k, DString v, []) -> let k = String.trim k @@ -719,7 +721,7 @@ let fns (config : Configuration) : List = |> RTE.Apply |> raiseRTE vm.threadID }) - |> Ply.map Result.collect + |> Task.map Result.collect let method = try @@ -746,8 +748,8 @@ let fns (config : Configuration) : List = // path. `Stream.newChunked` synthesises a // byte-wise `next` from the same source so // `streamNext` semantics are preserved. - let nextChunk (maxBytes : int) : Ply> = - uply { + let nextChunk (maxBytes : int) : Task> = + task { let cap = max 1 maxBytes let buf = Array.zeroCreate cap let! n = responseStream.ReadAsync(buf, 0, cap) @@ -796,6 +798,7 @@ let fns (config : Configuration) : List = | _, None -> return resultError (RequestError.toDT RequestError.BadMethod) } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure diff --git a/backend/src/BuiltinExecution/Libs/Int128.fs b/backend/src/BuiltinExecution/Libs/Int128.fs index 2cc093cd5e..498f45df3a 100644 --- a/backend/src/BuiltinExecution/Libs/Int128.fs +++ b/backend/src/BuiltinExecution/Libs/Int128.fs @@ -3,6 +3,7 @@ module BuiltinExecution.Libs.Int128 open Prelude open LibExecution.RuntimeTypes open LibExecution.Builtin.Shortcuts +open System.Threading.Tasks module VT = LibExecution.ValueType module Dval = LibExecution.Dval @@ -47,7 +48,7 @@ let fns () : List = else let result = v % m let result = if result < System.Int128.Zero then m + result else result - Ply(DInt128(result)) + Task.FromResult(DInt128(result)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -69,7 +70,7 @@ let fns () : List = Returns an {{Error}} if is {{0}}." fn = - let resultOk r = Dval.resultOk KTInt128 KTString r |> Ply + let resultOk r = Dval.resultOk KTInt128 KTString r |> Task.FromResult (function | _, vm, _, [ DInt128 v; DInt128 d ] -> (try @@ -98,7 +99,7 @@ let fns () : List = | _, vm, _, [ DInt128 a; DInt128 b ] -> try let result = System.Int128.op_CheckedAddition (a, b) - Ply(DInt128(result)) + Task.FromResult(DInt128(result)) with :? System.OverflowException -> RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID | _ -> incorrectArgs ()) @@ -117,7 +118,7 @@ let fns () : List = | _, vm, _, [ DInt128 a; DInt128 b ] -> try let result = System.Int128.op_CheckedSubtraction (a, b) - Ply(DInt128(result)) + Task.FromResult(DInt128(result)) with :? System.OverflowException -> RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID | _ -> incorrectArgs ()) @@ -137,7 +138,7 @@ let fns () : List = | _, vm, _, [ DInt128 a; DInt128 b ] -> try let result = System.Int128.op_CheckedMultiply (a, b) - Ply(DInt128(result)) + Task.FromResult(DInt128(result)) with :? System.OverflowException -> RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID | _ -> incorrectArgs ()) @@ -159,7 +160,7 @@ let fns () : List = | _, vm, _, [ DInt128 a; DInt128 b ] -> try let result = System.Int128.op_Division (a, b) - Ply(DInt128(result)) + Task.FromResult(DInt128(result)) with | :? System.DivideByZeroException -> RTE.Ints.DivideByZeroError |> RTE.Int |> raiseRTE vm.threadID @@ -181,7 +182,7 @@ let fns () : List = | _, vm, _, [ DInt128 a ] -> try let result = System.Int128.op_CheckedUnaryNegation a - Ply(DInt128(result)) + Task.FromResult(DInt128(result)) with :? System.OverflowException -> RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID | _ -> incorrectArgs ()) @@ -197,7 +198,7 @@ let fns () : List = description = "Returns {{true}} if is greater than " fn = (function - | _, _, _, [ DInt128 a; DInt128 b ] -> Ply(DBool(a > b)) + | _, _, _, [ DInt128 a; DInt128 b ] -> Task.FromResult(DBool(a > b)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -212,7 +213,7 @@ let fns () : List = "Returns {{true}} if is greater than or equal to " fn = (function - | _, _, _, [ DInt128 a; DInt128 b ] -> Ply(DBool(a >= b)) + | _, _, _, [ DInt128 a; DInt128 b ] -> Task.FromResult(DBool(a >= b)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -226,7 +227,7 @@ let fns () : List = description = "Returns {{true}} if is less than " fn = (function - | _, _, _, [ DInt128 a; DInt128 b ] -> Ply(DBool(a < b)) + | _, _, _, [ DInt128 a; DInt128 b ] -> Task.FromResult(DBool(a < b)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -241,7 +242,7 @@ let fns () : List = "Returns {{true}} if is less than or equal to " fn = (function - | _, _, _, [ DInt128 a; DInt128 b ] -> Ply(DBool(a <= b)) + | _, _, _, [ DInt128 a; DInt128 b ] -> Task.FromResult(DBool(a <= b)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -255,7 +256,7 @@ let fns () : List = description = "Converts an to a " fn = (function - | _, _, _, [ DInt128 a ] -> Ply(DString(string a)) + | _, _, _, [ DInt128 a ] -> Task.FromResult(DString(string a)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -269,7 +270,7 @@ let fns () : List = description = "Converts an to a " fn = (function - | _, _, _, [ DInt128 a ] -> Ply(DFloat(float a)) + | _, _, _, [ DInt128 a ] -> Task.FromResult(DFloat(float a)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -283,7 +284,7 @@ let fns () : List = description = "Get the square root of an " fn = (function - | _, _, _, [ DInt128 a ] -> Ply(DFloat(sqrt (float a))) + | _, _, _, [ DInt128 a ] -> Task.FromResult(DFloat(sqrt (float a))) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -313,12 +314,15 @@ let fns () : List = (function | _, _, _, [ DString s ] -> try - s |> System.Int128.Parse |> DInt128 |> resultOk |> Ply + s |> System.Int128.Parse |> DInt128 |> resultOk |> Task.FromResult with | :? System.FormatException -> - ParseError.BadFormat |> ParseError.toDT |> resultError |> Ply + ParseError.BadFormat |> ParseError.toDT |> resultError |> Task.FromResult | :? System.OverflowException -> - ParseError.OutOfRange |> ParseError.toDT |> resultError |> Ply + ParseError.OutOfRange + |> ParseError.toDT + |> resultError + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -332,7 +336,8 @@ let fns () : List = description = "Converts an Int8 to a 128-bit signed integer." fn = (function - | _, _, _, [ DInt8 a ] -> DInt128(System.Int128.op_Implicit a) |> Ply + | _, _, _, [ DInt8 a ] -> + DInt128(System.Int128.op_Implicit a) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -346,7 +351,8 @@ let fns () : List = description = "Converts a UInt8 to a 128-bit signed integer." fn = (function - | _, _, _, [ DUInt8 a ] -> DInt128(System.Int128.op_Implicit a) |> Ply + | _, _, _, [ DUInt8 a ] -> + DInt128(System.Int128.op_Implicit a) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -360,7 +366,8 @@ let fns () : List = description = "Converts an Int16 to a 128-bit signed integer." fn = (function - | _, _, _, [ DInt16 a ] -> DInt128(System.Int128.op_Implicit a) |> Ply + | _, _, _, [ DInt16 a ] -> + DInt128(System.Int128.op_Implicit a) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -374,7 +381,8 @@ let fns () : List = description = "Converts a UInt16 to a 128-bit signed integer." fn = (function - | _, _, _, [ DUInt16 a ] -> DInt128(System.Int128.op_Implicit a) |> Ply + | _, _, _, [ DUInt16 a ] -> + DInt128(System.Int128.op_Implicit a) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -388,7 +396,8 @@ let fns () : List = description = "Converts an Int32 to a 128-bit signed integer." fn = (function - | _, _, _, [ DInt32 a ] -> DInt128(System.Int128.op_Implicit a) |> Ply + | _, _, _, [ DInt32 a ] -> + DInt128(System.Int128.op_Implicit a) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -402,7 +411,8 @@ let fns () : List = description = "Converts a UInt32 to a 128-bit signed integer." fn = (function - | _, _, _, [ DUInt32 a ] -> DInt128(System.Int128.op_Implicit a) |> Ply + | _, _, _, [ DUInt32 a ] -> + DInt128(System.Int128.op_Implicit a) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -416,7 +426,8 @@ let fns () : List = description = "Converts an Int64 to a 128-bit signed integer." fn = (function - | _, _, _, [ DInt64 a ] -> DInt128(System.Int128.op_Implicit a) |> Ply + | _, _, _, [ DInt64 a ] -> + DInt128(System.Int128.op_Implicit a) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -430,7 +441,8 @@ let fns () : List = description = "Converts a UInt64 to a 128-bit signed integer." fn = (function - | _, _, _, [ DUInt64 a ] -> DInt128(System.Int128.op_Implicit a) |> Ply + | _, _, _, [ DUInt64 a ] -> + DInt128(System.Int128.op_Implicit a) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -444,7 +456,7 @@ let fns () : List = description = "Bitwise AND on two values" fn = (function - | _, _, _, [ DInt128 a; DInt128 b ] -> Ply(DInt128(a &&& b)) + | _, _, _, [ DInt128 a; DInt128 b ] -> Task.FromResult(DInt128(a &&& b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -458,7 +470,7 @@ let fns () : List = description = "Bitwise OR on two values" fn = (function - | _, _, _, [ DInt128 a; DInt128 b ] -> Ply(DInt128(a ||| b)) + | _, _, _, [ DInt128 a; DInt128 b ] -> Task.FromResult(DInt128(a ||| b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -472,7 +484,7 @@ let fns () : List = description = "Bitwise XOR on two values" fn = (function - | _, _, _, [ DInt128 a; DInt128 b ] -> Ply(DInt128(a ^^^ b)) + | _, _, _, [ DInt128 a; DInt128 b ] -> Task.FromResult(DInt128(a ^^^ b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -486,7 +498,8 @@ let fns () : List = description = "Bitwise NOT on an value" fn = (function - | _, _, _, [ DInt128 a ] -> Ply(DInt128(System.Int128.op_OnesComplement (a))) + | _, _, _, [ DInt128 a ] -> + Task.FromResult(DInt128(System.Int128.op_OnesComplement (a))) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -500,7 +513,7 @@ let fns () : List = description = "Bitwise left shift of an value" fn = (function - | _, _, _, [ DInt128 a; DInt128 b ] -> Ply(DInt128(a <<< int b)) + | _, _, _, [ DInt128 a; DInt128 b ] -> Task.FromResult(DInt128(a <<< int b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -514,7 +527,7 @@ let fns () : List = description = "Bitwise right shift of an value" fn = (function - | _, _, _, [ DInt128 a; DInt128 b ] -> Ply(DInt128(a >>> int b)) + | _, _, _, [ DInt128 a; DInt128 b ] -> Task.FromResult(DInt128(a >>> int b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure diff --git a/backend/src/BuiltinExecution/Libs/Int16.fs b/backend/src/BuiltinExecution/Libs/Int16.fs index e2f959ff94..14598757ef 100644 --- a/backend/src/BuiltinExecution/Libs/Int16.fs +++ b/backend/src/BuiltinExecution/Libs/Int16.fs @@ -3,6 +3,7 @@ module BuiltinExecution.Libs.Int16 open Prelude open LibExecution.RuntimeTypes open LibExecution.Builtin.Shortcuts +open System.Threading.Tasks module VT = LibExecution.ValueType module Dval = LibExecution.Dval @@ -48,7 +49,7 @@ let fns () : List = else let result = v % m let result = if result < 0s then m + result else result - Ply(DInt16 result) + Task.FromResult(DInt16 result) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -70,7 +71,7 @@ let fns () : List = Returns an {{Error}} if is {{0}}." fn = - let resultOk r = Dval.resultOk KTInt16 KTString r |> Ply + let resultOk r = Dval.resultOk KTInt16 KTString r |> Task.FromResult (function | _, vm, _, [ DInt16 v; DInt16 d ] -> (try @@ -99,7 +100,7 @@ let fns () : List = | _, vm, _, [ DInt16 a; DInt16 b ] -> try let result = Checked.(+) a b - Ply(DInt16(result)) + Task.FromResult(DInt16(result)) with :? System.OverflowException -> RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID | _ -> incorrectArgs ()) @@ -118,7 +119,7 @@ let fns () : List = | _, vm, _, [ DInt16 a; DInt16 b ] -> try let result = Checked.(-) a b - Ply(DInt16(result)) + Task.FromResult(DInt16(result)) with :? System.OverflowException -> RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID | _ -> incorrectArgs ()) @@ -137,7 +138,7 @@ let fns () : List = | _, vm, _, [ DInt16 a; DInt16 b ] -> try let result = Checked.(*) a b - Ply(DInt16(result)) + Task.FromResult(DInt16(result)) with :? System.OverflowException -> RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID | _ -> incorrectArgs ()) @@ -161,7 +162,7 @@ let fns () : List = if exp < 0s then RTE.Ints.NegativeExponent |> RTE.Int |> raiseRTE vm.threadID else - (bigint number) ** (int exp) |> int16 |> DInt16 |> Ply + (bigint number) ** (int exp) |> int16 |> DInt16 |> Task.FromResult with :? System.OverflowException -> RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID) | _ -> incorrectArgs ()) @@ -187,7 +188,7 @@ let fns () : List = if result < System.Int16.MinValue || result > System.Int16.MaxValue then RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID else - Ply(DInt16(int16 result)) + Task.FromResult(DInt16(int16 result)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented @@ -207,7 +208,7 @@ let fns () : List = RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID else let result = -a - Ply(DInt16 result) + Task.FromResult(DInt16 result) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented @@ -222,7 +223,7 @@ let fns () : List = description = "Returns {{true}} if is greater than " fn = (function - | _, _, _, [ DInt16 a; DInt16 b ] -> Ply(DBool(a > b)) + | _, _, _, [ DInt16 a; DInt16 b ] -> Task.FromResult(DBool(a > b)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -237,7 +238,7 @@ let fns () : List = "Returns {{true}} if is greater than or equal to " fn = (function - | _, _, _, [ DInt16 a; DInt16 b ] -> Ply(DBool(a >= b)) + | _, _, _, [ DInt16 a; DInt16 b ] -> Task.FromResult(DBool(a >= b)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -251,7 +252,7 @@ let fns () : List = description = "Returns {{true}} if is less than " fn = (function - | _, _, _, [ DInt16 a; DInt16 b ] -> Ply(DBool(a < b)) + | _, _, _, [ DInt16 a; DInt16 b ] -> Task.FromResult(DBool(a < b)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -266,7 +267,7 @@ let fns () : List = "Returns {{true}} if is less than or equal to " fn = (function - | _, _, _, [ DInt16 a; DInt16 b ] -> Ply(DBool(a <= b)) + | _, _, _, [ DInt16 a; DInt16 b ] -> Task.FromResult(DBool(a <= b)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -280,7 +281,7 @@ let fns () : List = description = "Stringify " fn = (function - | _, _, _, [ DInt16 a ] -> Ply(DString(string a)) + | _, _, _, [ DInt16 a ] -> Task.FromResult(DString(string a)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -294,7 +295,7 @@ let fns () : List = description = "Converts an to a " fn = (function - | _, _, _, [ DInt16 a ] -> Ply(DFloat(float a)) + | _, _, _, [ DInt16 a ] -> Task.FromResult(DFloat(float a)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -317,7 +318,7 @@ let fns () : List = int lower + randomSeeded().Next(int upper - int lower + correctRange) |> int16 |> DInt16 - |> Ply + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented @@ -341,13 +342,16 @@ let fns () : List = (function | _, _, _, [ DString s ] -> try - s |> System.Convert.ToInt16 |> DInt16 |> resultOk |> Ply + s |> System.Convert.ToInt16 |> DInt16 |> resultOk |> Task.FromResult with | :? System.OverflowException -> - ParseError.OutOfRange |> ParseError.toDT |> resultError |> Ply + ParseError.OutOfRange + |> ParseError.toDT + |> resultError + |> Task.FromResult | :? System.FormatException -> - ParseError.BadFormat |> ParseError.toDT |> resultError |> Ply + ParseError.BadFormat |> ParseError.toDT |> resultError |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented @@ -362,7 +366,7 @@ let fns () : List = description = "Converts an Int8 to a 16-bit signed integer." fn = (function - | _, _, _, [ DInt8 a ] -> DInt16(int16 a) |> Ply + | _, _, _, [ DInt8 a ] -> DInt16(int16 a) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -376,7 +380,7 @@ let fns () : List = description = "Converts a UInt8 to a 16-bit signed integer." fn = (function - | _, _, _, [ DUInt8 a ] -> DInt16(int16 a) |> Ply + | _, _, _, [ DUInt8 a ] -> DInt16(int16 a) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -393,9 +397,9 @@ let fns () : List = (function | _, _, _, [ DUInt16 a ] -> if a > uint16 System.Int16.MaxValue then - Dval.optionNone KTInt16 |> Ply + Dval.optionNone KTInt16 |> Task.FromResult else - Dval.optionSome KTInt16 (DInt16(int16 a)) |> Ply + Dval.optionSome KTInt16 (DInt16(int16 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -412,9 +416,9 @@ let fns () : List = (function | _, _, _, [ DInt32 a ] -> if a < int32 System.Int16.MinValue || a > int32 System.Int16.MaxValue then - Dval.optionNone KTInt16 |> Ply + Dval.optionNone KTInt16 |> Task.FromResult else - Dval.optionSome KTInt16 (DInt16(int16 a)) |> Ply + Dval.optionSome KTInt16 (DInt16(int16 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -431,9 +435,9 @@ let fns () : List = (function | _, _, _, [ DUInt32 a ] -> if a > uint32 System.Int16.MaxValue then - Dval.optionNone KTInt16 |> Ply + Dval.optionNone KTInt16 |> Task.FromResult else - Dval.optionSome KTInt16 (DInt16(int16 a)) |> Ply + Dval.optionSome KTInt16 (DInt16(int16 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -450,9 +454,9 @@ let fns () : List = (function | _, _, _, [ DInt64 a ] -> if a < int64 System.Int16.MinValue || a > int64 System.Int16.MaxValue then - Dval.optionNone KTInt16 |> Ply + Dval.optionNone KTInt16 |> Task.FromResult else - Dval.optionSome KTInt16 (DInt16(int16 a)) |> Ply + Dval.optionSome KTInt16 (DInt16(int16 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -469,9 +473,9 @@ let fns () : List = (function | _, _, _, [ DUInt64 a ] -> if a > uint64 System.Int16.MaxValue then - Dval.optionNone KTInt16 |> Ply + Dval.optionNone KTInt16 |> Task.FromResult else - Dval.optionSome KTInt16 (DInt16(int16 a)) |> Ply + Dval.optionSome KTInt16 (DInt16(int16 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -491,9 +495,9 @@ let fns () : List = a < System.Int128.op_Implicit System.Int16.MinValue || a > System.Int128.op_Implicit System.Int16.MaxValue then - Dval.optionNone KTInt16 |> Ply + Dval.optionNone KTInt16 |> Task.FromResult else - Dval.optionSome KTInt16 (DInt16(int16 a)) |> Ply + Dval.optionSome KTInt16 (DInt16(int16 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -510,9 +514,9 @@ let fns () : List = (function | _, _, _, [ DUInt128 a ] -> if a > 32767Z then - Dval.optionNone KTInt16 |> Ply + Dval.optionNone KTInt16 |> Task.FromResult else - Dval.optionSome KTInt16 (DInt16(int16 a)) |> Ply + Dval.optionSome KTInt16 (DInt16(int16 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -526,7 +530,7 @@ let fns () : List = description = "Bitwise AND on two values" fn = (function - | _, _, _, [ DInt16 a; DInt16 b ] -> Ply(DInt16(a &&& b)) + | _, _, _, [ DInt16 a; DInt16 b ] -> Task.FromResult(DInt16(a &&& b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -540,7 +544,7 @@ let fns () : List = description = "Bitwise OR on two values" fn = (function - | _, _, _, [ DInt16 a; DInt16 b ] -> Ply(DInt16(a ||| b)) + | _, _, _, [ DInt16 a; DInt16 b ] -> Task.FromResult(DInt16(a ||| b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -554,7 +558,7 @@ let fns () : List = description = "Bitwise XOR on two values" fn = (function - | _, _, _, [ DInt16 a; DInt16 b ] -> Ply(DInt16(a ^^^ b)) + | _, _, _, [ DInt16 a; DInt16 b ] -> Task.FromResult(DInt16(a ^^^ b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -568,7 +572,7 @@ let fns () : List = description = "Bitwise NOT on an value" fn = (function - | _, _, _, [ DInt16 a ] -> Ply(DInt16(~~~a)) + | _, _, _, [ DInt16 a ] -> Task.FromResult(DInt16(~~~a)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -582,7 +586,7 @@ let fns () : List = description = "Bitwise left shift of an value" fn = (function - | _, _, _, [ DInt16 a; DInt16 b ] -> Ply(DInt16(a <<< int b)) + | _, _, _, [ DInt16 a; DInt16 b ] -> Task.FromResult(DInt16(a <<< int b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -596,7 +600,7 @@ let fns () : List = description = "Bitwise right shift of an value" fn = (function - | _, _, _, [ DInt16 a; DInt16 b ] -> Ply(DInt16(a >>> int b)) + | _, _, _, [ DInt16 a; DInt16 b ] -> Task.FromResult(DInt16(a >>> int b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure diff --git a/backend/src/BuiltinExecution/Libs/Int32.fs b/backend/src/BuiltinExecution/Libs/Int32.fs index 003c24cac7..ded8be9d99 100644 --- a/backend/src/BuiltinExecution/Libs/Int32.fs +++ b/backend/src/BuiltinExecution/Libs/Int32.fs @@ -3,6 +3,7 @@ module BuiltinExecution.Libs.Int32 open Prelude open LibExecution.RuntimeTypes open LibExecution.Builtin.Shortcuts +open System.Threading.Tasks module VT = LibExecution.ValueType module Dval = LibExecution.Dval @@ -48,7 +49,7 @@ let fns () : List = else let result = v % m let result = if result < 0 then m + result else result - Ply(DInt32 result) + Task.FromResult(DInt32 result) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -70,7 +71,7 @@ let fns () : List = Returns an {{Error}} if is {{0}}." fn = - let resultOk r = Dval.resultOk KTInt32 KTString r |> Ply + let resultOk r = Dval.resultOk KTInt32 KTString r |> Task.FromResult (function | _, vm, _, [ DInt32 v; DInt32 d ] -> (try @@ -96,7 +97,7 @@ let fns () : List = description = "Adds two 32-bit signed integers together" fn = (function - | _, _, _, [ DInt32 a; DInt32 b ] -> Ply(DInt32(a + b)) + | _, _, _, [ DInt32 a; DInt32 b ] -> Task.FromResult(DInt32(a + b)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -110,7 +111,7 @@ let fns () : List = description = "Subtracts two 32-bit signed integers" fn = (function - | _, _, _, [ DInt32 a; DInt32 b ] -> Ply(DInt32(a - b)) + | _, _, _, [ DInt32 a; DInt32 b ] -> Task.FromResult(DInt32(a - b)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -124,7 +125,7 @@ let fns () : List = description = "Multiplies two 32-bit signed integers" fn = (function - | _, _, _, [ DInt32 a; DInt32 b ] -> Ply(DInt32(a * b)) + | _, _, _, [ DInt32 a; DInt32 b ] -> Task.FromResult(DInt32(a * b)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -146,7 +147,7 @@ let fns () : List = if exp < 0 then RTE.Ints.NegativeExponent |> RTE.Int |> raiseRTE vm.threadID else - (bigint number) ** (int exp) |> int32 |> DInt32 |> Ply + (bigint number) ** (int exp) |> int32 |> DInt32 |> Task.FromResult with :? System.OverflowException -> RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID) | _ -> incorrectArgs ()) @@ -166,7 +167,7 @@ let fns () : List = if b = 0 then RTE.Ints.DivideByZeroError |> RTE.Int |> raiseRTE vm.threadID else - Ply(DInt32(a / b)) + Task.FromResult(DInt32(a / b)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -180,7 +181,7 @@ let fns () : List = description = "Returns the negation of , {{-a}}" fn = (function - | _, _, _, [ DInt32 a ] -> Ply(DInt32(-a)) + | _, _, _, [ DInt32 a ] -> Task.FromResult(DInt32(-a)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -194,7 +195,7 @@ let fns () : List = description = "Returns {{true}} if is greater than " fn = (function - | _, _, _, [ DInt32 a; DInt32 b ] -> Ply(DBool(a > b)) + | _, _, _, [ DInt32 a; DInt32 b ] -> Task.FromResult(DBool(a > b)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -209,7 +210,7 @@ let fns () : List = "Returns {{true}} if is greater than or equal to " fn = (function - | _, _, _, [ DInt32 a; DInt32 b ] -> Ply(DBool(a >= b)) + | _, _, _, [ DInt32 a; DInt32 b ] -> Task.FromResult(DBool(a >= b)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -223,7 +224,7 @@ let fns () : List = description = "Returns {{true}} if is less than " fn = (function - | _, _, _, [ DInt32 a; DInt32 b ] -> Ply(DBool(a < b)) + | _, _, _, [ DInt32 a; DInt32 b ] -> Task.FromResult(DBool(a < b)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -238,7 +239,7 @@ let fns () : List = "Returns {{true}} if is less than or equal to " fn = (function - | _, _, _, [ DInt32 a; DInt32 b ] -> Ply(DBool(a <= b)) + | _, _, _, [ DInt32 a; DInt32 b ] -> Task.FromResult(DBool(a <= b)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -258,7 +259,9 @@ let fns () : List = let correction : int32 = 1 - lower + randomSeeded().Next(upper - lower + correction) |> DInt32 |> Ply + lower + randomSeeded().Next(upper - lower + correction) + |> DInt32 + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -272,7 +275,7 @@ let fns () : List = description = "Get the square root of an " fn = (function - | _, _, _, [ DInt32 a ] -> Ply(DFloat(sqrt (float a))) + | _, _, _, [ DInt32 a ] -> Task.FromResult(DFloat(sqrt (float a))) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -286,7 +289,7 @@ let fns () : List = description = "Converts an to a " fn = (function - | _, _, _, [ DInt32 a ] -> Ply(DFloat(float a)) + | _, _, _, [ DInt32 a ] -> Task.FromResult(DFloat(float a)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -310,12 +313,15 @@ let fns () : List = (function | _, _, _, [ DString s ] -> try - s |> System.Convert.ToInt32 |> DInt32 |> resultOk |> Ply + s |> System.Convert.ToInt32 |> DInt32 |> resultOk |> Task.FromResult with | :? System.FormatException -> - ParseError.BadFormat |> ParseError.toDT |> resultError |> Ply + ParseError.BadFormat |> ParseError.toDT |> resultError |> Task.FromResult | :? System.OverflowException -> - ParseError.OutOfRange |> ParseError.toDT |> resultError |> Ply + ParseError.OutOfRange + |> ParseError.toDT + |> resultError + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -329,7 +335,7 @@ let fns () : List = description = "Stringify " fn = (function - | _, _, _, [ DInt32 int ] -> Ply(DString(string int)) + | _, _, _, [ DInt32 int ] -> Task.FromResult(DString(string int)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -343,7 +349,7 @@ let fns () : List = description = "Converts an Int8 to a 32-bit signed integer." fn = (function - | _, _, _, [ DInt8 a ] -> DInt32(int32 a) |> Ply + | _, _, _, [ DInt8 a ] -> DInt32(int32 a) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -357,7 +363,7 @@ let fns () : List = description = "Converts a UInt8 to a 32-bit signed integer." fn = (function - | _, _, _, [ DUInt8 a ] -> DInt32(int32 a) |> Ply + | _, _, _, [ DUInt8 a ] -> DInt32(int32 a) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -371,7 +377,7 @@ let fns () : List = description = "Converts an Int16 to a 32-bit signed integer." fn = (function - | _, _, _, [ DInt16 a ] -> DInt32(int32 a) |> Ply + | _, _, _, [ DInt16 a ] -> DInt32(int32 a) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -385,7 +391,7 @@ let fns () : List = description = "Converts a UInt16 to a 32-bit signed integer." fn = (function - | _, _, _, [ DUInt16 a ] -> DInt32(int32 a) |> Ply + | _, _, _, [ DUInt16 a ] -> DInt32(int32 a) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -402,9 +408,9 @@ let fns () : List = (function | _, _, _, [ DUInt32 a ] -> if (a > uint32 System.Int32.MaxValue) then - Dval.optionNone KTInt32 |> Ply + Dval.optionNone KTInt32 |> Task.FromResult else - Dval.optionSome KTInt32 (DInt32(int32 a)) |> Ply + Dval.optionSome KTInt32 (DInt32(int32 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -423,9 +429,9 @@ let fns () : List = if (a < int64 System.Int32.MinValue) || (a > int64 System.Int32.MaxValue) then - Dval.optionNone KTInt32 |> Ply + Dval.optionNone KTInt32 |> Task.FromResult else - Dval.optionSome KTInt32 (DInt32(int32 a)) |> Ply + Dval.optionSome KTInt32 (DInt32(int32 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -442,9 +448,9 @@ let fns () : List = (function | _, _, _, [ DUInt64 a ] -> if (a > uint64 System.Int32.MaxValue) then - Dval.optionNone KTInt32 |> Ply + Dval.optionNone KTInt32 |> Task.FromResult else - Dval.optionSome KTInt32 (DInt32(int32 a)) |> Ply + Dval.optionSome KTInt32 (DInt32(int32 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -464,9 +470,9 @@ let fns () : List = (a < System.Int128.op_Implicit System.Int32.MinValue) || (a > System.Int128.op_Implicit System.Int32.MaxValue) then - Dval.optionNone KTInt32 |> Ply + Dval.optionNone KTInt32 |> Task.FromResult else - Dval.optionSome KTInt32 (DInt32(int32 a)) |> Ply + Dval.optionSome KTInt32 (DInt32(int32 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -483,9 +489,9 @@ let fns () : List = (function | _, _, _, [ DUInt128 a ] -> if (a > 2147483647Z) then - Dval.optionNone KTInt32 |> Ply + Dval.optionNone KTInt32 |> Task.FromResult else - Dval.optionSome KTInt32 (DInt32(int32 a)) |> Ply + Dval.optionSome KTInt32 (DInt32(int32 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -499,7 +505,7 @@ let fns () : List = description = "Bitwise AND on two values" fn = (function - | _, _, _, [ DInt32 a; DInt32 b ] -> Ply(DInt32(a &&& b)) + | _, _, _, [ DInt32 a; DInt32 b ] -> Task.FromResult(DInt32(a &&& b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -513,7 +519,7 @@ let fns () : List = description = "Bitwise OR on two values" fn = (function - | _, _, _, [ DInt32 a; DInt32 b ] -> Ply(DInt32(a ||| b)) + | _, _, _, [ DInt32 a; DInt32 b ] -> Task.FromResult(DInt32(a ||| b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -527,7 +533,7 @@ let fns () : List = description = "Bitwise XOR on two values" fn = (function - | _, _, _, [ DInt32 a; DInt32 b ] -> Ply(DInt32(a ^^^ b)) + | _, _, _, [ DInt32 a; DInt32 b ] -> Task.FromResult(DInt32(a ^^^ b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -541,7 +547,7 @@ let fns () : List = description = "Bitwise NOT on an value" fn = (function - | _, _, _, [ DInt32 a ] -> Ply(DInt32(~~~a)) + | _, _, _, [ DInt32 a ] -> Task.FromResult(DInt32(~~~a)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -555,7 +561,7 @@ let fns () : List = description = "Bitwise left shift of an value" fn = (function - | _, _, _, [ DInt32 a; DInt32 b ] -> Ply(DInt32(a <<< int b)) + | _, _, _, [ DInt32 a; DInt32 b ] -> Task.FromResult(DInt32(a <<< int b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -569,7 +575,7 @@ let fns () : List = description = "Bitwise right shift of an value" fn = (function - | _, _, _, [ DInt32 a; DInt32 b ] -> Ply(DInt32(a >>> int b)) + | _, _, _, [ DInt32 a; DInt32 b ] -> Task.FromResult(DInt32(a >>> int b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure diff --git a/backend/src/BuiltinExecution/Libs/Int64.fs b/backend/src/BuiltinExecution/Libs/Int64.fs index ea36599f3e..591dc52826 100644 --- a/backend/src/BuiltinExecution/Libs/Int64.fs +++ b/backend/src/BuiltinExecution/Libs/Int64.fs @@ -3,6 +3,7 @@ module BuiltinExecution.Libs.Int64 open Prelude open LibExecution.RuntimeTypes open LibExecution.Builtin.Shortcuts +open System.Threading.Tasks module VT = LibExecution.ValueType module Dval = LibExecution.Dval @@ -49,7 +50,7 @@ let fns () : List = else let result = v % m let result = if result < 0L then m + result else result - Ply(DInt64 result) + Task.FromResult(DInt64 result) | _ -> incorrectArgs ()) sqlSpec = SqlBinOp "%" previewable = Pure @@ -73,11 +74,11 @@ let fns () : List = // (function // | _, [ DInt64 v; DInt64 m ] -> // (try - // Ply(Dval.resultOk(DInt64(v % m))) + // Task.FromResult(Dval.resultOk(DInt64(v % m))) // with // | e -> // if m <= 0L then - // Ply( + // Task.FromResult( // DResult( // Error( // DString( @@ -111,7 +112,7 @@ let fns () : List = Returns an {{Error}} if is {{0}}." fn = - let resultOk r = Dval.resultOk KTInt64 KTString r |> Ply + let resultOk r = Dval.resultOk KTInt64 KTString r |> Task.FromResult (function | _, vm, _, [ DInt64 v; DInt64 d ] -> (try @@ -137,7 +138,7 @@ let fns () : List = description = "Adds two integers together" fn = (function - | _, _, _, [ DInt64 a; DInt64 b ] -> Ply(DInt64(a + b)) + | _, _, _, [ DInt64 a; DInt64 b ] -> Task.FromResult(DInt64(a + b)) | _ -> incorrectArgs ()) sqlSpec = SqlBinOp "+" previewable = Pure @@ -151,7 +152,7 @@ let fns () : List = description = "Subtracts two integers" fn = (function - | _, _, _, [ DInt64 a; DInt64 b ] -> Ply(DInt64(a - b)) + | _, _, _, [ DInt64 a; DInt64 b ] -> Task.FromResult(DInt64(a - b)) | _ -> incorrectArgs ()) sqlSpec = SqlBinOp "-" previewable = Pure @@ -165,7 +166,7 @@ let fns () : List = description = "Multiplies two integers" fn = (function - | _, _, _, [ DInt64 a; DInt64 b ] -> Ply(DInt64(a * b)) + | _, _, _, [ DInt64 a; DInt64 b ] -> Task.FromResult(DInt64(a * b)) | _ -> incorrectArgs ()) sqlSpec = SqlBinOp "*" previewable = Pure @@ -187,7 +188,7 @@ let fns () : List = if exp < 0L then RTE.Ints.NegativeExponent |> RTE.Int |> raiseRTE vm.threadID else - (bigint number) ** (int exp) |> int64 |> DInt64 |> Ply + (bigint number) ** (int exp) |> int64 |> DInt64 |> Task.FromResult with :? System.OverflowException -> RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID) | _ -> incorrectArgs ()) @@ -207,7 +208,7 @@ let fns () : List = if b = 0L then RTE.Ints.DivideByZeroError |> RTE.Int |> raiseRTE vm.threadID else - Ply(DInt64(a / b)) + Task.FromResult(DInt64(a / b)) | _ -> incorrectArgs ()) sqlSpec = SqlBinOp "/" previewable = Pure @@ -221,7 +222,7 @@ let fns () : List = description = "Returns the negation of , {{-a}}" fn = (function - | _, _, _, [ DInt64 a ] -> Ply(DInt64(-a)) + | _, _, _, [ DInt64 a ] -> Task.FromResult(DInt64(-a)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -235,7 +236,7 @@ let fns () : List = description = "Returns {{true}} if is greater than " fn = (function - | _, _, _, [ DInt64 a; DInt64 b ] -> Ply(DBool(a > b)) + | _, _, _, [ DInt64 a; DInt64 b ] -> Task.FromResult(DBool(a > b)) | _ -> incorrectArgs ()) sqlSpec = SqlBinOp ">" previewable = Pure @@ -250,7 +251,7 @@ let fns () : List = "Returns {{true}} if is greater than or equal to " fn = (function - | _, _, _, [ DInt64 a; DInt64 b ] -> Ply(DBool(a >= b)) + | _, _, _, [ DInt64 a; DInt64 b ] -> Task.FromResult(DBool(a >= b)) | _ -> incorrectArgs ()) sqlSpec = SqlBinOp ">=" previewable = Pure @@ -264,7 +265,7 @@ let fns () : List = description = "Returns {{true}} if is less than " fn = (function - | _, _, _, [ DInt64 a; DInt64 b ] -> Ply(DBool(a < b)) + | _, _, _, [ DInt64 a; DInt64 b ] -> Task.FromResult(DBool(a < b)) | _ -> incorrectArgs ()) sqlSpec = SqlBinOp "<" previewable = Pure @@ -279,7 +280,7 @@ let fns () : List = "Returns {{true}} if is less than or equal to " fn = (function - | _, _, _, [ DInt64 a; DInt64 b ] -> Ply(DBool(a <= b)) + | _, _, _, [ DInt64 a; DInt64 b ] -> Task.FromResult(DBool(a <= b)) | _ -> incorrectArgs ()) sqlSpec = SqlBinOp "<=" previewable = Pure @@ -303,7 +304,7 @@ let fns () : List = lower + randomSeeded().NextInt64(upper - lower + correction) |> DInt64 - |> Ply + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -317,7 +318,7 @@ let fns () : List = description = "Get the square root of an " fn = (function - | _, _, _, [ DInt64 a ] -> Ply(DFloat(sqrt (float a))) + | _, _, _, [ DInt64 a ] -> Task.FromResult(DFloat(sqrt (float a))) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -331,7 +332,7 @@ let fns () : List = description = "Converts an to a " fn = (function - | _, _, _, [ DInt64 a ] -> Ply(DFloat(float a)) + | _, _, _, [ DInt64 a ] -> Task.FromResult(DFloat(float a)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -354,12 +355,15 @@ let fns () : List = (function | _, _, _, [ DString s ] -> try - s |> System.Convert.ToInt64 |> DInt64 |> resultOk |> Ply + s |> System.Convert.ToInt64 |> DInt64 |> resultOk |> Task.FromResult with | :? System.FormatException -> - ParseError.BadFormat |> ParseError.toDT |> resultError |> Ply + ParseError.BadFormat |> ParseError.toDT |> resultError |> Task.FromResult | :? System.OverflowException -> - ParseError.OutOfRange |> ParseError.toDT |> resultError |> Ply + ParseError.OutOfRange + |> ParseError.toDT + |> resultError + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -373,7 +377,7 @@ let fns () : List = description = "Stringify " fn = (function - | _, _, _, [ DInt64 int ] -> Ply(DString(string int)) + | _, _, _, [ DInt64 int ] -> Task.FromResult(DString(string int)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -387,7 +391,7 @@ let fns () : List = description = "Converts an Int8 to a 64-bit signed integer." fn = (function - | _, _, _, [ DInt8 a ] -> DInt64(int64 a) |> Ply + | _, _, _, [ DInt8 a ] -> DInt64(int64 a) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -401,7 +405,7 @@ let fns () : List = description = "Converts a UInt8 to a 64-bit signed integer." fn = (function - | _, _, _, [ DUInt8 a ] -> DInt64(int64 a) |> Ply + | _, _, _, [ DUInt8 a ] -> DInt64(int64 a) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -415,7 +419,7 @@ let fns () : List = description = "Converts an Int16 to a 64-bit signed integer." fn = (function - | _, _, _, [ DInt16 a ] -> DInt64(int64 a) |> Ply + | _, _, _, [ DInt16 a ] -> DInt64(int64 a) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -429,7 +433,7 @@ let fns () : List = description = "Converts a UInt16 to a 64-bit signed integer." fn = (function - | _, _, _, [ DUInt16 a ] -> DInt64(int64 a) |> Ply + | _, _, _, [ DUInt16 a ] -> DInt64(int64 a) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -443,7 +447,7 @@ let fns () : List = description = "Converts an Int32 to a 64-bit signed integer." fn = (function - | _, _, _, [ DInt32 a ] -> DInt64(int64 a) |> Ply + | _, _, _, [ DInt32 a ] -> DInt64(int64 a) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -457,7 +461,7 @@ let fns () : List = description = "Converts a UInt32 to a 64-bit signed integer." fn = (function - | _, _, _, [ DUInt32 a ] -> DInt64(int64 a) |> Ply + | _, _, _, [ DUInt32 a ] -> DInt64(int64 a) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -474,9 +478,9 @@ let fns () : List = (function | _, _, _, [ DUInt64 a ] -> if (a > uint64 System.Int64.MaxValue) then - Dval.optionNone KTInt64 |> Ply + Dval.optionNone KTInt64 |> Task.FromResult else - Dval.optionSome KTInt64 (DInt64(int64 a)) |> Ply + Dval.optionSome KTInt64 (DInt64(int64 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -496,9 +500,9 @@ let fns () : List = (a < System.Int128.op_Implicit System.Int64.MinValue) || (a > System.Int128.op_Implicit System.Int64.MaxValue) then - Dval.optionNone KTInt64 |> Ply + Dval.optionNone KTInt64 |> Task.FromResult else - Dval.optionSome KTInt64 (DInt64(int64 a)) |> Ply + Dval.optionSome KTInt64 (DInt64(int64 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -515,9 +519,9 @@ let fns () : List = (function | _, _, _, [ DUInt128 a ] -> if (a > 9223372036854775807Z) then - Dval.optionNone KTInt64 |> Ply + Dval.optionNone KTInt64 |> Task.FromResult else - Dval.optionSome KTInt64 (DInt64(int64 a)) |> Ply + Dval.optionSome KTInt64 (DInt64(int64 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -531,7 +535,7 @@ let fns () : List = description = "Bitwise AND on two values" fn = (function - | _, _, _, [ DInt64 a; DInt64 b ] -> Ply(DInt64(a &&& b)) + | _, _, _, [ DInt64 a; DInt64 b ] -> Task.FromResult(DInt64(a &&& b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -545,7 +549,7 @@ let fns () : List = description = "Bitwise OR on two values" fn = (function - | _, _, _, [ DInt64 a; DInt64 b ] -> Ply(DInt64(a ||| b)) + | _, _, _, [ DInt64 a; DInt64 b ] -> Task.FromResult(DInt64(a ||| b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -559,7 +563,7 @@ let fns () : List = description = "Bitwise XOR on two values" fn = (function - | _, _, _, [ DInt64 a; DInt64 b ] -> Ply(DInt64(a ^^^ b)) + | _, _, _, [ DInt64 a; DInt64 b ] -> Task.FromResult(DInt64(a ^^^ b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -573,7 +577,7 @@ let fns () : List = description = "Bitwise NOT on an value" fn = (function - | _, _, _, [ DInt64 a ] -> Ply(DInt64(~~~a)) + | _, _, _, [ DInt64 a ] -> Task.FromResult(DInt64(~~~a)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -587,7 +591,7 @@ let fns () : List = description = "Bitwise left shift of an value" fn = (function - | _, _, _, [ DInt64 a; DInt64 b ] -> Ply(DInt64(a <<< int b)) + | _, _, _, [ DInt64 a; DInt64 b ] -> Task.FromResult(DInt64(a <<< int b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -601,7 +605,7 @@ let fns () : List = description = "Bitwise right shift of an value" fn = (function - | _, _, _, [ DInt64 a; DInt64 b ] -> Ply(DInt64(a >>> int b)) + | _, _, _, [ DInt64 a; DInt64 b ] -> Task.FromResult(DInt64(a >>> int b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure diff --git a/backend/src/BuiltinExecution/Libs/Int8.fs b/backend/src/BuiltinExecution/Libs/Int8.fs index 700ebc2ec8..d6cfb2c4c0 100644 --- a/backend/src/BuiltinExecution/Libs/Int8.fs +++ b/backend/src/BuiltinExecution/Libs/Int8.fs @@ -3,6 +3,7 @@ module BuiltinExecution.Libs.Int8 open Prelude open LibExecution.RuntimeTypes open LibExecution.Builtin.Shortcuts +open System.Threading.Tasks module VT = LibExecution.ValueType module Dval = LibExecution.Dval @@ -48,7 +49,7 @@ let fns () : List = else let result = v % m let result = if result < 0y then m + result else result - Ply(DInt8 result) + Task.FromResult(DInt8 result) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -70,7 +71,7 @@ let fns () : List = Returns an {{Error}} if is {{0}}." fn = - let resultOk r = Dval.resultOk KTInt8 KTString r |> Ply + let resultOk r = Dval.resultOk KTInt8 KTString r |> Task.FromResult (function | _, vm, _, [ DInt8 v; DInt8 d ] -> (try @@ -98,7 +99,7 @@ let fns () : List = (function | _, vm, _, [ DInt8 a; DInt8 b ] -> try - DInt8(Checked.(+) a b) |> Ply + DInt8(Checked.(+) a b) |> Task.FromResult with :? System.OverflowException -> RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID | _ -> incorrectArgs ()) @@ -116,7 +117,7 @@ let fns () : List = (function | _, vm, _, [ DInt8 a; DInt8 b ] -> try - DInt8(Checked.(-) a b) |> Ply + DInt8(Checked.(-) a b) |> Task.FromResult with :? System.OverflowException -> RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID | _ -> incorrectArgs ()) @@ -134,7 +135,7 @@ let fns () : List = (function | _, vm, _, [ DInt8 a; DInt8 b ] -> try - DInt8(Checked.(*) a b) |> Ply + DInt8(Checked.(*) a b) |> Task.FromResult with :? System.OverflowException -> RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID | _ -> incorrectArgs ()) @@ -158,7 +159,7 @@ let fns () : List = if exp < 0y then RTE.Ints.NegativeExponent |> RTE.Int |> raiseRTE vm.threadID else - (bigint number) ** (int exp) |> int8 |> DInt8 |> Ply + (bigint number) ** (int exp) |> int8 |> DInt8 |> Task.FromResult with :? System.OverflowException -> RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID) | _ -> incorrectArgs ()) @@ -182,7 +183,7 @@ let fns () : List = if result < -128 || result > 127 then RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID else - Ply(DInt8(int8 result)) + Task.FromResult(DInt8(int8 result)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -201,7 +202,7 @@ let fns () : List = if result < -128 || result > 127 then RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID else - Ply(DInt8(int8 result)) + Task.FromResult(DInt8(int8 result)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -215,7 +216,7 @@ let fns () : List = description = "Returns {{true}} if is greater than " fn = (function - | _, _, _, [ DInt8 a; DInt8 b ] -> Ply(DBool(a > b)) + | _, _, _, [ DInt8 a; DInt8 b ] -> Task.FromResult(DBool(a > b)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -230,7 +231,7 @@ let fns () : List = "Returns {{true}} if is greater than or equal to " fn = (function - | _, _, _, [ DInt8 a; DInt8 b ] -> Ply(DBool(a >= b)) + | _, _, _, [ DInt8 a; DInt8 b ] -> Task.FromResult(DBool(a >= b)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -244,7 +245,7 @@ let fns () : List = description = "Returns {{true}} if is less than " fn = (function - | _, _, _, [ DInt8 a; DInt8 b ] -> Ply(DBool(a < b)) + | _, _, _, [ DInt8 a; DInt8 b ] -> Task.FromResult(DBool(a < b)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -259,7 +260,7 @@ let fns () : List = "Returns {{true}} if is less than or equal to " fn = (function - | _, _, _, [ DInt8 a; DInt8 b ] -> Ply(DBool(a <= b)) + | _, _, _, [ DInt8 a; DInt8 b ] -> Task.FromResult(DBool(a <= b)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -273,7 +274,7 @@ let fns () : List = description = "Converts an to a " fn = (function - | _, _, _, [ DInt8 a ] -> Ply(DString(string a)) + | _, _, _, [ DInt8 a ] -> Task.FromResult(DString(string a)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -287,7 +288,7 @@ let fns () : List = description = "Converts an to a " fn = (function - | _, _, _, [ DInt8 a ] -> Ply(DFloat(float a)) + | _, _, _, [ DInt8 a ] -> Task.FromResult(DFloat(float a)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -314,7 +315,7 @@ let fns () : List = let int8Result = lowerBound + (int8 resultInt) - int8Result |> DInt8 |> Ply + int8Result |> DInt8 |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -328,7 +329,7 @@ let fns () : List = description = "Get the square root of an " fn = (function - | _, _, _, [ DInt8 a ] -> Ply(DFloat(sqrt (float a))) + | _, _, _, [ DInt8 a ] -> Task.FromResult(DFloat(sqrt (float a))) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -351,12 +352,15 @@ let fns () : List = (function | _, _, _, [ DString s ] -> try - s |> System.SByte.Parse |> DInt8 |> resultOk |> Ply + s |> System.SByte.Parse |> DInt8 |> resultOk |> Task.FromResult with | :? System.FormatException -> - ParseError.BadFormat |> ParseError.toDT |> resultError |> Ply + ParseError.BadFormat |> ParseError.toDT |> resultError |> Task.FromResult | :? System.OverflowException -> - ParseError.OutOfRange |> ParseError.toDT |> resultError |> Ply + ParseError.OutOfRange + |> ParseError.toDT + |> resultError + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -373,9 +377,9 @@ let fns () : List = (function | _, _, _, [ DUInt8 a ] -> if a > 127uy then - Dval.optionNone KTInt8 |> Ply + Dval.optionNone KTInt8 |> Task.FromResult else - Dval.optionSome KTInt8 (DInt8(int8 a)) |> Ply + Dval.optionSome KTInt8 (DInt8(int8 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -392,9 +396,9 @@ let fns () : List = (function | _, _, _, [ DInt16 a ] -> if a < -128s || a > 127s then - Dval.optionNone KTInt8 |> Ply + Dval.optionNone KTInt8 |> Task.FromResult else - Dval.optionSome KTInt8 (DInt8(int8 a)) |> Ply + Dval.optionSome KTInt8 (DInt8(int8 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -411,9 +415,9 @@ let fns () : List = (function | _, _, _, [ DUInt16 a ] -> if a > 127us then - Dval.optionNone KTInt8 |> Ply + Dval.optionNone KTInt8 |> Task.FromResult else - Dval.optionSome KTInt8 (DInt8(int8 a)) |> Ply + Dval.optionSome KTInt8 (DInt8(int8 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -430,9 +434,9 @@ let fns () : List = (function | _, _, _, [ DInt32 a ] -> if a < -128l || a > 127l then - Dval.optionNone KTInt8 |> Ply + Dval.optionNone KTInt8 |> Task.FromResult else - Dval.optionSome KTInt8 (DInt8(int8 a)) |> Ply + Dval.optionSome KTInt8 (DInt8(int8 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -449,9 +453,9 @@ let fns () : List = (function | _, _, _, [ DUInt32 a ] -> if a > 127ul then - Dval.optionNone KTInt8 |> Ply + Dval.optionNone KTInt8 |> Task.FromResult else - Dval.optionSome KTInt8 (DInt8(int8 a)) |> Ply + Dval.optionSome KTInt8 (DInt8(int8 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -468,9 +472,9 @@ let fns () : List = (function | _, _, _, [ DInt64 a ] -> if a < -128L || a > 127L then - Dval.optionNone KTInt8 |> Ply + Dval.optionNone KTInt8 |> Task.FromResult else - Dval.optionSome KTInt8 (DInt8(int8 a)) |> Ply + Dval.optionSome KTInt8 (DInt8(int8 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -487,9 +491,9 @@ let fns () : List = (function | _, _, _, [ DUInt64 a ] -> if a > 127UL then - Dval.optionNone KTInt8 |> Ply + Dval.optionNone KTInt8 |> Task.FromResult else - Dval.optionSome KTInt8 (DInt8(int8 a)) |> Ply + Dval.optionSome KTInt8 (DInt8(int8 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -506,9 +510,9 @@ let fns () : List = (function | _, _, _, [ DInt128 a ] -> if a < -128Q || a > 127Q then - Dval.optionNone KTInt8 |> Ply + Dval.optionNone KTInt8 |> Task.FromResult else - Dval.optionSome KTInt8 (DInt8(int8 a)) |> Ply + Dval.optionSome KTInt8 (DInt8(int8 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -525,9 +529,9 @@ let fns () : List = (function | _, _, _, [ DUInt128 a ] -> if a > 127Z then - Dval.optionNone KTInt8 |> Ply + Dval.optionNone KTInt8 |> Task.FromResult else - Dval.optionSome KTInt8 (DInt8(int8 a)) |> Ply + Dval.optionSome KTInt8 (DInt8(int8 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -541,7 +545,7 @@ let fns () : List = description = "Bitwise AND on two values" fn = (function - | _, _, _, [ DInt8 a; DInt8 b ] -> Ply(DInt8(a &&& b)) + | _, _, _, [ DInt8 a; DInt8 b ] -> Task.FromResult(DInt8(a &&& b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -555,7 +559,7 @@ let fns () : List = description = "Bitwise OR on two values" fn = (function - | _, _, _, [ DInt8 a; DInt8 b ] -> Ply(DInt8(a ||| b)) + | _, _, _, [ DInt8 a; DInt8 b ] -> Task.FromResult(DInt8(a ||| b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -569,7 +573,7 @@ let fns () : List = description = "Bitwise XOR on two values" fn = (function - | _, _, _, [ DInt8 a; DInt8 b ] -> Ply(DInt8(a ^^^ b)) + | _, _, _, [ DInt8 a; DInt8 b ] -> Task.FromResult(DInt8(a ^^^ b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -583,7 +587,7 @@ let fns () : List = description = "Bitwise NOT on an value" fn = (function - | _, _, _, [ DInt8 a ] -> Ply(DInt8(~~~a)) + | _, _, _, [ DInt8 a ] -> Task.FromResult(DInt8(~~~a)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -597,7 +601,7 @@ let fns () : List = description = "Bitwise left shift of an value" fn = (function - | _, _, _, [ DInt8 a; DInt8 b ] -> Ply(DInt8(a <<< int b)) + | _, _, _, [ DInt8 a; DInt8 b ] -> Task.FromResult(DInt8(a <<< int b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -611,7 +615,7 @@ let fns () : List = description = "Bitwise right shift of an value" fn = (function - | _, _, _, [ DInt8 a; DInt8 b ] -> Ply(DInt8(a >>> int b)) + | _, _, _, [ DInt8 a; DInt8 b ] -> Task.FromResult(DInt8(a >>> int b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure diff --git a/backend/src/BuiltinExecution/Libs/Json.fs b/backend/src/BuiltinExecution/Libs/Json.fs index 960100ed4f..aa86051ef7 100644 --- a/backend/src/BuiltinExecution/Libs/Json.fs +++ b/backend/src/BuiltinExecution/Libs/Json.fs @@ -5,6 +5,7 @@ open System.Text.Json open Prelude open LibExecution.RuntimeTypes open LibExecution.Builtin.Shortcuts +open System.Threading.Tasks module DarkDateTime = LibExecution.DarkDateTime module VT = LibExecution.ValueType @@ -232,7 +233,7 @@ let parse (types : Types) (typ : TypeReference) (str : string) - : Ply> = + : Task> = let tst = Map.empty // TODO consider passing this in.. somehow? @@ -240,14 +241,14 @@ let parse (typ : TypeReference) (pathSoFar : JsonPath.JsonPath) (j : JsonElement) - : Ply = + : Task = match typ, j.ValueKind with // basic types - | TUnit, JsonValueKind.Null -> DUnit |> Ply + | TUnit, JsonValueKind.Null -> DUnit |> Task.FromResult - | TBool, JsonValueKind.True -> DBool true |> Ply - | TBool, JsonValueKind.False -> DBool false |> Ply + | TBool, JsonValueKind.True -> DBool true |> Task.FromResult + | TBool, JsonValueKind.False -> DBool false |> Task.FromResult | TInt64, JsonValueKind.Number -> let mutable i64 = 0L @@ -258,11 +259,11 @@ let parse if j.TryGetUInt64(&ui64) then if ui64 <= uint64 System.Int64.MaxValue then - DInt64(int64 ui64) |> Ply + DInt64(int64 ui64) |> Task.FromResult else - raiseCantMatchWithType TInt64 j pathSoFar |> Ply + raiseCantMatchWithType TInt64 j pathSoFar |> Task.FromResult else if j.TryGetInt64(&i64) then - DInt64 i64 |> Ply + DInt64 i64 |> Task.FromResult // We allow the user to specify numbers in int or float format (e.g. 1 or 1.0 // or even 1E+0) -- JSON uses floating point numbers, and the person/API // client/server that is creating a field we understand to be an int may choose @@ -273,24 +274,24 @@ let parse && d >= (float System.Int64.MinValue) && System.Double.IsInteger d then - int64 d |> DInt64 |> Ply + int64 d |> DInt64 |> Task.FromResult else - raiseCantMatchWithType TInt64 j pathSoFar |> Ply + raiseCantMatchWithType TInt64 j pathSoFar |> Task.FromResult | TUInt64, JsonValueKind.Number -> let mutable ui64 = 0UL let mutable d = 0.0 if j.TryGetUInt64(&ui64) then - DUInt64 ui64 |> Ply + DUInt64 ui64 |> Task.FromResult else if j.TryGetDouble(&d) && d <= (float System.UInt64.MaxValue) && d >= (float System.UInt64.MinValue) && System.Double.IsInteger d then - uint64 d |> DUInt64 |> Ply + uint64 d |> DUInt64 |> Task.FromResult else - raiseCantMatchWithType TUInt64 j pathSoFar |> Ply + raiseCantMatchWithType TUInt64 j pathSoFar |> Task.FromResult | TInt8, JsonValueKind.Number -> let mutable i64 = 0L @@ -301,14 +302,14 @@ let parse && ui64 >= uint64 System.SByte.MinValue && ui64 <= uint64 System.SByte.MaxValue then - DInt8(int8 ui64) |> Ply + DInt8(int8 ui64) |> Task.FromResult else if j.TryGetInt64(&i64) && i64 >= int System.SByte.MinValue && i64 <= int System.SByte.MaxValue then - DInt8(int8 i64) |> Ply + DInt8(int8 i64) |> Task.FromResult else if j.TryGetDouble(&d) @@ -316,9 +317,9 @@ let parse && d >= (float System.SByte.MinValue) && System.Double.IsInteger d then - int8 d |> DInt8 |> Ply + int8 d |> DInt8 |> Task.FromResult else - raiseCantMatchWithType TInt8 j pathSoFar |> Ply + raiseCantMatchWithType TInt8 j pathSoFar |> Task.FromResult | TUInt8, JsonValueKind.Number -> let mutable i64 = 0L @@ -326,14 +327,14 @@ let parse let mutable d = 0.0 if j.TryGetUInt64(&ui64) && ui64 <= uint64 System.Byte.MaxValue then - DUInt8(uint8 ui64) |> Ply + DUInt8(uint8 ui64) |> Task.FromResult else if j.TryGetInt64(&i64) && i64 >= int System.Byte.MinValue && i64 <= int System.Byte.MaxValue then - DUInt8(uint8 i64) |> Ply + DUInt8(uint8 i64) |> Task.FromResult else if j.TryGetDouble(&d) @@ -341,129 +342,129 @@ let parse && d >= (float System.Byte.MinValue) && System.Double.IsInteger d then - uint8 d |> DUInt8 |> Ply + uint8 d |> DUInt8 |> Task.FromResult else - raiseCantMatchWithType TUInt8 j pathSoFar |> Ply + raiseCantMatchWithType TUInt8 j pathSoFar |> Task.FromResult | TInt16, JsonValueKind.Number -> let mutable i16 = 0s let mutable d = 0.0 if j.TryGetInt16(&i16) then - DInt16 i16 |> Ply + DInt16 i16 |> Task.FromResult else if j.TryGetDouble(&d) && d <= (float System.Int16.MaxValue) && d >= (float System.Int16.MinValue) && System.Double.IsInteger d then - int16 d |> DInt16 |> Ply + int16 d |> DInt16 |> Task.FromResult else - raiseCantMatchWithType TInt16 j pathSoFar |> Ply + raiseCantMatchWithType TInt16 j pathSoFar |> Task.FromResult | TUInt16, JsonValueKind.Number -> let mutable ui16 = 0us let mutable d = 0.0 if j.TryGetUInt16(&ui16) then - DUInt16 ui16 |> Ply + DUInt16 ui16 |> Task.FromResult else if j.TryGetDouble(&d) && d <= (float System.UInt16.MaxValue) && d >= (float System.UInt16.MinValue) && System.Double.IsInteger d then - uint16 d |> DUInt16 |> Ply + uint16 d |> DUInt16 |> Task.FromResult else - raiseCantMatchWithType TUInt16 j pathSoFar |> Ply + raiseCantMatchWithType TUInt16 j pathSoFar |> Task.FromResult | TInt32, JsonValueKind.Number -> let mutable i32 = 0 let mutable d = 0.0 if j.TryGetInt32(&i32) then - DInt32 i32 |> Ply + DInt32 i32 |> Task.FromResult else if j.TryGetDouble(&d) && d <= (float System.Int32.MaxValue) && d >= (float System.Int32.MinValue) && System.Double.IsInteger d then - int32 d |> DInt32 |> Ply + int32 d |> DInt32 |> Task.FromResult else - raiseCantMatchWithType TInt32 j pathSoFar |> Ply + raiseCantMatchWithType TInt32 j pathSoFar |> Task.FromResult | TUInt32, JsonValueKind.Number -> let mutable ui32 = 0ul let mutable d = 0.0 if j.TryGetUInt32(&ui32) then - DUInt32 ui32 |> Ply + DUInt32 ui32 |> Task.FromResult else if j.TryGetDouble(&d) && d <= (float System.UInt32.MaxValue) && d >= (float System.UInt32.MinValue) && System.Double.IsInteger d then - uint32 d |> DUInt32 |> Ply + uint32 d |> DUInt32 |> Task.FromResult else - raiseCantMatchWithType TUInt32 j pathSoFar |> Ply + raiseCantMatchWithType TUInt32 j pathSoFar |> Task.FromResult | TInt128, JsonValueKind.Number -> let mutable i128 = System.Int128.Zero let mutable d = 0.0 if System.Int128.TryParse(j.GetRawText(), &i128) then - DInt128 i128 |> Ply + DInt128 i128 |> Task.FromResult else if j.TryGetDouble(&d) && System.Double.IsInteger d then try System.Int128.Parse( d.ToString("F0", System.Globalization.CultureInfo.InvariantCulture) ) |> DInt128 - |> Ply + |> Task.FromResult with :? System.OverflowException -> - raiseCantMatchWithType TInt128 j pathSoFar |> Ply + raiseCantMatchWithType TInt128 j pathSoFar |> Task.FromResult else - raiseCantMatchWithType TInt128 j pathSoFar |> Ply + raiseCantMatchWithType TInt128 j pathSoFar |> Task.FromResult | TUInt128, JsonValueKind.Number -> let mutable ui128 = System.UInt128.Zero let mutable d = 0.0 if System.UInt128.TryParse(j.GetRawText(), &ui128) then - DUInt128 ui128 |> Ply + DUInt128 ui128 |> Task.FromResult else if j.TryGetDouble(&d) && System.Double.IsInteger d then try System.UInt128.Parse( d.ToString("F0", System.Globalization.CultureInfo.InvariantCulture) ) |> DUInt128 - |> Ply + |> Task.FromResult with :? System.OverflowException -> - raiseCantMatchWithType TUInt128 j pathSoFar |> Ply + raiseCantMatchWithType TUInt128 j pathSoFar |> Task.FromResult else - raiseCantMatchWithType TUInt128 j pathSoFar |> Ply + raiseCantMatchWithType TUInt128 j pathSoFar |> Task.FromResult - | TFloat, JsonValueKind.Number -> j.GetDouble() |> DFloat |> Ply + | TFloat, JsonValueKind.Number -> j.GetDouble() |> DFloat |> Task.FromResult | TFloat, JsonValueKind.String -> match j.GetString() with | "NaN" -> DFloat System.Double.NaN | "Infinity" -> DFloat System.Double.PositiveInfinity | "-Infinity" -> DFloat System.Double.NegativeInfinity | _ -> raiseCantMatchWithType TFloat j pathSoFar - |> Ply + |> Task.FromResult | TChar, JsonValueKind.String -> match String.toEgcChar (j.GetString()) with - | Some c -> Ply(DChar c) + | Some c -> Task.FromResult(DChar c) | None -> raiseCantMatchWithType TChar j pathSoFar - | TString, JsonValueKind.String -> DString(j.GetString()) |> Ply + | TString, JsonValueKind.String -> DString(j.GetString()) |> Task.FromResult | TUuid, JsonValueKind.String -> try - DUuid(System.Guid(j.GetString())) |> Ply + DUuid(System.Guid(j.GetString())) |> Task.FromResult with _ -> raiseCantMatchWithType TUuid j pathSoFar @@ -473,7 +474,7 @@ let parse |> NodaTime.Instant.ofIsoString |> DarkDateTime.fromInstant |> DDateTime - |> Ply + |> Task.FromResult with _ -> raiseCantMatchWithType TDateTime j pathSoFar @@ -484,8 +485,8 @@ let parse j.EnumerateArray() |> Seq.mapi (fun i v -> convert nested (JsonPath.Part.Index i :: pathSoFar) v) |> Seq.toList - |> Ply.List.flatten - |> Ply.map (TypeChecker.DvalCreator.list threadID VT.unknownTODO) + |> Task.flatten + |> Task.map (TypeChecker.DvalCreator.list threadID VT.unknownTODO) | TTuple(t1, t2, rest), JsonValueKind.Array -> let values = j.EnumerateArray() |> Seq.toList @@ -494,8 +495,8 @@ let parse List.zip types values |> List.mapi (fun i (t, v) -> convert t (JsonPath.Part.Index i :: pathSoFar) v) - |> Ply.List.flatten - |> Ply.map (fun mapped -> + |> Task.flatten + |> Task.map (fun mapped -> match mapped with | (d1 :: d2 :: rest) -> DTuple(d1, d2, rest) | _ -> @@ -504,19 +505,19 @@ let parse | TDict tDict, JsonValueKind.Object -> j.EnumerateObject() |> Seq.map (fun jp -> - uply { + task { let! converted = convert tDict (JsonPath.Part.Field jp.Name :: pathSoFar) jp.Value return (jp.Name, converted) }) |> Seq.toList - |> Ply.List.flatten - |> Ply.map (TypeChecker.DvalCreator.dict threadID VT.unknownTODO) + |> Task.flatten + |> Task.map (TypeChecker.DvalCreator.dict threadID VT.unknownTODO) | TCustomType({ resolved = Ok typeName }, typeArgs), jsonValueKind -> - uply { + task { let! typeArgsVT = - typeArgs |> Ply.List.mapSequentially (TypeReference.toVT types tst) + typeArgs |> Task.mapSequentially (fun t -> TypeReference.toVT types tst t) match! Types.find types typeName with | None -> @@ -567,7 +568,7 @@ let parse let path = JsonPath.Part.Index i :: casePath let typ = Types.substitute decl.typeParams typeArgs typ convert typ path j) - |> Ply.List.flatten + |> Task.flatten if expectedFieldCount > actualFieldCount then let index = actualFieldCount // one higher than greatest index @@ -628,7 +629,7 @@ let parse fields |> NEList.toList |> List.map (fun def -> - uply { + task { let correspondingValue = let matchingFieldDef = // TODO: allow Option<>al fields to be omitted @@ -653,7 +654,7 @@ let parse correspondingValue return (def.name, converted) }) - |> Ply.List.flatten + |> Task.flatten let! record = TypeChecker.DvalCreator.record @@ -705,9 +706,9 @@ let parse Error ParseError.NotJson match parsed with - | Error err -> Error err |> Ply + | Error err -> Error err |> Task.FromResult | Ok parsed -> - uply { + task { try let! converted = convert typ [ JsonPath.Part.Root ] parsed return Ok converted @@ -725,10 +726,8 @@ let fns () : List = fn = (function | _, vm, [ _typeToSerializeAs ], [ arg ] -> - uply { - let response = writeJson (fun w -> serialize vm.threadID w arg) - return DString response - } + let response = writeJson (fun w -> serialize vm.threadID w arg) + DString response |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -755,11 +754,12 @@ let fns () : List = let resultError = TypeChecker.DvalCreator.Result.error threadID okType errType - uply { + task { match! parse threadID exeState.types typeArg arg with | Ok v -> return resultOk v | Error e -> return resultError (ParseError.toDT e) } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure diff --git a/backend/src/BuiltinExecution/Libs/LanguageTools.fs b/backend/src/BuiltinExecution/Libs/LanguageTools.fs index 42fa52aeb2..8f083a12f0 100644 --- a/backend/src/BuiltinExecution/Libs/LanguageTools.fs +++ b/backend/src/BuiltinExecution/Libs/LanguageTools.fs @@ -3,6 +3,7 @@ module BuiltinExecution.Libs.LanguageTools open Prelude open LibExecution.RuntimeTypes open LibExecution.Builtin.Shortcuts +open System.Threading.Tasks module VT = LibExecution.ValueType module Dval = LibExecution.Dval @@ -39,7 +40,7 @@ let fns () : List = DRecord(builtinValue (), builtinValue (), [], Map fields)) - DList(VT.customType (builtinValue ()) [], vals) |> Ply + DList(VT.customType (builtinValue ()) [], vals) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -76,7 +77,7 @@ let fns () : List = DRecord(builtinFn (), builtinFn (), [], Map fields)) - DList(VT.customType (builtinFn ()) [], fns) |> Ply + DList(VT.customType (builtinFn ()) [], fns) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure diff --git a/backend/src/BuiltinExecution/Libs/List.fs b/backend/src/BuiltinExecution/Libs/List.fs index 01f147917f..8a1633ff9d 100644 --- a/backend/src/BuiltinExecution/Libs/List.fs +++ b/backend/src/BuiltinExecution/Libs/List.fs @@ -3,6 +3,7 @@ module BuiltinExecution.Libs.List open Prelude open LibExecution.RuntimeTypes open LibExecution.Builtin.Shortcuts +open System.Threading.Tasks module VT = LibExecution.ValueType module Dval = LibExecution.Dval @@ -171,7 +172,7 @@ module DvalComparator = module Sort = exception InvalidSortComparatorInt of int64 - type Comparer = Dval -> Dval -> Ply + type Comparer = Dval -> Dval -> Task type Array = array @@ -191,8 +192,8 @@ module Sort = (halfLen : int) (length : int) (comparer : Comparer) - : Ply = - uply { + : Task = + task { let mutable leftHalfIndex = 0 let mutable rightHalfIndex = index + halfLen let rightHalfEnd = index + length @@ -238,8 +239,8 @@ module Sort = (length : int) (comparer : Comparer) (scratchSpace : Array) - : Ply = - uply { + : Task = + task { if length <= 1 then return () elif length = 2 then @@ -268,13 +269,13 @@ module Sort = (index : int) (length : int) (comparer : Comparer) - : Ply = + : Task = let scratchSpace = System.Array.CreateInstance(typeof, arrayToSort.Length / 2) :?> Array mergeSortHelper arrayToSort index length comparer scratchSpace - let sort (comparer : Comparer) (arrayToSort : Array) : Ply = + let sort (comparer : Comparer) (arrayToSort : Array) : Task = sequentialSort arrayToSort 0 arrayToSort.Length comparer let varA = TVariable "a" @@ -290,7 +291,7 @@ let fns () : List = description = "Returns the number of values in " fn = (function - | _, _, _, [ DList(_, l) ] -> Ply(Dval.int64 (l.Length)) + | _, _, _, [ DList(_, l) ] -> Task.FromResult(Dval.int64 (l.Length)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -311,7 +312,7 @@ let fns () : List = List.distinct l |> List.sortWith DvalComparator.compareDvalInt |> fun l -> DList(vt, l) - |> Ply + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -335,7 +336,7 @@ let fns () : List = list |> List.sortWith DvalComparator.compareDvalInt |> (fun l -> DList(vt, l)) - |> Ply + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -355,7 +356,9 @@ let fns () : List = | _, vm, _, [ DList(vt1, l1); DList(_vt2, l2) ] -> // VTTODO should fail here in the case of vt1 conflicting with vt2? // (or is this handled by the interpreter?) - Ply(TypeChecker.DvalCreator.list vm.threadID vt1 (List.append l1 l2)) + Task.FromResult( + TypeChecker.DvalCreator.list vm.threadID vt1 (List.append l1 l2) + ) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -374,7 +377,7 @@ let fns () : List = let optType = VT.unknownTODO (function | _, _, _, [ DList(_, []) ] -> - TypeChecker.DvalCreator.optionNone optType |> Ply + TypeChecker.DvalCreator.optionNone optType |> Task.FromResult | _, vm, _, [ DList(_, l) ] -> // Will return <= (length - 1) // Maximum value is Int64.MaxValue which is half of UInt64.MaxValue, but @@ -383,7 +386,7 @@ let fns () : List = let index = RNG.GetInt32(l.Length) (List.tryItem index l) |> TypeChecker.DvalCreator.option vm.threadID optType - |> Ply + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Impure diff --git a/backend/src/BuiltinExecution/Libs/Math.fs b/backend/src/BuiltinExecution/Libs/Math.fs index b57124a60e..210ca44b34 100644 --- a/backend/src/BuiltinExecution/Libs/Math.fs +++ b/backend/src/BuiltinExecution/Libs/Math.fs @@ -3,6 +3,7 @@ module BuiltinExecution.Libs.Math open Prelude open LibExecution.RuntimeTypes open LibExecution.Builtin.Shortcuts +open System.Threading.Tasks module VT = LibExecution.ValueType module Dval = LibExecution.Dval @@ -23,7 +24,7 @@ let fns () : List = hypotenuse." fn = (function - | _, _, _, [ DFloat a ] -> Ply(DFloat(System.Math.Cos a)) + | _, _, _, [ DFloat a ] -> Task.FromResult(DFloat(System.Math.Cos a)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -41,7 +42,7 @@ let fns () : List = the ratio of the lengths of the side opposite the angle and the hypotenuse" fn = (function - | _, _, _, [ DFloat a ] -> Ply(DFloat(System.Math.Sin a)) + | _, _, _, [ DFloat a ] -> Task.FromResult(DFloat(System.Math.Sin a)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -60,7 +61,7 @@ let fns () : List = adjacent to the angle." fn = (function - | _, _, _, [ DFloat a ] -> Ply(DFloat(System.Math.Tan a)) + | _, _, _, [ DFloat a ] -> Task.FromResult(DFloat(System.Math.Tan a)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -85,9 +86,9 @@ let fns () : List = let res = System.Math.Acos r in if System.Double.IsNaN res then - Dval.optionNone KTFloat |> Ply + Dval.optionNone KTFloat |> Task.FromResult else - Dval.optionSome KTFloat (DFloat res) |> Ply + Dval.optionSome KTFloat (DFloat res) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -112,9 +113,9 @@ let fns () : List = let res = System.Math.Asin r in if System.Double.IsNaN res then - Dval.optionNone KTFloat |> Ply + Dval.optionNone KTFloat |> Task.FromResult else - Dval.optionSome KTFloat (DFloat res) |> Ply + Dval.optionSome KTFloat (DFloat res) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -133,7 +134,7 @@ let fns () : List = output range, if you know the numerator and denominator of ." fn = (function - | _, _, _, [ DFloat a ] -> Ply(DFloat(System.Math.Atan a)) + | _, _, _, [ DFloat a ] -> Task.FromResult(DFloat(System.Math.Atan a)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -154,7 +155,8 @@ let fns () : List = individual values and ." fn = (function - | _, _, _, [ DFloat y; DFloat x ] -> Ply(DFloat(System.Math.Atan2(y, x))) + | _, _, _, [ DFloat y; DFloat x ] -> + Task.FromResult(DFloat(System.Math.Atan2(y, x))) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -168,7 +170,7 @@ let fns () : List = description = "Returns the hyperbolic cosine of " fn = (function - | _, _, _, [ DFloat a ] -> Ply(DFloat(System.Math.Cosh a)) + | _, _, _, [ DFloat a ] -> Task.FromResult(DFloat(System.Math.Cosh a)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -182,7 +184,7 @@ let fns () : List = description = "Returns the hyperbolic sine of " fn = (function - | _, _, _, [ DFloat a ] -> Ply(DFloat(System.Math.Sinh a)) + | _, _, _, [ DFloat a ] -> Task.FromResult(DFloat(System.Math.Sinh a)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -196,7 +198,7 @@ let fns () : List = description = "Returns the hyperbolic tangent of " fn = (function - | _, _, _, [ DFloat a ] -> Ply(DFloat(System.Math.Sinh a)) + | _, _, _, [ DFloat a ] -> Task.FromResult(DFloat(System.Math.Sinh a)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure diff --git a/backend/src/BuiltinExecution/Libs/NoModule.fs b/backend/src/BuiltinExecution/Libs/NoModule.fs index c21bcb39ec..e06400cc97 100644 --- a/backend/src/BuiltinExecution/Libs/NoModule.fs +++ b/backend/src/BuiltinExecution/Libs/NoModule.fs @@ -4,6 +4,7 @@ open Prelude open LibExecution.RuntimeTypes open LibExecution.Builtin.Shortcuts +open System.Threading.Tasks module PackageRefs = LibExecution.PackageRefs module Dval = LibExecution.Dval module ValueType = LibExecution.ValueType @@ -182,7 +183,7 @@ let fns () : List = description = "Returns true if the two value are equal" fn = (function - | _, vm, _, [ a; b ] -> equalsBuiltinImpl vm a b |> DBool |> Ply + | _, vm, _, [ a; b ] -> equalsBuiltinImpl vm a b |> DBool |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = SqlBinOp "=" previewable = Pure @@ -196,7 +197,8 @@ let fns () : List = description = "Returns true if the two value are not equal" fn = (function - | _, vm, _, [ a; b ] -> equalsBuiltinImpl vm a b |> not |> DBool |> Ply + | _, vm, _, [ a; b ] -> + equalsBuiltinImpl vm a b |> not |> DBool |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = SqlBinOp "<>" previewable = Pure @@ -219,13 +221,13 @@ let fns () : List = | DEnum(FQTypeName.Package(Hash id), _, _, "Some", [ value ]) when id = PackageRefs.Type.Stdlib.option () -> - Ply value + Task.FromResult value // Success: extract `Ok` out of a Result | DEnum(FQTypeName.Package(Hash id), _, _, "Ok", [ value ]) when id = PackageRefs.Type.Stdlib.result () -> - Ply value + Task.FromResult value // Error: expected Some, got None | DEnum(FQTypeName.Package(Hash id), _, _, "None", []) when @@ -270,11 +272,12 @@ let fns () : List = fn = (function | exeState, _, _, [ DString label; value ] -> - uply { + task { let! repr = Exe.dvalToRepr exeState value print $"DEBUG: {label}: {repr}" return DUnit } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -290,10 +293,11 @@ let fns () : List = fn = (function | exeState, _, _, [ value ] -> - uply { + task { let! repr = Exe.dvalToRepr exeState value return DString repr } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure diff --git a/backend/src/BuiltinExecution/Libs/Parser.fs b/backend/src/BuiltinExecution/Libs/Parser.fs index 87b3740cfc..c2a3f5beb7 100644 --- a/backend/src/BuiltinExecution/Libs/Parser.fs +++ b/backend/src/BuiltinExecution/Libs/Parser.fs @@ -7,6 +7,7 @@ open LibExecution.RuntimeTypes open LibExecution.Builtin.Shortcuts open LibTreeSitter +open System.Threading.Tasks module VT = LibExecution.ValueType module Dval = LibExecution.Dval @@ -100,7 +101,7 @@ let fns () : List = let tree = parser.Parse(Encoding.UTF8.GetBytes sourceCode, InputEncoding.Utf8, None) - tree.Root.Walk() |> mapNodeAtCursor |> Ply + tree.Root.Walk() |> mapNodeAtCursor |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure diff --git a/backend/src/BuiltinExecution/Libs/Reflection.fs b/backend/src/BuiltinExecution/Libs/Reflection.fs index 14b865cfac..095b689dd8 100644 --- a/backend/src/BuiltinExecution/Libs/Reflection.fs +++ b/backend/src/BuiltinExecution/Libs/Reflection.fs @@ -3,6 +3,7 @@ module BuiltinExecution.Libs.Reflection open Prelude open LibExecution.RuntimeTypes open LibExecution.Builtin.Shortcuts +open System.Threading.Tasks module VT = LibExecution.ValueType module Dval = LibExecution.Dval @@ -27,7 +28,7 @@ let fns () : List = fn = function | _, _, _, [ dv ] -> - dv |> LibExecution.RuntimeTypesToDarkTypes.Dval.toDT |> Ply + dv |> LibExecution.RuntimeTypesToDarkTypes.Dval.toDT |> Task.FromResult | _ -> incorrectArgs () sqlSpec = NotQueryable previewable = Pure diff --git a/backend/src/BuiltinExecution/Libs/Regex.fs b/backend/src/BuiltinExecution/Libs/Regex.fs index 808edcf460..09e1c8944a 100644 --- a/backend/src/BuiltinExecution/Libs/Regex.fs +++ b/backend/src/BuiltinExecution/Libs/Regex.fs @@ -5,6 +5,7 @@ open System.Text.RegularExpressions open Prelude open LibExecution.RuntimeTypes open LibExecution.Builtin.Shortcuts +open System.Threading.Tasks module VT = LibExecution.ValueType module Dval = LibExecution.Dval @@ -24,7 +25,7 @@ let fns () : List = | _, _, _, [ DString input; DString pattern ] -> try let isMatch = Regex.IsMatch(input, pattern) - Ply(DBool isMatch) + Task.FromResult(DBool isMatch) with :? System.ArgumentException as e -> Exception.raiseInternal "Invalid regex pattern" @@ -49,9 +50,9 @@ let fns () : List = try let m = Regex.Match(input, pattern) if m.Success then - Dval.optionSome KTString (DString m.Value) |> Ply + Dval.optionSome KTString (DString m.Value) |> Task.FromResult else - Dval.optionNone KTString |> Ply + Dval.optionNone KTString |> Task.FromResult with :? System.ArgumentException as e -> Exception.raiseInternal "Invalid regex pattern" @@ -80,7 +81,7 @@ let fns () : List = |> Seq.cast |> Seq.map (fun m -> DString m.Value) |> Seq.toList - Ply(Dval.list KTString results) + Task.FromResult(Dval.list KTString results) with :? System.ArgumentException as e -> Exception.raiseInternal "Invalid regex pattern" @@ -111,9 +112,9 @@ let fns () : List = input.Substring(0, m.Index) + replacement + input.Substring(m.Index + m.Length) - Ply(DString result) + Task.FromResult(DString result) else - Ply(DString input) + Task.FromResult(DString input) with | :? System.ArgumentException as e -> Exception.raiseInternal @@ -148,7 +149,7 @@ let fns () : List = RegexOptions.None, System.TimeSpan.FromMilliseconds(1000.0) ) - Ply(DString result) + Task.FromResult(DString result) with | :? System.ArgumentException as e -> Exception.raiseInternal @@ -176,7 +177,7 @@ let fns () : List = try let parts = Regex.Split(input, pattern) let results = parts |> Array.map DString |> Array.toList - Ply(Dval.list KTString results) + Task.FromResult(Dval.list KTString results) with :? System.ArgumentException as e -> Exception.raiseInternal "Invalid regex pattern" diff --git a/backend/src/BuiltinExecution/Libs/Stream.fs b/backend/src/BuiltinExecution/Libs/Stream.fs index 49033f9252..ee43b8a2df 100644 --- a/backend/src/BuiltinExecution/Libs/Stream.fs +++ b/backend/src/BuiltinExecution/Libs/Stream.fs @@ -13,7 +13,6 @@ module BuiltinExecution.Libs.Stream open System.Threading.Tasks -open FSharp.Control.Tasks open Prelude @@ -39,7 +38,7 @@ let varA = TVariable "a" let private resolveElemVT (state : ExecutionState) (t : TypeReference) - : Ply = + : Task = LibExecution.RuntimeTypes.TypeReference.toVT state.types Map.empty t @@ -49,8 +48,8 @@ let private resolveElemVT let private resolveElemKT (state : ExecutionState) (t : TypeReference) - : Ply = - uply { + : Task = + task { let! vt = resolveElemVT state t match vt with | ValueType.Known kt -> return kt @@ -68,10 +67,10 @@ let fns () : List = fn = (function | state, _, [ elemType ], [ DList(elemVT, items) ] -> - uply { + task { let remaining = ref items - let nextFn () : Ply> = - uply { + let nextFn () : Task> = + task { match remaining.Value with | head :: tail -> remaining.Value <- tail @@ -85,9 +84,10 @@ let fns () : List = let! inferredElem = match elemVT with | ValueType.Unknown -> resolveElemVT state elemType - | known -> Ply known + | known -> Task.FromResult known return Stream.newFromIO inferredElem nextFn None } + | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -117,11 +117,11 @@ let fns () : List = fn = (function | state, vm, [ _; outputType ], [ initialState; DApplicable app ] -> - uply { + task { let! elemType = resolveElemVT state outputType let currentState = ref initialState - let next () : Ply> = - uply { + let next () : Task> = + task { let! result = Exe.executeApplicable state @@ -141,6 +141,7 @@ let fns () : List = } return Stream.newFromIO elemType next None } + | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Impure @@ -156,11 +157,12 @@ let fns () : List = fn = (function | state, _, [ elemType ], [ s ] -> - uply { + task { let! nextResult = Stream.readNext s let! elemKT = resolveElemKT state elemType return Dval.option elemKT nextResult } + | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Impure @@ -175,7 +177,7 @@ let fns () : List = fn = (function | state, _, [ elemType ], [ s ] -> - uply { + task { let collected = ResizeArray() let mutable keepGoing = true while keepGoing do @@ -189,11 +191,12 @@ let fns () : List = // the declared type-arg for empty results. let! elemVT = if collected.Count > 0 then - Ply(Dval.toValueType collected[0]) + Task.FromResult(Dval.toValueType collected[0]) else resolveElemVT state elemType return DList(elemVT, List.ofSeq collected) } + | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Impure @@ -209,7 +212,7 @@ let fns () : List = fn = (function | state, _, _, [ s ] -> - uply { + task { // Drain via `readStreamChunk` so IO-backed byte streams // (HttpClient.stream) hand back a whole buffer per pull // instead of boxing one DUInt8 per byte. Falls back to @@ -225,6 +228,7 @@ let fns () : List = | None -> keepGoing <- false return Blob.newEphemeral state (collected.ToArray()) } + | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Impure @@ -253,7 +257,7 @@ let fns () : List = if not disposed.Value then disposed.Value <- true Stream.disposeImpl impl - DUnit |> Ply + DUnit |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Impure @@ -283,10 +287,10 @@ let fns () : List = fn = (function | state, vm, [ _; outputType ], [ DStream(src, _, _); DApplicable app ] -> - uply { + task { let! elemType = resolveElemVT state outputType - let apply (dv : Dval) : Ply = - uply { + let apply (dv : Dval) : Task = + task { let! result = Exe.executeApplicable state app (NEList.singleton dv) match result with | Ok v -> return v @@ -294,6 +298,7 @@ let fns () : List = } return Stream.wrapImpl (Mapped(src, apply, elemType)) } + | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Impure @@ -317,8 +322,8 @@ let fns () : List = fn = (function | state, vm, _, [ DStream(src, _, _); DApplicable app ] -> - let pred (dv : Dval) : Ply = - uply { + let pred (dv : Dval) : Task = + task { let! result = Exe.executeApplicable state app (NEList.singleton dv) match result with | Ok(DBool b) -> return b @@ -329,7 +334,7 @@ let fns () : List = [ "got", other ] | Error(rte, _cs) -> return raiseRTE vm.threadID rte } - Stream.wrapImpl (Filtered(src, pred)) |> Ply + Stream.wrapImpl (Filtered(src, pred)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Impure @@ -352,7 +357,7 @@ let fns () : List = // Clamp negative n to 0 — pullStreamImpl treats remaining<=0 // as done, so a negative here becomes an empty stream. let clamped = max 0L n - Stream.wrapImpl (Take(src, clamped, ref clamped)) |> Ply + Stream.wrapImpl (Take(src, clamped, ref clamped)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Impure @@ -379,7 +384,7 @@ let fns () : List = Exception.raiseInternal "streamConcat: expected List" [ "got", other ]) - Stream.wrapImpl (Concat(ref impls)) |> Ply + Stream.wrapImpl (Concat(ref impls)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Impure diff --git a/backend/src/BuiltinExecution/Libs/String.fs b/backend/src/BuiltinExecution/Libs/String.fs index ff86ea00a8..03a85659c8 100644 --- a/backend/src/BuiltinExecution/Libs/String.fs +++ b/backend/src/BuiltinExecution/Libs/String.fs @@ -7,6 +7,7 @@ open System.Text.RegularExpressions open Prelude open LibExecution.RuntimeTypes open LibExecution.Builtin.Shortcuts +open System.Threading.Tasks module VT = LibExecution.ValueType module Dval = LibExecution.Dval @@ -29,7 +30,7 @@ let fns () : List = |> Seq.map DChar |> Seq.toList |> Dval.list KTChar - |> Ply + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -51,7 +52,7 @@ let fns () : List = | _, _, _, [ DString s; DString search; DString replace ] -> if search = "" then if s = "" then - Ply(DString replace) + Task.FromResult(DString replace) else // .Net Replace doesn't allow empty string, but we do. String.toEgcSeq s @@ -60,9 +61,9 @@ let fns () : List = |> (fun l -> replace :: l @ [ replace ]) |> String.concat "" |> DString - |> Ply + |> Task.FromResult else - Ply(DString(s.Replace(search, replace))) + Task.FromResult(DString(s.Replace(search, replace))) | _ -> incorrectArgs ()) sqlSpec = SqlFunction "replace" previewable = Pure @@ -76,7 +77,7 @@ let fns () : List = description = "Returns the string, uppercased" fn = (function - | _, _, _, [ DString s ] -> Ply(DString(String.toUppercase s)) + | _, _, _, [ DString s ] -> Task.FromResult(DString(String.toUppercase s)) | _ -> incorrectArgs ()) sqlSpec = SqlFunction "upper" previewable = Pure @@ -90,7 +91,7 @@ let fns () : List = description = "Returns the string, lowercased" fn = (function - | _, _, _, [ DString s ] -> Ply(DString(String.toLowercase s)) + | _, _, _, [ DString s ] -> Task.FromResult(DString(String.toLowercase s)) | _ -> incorrectArgs ()) sqlSpec = SqlFunction "lower" previewable = Pure @@ -105,7 +106,7 @@ let fns () : List = fn = (function | _, _, _, [ DString s ] -> - s |> String.lengthInEgcs |> int64 |> Dval.int64 |> Ply + s |> String.lengthInEgcs |> int64 |> Dval.int64 |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented // CLEANUP: Sqlite has "LENGTH" but that counts characters; if we can get it to count EGCs, great previewable = Pure @@ -123,7 +124,7 @@ let fns () : List = (function // TODO add fuzzer to ensure all strings are normalized no matter what we do to them. | _, _, _, [ DString s1; DString s2 ] -> - (s1 + s2) |> String.normalize |> DString |> Ply + (s1 + s2) |> String.normalize |> DString |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -156,7 +157,7 @@ let fns () : List = |> String.trim |> replace toBeHyphenated "-" |> DString - |> Ply + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -171,7 +172,11 @@ let fns () : List = fn = (function | _, _, _, [ DString s ] -> - String.toEgcSeq s |> Seq.rev |> String.concat "" |> DString |> Ply + String.toEgcSeq s + |> Seq.rev + |> String.concat "" + |> DString + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = SqlFunction "reverse" previewable = Pure @@ -215,7 +220,7 @@ let fns () : List = (s |> String.toEgcSeq |> Seq.toList) (sep |> String.toEgcSeq |> Seq.toList) - parts |> List.map DString |> Dval.list KTString |> Ply + parts |> List.map DString |> Dval.list KTString |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -241,7 +246,7 @@ let fns () : List = |> String.concat sep |> String.normalize |> DString - |> Ply + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -270,7 +275,7 @@ let fns () : List = if last < 0 then getLengthInTextElements (s) + int last else int last if first >= last then - Ply(DString "") + Task.FromResult(DString "") else // Create a TextElementEnumerator to handle EGCs let textElemEnumerator = @@ -289,7 +294,7 @@ let fns () : List = if endIndex = 0 then endIndex <- s.Length let substringLength = endIndex - startIndex - s.Substring(startIndex, substringLength) |> DString |> Ply + s.Substring(startIndex, substringLength) |> DString |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -307,7 +312,7 @@ let fns () : List = {{\"\\n\"}}" fn = (function - | _, _, _, [ DString toTrim ] -> toTrim.Trim() |> DString |> Ply + | _, _, _, [ DString toTrim ] -> toTrim.Trim() |> DString |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = SqlFunction "trim" previewable = Pure @@ -324,7 +329,7 @@ let fns () : List = includes {{\" \"}}, {{\"\\t\"}} and {{\"\\n\"}}" fn = (function - | _, _, _, [ DString toTrim ] -> Ply(DString(toTrim.TrimStart())) + | _, _, _, [ DString toTrim ] -> Task.FromResult(DString(toTrim.TrimStart())) | _ -> incorrectArgs ()) sqlSpec = SqlFunction "ltrim" previewable = Pure @@ -341,7 +346,7 @@ let fns () : List = property, which includes {{\" \"}}, {{\"\\t\"}} and {{\"\\n\"}}." fn = (function - | _, _, _, [ DString toTrim ] -> Ply(DString(toTrim.TrimEnd())) + | _, _, _, [ DString toTrim ] -> Task.FromResult(DString(toTrim.TrimEnd())) | _ -> incorrectArgs ()) sqlSpec = SqlFunction "rtrim" previewable = Pure @@ -357,7 +362,7 @@ let fns () : List = (function | state, _, _, [ DString str ] -> let theBytes = System.Text.Encoding.UTF8.GetBytes str - Blob.newEphemeral state theBytes |> Ply + Blob.newEphemeral state theBytes |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -373,10 +378,11 @@ let fns () : List = fn = (function | state, _, _, [ DBlob ref ] -> - uply { + task { let! bytes = Blob.readBytes state ref return DString(System.Text.Encoding.UTF8.GetString bytes) } + | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -395,9 +401,9 @@ let fns () : List = try let bytes = Dval.dlistToByteArray bytes let str = UTF8Encoding(false, true).GetString bytes - Dval.optionSome KTString (DString str) |> Ply + Dval.optionSome KTString (DString str) |> Task.FromResult with _e -> - Dval.optionNone KTString |> Ply + Dval.optionNone KTString |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -413,7 +419,7 @@ let fns () : List = fn = (function | state, _, _, [ DBlob ref ] -> - uply { + task { let! bytes = Blob.readBytes state ref try let str = UTF8Encoding(false, true).GetString bytes @@ -421,6 +427,7 @@ let fns () : List = with _e -> return Dval.optionNone KTString } + | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -442,7 +449,7 @@ let fns () : List = (function | _, _, _, [ DString str; DString search ] -> let index = str.IndexOf(search) - Ply(DInt64 index) + Task.FromResult(DInt64 index) | _ -> incorrectArgs ()) sqlSpec = SqlCallback2(fun str search -> $"(INSTR({str}, {search}) - 1)") previewable = Pure @@ -464,7 +471,7 @@ let fns () : List = (function | _, _, _, [ DString str; DString search ] -> let index = str.LastIndexOf(search) - Ply(DInt64 index) + Task.FromResult(DInt64 index) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -481,10 +488,10 @@ let fns () : List = (function | _, _, _, [ DString str ] -> if str = "" then - Dval.optionNone KTChar |> Ply + Dval.optionNone KTChar |> Task.FromResult else let head = String.toEgcSeq str |> Seq.head - Dval.optionSome KTChar (DChar head) |> Ply + Dval.optionSome KTChar (DChar head) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented diff --git a/backend/src/BuiltinExecution/Libs/UInt128.fs b/backend/src/BuiltinExecution/Libs/UInt128.fs index d3ca4e4211..e9462bab2d 100644 --- a/backend/src/BuiltinExecution/Libs/UInt128.fs +++ b/backend/src/BuiltinExecution/Libs/UInt128.fs @@ -3,6 +3,7 @@ module BuiltinExecution.Libs.UInt128 open Prelude open LibExecution.RuntimeTypes open LibExecution.Builtin.Shortcuts +open System.Threading.Tasks module VT = LibExecution.ValueType module Dval = LibExecution.Dval @@ -46,7 +47,7 @@ let fns () : List = else let result = v % m let result = if result < System.UInt128.Zero then m + result else result - Ply(DUInt128(result)) + Task.FromResult(DUInt128(result)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -63,7 +64,7 @@ let fns () : List = | _, vm, _, [ DUInt128 a; DUInt128 b ] -> try let result = System.UInt128.op_CheckedAddition (a, b) - Ply(DUInt128(result)) + Task.FromResult(DUInt128(result)) with :? System.OverflowException -> RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID | _ -> incorrectArgs ()) @@ -82,7 +83,7 @@ let fns () : List = | _, vm, _, [ DUInt128 a; DUInt128 b ] -> try let result = System.UInt128.op_CheckedSubtraction (a, b) - Ply(DUInt128(result)) + Task.FromResult(DUInt128(result)) with :? System.OverflowException -> RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID | _ -> incorrectArgs ()) @@ -102,7 +103,7 @@ let fns () : List = | _, vm, _, [ DUInt128 a; DUInt128 b ] -> try let result = System.UInt128.op_CheckedMultiply (a, b) - Ply(DUInt128(result)) + Task.FromResult(DUInt128(result)) with :? System.OverflowException -> RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID | _ -> incorrectArgs ()) @@ -124,7 +125,7 @@ let fns () : List = | _, vm, _, [ DUInt128 a; DUInt128 b ] -> try let result = System.UInt128.op_Division (a, b) - Ply(DUInt128(result)) + Task.FromResult(DUInt128(result)) with | :? System.DivideByZeroException -> RTE.Ints.DivideByZeroError |> RTE.Int |> raiseRTE vm.threadID @@ -143,7 +144,7 @@ let fns () : List = description = "Returns {{true}} if is greater than " fn = (function - | _, _, _, [ DUInt128 a; DUInt128 b ] -> Ply(DBool(a > b)) + | _, _, _, [ DUInt128 a; DUInt128 b ] -> Task.FromResult(DBool(a > b)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -158,7 +159,7 @@ let fns () : List = "Returns {{true}} if is greater than or equal to " fn = (function - | _, _, _, [ DUInt128 a; DUInt128 b ] -> Ply(DBool(a >= b)) + | _, _, _, [ DUInt128 a; DUInt128 b ] -> Task.FromResult(DBool(a >= b)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -172,7 +173,7 @@ let fns () : List = description = "Returns {{true}} if is less than " fn = (function - | _, _, _, [ DUInt128 a; DUInt128 b ] -> Ply(DBool(a < b)) + | _, _, _, [ DUInt128 a; DUInt128 b ] -> Task.FromResult(DBool(a < b)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -187,7 +188,7 @@ let fns () : List = "Returns {{true}} if is less than or equal to " fn = (function - | _, _, _, [ DUInt128 a; DUInt128 b ] -> Ply(DBool(a <= b)) + | _, _, _, [ DUInt128 a; DUInt128 b ] -> Task.FromResult(DBool(a <= b)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -201,7 +202,7 @@ let fns () : List = description = "Converts an to a " fn = (function - | _, _, _, [ DUInt128 a ] -> Ply(DString(string a)) + | _, _, _, [ DUInt128 a ] -> Task.FromResult(DString(string a)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -215,7 +216,7 @@ let fns () : List = description = "Converts an to a " fn = (function - | _, _, _, [ DUInt128 a ] -> Ply(DFloat(float a)) + | _, _, _, [ DUInt128 a ] -> Task.FromResult(DFloat(float a)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -229,7 +230,7 @@ let fns () : List = description = "Get the square root of an " fn = (function - | _, _, _, [ DUInt128 a ] -> Ply(DFloat(sqrt (float a))) + | _, _, _, [ DUInt128 a ] -> Task.FromResult(DFloat(sqrt (float a))) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -259,12 +260,15 @@ let fns () : List = (function | _, _, _, [ DString s ] -> try - s |> System.UInt128.Parse |> DUInt128 |> resultOk |> Ply + s |> System.UInt128.Parse |> DUInt128 |> resultOk |> Task.FromResult with | :? System.FormatException -> - ParseError.BadFormat |> ParseError.toDT |> resultError |> Ply + ParseError.BadFormat |> ParseError.toDT |> resultError |> Task.FromResult | :? System.OverflowException -> - ParseError.OutOfRange |> ParseError.toDT |> resultError |> Ply + ParseError.OutOfRange + |> ParseError.toDT + |> resultError + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -278,7 +282,8 @@ let fns () : List = description = "Converts a UInt8 to a 128-bit unsigned integer." fn = (function - | _, _, _, [ DUInt8 a ] -> DUInt128(System.UInt128.op_Implicit a) |> Ply + | _, _, _, [ DUInt8 a ] -> + DUInt128(System.UInt128.op_Implicit a) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -292,7 +297,8 @@ let fns () : List = description = "Converts a UInt16 to a 128-bit unsigned integer." fn = (function - | _, _, _, [ DUInt16 a ] -> DUInt128(System.UInt128.op_Implicit a) |> Ply + | _, _, _, [ DUInt16 a ] -> + DUInt128(System.UInt128.op_Implicit a) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -306,7 +312,8 @@ let fns () : List = description = "Converts a UInt32 to a 128-bit unsigned integer." fn = (function - | _, _, _, [ DUInt32 a ] -> DUInt128(System.UInt128.op_Implicit a) |> Ply + | _, _, _, [ DUInt32 a ] -> + DUInt128(System.UInt128.op_Implicit a) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -320,7 +327,8 @@ let fns () : List = description = "Converts a UInt64 to a 128-bit unsigned integer." fn = (function - | _, _, _, [ DUInt64 a ] -> DUInt128(System.UInt128.op_Implicit a) |> Ply + | _, _, _, [ DUInt64 a ] -> + DUInt128(System.UInt128.op_Implicit a) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -334,7 +342,7 @@ let fns () : List = description = "Bitwise AND on two values" fn = (function - | _, _, _, [ DUInt128 a; DUInt128 b ] -> Ply(DUInt128(a &&& b)) + | _, _, _, [ DUInt128 a; DUInt128 b ] -> Task.FromResult(DUInt128(a &&& b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -348,7 +356,7 @@ let fns () : List = description = "Bitwise OR on two values" fn = (function - | _, _, _, [ DUInt128 a; DUInt128 b ] -> Ply(DUInt128(a ||| b)) + | _, _, _, [ DUInt128 a; DUInt128 b ] -> Task.FromResult(DUInt128(a ||| b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -362,7 +370,7 @@ let fns () : List = description = "Bitwise XOR on two values" fn = (function - | _, _, _, [ DUInt128 a; DUInt128 b ] -> Ply(DUInt128(a ^^^ b)) + | _, _, _, [ DUInt128 a; DUInt128 b ] -> Task.FromResult(DUInt128(a ^^^ b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -377,7 +385,7 @@ let fns () : List = fn = (function | _, _, _, [ DUInt128 a ] -> - Ply(DUInt128(System.UInt128.op_OnesComplement (a))) + Task.FromResult(DUInt128(System.UInt128.op_OnesComplement (a))) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -391,7 +399,8 @@ let fns () : List = description = "Bitwise left shift of a value" fn = (function - | _, _, _, [ DUInt128 a; DUInt128 b ] -> Ply(DUInt128(a <<< int b)) + | _, _, _, [ DUInt128 a; DUInt128 b ] -> + Task.FromResult(DUInt128(a <<< int b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -405,7 +414,8 @@ let fns () : List = description = "Bitwise right shift of a value" fn = (function - | _, _, _, [ DUInt128 a; DUInt128 b ] -> Ply(DUInt128(a >>> int b)) + | _, _, _, [ DUInt128 a; DUInt128 b ] -> + Task.FromResult(DUInt128(a >>> int b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure diff --git a/backend/src/BuiltinExecution/Libs/UInt16.fs b/backend/src/BuiltinExecution/Libs/UInt16.fs index cff40828a2..eada899aec 100644 --- a/backend/src/BuiltinExecution/Libs/UInt16.fs +++ b/backend/src/BuiltinExecution/Libs/UInt16.fs @@ -3,6 +3,7 @@ module BuiltinExecution.Libs.UInt16 open Prelude open LibExecution.RuntimeTypes open LibExecution.Builtin.Shortcuts +open System.Threading.Tasks module VT = LibExecution.ValueType module Dval = LibExecution.Dval @@ -43,11 +44,14 @@ let fns () : List = (function | _, vm, _, [ DUInt16 v; DUInt16 m ] -> if m = 0us then - RTE.Ints.ZeroModulus |> RTE.Int |> raiseRTE vm.threadID |> Ply + RTE.Ints.ZeroModulus + |> RTE.Int + |> raiseRTE vm.threadID + |> Task.FromResult else let result = v % m let result = if result < 0us then m + result else result - Ply(DUInt16(result)) + Task.FromResult(DUInt16(result)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -64,9 +68,9 @@ let fns () : List = | _, vm, _, [ DUInt16 a; DUInt16 b ] -> try let result = Checked.(+) a b - Ply(DUInt16(result)) + Task.FromResult(DUInt16(result)) with :? System.OverflowException -> - RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID |> Ply + RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented @@ -84,9 +88,9 @@ let fns () : List = | _, vm, _, [ DUInt16 a; DUInt16 b ] -> try let result = Checked.(-) a b - Ply(DUInt16(result)) + Task.FromResult(DUInt16(result)) with :? System.OverflowException -> - RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID |> Ply + RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented @@ -104,9 +108,9 @@ let fns () : List = | _, vm, _, [ DUInt16 a; DUInt16 b ] -> try let result = Checked.(*) a b - Ply(DUInt16(result)) + Task.FromResult(DUInt16(result)) with :? System.OverflowException -> - RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID |> Ply + RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented @@ -126,9 +130,12 @@ let fns () : List = (function | _, vm, _, [ DUInt16 number; DUInt16 exp ] -> (try - (bigint number) ** (int exp) |> uint16 |> DUInt16 |> Ply + (bigint number) ** (int exp) |> uint16 |> DUInt16 |> Task.FromResult with :? System.OverflowException -> - RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID |> Ply) + RTE.Ints.OutOfRange + |> RTE.Int + |> raiseRTE vm.threadID + |> Task.FromResult) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -144,15 +151,21 @@ let fns () : List = (function | _, vm, _, [ DUInt16 a; DUInt16 b ] -> if b = 0us then - RTE.Ints.DivideByZeroError |> RTE.Int |> raiseRTE vm.threadID |> Ply + RTE.Ints.DivideByZeroError + |> RTE.Int + |> raiseRTE vm.threadID + |> Task.FromResult else let result = a / b if result < System.UInt16.MinValue || result > System.UInt16.MaxValue then - RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID |> Ply + RTE.Ints.OutOfRange + |> RTE.Int + |> raiseRTE vm.threadID + |> Task.FromResult else - Ply(DUInt16(uint16 result)) + Task.FromResult(DUInt16(uint16 result)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented @@ -167,7 +180,7 @@ let fns () : List = description = "Returns {{true}} if is greater than " fn = (function - | _, _, _, [ DUInt16 a; DUInt16 b ] -> Ply(DBool(a > b)) + | _, _, _, [ DUInt16 a; DUInt16 b ] -> Task.FromResult(DBool(a > b)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -182,7 +195,7 @@ let fns () : List = "Returns {{true}} if is greater than or equal to " fn = (function - | _, _, _, [ DUInt16 a; DUInt16 b ] -> Ply(DBool(a >= b)) + | _, _, _, [ DUInt16 a; DUInt16 b ] -> Task.FromResult(DBool(a >= b)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -196,7 +209,7 @@ let fns () : List = description = "Returns {{true}} if is less than " fn = (function - | _, _, _, [ DUInt16 a; DUInt16 b ] -> Ply(DBool(a < b)) + | _, _, _, [ DUInt16 a; DUInt16 b ] -> Task.FromResult(DBool(a < b)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -211,7 +224,7 @@ let fns () : List = "Returns {{true}} if is less than or equal to " fn = (function - | _, _, _, [ DUInt16 a; DUInt16 b ] -> Ply(DBool(a <= b)) + | _, _, _, [ DUInt16 a; DUInt16 b ] -> Task.FromResult(DBool(a <= b)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -225,7 +238,7 @@ let fns () : List = description = "Stringify " fn = (function - | _, _, _, [ DUInt16 a ] -> Ply(DString(string a)) + | _, _, _, [ DUInt16 a ] -> Task.FromResult(DString(string a)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -239,7 +252,7 @@ let fns () : List = description = "Converts an to a " fn = (function - | _, _, _, [ DUInt16 a ] -> Ply(DFloat(float a)) + | _, _, _, [ DUInt16 a ] -> Task.FromResult(DFloat(float a)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -266,7 +279,7 @@ let fns () : List = let resultInt = randomSeeded().Next(uint16Range) let uint16Result = lowerBound + (uint16 resultInt) - Ply(DUInt16(uint16Result)) + Task.FromResult(DUInt16(uint16Result)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented @@ -281,7 +294,7 @@ let fns () : List = description = "Get the square root of an " fn = (function - | _, _, _, [ DUInt16 a ] -> Ply(DFloat(sqrt (float a))) + | _, _, _, [ DUInt16 a ] -> Task.FromResult(DFloat(sqrt (float a))) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -304,13 +317,16 @@ let fns () : List = (function | _, _, _, [ DString s ] -> try - s |> System.Convert.ToUInt16 |> DUInt16 |> resultOk |> Ply + s |> System.Convert.ToUInt16 |> DUInt16 |> resultOk |> Task.FromResult with | :? System.OverflowException -> - ParseError.OutOfRange |> ParseError.toDT |> resultError |> Ply + ParseError.OutOfRange + |> ParseError.toDT + |> resultError + |> Task.FromResult | :? System.FormatException -> - ParseError.BadFormat |> ParseError.toDT |> resultError |> Ply + ParseError.BadFormat |> ParseError.toDT |> resultError |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented @@ -328,9 +344,9 @@ let fns () : List = (function | _, _, _, [ DInt8 a ] -> if (a < 0y) then - Dval.optionNone KTUInt16 |> Ply + Dval.optionNone KTUInt16 |> Task.FromResult else - Dval.optionSome KTUInt16 (DUInt16(uint16 a)) |> Ply + Dval.optionSome KTUInt16 (DUInt16(uint16 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -344,7 +360,7 @@ let fns () : List = description = "Converts a UInt8 to a 16-bit unsigned integer." fn = (function - | _, _, _, [ DUInt8 a ] -> DUInt16(uint16 a) |> Ply + | _, _, _, [ DUInt8 a ] -> DUInt16(uint16 a) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -361,9 +377,9 @@ let fns () : List = (function | _, _, _, [ DInt16 a ] -> if (a < 0s) then - Dval.optionNone KTUInt16 |> Ply + Dval.optionNone KTUInt16 |> Task.FromResult else - Dval.optionSome KTUInt16 (DUInt16(uint16 a)) |> Ply + Dval.optionSome KTUInt16 (DUInt16(uint16 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -382,9 +398,9 @@ let fns () : List = if (a < int32 System.UInt16.MinValue) || (a > int32 System.UInt16.MaxValue) then - Dval.optionNone KTUInt16 |> Ply + Dval.optionNone KTUInt16 |> Task.FromResult else - Dval.optionSome KTUInt16 (DUInt16(uint16 a)) |> Ply + Dval.optionSome KTUInt16 (DUInt16(uint16 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -401,9 +417,9 @@ let fns () : List = (function | _, _, _, [ DUInt32 a ] -> if (a > uint32 System.UInt16.MaxValue) then - Dval.optionNone KTUInt16 |> Ply + Dval.optionNone KTUInt16 |> Task.FromResult else - Dval.optionSome KTUInt16 (DUInt16(uint16 a)) |> Ply + Dval.optionSome KTUInt16 (DUInt16(uint16 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -422,9 +438,9 @@ let fns () : List = if (a < int64 System.UInt16.MinValue) || (a > int64 System.UInt16.MaxValue) then - Dval.optionNone KTUInt16 |> Ply + Dval.optionNone KTUInt16 |> Task.FromResult else - Dval.optionSome KTUInt16 (DUInt16(uint16 a)) |> Ply + Dval.optionSome KTUInt16 (DUInt16(uint16 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -441,9 +457,9 @@ let fns () : List = (function | _, _, _, [ DUInt64 a ] -> if (a > uint64 System.UInt16.MaxValue) then - Dval.optionNone KTUInt16 |> Ply + Dval.optionNone KTUInt16 |> Task.FromResult else - Dval.optionSome KTUInt16 (DUInt16(uint16 a)) |> Ply + Dval.optionSome KTUInt16 (DUInt16(uint16 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -463,9 +479,9 @@ let fns () : List = (a < System.Int128.op_Implicit System.UInt16.MinValue) || (a > System.Int128.op_Implicit System.UInt16.MaxValue) then - Dval.optionNone KTUInt16 |> Ply + Dval.optionNone KTUInt16 |> Task.FromResult else - Dval.optionSome KTUInt16 (DUInt16(uint16 a)) |> Ply + Dval.optionSome KTUInt16 (DUInt16(uint16 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -482,9 +498,9 @@ let fns () : List = (function | _, _, _, [ DUInt128 a ] -> if (a > System.UInt128.op_Implicit System.UInt16.MaxValue) then - Dval.optionNone KTUInt16 |> Ply + Dval.optionNone KTUInt16 |> Task.FromResult else - Dval.optionSome KTUInt16 (DUInt16(uint16 a)) |> Ply + Dval.optionSome KTUInt16 (DUInt16(uint16 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -498,7 +514,7 @@ let fns () : List = description = "Bitwise AND on two values" fn = (function - | _, _, _, [ DUInt16 a; DUInt16 b ] -> Ply(DUInt16(a &&& b)) + | _, _, _, [ DUInt16 a; DUInt16 b ] -> Task.FromResult(DUInt16(a &&& b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -512,7 +528,7 @@ let fns () : List = description = "Bitwise OR on two values" fn = (function - | _, _, _, [ DUInt16 a; DUInt16 b ] -> Ply(DUInt16(a ||| b)) + | _, _, _, [ DUInt16 a; DUInt16 b ] -> Task.FromResult(DUInt16(a ||| b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -526,7 +542,7 @@ let fns () : List = description = "Bitwise XOR on two values" fn = (function - | _, _, _, [ DUInt16 a; DUInt16 b ] -> Ply(DUInt16(a ^^^ b)) + | _, _, _, [ DUInt16 a; DUInt16 b ] -> Task.FromResult(DUInt16(a ^^^ b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -540,7 +556,7 @@ let fns () : List = description = "Bitwise NOT on a value" fn = (function - | _, _, _, [ DUInt16 a ] -> Ply(DUInt16(~~~a)) + | _, _, _, [ DUInt16 a ] -> Task.FromResult(DUInt16(~~~a)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -554,7 +570,7 @@ let fns () : List = description = "Bitwise left shift of a value" fn = (function - | _, _, _, [ DUInt16 a; DUInt16 b ] -> Ply(DUInt16(a <<< int b)) + | _, _, _, [ DUInt16 a; DUInt16 b ] -> Task.FromResult(DUInt16(a <<< int b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -568,7 +584,7 @@ let fns () : List = description = "Bitwise right shift of a value" fn = (function - | _, _, _, [ DUInt16 a; DUInt16 b ] -> Ply(DUInt16(a >>> int b)) + | _, _, _, [ DUInt16 a; DUInt16 b ] -> Task.FromResult(DUInt16(a >>> int b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure diff --git a/backend/src/BuiltinExecution/Libs/UInt32.fs b/backend/src/BuiltinExecution/Libs/UInt32.fs index 3b87c76286..5d448aa62c 100644 --- a/backend/src/BuiltinExecution/Libs/UInt32.fs +++ b/backend/src/BuiltinExecution/Libs/UInt32.fs @@ -3,6 +3,7 @@ module BuiltinExecution.Libs.UInt32 open Prelude open LibExecution.RuntimeTypes open LibExecution.Builtin.Shortcuts +open System.Threading.Tasks module VT = LibExecution.ValueType module Dval = LibExecution.Dval @@ -47,7 +48,7 @@ let fns () : List = else let result = v % m let result = if result < 0ul then m + result else result - Ply(DUInt32(result)) + Task.FromResult(DUInt32(result)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -64,7 +65,7 @@ let fns () : List = | _, vm, _, [ DUInt32 a; DUInt32 b ] -> try let result = Checked.(+) a b - Ply(DUInt32(result)) + Task.FromResult(DUInt32(result)) with :? System.OverflowException -> RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID | _ -> incorrectArgs ()) @@ -83,7 +84,7 @@ let fns () : List = | _, vm, _, [ DUInt32 a; DUInt32 b ] -> try let result = Checked.(-) a b - Ply(DUInt32(result)) + Task.FromResult(DUInt32(result)) with :? System.OverflowException -> RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID | _ -> incorrectArgs ()) @@ -102,7 +103,7 @@ let fns () : List = | _, vm, _, [ DUInt32 a; DUInt32 b ] -> try let result = Checked.(*) a b - Ply(DUInt32(result)) + Task.FromResult(DUInt32(result)) with :? System.OverflowException -> RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID | _ -> incorrectArgs ()) @@ -123,7 +124,7 @@ let fns () : List = (function | _, vm, _, [ DUInt32 number; DUInt32 exp ] -> (try - (bigint number) ** (int exp) |> uint32 |> DUInt32 |> Ply + (bigint number) ** (int exp) |> uint32 |> DUInt32 |> Task.FromResult with :? System.OverflowException -> RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID) | _ -> incorrectArgs ()) @@ -149,7 +150,7 @@ let fns () : List = then RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID else - Ply(DUInt32(uint32 result)) + Task.FromResult(DUInt32(uint32 result)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented @@ -164,7 +165,7 @@ let fns () : List = description = "Returns {{true}} if is greater than " fn = (function - | _, _, _, [ DUInt32 a; DUInt32 b ] -> Ply(DBool(a > b)) + | _, _, _, [ DUInt32 a; DUInt32 b ] -> Task.FromResult(DBool(a > b)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -179,7 +180,7 @@ let fns () : List = "Returns {{true}} if is greater than or equal to " fn = (function - | _, _, _, [ DUInt32 a; DUInt32 b ] -> Ply(DBool(a >= b)) + | _, _, _, [ DUInt32 a; DUInt32 b ] -> Task.FromResult(DBool(a >= b)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -193,7 +194,7 @@ let fns () : List = description = "Returns {{true}} if is less than " fn = (function - | _, _, _, [ DUInt32 a; DUInt32 b ] -> Ply(DBool(a < b)) + | _, _, _, [ DUInt32 a; DUInt32 b ] -> Task.FromResult(DBool(a < b)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -208,7 +209,7 @@ let fns () : List = "Returns {{true}} if is less than or equal to " fn = (function - | _, _, _, [ DUInt32 a; DUInt32 b ] -> Ply(DBool(a <= b)) + | _, _, _, [ DUInt32 a; DUInt32 b ] -> Task.FromResult(DBool(a <= b)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -222,7 +223,7 @@ let fns () : List = description = "Stringify " fn = (function - | _, _, _, [ DUInt32 a ] -> Ply(DString(string a)) + | _, _, _, [ DUInt32 a ] -> Task.FromResult(DString(string a)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -236,7 +237,7 @@ let fns () : List = description = "Converts an to a " fn = (function - | _, _, _, [ DUInt32 a ] -> Ply(DFloat(float a)) + | _, _, _, [ DUInt32 a ] -> Task.FromResult(DFloat(float a)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -263,7 +264,7 @@ let fns () : List = let resultInt = randomSeeded().Next(uint32Range) let uint32Result = lowerBound + (uint32 resultInt) - Ply(DUInt32(uint32Result)) + Task.FromResult(DUInt32(uint32Result)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented @@ -278,7 +279,7 @@ let fns () : List = description = "Get the square root of an " fn = (function - | _, _, _, [ DUInt32 a ] -> Ply(DFloat(sqrt (float a))) + | _, _, _, [ DUInt32 a ] -> Task.FromResult(DFloat(sqrt (float a))) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -301,13 +302,16 @@ let fns () : List = (function | _, _, _, [ DString s ] -> try - s |> System.Convert.ToUInt32 |> DUInt32 |> resultOk |> Ply + s |> System.Convert.ToUInt32 |> DUInt32 |> resultOk |> Task.FromResult with | :? System.OverflowException -> - ParseError.OutOfRange |> ParseError.toDT |> resultError |> Ply + ParseError.OutOfRange + |> ParseError.toDT + |> resultError + |> Task.FromResult | :? System.FormatException -> - ParseError.BadFormat |> ParseError.toDT |> resultError |> Ply + ParseError.BadFormat |> ParseError.toDT |> resultError |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented @@ -326,9 +330,9 @@ let fns () : List = (function | _, _, _, [ DInt8 a ] -> if (a < 0y) then - Dval.optionNone KTUInt32 |> Ply + Dval.optionNone KTUInt32 |> Task.FromResult else - Dval.optionSome KTUInt32 (DUInt32(uint32 a)) |> Ply + Dval.optionSome KTUInt32 (DUInt32(uint32 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -342,7 +346,7 @@ let fns () : List = description = "Converts a UInt8 to a 32-bit unsigned integer." fn = (function - | _, _, _, [ DUInt8 a ] -> DUInt32(uint32 a) |> Ply + | _, _, _, [ DUInt8 a ] -> DUInt32(uint32 a) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -360,9 +364,9 @@ let fns () : List = (function | _, _, _, [ DInt16 a ] -> if (a < 0s) then - Dval.optionNone KTUInt32 |> Ply + Dval.optionNone KTUInt32 |> Task.FromResult else - Dval.optionSome KTUInt32 (DUInt32(uint32 a)) |> Ply + Dval.optionSome KTUInt32 (DUInt32(uint32 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -376,7 +380,7 @@ let fns () : List = description = "Converts a UInt16 to a 32-bit unsigned integer." fn = (function - | _, _, _, [ DUInt16 a ] -> DUInt32(uint32 a) |> Ply + | _, _, _, [ DUInt16 a ] -> DUInt32(uint32 a) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -394,9 +398,9 @@ let fns () : List = (function | _, _, _, [ DInt32 a ] -> if (a < 0l) then - Dval.optionNone KTUInt32 |> Ply + Dval.optionNone KTUInt32 |> Task.FromResult else - Dval.optionSome KTUInt32 (DUInt32(uint32 a)) |> Ply + Dval.optionSome KTUInt32 (DUInt32(uint32 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -416,9 +420,9 @@ let fns () : List = if (a < int64 System.UInt32.MinValue) || (a > int64 System.UInt32.MaxValue) then - Dval.optionNone KTUInt32 |> Ply + Dval.optionNone KTUInt32 |> Task.FromResult else - Dval.optionSome KTUInt32 (DUInt32(uint32 a)) |> Ply + Dval.optionSome KTUInt32 (DUInt32(uint32 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -436,9 +440,9 @@ let fns () : List = (function | _, _, _, [ DUInt64 a ] -> if (a > uint64 System.UInt32.MaxValue) then - Dval.optionNone KTUInt32 |> Ply + Dval.optionNone KTUInt32 |> Task.FromResult else - Dval.optionSome KTUInt32 (DUInt32(uint32 a)) |> Ply + Dval.optionSome KTUInt32 (DUInt32(uint32 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -458,9 +462,9 @@ let fns () : List = (a < System.Int128.op_Implicit System.UInt32.MinValue) || (a > System.Int128.op_Implicit System.UInt32.MaxValue) then - Dval.optionNone KTUInt32 |> Ply + Dval.optionNone KTUInt32 |> Task.FromResult else - Dval.optionSome KTUInt32 (DUInt32(uint32 a)) |> Ply + Dval.optionSome KTUInt32 (DUInt32(uint32 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -478,9 +482,9 @@ let fns () : List = (function | _, _, _, [ DUInt128 a ] -> if (a > System.UInt128.op_Implicit System.UInt32.MaxValue) then - Dval.optionNone KTUInt32 |> Ply + Dval.optionNone KTUInt32 |> Task.FromResult else - Dval.optionSome KTUInt32 (DUInt32(uint32 a)) |> Ply + Dval.optionSome KTUInt32 (DUInt32(uint32 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -494,7 +498,7 @@ let fns () : List = description = "Bitwise AND on two values" fn = (function - | _, _, _, [ DUInt32 a; DUInt32 b ] -> Ply(DUInt32(a &&& b)) + | _, _, _, [ DUInt32 a; DUInt32 b ] -> Task.FromResult(DUInt32(a &&& b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -508,7 +512,7 @@ let fns () : List = description = "Bitwise OR on two values" fn = (function - | _, _, _, [ DUInt32 a; DUInt32 b ] -> Ply(DUInt32(a ||| b)) + | _, _, _, [ DUInt32 a; DUInt32 b ] -> Task.FromResult(DUInt32(a ||| b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -522,7 +526,7 @@ let fns () : List = description = "Bitwise XOR on two values" fn = (function - | _, _, _, [ DUInt32 a; DUInt32 b ] -> Ply(DUInt32(a ^^^ b)) + | _, _, _, [ DUInt32 a; DUInt32 b ] -> Task.FromResult(DUInt32(a ^^^ b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -536,7 +540,7 @@ let fns () : List = description = "Bitwise NOT on a value" fn = (function - | _, _, _, [ DUInt32 a ] -> Ply(DUInt32(~~~a)) + | _, _, _, [ DUInt32 a ] -> Task.FromResult(DUInt32(~~~a)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -550,7 +554,7 @@ let fns () : List = description = "Bitwise left shift of a value" fn = (function - | _, _, _, [ DUInt32 a; DUInt32 b ] -> Ply(DUInt32(a <<< int b)) + | _, _, _, [ DUInt32 a; DUInt32 b ] -> Task.FromResult(DUInt32(a <<< int b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -564,7 +568,7 @@ let fns () : List = description = "Bitwise right shift of a value" fn = (function - | _, _, _, [ DUInt32 a; DUInt32 b ] -> Ply(DUInt32(a >>> int b)) + | _, _, _, [ DUInt32 a; DUInt32 b ] -> Task.FromResult(DUInt32(a >>> int b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure diff --git a/backend/src/BuiltinExecution/Libs/UInt64.fs b/backend/src/BuiltinExecution/Libs/UInt64.fs index cf9916c7ab..15fc48a05c 100644 --- a/backend/src/BuiltinExecution/Libs/UInt64.fs +++ b/backend/src/BuiltinExecution/Libs/UInt64.fs @@ -3,6 +3,7 @@ module BuiltinExecution.Libs.UInt64 open Prelude open LibExecution.RuntimeTypes open LibExecution.Builtin.Shortcuts +open System.Threading.Tasks module VT = LibExecution.ValueType module Dval = LibExecution.Dval @@ -46,7 +47,7 @@ let fns () : List = else let result = v % m let result = if result < 0UL then m + result else result - Ply(DUInt64(result)) + Task.FromResult(DUInt64(result)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -62,7 +63,7 @@ let fns () : List = (function | _, vm, _, [ DUInt64 a; DUInt64 b ] -> try - DUInt64(Checked.(+) a b) |> Ply + DUInt64(Checked.(+) a b) |> Task.FromResult with :? System.OverflowException -> RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID | _ -> incorrectArgs ()) @@ -80,7 +81,7 @@ let fns () : List = (function | _, vm, _, [ DUInt64 a; DUInt64 b ] -> try - DUInt64(Checked.(-) a b) |> Ply + DUInt64(Checked.(-) a b) |> Task.FromResult with :? System.OverflowException -> RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID | _ -> incorrectArgs ()) @@ -98,7 +99,7 @@ let fns () : List = (function | _, vm, _, [ DUInt64 a; DUInt64 b ] -> try - DUInt64(Checked.(*) a b) |> Ply + DUInt64(Checked.(*) a b) |> Task.FromResult with :? System.OverflowException -> RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID | _ -> incorrectArgs ()) @@ -119,7 +120,7 @@ let fns () : List = (function | _, vm, _, [ DUInt64 number; DUInt64 exp ] -> (try - (bigint number) ** (int exp) |> uint64 |> DUInt64 |> Ply + (bigint number) ** (int exp) |> uint64 |> DUInt64 |> Task.FromResult with :? System.OverflowException -> RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID) | _ -> incorrectArgs ()) @@ -145,7 +146,7 @@ let fns () : List = then RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID else - Ply(DUInt64(result)) + Task.FromResult(DUInt64(result)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -159,7 +160,7 @@ let fns () : List = description = "Returns {{true}} if is greater than " fn = (function - | _, _, _, [ DUInt64 a; DUInt64 b ] -> Ply(DBool(a > b)) + | _, _, _, [ DUInt64 a; DUInt64 b ] -> Task.FromResult(DBool(a > b)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -174,7 +175,7 @@ let fns () : List = "Returns {{true}} if is greater than or equal to " fn = (function - | _, _, _, [ DUInt64 a; DUInt64 b ] -> Ply(DBool(a >= b)) + | _, _, _, [ DUInt64 a; DUInt64 b ] -> Task.FromResult(DBool(a >= b)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -188,7 +189,7 @@ let fns () : List = description = "Returns {{true}} if is less than " fn = (function - | _, _, _, [ DUInt64 a; DUInt64 b ] -> Ply(DBool(a < b)) + | _, _, _, [ DUInt64 a; DUInt64 b ] -> Task.FromResult(DBool(a < b)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -203,7 +204,7 @@ let fns () : List = "Returns {{true}} if is less than or equal to " fn = (function - | _, _, _, [ DUInt64 a; DUInt64 b ] -> Ply(DBool(a <= b)) + | _, _, _, [ DUInt64 a; DUInt64 b ] -> Task.FromResult(DBool(a <= b)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -233,7 +234,7 @@ let fns () : List = let uint64Result = lowerBound + (uint64 resultInt) - Ply(DUInt64(uint64Result)) + Task.FromResult(DUInt64(uint64Result)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable @@ -248,7 +249,7 @@ let fns () : List = description = "Get the square root of an " fn = (function - | _, _, _, [ DUInt64 a ] -> Ply(DFloat(sqrt (float a))) + | _, _, _, [ DUInt64 a ] -> Task.FromResult(DFloat(sqrt (float a))) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -262,7 +263,7 @@ let fns () : List = description = "Converts an to a " fn = (function - | _, _, _, [ DUInt64 a ] -> Ply(DFloat(float a)) + | _, _, _, [ DUInt64 a ] -> Task.FromResult(DFloat(float a)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -292,12 +293,15 @@ let fns () : List = (function | _, _, _, [ DString s ] -> try - s |> System.Convert.ToUInt64 |> DUInt64 |> resultOk |> Ply + s |> System.Convert.ToUInt64 |> DUInt64 |> resultOk |> Task.FromResult with | :? System.FormatException -> - ParseError.BadFormat |> ParseError.toDT |> resultError |> Ply + ParseError.BadFormat |> ParseError.toDT |> resultError |> Task.FromResult | :? System.OverflowException -> - ParseError.OutOfRange |> ParseError.toDT |> resultError |> Ply + ParseError.OutOfRange + |> ParseError.toDT + |> resultError + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -311,7 +315,7 @@ let fns () : List = description = "Stringify " fn = (function - | _, _, _, [ DUInt64 int ] -> Ply(DString(string int)) + | _, _, _, [ DUInt64 int ] -> Task.FromResult(DString(string int)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -328,9 +332,9 @@ let fns () : List = (function | _, _, _, [ DInt8 a ] -> if (a < 0y) then - Dval.optionNone KTUInt64 |> Ply + Dval.optionNone KTUInt64 |> Task.FromResult else - Dval.optionSome KTUInt64 (DUInt64(uint64 a)) |> Ply + Dval.optionSome KTUInt64 (DUInt64(uint64 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -344,7 +348,7 @@ let fns () : List = description = "Converts a UInt8 to a 64-bit usigned integer." fn = (function - | _, _, _, [ DUInt8 a ] -> DUInt64(uint64 a) |> Ply + | _, _, _, [ DUInt8 a ] -> DUInt64(uint64 a) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -361,9 +365,9 @@ let fns () : List = (function | _, _, _, [ DInt16 a ] -> if (a < 0s) then - Dval.optionNone KTUInt64 |> Ply + Dval.optionNone KTUInt64 |> Task.FromResult else - Dval.optionSome KTUInt64 (DUInt64(uint64 a)) |> Ply + Dval.optionSome KTUInt64 (DUInt64(uint64 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -377,7 +381,7 @@ let fns () : List = description = "Converts a UInt16 to a 64-bit usigned integer." fn = (function - | _, _, _, [ DUInt16 a ] -> DUInt64(uint64 a) |> Ply + | _, _, _, [ DUInt16 a ] -> DUInt64(uint64 a) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -394,9 +398,9 @@ let fns () : List = (function | _, _, _, [ DInt32 a ] -> if (a < 0l) then - Dval.optionNone KTUInt64 |> Ply + Dval.optionNone KTUInt64 |> Task.FromResult else - Dval.optionSome KTUInt64 (DUInt64(uint64 a)) |> Ply + Dval.optionSome KTUInt64 (DUInt64(uint64 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -410,7 +414,7 @@ let fns () : List = description = "Converts a UInt32 to a 64-bit usigned integer." fn = (function - | _, _, _, [ DUInt32 a ] -> DUInt64(uint64 a) |> Ply + | _, _, _, [ DUInt32 a ] -> DUInt64(uint64 a) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -427,9 +431,9 @@ let fns () : List = (function | _, _, _, [ DInt64 a ] -> if (a < 0L) then - Dval.optionNone KTUInt64 |> Ply + Dval.optionNone KTUInt64 |> Task.FromResult else - Dval.optionSome KTUInt64 (DUInt64(uint64 a)) |> Ply + Dval.optionSome KTUInt64 (DUInt64(uint64 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -449,9 +453,9 @@ let fns () : List = (a < System.Int128.op_Implicit System.UInt64.MinValue) || (a > System.Int128.op_Implicit System.UInt64.MaxValue) then - Dval.optionNone KTUInt64 |> Ply + Dval.optionNone KTUInt64 |> Task.FromResult else - Dval.optionSome KTUInt64 (DUInt64(uint64 a)) |> Ply + Dval.optionSome KTUInt64 (DUInt64(uint64 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -468,9 +472,9 @@ let fns () : List = (function | _, _, _, [ DUInt128 a ] -> if (a > System.UInt128.op_Implicit System.UInt64.MaxValue) then - Dval.optionNone KTUInt64 |> Ply + Dval.optionNone KTUInt64 |> Task.FromResult else - Dval.optionSome KTUInt64 (DUInt64(uint64 a)) |> Ply + Dval.optionSome KTUInt64 (DUInt64(uint64 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -484,7 +488,7 @@ let fns () : List = description = "Bitwise AND on two values" fn = (function - | _, _, _, [ DUInt64 a; DUInt64 b ] -> Ply(DUInt64(a &&& b)) + | _, _, _, [ DUInt64 a; DUInt64 b ] -> Task.FromResult(DUInt64(a &&& b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -498,7 +502,7 @@ let fns () : List = description = "Bitwise OR on two values" fn = (function - | _, _, _, [ DUInt64 a; DUInt64 b ] -> Ply(DUInt64(a ||| b)) + | _, _, _, [ DUInt64 a; DUInt64 b ] -> Task.FromResult(DUInt64(a ||| b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -512,7 +516,7 @@ let fns () : List = description = "Bitwise XOR on two values" fn = (function - | _, _, _, [ DUInt64 a; DUInt64 b ] -> Ply(DUInt64(a ^^^ b)) + | _, _, _, [ DUInt64 a; DUInt64 b ] -> Task.FromResult(DUInt64(a ^^^ b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -526,7 +530,7 @@ let fns () : List = description = "Bitwise NOT on a value" fn = (function - | _, _, _, [ DUInt64 a ] -> Ply(DUInt64(~~~a)) + | _, _, _, [ DUInt64 a ] -> Task.FromResult(DUInt64(~~~a)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -540,7 +544,7 @@ let fns () : List = description = "Bitwise left shift of a value" fn = (function - | _, _, _, [ DUInt64 a; DUInt64 b ] -> Ply(DUInt64(a <<< int b)) + | _, _, _, [ DUInt64 a; DUInt64 b ] -> Task.FromResult(DUInt64(a <<< int b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -554,7 +558,7 @@ let fns () : List = description = "Bitwise right shift of a value" fn = (function - | _, _, _, [ DUInt64 a; DUInt64 b ] -> Ply(DUInt64(a >>> int b)) + | _, _, _, [ DUInt64 a; DUInt64 b ] -> Task.FromResult(DUInt64(a >>> int b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure diff --git a/backend/src/BuiltinExecution/Libs/UInt8.fs b/backend/src/BuiltinExecution/Libs/UInt8.fs index 69dc68748a..6a6d1702b6 100644 --- a/backend/src/BuiltinExecution/Libs/UInt8.fs +++ b/backend/src/BuiltinExecution/Libs/UInt8.fs @@ -3,6 +3,7 @@ module BuiltinExecution.Libs.UInt8 open Prelude open LibExecution.RuntimeTypes open LibExecution.Builtin.Shortcuts +open System.Threading.Tasks module VT = LibExecution.ValueType module Dval = LibExecution.Dval @@ -43,11 +44,14 @@ let fns () : List = (function | _, vm, _, [ DUInt8 v; DUInt8 m ] -> if m = 0uy then - RTE.Ints.ZeroModulus |> RTE.Int |> raiseRTE vm.threadID |> Ply + RTE.Ints.ZeroModulus + |> RTE.Int + |> raiseRTE vm.threadID + |> Task.FromResult else let result = v % m let result = if result < 0uy then m + result else result - Ply(DUInt8(result)) + Task.FromResult(DUInt8(result)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -63,9 +67,9 @@ let fns () : List = (function | _, vm, _, [ DUInt8 a; DUInt8 b ] -> try - DUInt8(Checked.(+) a b) |> Ply + DUInt8(Checked.(+) a b) |> Task.FromResult with :? System.OverflowException -> - RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID |> Ply + RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -81,9 +85,9 @@ let fns () : List = (function | _, vm, _, [ DUInt8 a; DUInt8 b ] -> try - DUInt8(Checked.(-) a b) |> Ply + DUInt8(Checked.(-) a b) |> Task.FromResult with :? System.OverflowException -> - RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID |> Ply + RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -99,9 +103,9 @@ let fns () : List = (function | _, vm, _, [ DUInt8 a; DUInt8 b ] -> try - DUInt8(Checked.(*) a b) |> Ply + DUInt8(Checked.(*) a b) |> Task.FromResult with :? System.OverflowException -> - RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID |> Ply + RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -120,9 +124,12 @@ let fns () : List = (function | _, vm, _, [ DUInt8 number; DUInt8 exp ] -> (try - (bigint number) ** (int exp) |> uint8 |> DUInt8 |> Ply + (bigint number) ** (int exp) |> uint8 |> DUInt8 |> Task.FromResult with :? System.OverflowException -> - RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID |> Ply) + RTE.Ints.OutOfRange + |> RTE.Int + |> raiseRTE vm.threadID + |> Task.FromResult) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -138,13 +145,19 @@ let fns () : List = (function | _, vm, _, [ DUInt8 a; DUInt8 b ] -> if b = 0uy then - RTE.Ints.DivideByZeroError |> RTE.Int |> raiseRTE vm.threadID |> Ply + RTE.Ints.DivideByZeroError + |> RTE.Int + |> raiseRTE vm.threadID + |> Task.FromResult else let result = int a / int b if result < 0 || result > 255 then - RTE.Ints.OutOfRange |> RTE.Int |> raiseRTE vm.threadID |> Ply + RTE.Ints.OutOfRange + |> RTE.Int + |> raiseRTE vm.threadID + |> Task.FromResult else - Ply(DUInt8(uint8 result)) + Task.FromResult(DUInt8(uint8 result)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -158,7 +171,7 @@ let fns () : List = description = "Returns {{true}} if is greater than " fn = (function - | _, _, _, [ DUInt8 a; DUInt8 b ] -> Ply(DBool(a > b)) + | _, _, _, [ DUInt8 a; DUInt8 b ] -> Task.FromResult(DBool(a > b)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -173,7 +186,7 @@ let fns () : List = "Returns {{true}} if is greater than or equal to " fn = (function - | _, _, _, [ DUInt8 a; DUInt8 b ] -> Ply(DBool(a >= b)) + | _, _, _, [ DUInt8 a; DUInt8 b ] -> Task.FromResult(DBool(a >= b)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -187,7 +200,7 @@ let fns () : List = description = "Returns {{true}} if is less than " fn = (function - | _, _, _, [ DUInt8 a; DUInt8 b ] -> Ply(DBool(a < b)) + | _, _, _, [ DUInt8 a; DUInt8 b ] -> Task.FromResult(DBool(a < b)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -202,7 +215,7 @@ let fns () : List = "Returns {{true}} if is less than or equal to " fn = (function - | _, _, _, [ DUInt8 a; DUInt8 b ] -> Ply(DBool(a <= b)) + | _, _, _, [ DUInt8 a; DUInt8 b ] -> Task.FromResult(DBool(a <= b)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -216,7 +229,7 @@ let fns () : List = description = "Converts an to a " fn = (function - | _, _, _, [ DUInt8 a ] -> Ply(DString(string a)) + | _, _, _, [ DUInt8 a ] -> Task.FromResult(DString(string a)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -230,7 +243,7 @@ let fns () : List = description = "Converts an to a " fn = (function - | _, _, _, [ DUInt8 a ] -> Ply(DFloat(float a)) + | _, _, _, [ DUInt8 a ] -> Task.FromResult(DFloat(float a)) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -257,7 +270,7 @@ let fns () : List = let uint8Result = lowerBound + (uint8 resultInt) - uint8Result |> DUInt8 |> Ply + uint8Result |> DUInt8 |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -271,7 +284,7 @@ let fns () : List = description = "Get the square root of an " fn = (function - | _, _, _, [ DUInt8 a ] -> Ply(DFloat(sqrt (float a))) + | _, _, _, [ DUInt8 a ] -> Task.FromResult(DFloat(sqrt (float a))) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -294,12 +307,15 @@ let fns () : List = (function | _, _, _, [ DString s ] -> try - s |> System.Byte.Parse |> DUInt8 |> resultOk |> Ply + s |> System.Byte.Parse |> DUInt8 |> resultOk |> Task.FromResult with | :? System.FormatException -> - ParseError.BadFormat |> ParseError.toDT |> resultError |> Ply + ParseError.BadFormat |> ParseError.toDT |> resultError |> Task.FromResult | :? System.OverflowException -> - ParseError.OutOfRange |> ParseError.toDT |> resultError |> Ply + ParseError.OutOfRange + |> ParseError.toDT + |> resultError + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -316,9 +332,9 @@ let fns () : List = (function | _, _, _, [ DInt8 a ] -> if a < 0y then - Dval.optionNone KTUInt8 |> Ply + Dval.optionNone KTUInt8 |> Task.FromResult else - Dval.optionSome KTUInt8 (DUInt8(uint8 a)) |> Ply + Dval.optionSome KTUInt8 (DUInt8(uint8 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -335,9 +351,9 @@ let fns () : List = (function | _, _, _, [ DInt16 a ] -> if a < 0s || a > 255s then - Dval.optionNone KTUInt8 |> Ply + Dval.optionNone KTUInt8 |> Task.FromResult else - Dval.optionSome KTUInt8 (DUInt8(uint8 a)) |> Ply + Dval.optionSome KTUInt8 (DUInt8(uint8 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -354,9 +370,9 @@ let fns () : List = (function | _, _, _, [ DUInt16 a ] -> if a > 255us then - Dval.optionNone KTUInt8 |> Ply + Dval.optionNone KTUInt8 |> Task.FromResult else - Dval.optionSome KTUInt8 (DUInt8(uint8 a)) |> Ply + Dval.optionSome KTUInt8 (DUInt8(uint8 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -373,9 +389,9 @@ let fns () : List = (function | _, _, _, [ DInt32 a ] -> if a < 0l || a > 255l then - Dval.optionNone KTUInt8 |> Ply + Dval.optionNone KTUInt8 |> Task.FromResult else - Dval.optionSome KTUInt8 (DUInt8(uint8 a)) |> Ply + Dval.optionSome KTUInt8 (DUInt8(uint8 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -392,9 +408,9 @@ let fns () : List = (function | _, _, _, [ DUInt32 a ] -> if a > 255ul then - Dval.optionNone KTUInt8 |> Ply + Dval.optionNone KTUInt8 |> Task.FromResult else - Dval.optionSome KTUInt8 (DUInt8(uint8 a)) |> Ply + Dval.optionSome KTUInt8 (DUInt8(uint8 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -411,9 +427,9 @@ let fns () : List = (function | _, _, _, [ DInt64 a ] -> if a < 0L || a > 255L then - Dval.optionNone KTUInt8 |> Ply + Dval.optionNone KTUInt8 |> Task.FromResult else - Dval.optionSome KTUInt8 (DUInt8(uint8 a)) |> Ply + Dval.optionSome KTUInt8 (DUInt8(uint8 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -430,9 +446,9 @@ let fns () : List = (function | _, _, _, [ DUInt64 a ] -> if a > 255UL then - Dval.optionNone KTUInt8 |> Ply + Dval.optionNone KTUInt8 |> Task.FromResult else - Dval.optionSome KTUInt8 (DUInt8(uint8 a)) |> Ply + Dval.optionSome KTUInt8 (DUInt8(uint8 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -449,9 +465,9 @@ let fns () : List = (function | _, _, _, [ DInt128 a ] -> if a < 0Q || a > 255Q then - Dval.optionNone KTUInt8 |> Ply + Dval.optionNone KTUInt8 |> Task.FromResult else - Dval.optionSome KTUInt8 (DUInt8(uint8 a)) |> Ply + Dval.optionSome KTUInt8 (DUInt8(uint8 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -468,9 +484,9 @@ let fns () : List = (function | _, _, _, [ DUInt128 a ] -> if a > 255Z then - Dval.optionNone KTUInt8 |> Ply + Dval.optionNone KTUInt8 |> Task.FromResult else - Dval.optionSome KTUInt8 (DUInt8(uint8 a)) |> Ply + Dval.optionSome KTUInt8 (DUInt8(uint8 a)) |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -484,7 +500,7 @@ let fns () : List = description = "Bitwise AND on two values" fn = (function - | _, _, _, [ DUInt8 a; DUInt8 b ] -> Ply(DUInt8(a &&& b)) + | _, _, _, [ DUInt8 a; DUInt8 b ] -> Task.FromResult(DUInt8(a &&& b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -498,7 +514,7 @@ let fns () : List = description = "Bitwise OR on two values" fn = (function - | _, _, _, [ DUInt8 a; DUInt8 b ] -> Ply(DUInt8(a ||| b)) + | _, _, _, [ DUInt8 a; DUInt8 b ] -> Task.FromResult(DUInt8(a ||| b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -512,7 +528,7 @@ let fns () : List = description = "Bitwise XOR on two values" fn = (function - | _, _, _, [ DUInt8 a; DUInt8 b ] -> Ply(DUInt8(a ^^^ b)) + | _, _, _, [ DUInt8 a; DUInt8 b ] -> Task.FromResult(DUInt8(a ^^^ b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -526,7 +542,7 @@ let fns () : List = description = "Bitwise NOT on a value" fn = (function - | _, _, _, [ DUInt8 a ] -> Ply(DUInt8(~~~a)) + | _, _, _, [ DUInt8 a ] -> Task.FromResult(DUInt8(~~~a)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -540,7 +556,7 @@ let fns () : List = description = "Bitwise left shift of a value" fn = (function - | _, _, _, [ DUInt8 a; DUInt8 b ] -> Ply(DUInt8(a <<< int b)) + | _, _, _, [ DUInt8 a; DUInt8 b ] -> Task.FromResult(DUInt8(a <<< int b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -554,7 +570,7 @@ let fns () : List = description = "Bitwise right shift of a value" fn = (function - | _, _, _, [ DUInt8 a; DUInt8 b ] -> Ply(DUInt8(a >>> int b)) + | _, _, _, [ DUInt8 a; DUInt8 b ] -> Task.FromResult(DUInt8(a >>> int b)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure diff --git a/backend/src/BuiltinExecution/Libs/Uuid.fs b/backend/src/BuiltinExecution/Libs/Uuid.fs index 97de23fbdc..f45ff64047 100644 --- a/backend/src/BuiltinExecution/Libs/Uuid.fs +++ b/backend/src/BuiltinExecution/Libs/Uuid.fs @@ -3,6 +3,7 @@ module BuiltinExecution.Libs.Uuid open LibExecution.RuntimeTypes open Prelude open LibExecution.Builtin.Shortcuts +open System.Threading.Tasks module VT = LibExecution.ValueType module Dval = LibExecution.Dval module PackageRefs = LibExecution.PackageRefs @@ -28,7 +29,7 @@ let fns () : List = description = "Generate a new v4 according to RFC 4122" fn = (function - | _, _, _, [ DUnit ] -> Ply(DUuid(System.Guid.NewGuid())) + | _, _, _, [ DUnit ] -> Task.FromResult(DUuid(System.Guid.NewGuid())) | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = @@ -60,8 +61,9 @@ let fns () : List = (function | _, _, _, [ DString s ] -> match System.Guid.TryParse s with - | true, x -> x |> DUuid |> resultOk |> Ply - | _ -> ParseError.BadFormat |> ParseError.toDT |> resultError |> Ply + | true, x -> x |> DUuid |> resultOk |> Task.FromResult + | _ -> + ParseError.BadFormat |> ParseError.toDT |> resultError |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotYetImplemented previewable = Pure @@ -76,7 +78,7 @@ let fns () : List = "Stringify to the format XXXXXXXX-XXXX-XXXX-XXXX-XXXXXXXXXXXX" fn = (function - | _, _, _, [ DUuid uuid ] -> Ply(DString(string uuid)) + | _, _, _, [ DUuid uuid ] -> Task.FromResult(DString(string uuid)) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure diff --git a/backend/src/BuiltinExecution/Libs/X509.fs b/backend/src/BuiltinExecution/Libs/X509.fs index eb46f94293..b5937eb3f3 100644 --- a/backend/src/BuiltinExecution/Libs/X509.fs +++ b/backend/src/BuiltinExecution/Libs/X509.fs @@ -7,6 +7,7 @@ open System.Security.Cryptography.X509Certificates open Prelude open LibExecution.RuntimeTypes open LibExecution.Builtin.Shortcuts +open System.Threading.Tasks module Dval = LibExecution.Dval @@ -43,13 +44,13 @@ let fns () : List = let label = System.ReadOnlySpan("PUBLIC KEY".ToCharArray()) let chars = PemEncoding.Write(label, data) let str = new System.String(chars) + "\n" - str |> DString |> resultOk |> Ply + str |> DString |> resultOk |> Task.FromResult with e -> // If it doesn't find BEGIN CERTIFICATE that, it errors with No // certificates. If it does find that, it tries to parse it, returning // X509: failed to parse certificate if it fails (either data is bullshit // or it's not an RSA cert). - resultError (DString "No certificates") |> Ply + resultError (DString "No certificates") |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure diff --git a/backend/src/BuiltinExecution/paket.references b/backend/src/BuiltinExecution/paket.references index f0292eb8f5..63b54bcf05 100644 --- a/backend/src/BuiltinExecution/paket.references +++ b/backend/src/BuiltinExecution/paket.references @@ -1,4 +1,3 @@ -Ply FSharp.Core FSharpPlus Sodium.Core \ No newline at end of file diff --git a/backend/src/BuiltinHttpServer/Libs/HttpServer.fs b/backend/src/BuiltinHttpServer/Libs/HttpServer.fs index f1f9900d40..b6e38e0472 100644 --- a/backend/src/BuiltinHttpServer/Libs/HttpServer.fs +++ b/backend/src/BuiltinHttpServer/Libs/HttpServer.fs @@ -14,7 +14,6 @@ module BuiltinHttpServer.Libs.HttpServer open System open System.Threading.Tasks -open FSharp.Control.Tasks open Microsoft.AspNetCore.Builder open Microsoft.AspNetCore.Hosting @@ -66,7 +65,7 @@ let fns () : List = fn = (function | exeState, _, _, [ DInt64 port; DApplicable handler ] -> - uply { + task { let builder = WebApplication.CreateBuilder() builder.WebHost.UseUrls($"http://*:{port}") |> ignore @@ -147,6 +146,7 @@ let fns () : List = return DUnit } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure diff --git a/backend/src/BuiltinHttpServer/paket.references b/backend/src/BuiltinHttpServer/paket.references index 668f52d153..6f627f42c5 100644 --- a/backend/src/BuiltinHttpServer/paket.references +++ b/backend/src/BuiltinHttpServer/paket.references @@ -1,2 +1 @@ -Ply FSharp.Core diff --git a/backend/src/BuiltinPM/Libs/Branches.fs b/backend/src/BuiltinPM/Libs/Branches.fs index 9bd056a68b..5824540f98 100644 --- a/backend/src/BuiltinPM/Libs/Branches.fs +++ b/backend/src/BuiltinPM/Libs/Branches.fs @@ -25,10 +25,11 @@ let fns () : List = fn = function | _, _, _, [ DString name; DUuid parentBranchId ] -> - uply { + task { let! branch = LibPackageManager.Branches.create name parentBranchId return PT2DT.Branch.toDT branch } + | _ -> incorrectArgs () sqlSpec = NotQueryable previewable = Impure @@ -43,13 +44,14 @@ let fns () : List = fn = function | _, _, _, [ DUnit ] -> - uply { + task { let! branches = LibPackageManager.Branches.list () return branches |> List.map PT2DT.Branch.toDT |> D.list (PT2DT.Branch.knownType ()) } + | _ -> incorrectArgs () sqlSpec = NotQueryable previewable = Impure @@ -64,13 +66,14 @@ let fns () : List = fn = function | _, _, _, [ DUnit ] -> - uply { + task { let! branches = LibPackageManager.Branches.listAll () return branches |> List.map PT2DT.Branch.toDT |> D.list (PT2DT.Branch.knownType ()) } + | _ -> incorrectArgs () sqlSpec = NotQueryable previewable = Impure @@ -85,13 +88,14 @@ let fns () : List = fn = function | _, _, _, [ DUuid id ] -> - uply { + task { let! branchOpt = LibPackageManager.Branches.get id return branchOpt |> Option.map PT2DT.Branch.toDT |> D.option (PT2DT.Branch.knownType ()) } + | _ -> incorrectArgs () sqlSpec = NotQueryable previewable = Impure @@ -106,13 +110,14 @@ let fns () : List = fn = function | _, _, _, [ DString name ] -> - uply { + task { let! branchOpt = LibPackageManager.Branches.getByName name return branchOpt |> Option.map PT2DT.Branch.toDT |> D.option (PT2DT.Branch.knownType ()) } + | _ -> incorrectArgs () sqlSpec = NotQueryable previewable = Impure @@ -129,7 +134,7 @@ let fns () : List = fn = function | _, _, _, [ DUuid id; DString newName ] -> - uply { + task { let! result = LibPackageManager.Branches.rename id newName return result @@ -137,6 +142,7 @@ let fns () : List = |> Result.mapError DString |> D.result KTUnit KTString } + | _ -> incorrectArgs () sqlSpec = NotQueryable previewable = Impure @@ -151,7 +157,7 @@ let fns () : List = fn = function | _, _, _, [ DUuid id ] -> - uply { + task { let! result = LibPackageManager.Branches.archive id return result @@ -159,6 +165,7 @@ let fns () : List = |> Result.mapError DString |> D.result KTUnit KTString } + | _ -> incorrectArgs () sqlSpec = NotQueryable previewable = Impure @@ -173,7 +180,7 @@ let fns () : List = fn = function | _, _, _, [ DUuid id ] -> - uply { + task { let! result = LibPackageManager.Branches.archive id return result @@ -181,6 +188,7 @@ let fns () : List = |> Result.mapError DString |> D.result KTUnit KTString } + | _ -> incorrectArgs () sqlSpec = NotQueryable previewable = Impure @@ -195,7 +203,7 @@ let fns () : List = fn = function | _, _, _, [ DUuid id ] -> - uply { + task { let! result = LibPackageManager.Branches.unarchive id return result @@ -203,6 +211,7 @@ let fns () : List = |> Result.mapError DString |> D.result KTUnit KTString } + | _ -> incorrectArgs () sqlSpec = NotQueryable previewable = Impure diff --git a/backend/src/BuiltinPM/Libs/Dependencies.fs b/backend/src/BuiltinPM/Libs/Dependencies.fs index af53965b97..c75cb45744 100644 --- a/backend/src/BuiltinPM/Libs/Dependencies.fs +++ b/backend/src/BuiltinPM/Libs/Dependencies.fs @@ -2,6 +2,7 @@ /// Enables "what calls this?" and "what does this call?" queries. module BuiltinPM.Libs.Dependencies +open System.Threading.Tasks open Prelude open LibExecution.RuntimeTypes open LibExecution.Builtin.Shortcuts @@ -22,8 +23,8 @@ let tupleVT = VT.tuple hashVT VT.string [] let private getLocationAny (branchChain : List) (hash : PT.Hash) - : Ply> = - uply { + : Task> = + task { // Try fn first (most common) match! PMPT.Fn.getLocations branchChain hash with | loc :: _ -> return Some loc @@ -54,7 +55,7 @@ let fns () : List = fn = (function | _, _, _, [ DUuid branchId; targetDval ] -> - uply { + task { let target = PT2DT.Hash.fromDT targetDval let! branchChain = Branches.getBranchChain branchId let! results = LibPackageManager.Queries.getDependents branchChain target @@ -69,6 +70,7 @@ let fns () : List = )) return DList(tupleVT, dvals) } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -90,7 +92,7 @@ let fns () : List = fn = (function | _, _, _, [ DUuid branchId; sourceDval ] -> - uply { + task { let source = PT2DT.Hash.fromDT sourceDval let! branchChain = Branches.getBranchChain branchId let! results = @@ -105,6 +107,7 @@ let fns () : List = )) return DList(tupleVT, dvals) } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -132,7 +135,7 @@ let fns () : List = fn = (function | _, _, _, [ DUuid branchId; DList(_, targets) ] -> - uply { + task { let! branchChain = Branches.getBranchChain branchId let ids = targets |> List.map PT2DT.Hash.fromDT @@ -152,6 +155,7 @@ let fns () : List = return DList(resultVT, dvals) } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -179,7 +183,7 @@ let fns () : List = fn = (function | _, _, _, [ DUuid branchId; DList(_, itemHashes) ] -> - uply { + task { let hashes = itemHashes |> List.map PT2DT.Hash.fromDT let! branchChain = LibPackageManager.Branches.getBranchChain branchId @@ -187,13 +191,13 @@ let fns () : List = let! results = hashes |> List.map (fun hash -> - uply { + task { match! getLocationAny branchChain hash with | Some loc -> return Some(hash, loc) | None -> return None }) - |> Ply.List.flatten - |> Ply.map (List.choose identity) + |> Task.flatten + |> Task.map (List.choose identity) let dvals = results @@ -206,6 +210,7 @@ let fns () : List = dvals ) } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure diff --git a/backend/src/BuiltinPM/Libs/Merge.fs b/backend/src/BuiltinPM/Libs/Merge.fs index 1593fdf6a7..fd02a73450 100644 --- a/backend/src/BuiltinPM/Libs/Merge.fs +++ b/backend/src/BuiltinPM/Libs/Merge.fs @@ -27,12 +27,13 @@ let fns () : List = let resultError = Dval.resultError KTUnit (PT2DT.MergeError.knownType ()) (function | _, _, _, [ DUuid branchId ] -> - uply { + task { let! result = LibPackageManager.Merge.merge branchId match result with | Ok() -> return resultOk DUnit | Error e -> return resultError (PT2DT.MergeError.toDT e) } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -52,12 +53,13 @@ let fns () : List = let resultError = Dval.resultError KTUnit (PT2DT.MergeError.knownType ()) (function | _, _, _, [ DUuid branchId ] -> - uply { + task { let! result = LibPackageManager.Merge.canMerge branchId match result with | Ok() -> return resultOk DUnit | Error e -> return resultError (PT2DT.MergeError.toDT e) } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure diff --git a/backend/src/BuiltinPM/Libs/PackageOps.fs b/backend/src/BuiltinPM/Libs/PackageOps.fs index cdbdca4371..c998919761 100644 --- a/backend/src/BuiltinPM/Libs/PackageOps.fs +++ b/backend/src/BuiltinPM/Libs/PackageOps.fs @@ -12,6 +12,7 @@ module VT = LibExecution.ValueType module NR = LibExecution.RuntimeTypes.NameResolution open Builtin.Shortcuts +open System.Threading.Tasks let packageOpTypeName () = @@ -32,15 +33,11 @@ let fns (pm : PT.PackageManager) : List = fn = (function | _, _, _, [ DList(_vt, ops) ] -> - uply { - let ptOps = ops |> List.choose PT2DT.PackageOp.fromDT - let stabilized = - LibPackageManager.HashStabilization.computeRealHashes ptOps - return - Dval.list - (packageOpKT ()) - (stabilized |> List.map PT2DT.PackageOp.toDT) - } + let ptOps = ops |> List.choose PT2DT.PackageOp.fromDT + let stabilized = + LibPackageManager.HashStabilization.computeRealHashes ptOps + Dval.list (packageOpKT ()) (stabilized |> List.map PT2DT.PackageOp.toDT) + |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -62,7 +59,7 @@ let fns (pm : PT.PackageManager) : List = let resultError = Dval.resultError KTInt64 KTString (function | _, _, _, [ DUuid branchId; DList(_vtTODO, ops) ] -> - uply { + task { try let ops = ops |> List.choose PT2DT.PackageOp.fromDT @@ -78,6 +75,7 @@ let fns (pm : PT.PackageManager) : List = with ex -> return resultError (Dval.string ex.Message) } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -92,10 +90,11 @@ let fns (pm : PT.PackageManager) : List = fn = function | _, _, _, [ DInt64 limit ] -> - uply { + task { let! ops = LibPackageManager.Queries.getRecentOps limit return Dval.list (packageOpKT ()) (ops |> List.map PT2DT.PackageOp.toDT) } + | _ -> incorrectArgs () sqlSpec = NotQueryable previewable = Impure @@ -110,10 +109,11 @@ let fns (pm : PT.PackageManager) : List = fn = function | _, _, _, [ DUuid branchId ] -> - uply { + task { let! ops = LibPackageManager.Queries.getWipOps branchId return Dval.list (packageOpKT ()) (ops |> List.map PT2DT.PackageOp.toDT) } + | _ -> incorrectArgs () sqlSpec = NotQueryable previewable = Impure @@ -128,7 +128,7 @@ let fns (pm : PT.PackageManager) : List = fn = function | _, _, _, [ DUuid branchId ] -> - uply { + task { let! summary = LibPackageManager.Queries.getWipSummary branchId return Dval.dict @@ -140,6 +140,7 @@ let fns (pm : PT.PackageManager) : List = "deprecations", Dval.int64 summary.deprecations "total", Dval.int64 summary.total ] } + | _ -> incorrectArgs () sqlSpec = NotQueryable previewable = Impure @@ -156,7 +157,7 @@ let fns (pm : PT.PackageManager) : List = fn = function | _, _, _, [ DUuid branchId ] -> - uply { + task { let! items = LibPackageManager.Queries.getWipItems branchId return items @@ -169,6 +170,7 @@ let fns (pm : PT.PackageManager) : List = "propagatedCount", DString(string item.propagatedCount) ]) |> Dval.list (KTDict(ValueType.Known KTString)) } + | _ -> incorrectArgs () sqlSpec = NotQueryable previewable = Impure @@ -183,10 +185,11 @@ let fns (pm : PT.PackageManager) : List = fn = function | _, _, _, [ DUuid branchId ] -> - uply { + task { let! count = LibPackageManager.Queries.getWipOpCount branchId return Dval.int64 count } + | _ -> incorrectArgs () sqlSpec = NotQueryable previewable = Impure @@ -201,10 +204,11 @@ let fns (pm : PT.PackageManager) : List = fn = function | _, _, _, [ DUuid branchId ] -> - uply { + task { let! count = LibPackageManager.Queries.getCommitCount branchId return Dval.int64 count } + | _ -> incorrectArgs () sqlSpec = NotQueryable previewable = Impure @@ -226,7 +230,7 @@ let fns (pm : PT.PackageManager) : List = let resultError = Dval.resultError KTString KTString (function | _, _, _, [ DUuid accountId; DUuid branchId; DString message ] -> - uply { + task { let! result = LibPackageManager.Inserts.commitWipOps accountId branchId message match result with @@ -235,6 +239,7 @@ let fns (pm : PT.PackageManager) : List = return resultOk (Dval.string h) | Error msg -> return resultError (Dval.string msg) } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -253,12 +258,13 @@ let fns (pm : PT.PackageManager) : List = let resultError = Dval.resultError KTInt64 KTString (function | _, _, _, [ DUuid branchId ] -> - uply { + task { let! result = LibPackageManager.Inserts.discardWipOps branchId match result with | Ok count -> return resultOk (Dval.int64 count) | Error msg -> return resultError (Dval.string msg) } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -275,13 +281,14 @@ let fns (pm : PT.PackageManager) : List = fn = function | _, _, _, [ DUuid branchId; DInt64 limit ] -> - uply { + task { let! commits = LibPackageManager.Queries.getCommits branchId limit return Dval.list (PT2DT.Commit.knownType ()) (commits |> List.map PT2DT.Commit.toDT) } + | _ -> incorrectArgs () sqlSpec = NotQueryable previewable = Impure @@ -299,7 +306,7 @@ let fns (pm : PT.PackageManager) : List = fn = function | _, _, _, [ DUuid branchId; DInt64 limit ] -> - uply { + task { let! commits = LibPackageManager.Queries.getCommitsForBranchChain branchId limit return @@ -307,6 +314,7 @@ let fns (pm : PT.PackageManager) : List = (PT2DT.Commit.knownType ()) (commits |> List.map PT2DT.Commit.toDT) } + | _ -> incorrectArgs () sqlSpec = NotQueryable previewable = Impure @@ -321,10 +329,11 @@ let fns (pm : PT.PackageManager) : List = fn = function | _, _, _, [ DString commitHash ] -> - uply { + task { let! ops = LibPackageManager.Queries.getCommitOps (PT.Hash commitHash) return Dval.list (packageOpKT ()) (ops |> List.map PT2DT.PackageOp.toDT) } + | _ -> incorrectArgs () sqlSpec = NotQueryable previewable = Impure diff --git a/backend/src/BuiltinPM/Libs/Packages.fs b/backend/src/BuiltinPM/Libs/Packages.fs index b7c05e5155..f1cab6c4b9 100644 --- a/backend/src/BuiltinPM/Libs/Packages.fs +++ b/backend/src/BuiltinPM/Libs/Packages.fs @@ -51,8 +51,9 @@ let fns (pm : PT.PackageManager) : List = fn = function | _, _, _, [ DUnit ] -> - uply { - let! stats = LibPackageManager.Stats.get () + task { + let! (stats : LibPackageManager.Stats.Stats) = + LibPackageManager.Stats.get () return DRecord( @@ -65,6 +66,7 @@ let fns (pm : PT.PackageManager) : List = |> Map ) } + | _ -> incorrectArgs () sqlSpec = NotQueryable previewable = Impure @@ -87,7 +89,7 @@ let fns (pm : PT.PackageManager) : List = fn = (function | _, _, _, [ DUuid branchId; location ] -> - uply { + task { let location = PT2DT.PackageLocation.fromDT location // Do a fresh lookup using the branchId to get the current branch chain. // This ensures newly-created types on the branch are visible. @@ -98,6 +100,7 @@ let fns (pm : PT.PackageManager) : List = |> Option.map PT2DT.Hash.toDT |> Dval.option (PT2DT.Hash.knownType ()) } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -115,11 +118,12 @@ let fns (pm : PT.PackageManager) : List = let optType = KTCustomType((PT2DT.PackageType.typeName ()), []) (function | _, _, _, [ hashDval ] -> - uply { + task { let hash = PT2DT.Hash.fromDT hashDval let! result = pm.getType hash return result |> Option.map PT2DT.PackageType.toDT |> Dval.option optType } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -142,7 +146,7 @@ let fns (pm : PT.PackageManager) : List = fn = (function | _, _, _, [ DUuid branchId; location ] -> - uply { + task { let location = PT2DT.PackageLocation.fromDT location let! branchChain = Branches.getBranchChain branchId let! result = PMPT.Value.find branchChain location @@ -151,6 +155,7 @@ let fns (pm : PT.PackageManager) : List = |> Option.map PT2DT.Hash.toDT |> Dval.option (PT2DT.Hash.knownType ()) } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -169,7 +174,7 @@ let fns (pm : PT.PackageManager) : List = fn = (function | _, _, _, [ hashDval ] -> - uply { + task { let hash = PT2DT.Hash.fromDT hashDval let! result = pm.getValue hash return @@ -177,6 +182,7 @@ let fns (pm : PT.PackageManager) : List = |> Option.map PT2DT.PackageValue.toDT |> Dval.option (KTCustomType((PT2DT.PackageValue.typeName ()), [])) } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -198,7 +204,7 @@ let fns (pm : PT.PackageManager) : List = fn = (function | _, _, _, [ valueTypeDval ] -> - uply { + task { let vt = RT2DT.ValueType.fromDT valueTypeDval let! valueIds = RTPM.Value.findByValueType vt return @@ -207,6 +213,7 @@ let fns (pm : PT.PackageManager) : List = valueIds |> List.map RT2DT.Hash.toDT ) } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -228,7 +235,7 @@ let fns (pm : PT.PackageManager) : List = fn = (function | exeState, _, _, [ hashDval ] -> - uply { + task { let (PT.Hash hash) = PT2DT.Hash.fromDT hashDval let valueName = FQValueName.Package(Hash hash) let instrs : Instructions = @@ -244,6 +251,7 @@ let fns (pm : PT.PackageManager) : List = | ValueType.Unknown -> return Dval.optionSome KTUnit dval | Error _ -> return Dval.optionNone KTUnit } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -266,7 +274,7 @@ let fns (pm : PT.PackageManager) : List = fn = (function | _, _, _, [ DUuid branchId; location ] -> - uply { + task { let location = PT2DT.PackageLocation.fromDT location let! branchChain = Branches.getBranchChain branchId let! result = PMPT.Fn.find branchChain location @@ -275,6 +283,7 @@ let fns (pm : PT.PackageManager) : List = |> Option.map PT2DT.Hash.toDT |> Dval.option (PT2DT.Hash.knownType ()) } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -291,7 +300,7 @@ let fns (pm : PT.PackageManager) : List = fn = (function | _, _, _, [ hashDval ] -> - uply { + task { let hash = PT2DT.Hash.fromDT hashDval let! result = pm.getFn hash return @@ -299,6 +308,7 @@ let fns (pm : PT.PackageManager) : List = |> Option.map PT2DT.PackageFn.toDT |> Dval.option (KTCustomType((PT2DT.PackageFn.typeName ()), [])) } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -318,12 +328,13 @@ let fns (pm : PT.PackageManager) : List = fn = function | _, _, _, [ DUuid branchId; query as DRecord(_, _, _, _fields) ] -> - uply { + task { let searchQuery = PT2DT.Search.SearchQuery.fromDT query let! branchChain = Branches.getBranchChain branchId let! results = PMPT.search branchChain searchQuery return PT2DT.Search.SearchResults.toDT results } + | _ -> incorrectArgs () sqlSpec = NotQueryable previewable = Impure @@ -341,7 +352,7 @@ let fns (pm : PT.PackageManager) : List = fn = (function | _, _, _, [ DUuid branchId; hashDval ] -> - uply { + task { let hash = PT2DT.Hash.fromDT hashDval let! result = pm.getTypeLocations branchId hash return @@ -349,6 +360,7 @@ let fns (pm : PT.PackageManager) : List = |> List.map PT2DT.PackageLocation.toDT |> Dval.list (KTCustomType((PT2DT.PackageLocation.typeName ()), [])) } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -365,7 +377,7 @@ let fns (pm : PT.PackageManager) : List = fn = (function | _, _, _, [ DUuid branchId; hashDval ] -> - uply { + task { let hash = PT2DT.Hash.fromDT hashDval let! result = pm.getValueLocations branchId hash return @@ -373,6 +385,7 @@ let fns (pm : PT.PackageManager) : List = |> List.map PT2DT.PackageLocation.toDT |> Dval.list (KTCustomType((PT2DT.PackageLocation.typeName ()), [])) } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -389,7 +402,7 @@ let fns (pm : PT.PackageManager) : List = fn = (function | _, _, _, [ DUuid branchId; hashDval ] -> - uply { + task { let hash = PT2DT.Hash.fromDT hashDval let! result = pm.getFnLocations branchId hash return @@ -397,6 +410,7 @@ let fns (pm : PT.PackageManager) : List = |> List.map PT2DT.PackageLocation.toDT |> Dval.list (KTCustomType((PT2DT.PackageLocation.typeName ()), [])) } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -422,7 +436,7 @@ let fns (pm : PT.PackageManager) : List = fn = (function | _, _, _, [ DUuid branchId; location; itemKindDval ] -> - uply { + task { let location = PT2DT.PackageLocation.fromDT location let itemKind = PT2DT.ItemKind.fromDT itemKindDval let modulesStr = location.modules |> String.concat "." @@ -439,6 +453,7 @@ let fns (pm : PT.PackageManager) : List = |> List.map PT2DT.Hash.toDT |> Dval.list (PT2DT.Hash.knownType ()) } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -486,7 +501,7 @@ let fns (pm : PT.PackageManager) : List = sourceItemKindDval DList(_, fromSourceHashDvals) toSourceHashDval ] -> - uply { + task { let sourceLocation = PT2DT.PackageLocation.fromDT sourceLocation let sourceItemKind = PT2DT.ItemKind.fromDT sourceItemKindDval let fromSourceHashes = fromSourceHashDvals |> List.map PT2DT.Hash.fromDT @@ -527,6 +542,7 @@ let fns (pm : PT.PackageManager) : List = | Error errMsg -> return Dval.resultError tupleKT KTString (DString errMsg) } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -578,7 +594,7 @@ let fns (pm : PT.PackageManager) : List = sourceItemKindDval DList(_, propagationIds) targetHashDval ] -> - uply { + task { let repoints = repoints |> List.map PT2DT.PropagateRepoint.fromDT let sourceLocation = PT2DT.PackageLocation.fromDT sourceLocation let sourceItemKind = PT2DT.ItemKind.fromDT sourceItemKindDval @@ -595,9 +611,9 @@ let fns (pm : PT.PackageManager) : List = // Determine the hash to restore: explicit target or find committed let! restoredHashResult = match C2DT.Option.fromDT PT2DT.Hash.fromDT targetHashDval with - | Some targetHash -> uply { return Ok targetHash } + | Some targetHash -> task { return Ok targetHash } | None -> - uply { + task { let! result = LibPackageManager.Inserts.findCommittedHash branchId @@ -636,6 +652,7 @@ let fns (pm : PT.PackageManager) : List = DTuple(DUuid revertId, PT2DT.Hash.toDT restoredHash, []) return Dval.resultOk tupleKT KTString resultTuple } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -660,7 +677,7 @@ let fns (pm : PT.PackageManager) : List = fn = (function | _, _, _, [ DUuid branchId ] -> - uply { + task { let! branchChain = Branches.getBranchChain branchId let! sets = LibPackageManager.Queries.getDeprecationSets branchChain let hashListDval (hashes : Set) = @@ -671,6 +688,7 @@ let fns (pm : PT.PackageManager) : List = return DTuple(hashListDval sets.allDeprecated, hashListDval sets.hidden, []) } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -704,7 +722,7 @@ let fns (pm : PT.PackageManager) : List = fn = (function | _, _, _, [ DUuid branchId; hashDval; itemKindDval ] -> - uply { + task { let hash = PT2DT.Hash.fromDT hashDval let itemKind = PT2DT.ItemKind.fromDT itemKindDval let! branchChain = Branches.getBranchChain branchId @@ -727,6 +745,7 @@ let fns (pm : PT.PackageManager) : List = tupleKT (DTuple(PT2DT.DeprecationKind.toDT kind, DString message, [])) } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure diff --git a/backend/src/BuiltinPM/Libs/Rebase.fs b/backend/src/BuiltinPM/Libs/Rebase.fs index 4c4ba85aba..a9db67adcc 100644 --- a/backend/src/BuiltinPM/Libs/Rebase.fs +++ b/backend/src/BuiltinPM/Libs/Rebase.fs @@ -1,7 +1,6 @@ module BuiltinPM.Libs.Rebase open System.Threading.Tasks -open FSharp.Control.Tasks open Prelude open LibExecution.RuntimeTypes @@ -26,7 +25,7 @@ let fns () : List = let resultError = Dval.resultError KTString (KTList VT.string) (function | _, _, _, [ DUuid branchId ] -> - uply { + task { let! result = LibPackageManager.Rebase.rebase branchId match result with | Ok msg -> return resultOk (DString msg) @@ -38,6 +37,7 @@ let fns () : List = |> List.map DString return resultError (DList(VT.string, conflictStrs)) } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure @@ -52,7 +52,7 @@ let fns () : List = fn = function | _, _, _, [ DUuid branchId ] -> - uply { + task { let! conflicts = LibPackageManager.Rebase.getConflicts branchId let conflictStrs = conflicts @@ -60,6 +60,7 @@ let fns () : List = DString $"{c.owner}.{c.modules}.{c.name} ({c.itemType})") return DList(VT.string, conflictStrs) } + | _ -> incorrectArgs () sqlSpec = NotQueryable previewable = Impure diff --git a/backend/src/BuiltinPM/Libs/Scripts.fs b/backend/src/BuiltinPM/Libs/Scripts.fs index 30fb0f8309..50a032d506 100644 --- a/backend/src/BuiltinPM/Libs/Scripts.fs +++ b/backend/src/BuiltinPM/Libs/Scripts.fs @@ -33,13 +33,14 @@ let fns () : List = fn = function | _, _, _, [ DUnit ] -> - uply { + task { let! scripts = Scripts.list () return scripts |> List.map Scripts.toDT |> Dval.list (KTCustomType(scriptTypeName (), [])) } + | _ -> incorrectArgs () sqlSpec = NotQueryable previewable = Impure @@ -54,13 +55,14 @@ let fns () : List = fn = function | _, _, _, [ DString name ] -> - uply { + task { let! scriptOpt = Scripts.get name return scriptOpt |> Option.map Scripts.toDT |> Dval.option (KTCustomType(scriptTypeName (), [])) } + | _ -> incorrectArgs () sqlSpec = NotQueryable previewable = Impure @@ -75,7 +77,7 @@ let fns () : List = fn = function | _, _, _, [ DString name; DString text ] -> - uply { + task { let! result = Scripts.add name text return result @@ -83,6 +85,7 @@ let fns () : List = |> Result.mapError DString |> Dval.result (KTCustomType(scriptTypeName (), [])) KTString } + | _ -> incorrectArgs () sqlSpec = NotQueryable previewable = Impure @@ -97,7 +100,7 @@ let fns () : List = fn = function | _, _, _, [ DString name; DString text ] -> - uply { + task { let! result = Scripts.update name text return result @@ -105,6 +108,7 @@ let fns () : List = |> Result.mapError DString |> Dval.result KTUnit KTString } + | _ -> incorrectArgs () sqlSpec = NotQueryable previewable = Impure @@ -119,7 +123,7 @@ let fns () : List = fn = function | _, _, _, [ DString name ] -> - uply { + task { let! result = Scripts.delete name return result @@ -127,6 +131,7 @@ let fns () : List = |> Result.mapError DString |> Dval.result KTUnit KTString } + | _ -> incorrectArgs () sqlSpec = NotQueryable previewable = Impure diff --git a/backend/src/BuiltinPM/Libs/Seed.fs b/backend/src/BuiltinPM/Libs/Seed.fs index 7187fa5e75..0ce94889b6 100644 --- a/backend/src/BuiltinPM/Libs/Seed.fs +++ b/backend/src/BuiltinPM/Libs/Seed.fs @@ -20,13 +20,14 @@ let fns : List = let resultError = Dval.resultError KTUnit KTString (function | _, _, _, [ DString outputPath ] -> - uply { + task { try do! LibPackageManager.Seed.export outputPath return resultOk DUnit with ex -> return resultError (DString ex.Message) } + | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Impure diff --git a/backend/src/BuiltinPM/paket.references b/backend/src/BuiltinPM/paket.references index ad6b3cbfdf..888823634d 100644 --- a/backend/src/BuiltinPM/paket.references +++ b/backend/src/BuiltinPM/paket.references @@ -1,3 +1,2 @@ -Ply FSharp.Core FSharpPlus diff --git a/backend/src/BwdServer/Server.fs b/backend/src/BwdServer/Server.fs index ffdd0f1601..04ade3f8e2 100644 --- a/backend/src/BwdServer/Server.fs +++ b/backend/src/BwdServer/Server.fs @@ -4,7 +4,6 @@ /// See README.md for more details. module BwdServer.Server -open FSharp.Control.Tasks open System.Threading.Tasks open Microsoft.AspNetCore diff --git a/backend/src/Cli/Cli.fs b/backend/src/Cli/Cli.fs index 1582084cea..71eb9c26f1 100644 --- a/backend/src/Cli/Cli.fs +++ b/backend/src/Cli/Cli.fs @@ -2,7 +2,6 @@ module Cli.Main open System open System.Threading.Tasks -open FSharp.Control.Tasks open Prelude @@ -87,7 +86,7 @@ let state (packageManager : RT.PackageManager) = = // let metadata = extraMetadata state @ metadata // LibService.Rollbar.notify msg metadata - uply { return () } + task { return () } let sendException (_ : RT.ExecutionState) @@ -95,7 +94,7 @@ let state (packageManager : RT.PackageManager) = (metadata : Metadata) (exn : exn) = - uply { printException "Internal error" metadata exn } + task { printException "Internal error" metadata exn } Exe.createState builtins @@ -196,6 +195,17 @@ let main (args : string[]) = with e -> - System.Console.Error.WriteLine - $"Error starting Darklang CLI: {e.Message}\nStack trace:\n{e.StackTrace}" + let rec describe (depth : int) (ex : exn) : unit = + let indent = String.replicate depth " " + System.Console.Error.WriteLine $"{indent}{ex.GetType().FullName}: {ex.Message}" + match ex with + | :? System.AggregateException as agg -> + for inner in agg.InnerExceptions do + describe (depth + 1) inner + | _ -> + if not (isNull ex.InnerException) then describe (depth + 1) ex.InnerException + if depth = 0 && not (isNull ex.StackTrace) then + System.Console.Error.WriteLine $"Stack trace:\n{ex.StackTrace}" + System.Console.Error.WriteLine "Error starting Darklang CLI:" + describe 0 e 1 diff --git a/backend/src/Cli/paket.references b/backend/src/Cli/paket.references index d8c5d9e883..1e5d5bbe04 100644 --- a/backend/src/Cli/paket.references +++ b/backend/src/Cli/paket.references @@ -1,4 +1,3 @@ -Ply FSharp.Core FSharpPlus Microsoft.Data.Sqlite diff --git a/backend/src/LibExecution/CommonToDarkTypes.fs b/backend/src/DarkTypes/CommonToDarkTypes.fs similarity index 100% rename from backend/src/LibExecution/CommonToDarkTypes.fs rename to backend/src/DarkTypes/CommonToDarkTypes.fs diff --git a/backend/src/DarkTypes/DarkTypes.fsproj b/backend/src/DarkTypes/DarkTypes.fsproj new file mode 100644 index 0000000000..c7b249aafe --- /dev/null +++ b/backend/src/DarkTypes/DarkTypes.fsproj @@ -0,0 +1,26 @@ + + + + Library + net10.0 + 10.0 + false + true + true + + + + + + + + + + + + + + + + + diff --git a/backend/src/LibExecution/DvalDecoder.fs b/backend/src/DarkTypes/DvalDecoder.fs similarity index 100% rename from backend/src/LibExecution/DvalDecoder.fs rename to backend/src/DarkTypes/DvalDecoder.fs diff --git a/backend/src/LibExecution/ProgramTypesToDarkTypes.fs b/backend/src/DarkTypes/ProgramTypesToDarkTypes.fs similarity index 100% rename from backend/src/LibExecution/ProgramTypesToDarkTypes.fs rename to backend/src/DarkTypes/ProgramTypesToDarkTypes.fs diff --git a/backend/src/LibExecution/RuntimeTypesToDarkTypes.fs b/backend/src/DarkTypes/RuntimeTypesToDarkTypes.fs similarity index 100% rename from backend/src/LibExecution/RuntimeTypesToDarkTypes.fs rename to backend/src/DarkTypes/RuntimeTypesToDarkTypes.fs diff --git a/backend/src/DarkTypes/paket.references b/backend/src/DarkTypes/paket.references new file mode 100644 index 0000000000..888823634d --- /dev/null +++ b/backend/src/DarkTypes/paket.references @@ -0,0 +1,2 @@ +FSharp.Core +FSharpPlus diff --git a/backend/src/LibExecution/DarkDateTime.fs b/backend/src/Language/DarkDateTime.fs similarity index 100% rename from backend/src/LibExecution/DarkDateTime.fs rename to backend/src/Language/DarkDateTime.fs diff --git a/backend/src/Language/Language.fsproj b/backend/src/Language/Language.fsproj new file mode 100644 index 0000000000..bb550aa4ba --- /dev/null +++ b/backend/src/Language/Language.fsproj @@ -0,0 +1,32 @@ + + + + Library + net10.0 + 10.0 + false + true + true + + + + + + + + + + + + + + + + + + + + + + + diff --git a/backend/src/LibExecution/PackageRefs.fs b/backend/src/Language/PackageRefs.fs similarity index 99% rename from backend/src/LibExecution/PackageRefs.fs rename to backend/src/Language/PackageRefs.fs index 3e1c99da45..621ebb41b7 100644 --- a/backend/src/LibExecution/PackageRefs.fs +++ b/backend/src/Language/PackageRefs.fs @@ -42,7 +42,7 @@ let private loadHashes () : Map = use stream = System.Reflection.Assembly .GetExecutingAssembly() - .GetManifestResourceStream("LibExecution.package-ref-hashes.txt") + .GetManifestResourceStream("Language.package-ref-hashes.txt") if stream <> null then use reader = new System.IO.StreamReader(stream) reader.ReadToEnd().Split('\n') |> parseLines diff --git a/backend/src/LibExecution/ProgramTypes.fs b/backend/src/Language/ProgramTypes.fs similarity index 94% rename from backend/src/LibExecution/ProgramTypes.fs rename to backend/src/Language/ProgramTypes.fs index ce504f7cf0..3e62053f83 100644 --- a/backend/src/LibExecution/ProgramTypes.fs +++ b/backend/src/Language/ProgramTypes.fs @@ -1,6 +1,8 @@ /// The types that the user sees module LibExecution.ProgramTypes +open System.Threading.Tasks + open Prelude @@ -837,42 +839,44 @@ module Search = /// but there's a chance of Local <-> Cloud not being fully in sync, /// for whatever reasons. type PackageManager = - { findType : (BranchId * PackageLocation) -> Ply> - findValue : (BranchId * PackageLocation) -> Ply> - findFn : (BranchId * PackageLocation) -> Ply> + { findType : (BranchId * PackageLocation) -> Task> + findValue : (BranchId * PackageLocation) -> Task> + findFn : (BranchId * PackageLocation) -> Task> - search : (BranchId * Search.SearchQuery) -> Ply + search : (BranchId * Search.SearchQuery) -> Task // CLEANUP why does the PT one even need these? - getType : FQTypeName.Package -> Ply> - getValue : FQValueName.Package -> Ply> - getFn : FQFnName.Package -> Ply> + getType : FQTypeName.Package -> Task> + getValue : FQValueName.Package -> Task> + getFn : FQFnName.Package -> Task> // Reverse lookups — returns ALL locations for a hash - getTypeLocations : BranchId -> FQTypeName.Package -> Ply> - getValueLocations : BranchId -> FQValueName.Package -> Ply> - getFnLocations : BranchId -> FQFnName.Package -> Ply> + getTypeLocations : BranchId -> FQTypeName.Package -> Task> + getValueLocations : + BranchId -> FQValueName.Package -> Task> + getFnLocations : BranchId -> FQFnName.Package -> Task> - init : Ply } + init : Task } static member empty = - { findType = fun (_, _) -> Ply None - findFn = fun (_, _) -> Ply None - findValue = fun (_, _) -> Ply None + { findType = fun (_, _) -> Task.FromResult None + findFn = fun (_, _) -> Task.FromResult None + findValue = fun (_, _) -> Task.FromResult None search = - fun (_, _) -> Ply { submodules = []; types = []; values = []; fns = [] } + fun (_, _) -> + Task.FromResult { submodules = []; types = []; values = []; fns = [] } - getType = fun _ -> Ply None - getFn = fun _ -> Ply None - getValue = fun _ -> Ply None + getType = fun _ -> Task.FromResult None + getFn = fun _ -> Task.FromResult None + getValue = fun _ -> Task.FromResult None - getTypeLocations = fun _ _ -> Ply [] - getValueLocations = fun _ _ -> Ply [] - getFnLocations = fun _ _ -> Ply [] + getTypeLocations = fun _ _ -> Task.FromResult [] + getValueLocations = fun _ _ -> Task.FromResult [] + getFnLocations = fun _ _ -> Task.FromResult [] - init = uply { return () } } + init = task { return () } } /// Allows you to side-load a few 'extras' in-memory, along @@ -920,19 +924,19 @@ type PackageManager = { findType = fun (branchId, location) -> match Map.tryFind location typeLocationToHash with - | Some hash -> Ply(Some hash) + | Some hash -> Task.FromResult(Some hash) | None -> pm.findType (branchId, location) findValue = fun (branchId, location) -> match Map.tryFind location valueLocationToHash with - | Some hash -> Ply(Some hash) + | Some hash -> Task.FromResult(Some hash) | None -> pm.findValue (branchId, location) findFn = fun (branchId, location) -> match Map.tryFind location fnLocationToHash with - | Some hash -> Ply(Some hash) + | Some hash -> Task.FromResult(Some hash) | None -> pm.findFn (branchId, location) search = fun (branchId, query) -> pm.search (branchId, query) @@ -940,24 +944,24 @@ type PackageManager = getType = fun hash -> match Map.tryFind hash typeHashToType with - | Some t -> Ply(Some t) + | Some t -> Task.FromResult(Some t) | None -> pm.getType hash getValue = fun hash -> match Map.tryFind hash valueHashToValue with - | Some v -> Ply(Some v) + | Some v -> Task.FromResult(Some v) | None -> pm.getValue hash getFn = fun hash -> match Map.tryFind hash fnHashToFn with - | Some f -> Ply(Some f) + | Some f -> Task.FromResult(Some f) | None -> pm.getFn hash getTypeLocations = fun branchId hash -> - uply { + task { let local = Map.tryFind hash typeHashToLocations |> Option.defaultValue [] let! fallback = pm.getTypeLocations branchId hash @@ -966,7 +970,7 @@ type PackageManager = getValueLocations = fun branchId hash -> - uply { + task { let local = Map.tryFind hash valueHashToLocations |> Option.defaultValue [] let! fallback = pm.getValueLocations branchId hash @@ -975,7 +979,7 @@ type PackageManager = getFnLocations = fun branchId hash -> - uply { + task { let local = Map.tryFind hash fnHashToLocations |> Option.defaultValue [] let! fallback = pm.getFnLocations branchId hash return local @ fallback diff --git a/backend/src/LibExecution/ProgramTypesAst.fs b/backend/src/Language/ProgramTypesAst.fs similarity index 100% rename from backend/src/LibExecution/ProgramTypesAst.fs rename to backend/src/Language/ProgramTypesAst.fs diff --git a/backend/src/LibExecution/ProgramTypesParser.fs b/backend/src/Language/ProgramTypesParser.fs similarity index 100% rename from backend/src/LibExecution/ProgramTypesParser.fs rename to backend/src/Language/ProgramTypesParser.fs diff --git a/backend/src/Language/paket.references b/backend/src/Language/paket.references new file mode 100644 index 0000000000..888823634d --- /dev/null +++ b/backend/src/Language/paket.references @@ -0,0 +1,2 @@ +FSharp.Core +FSharpPlus diff --git a/backend/src/LibCloud/Account.fs b/backend/src/LibCloud/Account.fs index 4a86171606..4a7046ddd9 100644 --- a/backend/src/LibCloud/Account.fs +++ b/backend/src/LibCloud/Account.fs @@ -3,7 +3,6 @@ module LibCloud.Account open System.Threading.Tasks -open FSharp.Control.Tasks open Prelude open Fumble diff --git a/backend/src/LibCloud/Canvas.fs b/backend/src/LibCloud/Canvas.fs index 94ad564df8..c5942497c9 100644 --- a/backend/src/LibCloud/Canvas.fs +++ b/backend/src/LibCloud/Canvas.fs @@ -3,7 +3,6 @@ module LibCloud.Canvas // Functions related to Canvases open System.Threading.Tasks -open FSharp.Control.Tasks open Microsoft.Data.Sqlite open Fumble open LibDB.Db @@ -442,8 +441,8 @@ let healthCheck : K8s.HealthCheck = { name = "canvas"; checkFn = loadDomainsHealthCheck; probeTypes = [ K8s.Startup ] } -let toProgram (c : T) : Ply = - uply { +let toProgram (c : T) : Task = + task { let dbs = c.dbs |> Map.values diff --git a/backend/src/LibCloud/DvalReprInternalQueryable.fs b/backend/src/LibCloud/DvalReprInternalQueryable.fs index 074aea9f76..5639cb2de9 100644 --- a/backend/src/LibCloud/DvalReprInternalQueryable.fs +++ b/backend/src/LibCloud/DvalReprInternalQueryable.fs @@ -20,6 +20,7 @@ module LibExecution.DvalReprInternalQueryable open System.Text.Json +open System.Threading.Tasks open Prelude @@ -36,8 +37,8 @@ let parseJson (s : string) : JsonElement = JsonDocument.Parse(s, options).RootElement -let writeJson (f : Utf8JsonWriter -> Ply) : Ply = - uply { +let writeJson (f : Utf8JsonWriter -> Task) : Task = + task { let options = new JsonWriterOptions( Indented = false, @@ -57,15 +58,15 @@ let writeJson (f : Utf8JsonWriter -> Ply) : Ply = type Utf8JsonWriter with - member this.writeObject(f : unit -> Ply) = - uply { + member this.writeObject(f : unit -> Task) = + task { this.WriteStartObject() do! f () this.WriteEndObject() } - member this.writeArray(f : unit -> Ply) = - uply { + member this.writeArray(f : unit -> Task) = + task { this.WriteStartArray() do! f () this.WriteEndArray() @@ -85,8 +86,8 @@ let rec private toJsonV0 (threadID : ThreadID) (types : Types) (dv : Dval) - : Ply = - uply { + : Task = + task { let writeDval = toJsonV0 w threadID types match dv with @@ -127,19 +128,16 @@ let rec private toJsonV0 // nested types | DTuple(d1, d2, rest) -> - do! - w.writeArray (fun () -> - Ply.List.iterSequentially writeDval (d1 :: d2 :: rest)) + do! w.writeArray (fun () -> Task.iterSequentially writeDval (d1 :: d2 :: rest)) - | DList(_, l) -> - do! w.writeArray (fun () -> Ply.List.iterSequentially writeDval l) + | DList(_, l) -> do! w.writeArray (fun () -> Task.iterSequentially writeDval l) | DDict(_typeArgsTODO, o) -> do! w.writeObject (fun () -> - Ply.List.iterSequentially + Task.iterSequentially (fun (k : string, v) -> - uply { + task { w.WritePropertyName k do! writeDval v }) @@ -148,9 +146,9 @@ let rec private toJsonV0 | DRecord(_, _, _typeArgsDEnum, fields) -> do! w.writeObject (fun () -> - Ply.List.iterSequentially + Task.iterSequentially (fun (k : string, v) -> - uply { + task { w.WritePropertyName k do! writeDval v }) @@ -162,8 +160,7 @@ let rec private toJsonV0 w.WritePropertyName caseName // TODO: this might be where the type args go? hmmm w.writeArray (fun () -> - fields - |> Ply.List.iterSequentially (fun fieldVal -> writeDval fieldVal))) + fields |> Task.iterSequentially (fun fieldVal -> writeDval fieldVal))) // Blobs serialize as a hash-reference JSON envelope; bytes stay @@ -172,7 +169,7 @@ let rec private toJsonV0 | DBlob(Persistent(hash, length)) -> do! w.writeObject (fun () -> - uply { + task { w.WritePropertyName "type" w.WriteStringValue "blob" w.WritePropertyName "hash" @@ -201,7 +198,7 @@ let toJsonStringV0 (types : Types) (threadID : ThreadID) (dval : Dval) - : Ply = + : Task = writeJson (fun w -> toJsonV0 w threadID types dval) @@ -211,58 +208,59 @@ let parseJsonV0 (tst : TypeSymbolTable) (typ : TypeReference) (str : string) - : Ply = - let rec convert (typ : TypeReference) (j : JsonElement) : Ply = + : Task = + let rec convert (typ : TypeReference) (j : JsonElement) : Task = match typ, j.ValueKind with // simple cases - | TUnit, JsonValueKind.Number -> DUnit |> Ply - - | TBool, JsonValueKind.True -> DBool true |> Ply - | TBool, JsonValueKind.False -> DBool false |> Ply - - | TInt8, JsonValueKind.Number -> j.GetSByte() |> DInt8 |> Ply - | TUInt8, JsonValueKind.Number -> j.GetByte() |> DUInt8 |> Ply - | TInt16, JsonValueKind.Number -> j.GetInt16() |> DInt16 |> Ply - | TUInt16, JsonValueKind.Number -> j.GetUInt16() |> DUInt16 |> Ply - | TInt32, JsonValueKind.Number -> j.GetInt32() |> DInt32 |> Ply - | TUInt32, JsonValueKind.Number -> j.GetUInt32() |> DUInt32 |> Ply - | TInt64, JsonValueKind.Number -> j.GetInt64() |> DInt64 |> Ply - | TUInt64, JsonValueKind.Number -> j.GetUInt64() |> DUInt64 |> Ply + | TUnit, JsonValueKind.Number -> DUnit |> Task.FromResult + + | TBool, JsonValueKind.True -> DBool true |> Task.FromResult + | TBool, JsonValueKind.False -> DBool false |> Task.FromResult + + | TInt8, JsonValueKind.Number -> j.GetSByte() |> DInt8 |> Task.FromResult + | TUInt8, JsonValueKind.Number -> j.GetByte() |> DUInt8 |> Task.FromResult + | TInt16, JsonValueKind.Number -> j.GetInt16() |> DInt16 |> Task.FromResult + | TUInt16, JsonValueKind.Number -> j.GetUInt16() |> DUInt16 |> Task.FromResult + | TInt32, JsonValueKind.Number -> j.GetInt32() |> DInt32 |> Task.FromResult + | TUInt32, JsonValueKind.Number -> j.GetUInt32() |> DUInt32 |> Task.FromResult + | TInt64, JsonValueKind.Number -> j.GetInt64() |> DInt64 |> Task.FromResult + | TUInt64, JsonValueKind.Number -> j.GetUInt64() |> DUInt64 |> Task.FromResult | TInt128, JsonValueKind.Number -> - j.GetRawText() |> System.Int128.Parse |> DInt128 |> Ply + j.GetRawText() |> System.Int128.Parse |> DInt128 |> Task.FromResult | TUInt128, JsonValueKind.Number -> - j.GetRawText() |> System.UInt128.Parse |> DUInt128 |> Ply + j.GetRawText() |> System.UInt128.Parse |> DUInt128 |> Task.FromResult - | TFloat, JsonValueKind.Number -> j.GetDouble() |> DFloat |> Ply + | TFloat, JsonValueKind.Number -> j.GetDouble() |> DFloat |> Task.FromResult | TFloat, JsonValueKind.String -> match j.GetString() with | "NaN" -> DFloat System.Double.NaN | "Infinity" -> DFloat System.Double.PositiveInfinity | "-Infinity" -> DFloat System.Double.NegativeInfinity | v -> Exception.raiseInternal "Invalid float" [ "value", v ] - |> Ply + |> Task.FromResult - | TChar, JsonValueKind.String -> DChar(j.GetString()) |> Ply - | TString, JsonValueKind.String -> DString(j.GetString()) |> Ply + | TChar, JsonValueKind.String -> DChar(j.GetString()) |> Task.FromResult + | TString, JsonValueKind.String -> DString(j.GetString()) |> Task.FromResult - | TUuid, JsonValueKind.String -> DUuid(System.Guid(j.GetString())) |> Ply + | TUuid, JsonValueKind.String -> + DUuid(System.Guid(j.GetString())) |> Task.FromResult | TDateTime, JsonValueKind.String -> j.GetString() |> NodaTime.Instant.ofIsoString |> DarkDateTime.fromInstant |> DDateTime - |> Ply + |> Task.FromResult // nested structures | TTuple(t1, t2, rest), JsonValueKind.Array -> let arr = j.EnumerateArray() |> Seq.toList if List.length arr = 2 + List.length rest then - uply { + task { let! d1 = convert t1 arr[0] let! d2 = convert t2 arr[1] - let! rest = List.map2 convert rest arr[2..] |> Ply.List.flatten + let! rest = List.map2 convert rest arr[2..] |> Task.flatten return DTuple(d1, d2, rest) } else @@ -272,8 +270,8 @@ let parseJsonV0 j.EnumerateArray() |> Seq.map (convert nested) |> Seq.toList - |> Ply.List.flatten - |> Ply.map (TypeChecker.DvalCreator.list threadID VT.unknownTODO) + |> Task.flatten + |> Task.map (TypeChecker.DvalCreator.list threadID VT.unknownTODO) | TDict typ, JsonValueKind.Object -> let objFields = @@ -281,13 +279,13 @@ let parseJsonV0 objFields |> Map.toList - |> List.map (fun (k, v) -> convert typ v |> Ply.map (fun v -> k, v)) - |> Ply.List.flatten - |> Ply.map (TypeChecker.DvalCreator.dict threadID VT.unknownTODO) + |> List.map (fun (k, v) -> convert typ v |> Task.map (fun v -> k, v)) + |> Task.flatten + |> Task.map (TypeChecker.DvalCreator.dict threadID VT.unknownTODO) | TCustomType({ resolved = Ok typeName }, typeArgs), valueKind -> - uply { + task { match! Types.find types typeName with | None -> return Exception.raiseInternal "Type not found" [ "typeName", typeName ] @@ -314,8 +312,8 @@ let parseJsonV0 | None -> Exception.raiseInternal "Missing field" [ "field", f.name ] - dval |> Ply.map (fun dval -> f.name, dval)) - |> Ply.List.flatten + dval |> Task.map (fun dval -> f.name, dval)) + |> Task.flatten return! TypeChecker.DvalCreator.record @@ -354,7 +352,7 @@ let parseJsonV0 fields.EnumerateArray() |> Seq.map2 convert fieldTypes |> Seq.toList - |> Ply.List.flatten + |> Task.flatten let! enum = TypeChecker.DvalCreator.enum @@ -381,7 +379,7 @@ let parseJsonV0 // writer in toJsonV0. let hash = j.GetProperty("hash").GetString() let length = j.GetProperty("length").GetInt64() - DBlob(Persistent(hash, length)) |> Ply + DBlob(Persistent(hash, length)) |> Task.FromResult | TBlob, _ -> Exception.raiseInternal "Blob value must be a JSON object envelope" diff --git a/backend/src/LibCloud/Init.fs b/backend/src/LibCloud/Init.fs index be1528d1ad..8c31f4faea 100644 --- a/backend/src/LibCloud/Init.fs +++ b/backend/src/LibCloud/Init.fs @@ -1,7 +1,6 @@ module LibCloud.Init open System.Threading.Tasks -open FSharp.Control.Tasks open Prelude diff --git a/backend/src/LibCloud/Routing.fs b/backend/src/LibCloud/Routing.fs index b0ce1e3dc1..ad7ac67594 100644 --- a/backend/src/LibCloud/Routing.fs +++ b/backend/src/LibCloud/Routing.fs @@ -6,7 +6,6 @@ /// (i.e. if `/hello/:name` is defined, and you go to `/hello/john`) module LibCloud.Routing -open FSharp.Control.Tasks open System.Threading.Tasks open FSharpx diff --git a/backend/src/LibCloud/Secret.fs b/backend/src/LibCloud/Secret.fs index 01f9840834..8cc8bc1b60 100644 --- a/backend/src/LibCloud/Secret.fs +++ b/backend/src/LibCloud/Secret.fs @@ -2,7 +2,6 @@ module LibCloud.Secret open System.Threading.Tasks -open FSharp.Control.Tasks open Fumble open LibDB.Db diff --git a/backend/src/LibCloud/Stats.fs b/backend/src/LibCloud/Stats.fs index 26f6c3fc53..648d8efa2a 100644 --- a/backend/src/LibCloud/Stats.fs +++ b/backend/src/LibCloud/Stats.fs @@ -2,7 +2,6 @@ module LibCloud.Stats open System.Threading.Tasks -open FSharp.Control.Tasks open Microsoft.Data.Sqlite open Fumble diff --git a/backend/src/LibCloud/UserDB.fs b/backend/src/LibCloud/UserDB.fs index bc662e9798..b1518bb2e8 100644 --- a/backend/src/LibCloud/UserDB.fs +++ b/backend/src/LibCloud/UserDB.fs @@ -13,7 +13,6 @@ module LibCloud.UserDB open System.Threading.Tasks -open FSharp.Control.Tasks open Microsoft.Data.Sqlite open Fumble open LibDB.Db @@ -43,14 +42,14 @@ let rec dbToDval (tst : RT.TypeSymbolTable) (db : RT.DB.T) (dbValue : string) - : Ply = + : Task = DvalReprInternalQueryable.parseJsonV0 types threadID tst db.typ dbValue let dvalToDB (threadID : RT.ThreadID) (types : RT.Types) (dv : RT.Dval) - : Ply = + : Task = DvalReprInternalQueryable.toJsonStringV0 types threadID dv let rec set @@ -60,8 +59,8 @@ let rec set (db : RT.DB.T) (key : string) (dv : RT.Dval) - : Ply> = - uply { + : Task> = + task { let id = System.Guid.NewGuid() let types = exeState.types @@ -112,8 +111,8 @@ and getOption (threadID : RT.ThreadID) (db : RT.DB.T) (key : string) - : Ply> = - uply { + : Task> = + task { let types = exeState.types let! result = @@ -137,7 +136,7 @@ and getOption | None -> return None | Some dval -> let tst = Map.empty // OK? - return! dbToDval types threadID tst db dval |> Ply.map Some + return! dbToDval types threadID tst db dval |> Task.map Some } @@ -147,8 +146,8 @@ and getMany (tst : RT.TypeSymbolTable) (db : RT.DB.T) (keys : string list) - : Ply> = - uply { + : Task> = + task { let types = exeState.types // If no keys, return empty list early @@ -181,7 +180,7 @@ and getMany |> Sql.parameters (baseParams @ keyParams) |> Sql.executeAsync (fun read -> read.string "data") - return! result |> List.map (dbToDval types threadID tst db) |> Ply.List.flatten + return! result |> List.map (dbToDval types threadID tst db) |> Task.flatten } @@ -192,8 +191,8 @@ and getManyWithKeys (tst : RT.TypeSymbolTable) (db : RT.DB.T) (keys : string list) - : Ply> = - uply { + : Task> = + task { let types = exeState.types // If no keys, return empty list early @@ -229,8 +228,8 @@ and getManyWithKeys return! result |> List.map (fun (key, data) -> - dbToDval types threadID tst db data |> Ply.map (fun dval -> (key, dval))) - |> Ply.List.flatten + dbToDval types threadID tst db data |> Task.map (fun dval -> (key, dval))) + |> Task.flatten } @@ -240,8 +239,8 @@ let getAll (threadID : RT.ThreadID) (tst : RT.TypeSymbolTable) (db : RT.DB.T) - : Ply> = - uply { + : Task> = + task { let! result = Sql.query "SELECT key, data @@ -261,8 +260,8 @@ let getAll result |> List.map (fun (key, data) -> dbToDval exeState.types threadID tst db data - |> Ply.map (fun dval -> (key, dval))) - |> Ply.List.flatten + |> Task.map (fun dval -> (key, dval))) + |> Task.flatten } // // Reusable function that provides the template for the SqlCompiler query functions @@ -271,8 +270,8 @@ let getAll // (db : RT.DB.T) // (b : RT.LambdaImpl) // (queryFor : string) -// : Ply> = -// uply { +// : Task> = +// task { // let paramName = // match b.parameters with // | { head = RT.LPVariable(_, name); tail = [] } -> name @@ -309,8 +308,8 @@ let getAll // (exeState : RT.ExecutionState) // (db : RT.DB.T) // (b : RT.LambdaImpl) -// : Ply, RT.RuntimeError>> = -// uply { +// : Task, RT.RuntimeError>> = +// task { // let types = RT.ExecutionState.types exeState // let! query = doQuery exeState db b "key, data" @@ -325,20 +324,20 @@ let getAll // return! // results // |> List.map (fun (key, data) -> -// uply { +// task { // let! dval = dbToDval exeState.tracing.callStack types db data // return (key, dval) // }) -// |> Ply.List.flatten -// |> Ply.map Ok +// |> Task.flatten +// |> Task.map Ok // } // let queryValues // (exeState : RT.ExecutionState) // (db : RT.DB.T) // (b : RT.LambdaImpl) -// : Ply, RT.RuntimeError>> = -// uply { +// : Task, RT.RuntimeError>> = +// task { // let types = RT.ExecutionState.types exeState // let! query = doQuery exeState db b "data" @@ -350,16 +349,16 @@ let getAll // return! // results // |> List.map (dbToDval exeState.tracing.callStack types db) -// |> Ply.List.flatten -// |> Ply.map Ok +// |> Task.flatten +// |> Task.map Ok // } // let queryCount // (exeState : RT.ExecutionState) // (db : RT.DB.T) // (b : RT.LambdaImpl) -// : Ply> = -// uply { +// : Task> = +// task { // let! query = doQuery exeState db b "COUNT(*)" // match query with @@ -441,8 +440,8 @@ let deleteAll (exeState : RT.ExecutionState) (db : RT.DB.T) : Task = // let statsPluck // (canvasID : CanvasID) // (db : RT.DB.T) -// : Ply> = -// uply { +// : Task> = +// task { // let! result = // Sql.query // "SELECT data, key @@ -538,8 +537,8 @@ let executeCompiledQuery (queryType : DBQueryType) (compiledSql : string) (paramValues : List) - : Ply = - uply { + : Task = + task { let types = exeState.types let threadID = vm.threadID let tst = Map.empty // TODO: proper type symbol table @@ -549,22 +548,22 @@ let executeCompiledQuery let! paramBindings = paramValues |> List.mapi (fun i dv -> (i, dv)) - |> Ply.List.mapSequentially (fun (i, dv) -> - uply { + |> Task.mapSequentially (fun (i, dv) -> + task { let paramName = $"p{i + 1}" let! sqlValue = match dv with - | RT.DString s -> Ply(Sql.string s) - | RT.DInt64 n -> Ply(Sql.int64 n) - | RT.DFloat f -> Ply(Sql.double f) - | RT.DBool b -> Ply(Sql.bool b) - | RT.DUnit -> Ply(Sql.string "null") - | RT.DUuid u -> Ply(Sql.uuid u) + | RT.DString s -> Task.FromResult(Sql.string s) + | RT.DInt64 n -> Task.FromResult(Sql.int64 n) + | RT.DFloat f -> Task.FromResult(Sql.double f) + | RT.DBool b -> Task.FromResult(Sql.bool b) + | RT.DUnit -> Task.FromResult(Sql.string "null") + | RT.DUuid u -> Task.FromResult(Sql.uuid u) | RT.DDateTime dt -> - Ply(Sql.string (LibExecution.DarkDateTime.toIsoString dt)) + Task.FromResult(Sql.string (LibExecution.DarkDateTime.toIsoString dt)) | other -> // For complex types, convert to JSON string - uply { + task { let! json = dvalToDB threadID types other return Sql.string json } @@ -596,7 +595,7 @@ let executeCompiledQuery |> Sql.executeAsync (fun read -> read.string "data") let! dvals = - results |> List.map (dbToDval types threadID tst db) |> Ply.List.flatten + results |> List.map (dbToDval types threadID tst db) |> Task.flatten return dvals @@ -620,8 +619,8 @@ let executeCompiledQuery let! kvPairs = results |> List.map (fun (key, data) -> - dbToDval types threadID tst db data |> Ply.map (fun dval -> (key, dval))) - |> Ply.List.flatten + dbToDval types threadID tst db data |> Task.map (fun dval -> (key, dval))) + |> Task.flatten return LibExecution.TypeChecker.DvalCreator.dict diff --git a/backend/src/LibCloudExecution/CloudExecution.fs b/backend/src/LibCloudExecution/CloudExecution.fs index 0e2a886bf2..4882559923 100644 --- a/backend/src/LibCloudExecution/CloudExecution.fs +++ b/backend/src/LibCloudExecution/CloudExecution.fs @@ -3,7 +3,6 @@ /// Used by cloud services (bwdserver, etc.) module LibCloudExecution.CloudExecution -open FSharp.Control.Tasks open System.Threading.Tasks open Prelude @@ -40,22 +39,26 @@ let createState (tracing : RT.Tracing.Tracing) : Task = task { - let extraMetadata (state : RT.ExecutionState) (vm : RT.VMState) : Ply = - uply { + let extraMetadata + (state : RT.ExecutionState) + (vm : RT.VMState) + : Task = + task { let callStack = Exe.callStackFromVM vm let epToString ep = match ep with - | None -> Ply "None -- empty CallStack" + | None -> Task.FromResult "None -- empty CallStack" | Some ep -> Exe.executionPointToString state ep let! entrypoint = epToString (RT.CallStack.entrypoint callStack) let! lastCalled = epToString (RT.CallStack.last callStack) - return + let result : Metadata = [ ("entrypoint", entrypoint) ("lastCalled", lastCalled) ("traceID", traceID) ("canvasID", program.canvasID) ] + return result } let notify @@ -64,7 +67,7 @@ let createState (msg : string) (metadata : Metadata) = - uply { + task { let! extra = extraMetadata state vm let metadata = extra @ metadata print $"[notify] {msg}" @@ -77,7 +80,7 @@ let createState (metadata : Metadata) (exn : exn) = - uply { + task { let! extra = extraMetadata state vm let metadata = extra @ metadata printException "[exception]" metadata exn diff --git a/backend/src/LibCloudExecution/HttpClient.fs b/backend/src/LibCloudExecution/HttpClient.fs index 1e4aa4b28f..2a9ea31945 100644 --- a/backend/src/LibCloudExecution/HttpClient.fs +++ b/backend/src/LibCloudExecution/HttpClient.fs @@ -4,7 +4,6 @@ open System.IO open System.Net.Http open System.Threading.Tasks -open FSharp.Control.Tasks open Prelude open LibExecution diff --git a/backend/src/LibCloudExecution/Init.fs b/backend/src/LibCloudExecution/Init.fs index e8ef4d9147..fc974db04e 100644 --- a/backend/src/LibCloudExecution/Init.fs +++ b/backend/src/LibCloudExecution/Init.fs @@ -1,7 +1,6 @@ /// Initialize LibCloudExecution module LibCloudExecution.Init -open FSharp.Control.Tasks open System.Threading.Tasks open Prelude diff --git a/backend/src/LibDB/Db.fs b/backend/src/LibDB/Db.fs index 4fa1ecd32d..9caebebd1a 100644 --- a/backend/src/LibDB/Db.fs +++ b/backend/src/LibDB/Db.fs @@ -4,7 +4,6 @@ module LibDB.Db // To be reviewed by someone with more DB expertise. open System.Threading.Tasks -open FSharp.Control.Tasks open Microsoft.Data.Sqlite open Fumble @@ -43,7 +42,11 @@ module Sql = | Ok list -> return Exception.raiseInternal $"Too many results, expected 1" [ "actual", list ] - | Error err -> return Exception.raiseInternal "fail" [ "err", err ] + | Error err -> + return + Exception.raiseInternal + $"SQL query failed in executeRowAsync: {err.Message}" + [ "err", err ] } let executeRowOptionAsync @@ -59,7 +62,11 @@ module Sql = Exception.raiseInternal $"Too many results, expected 0 or 1" [ "actual", list ] - | Error err -> return Exception.raiseInternal "fail" [ "err", err ] + | Error err -> + return + Exception.raiseInternal + $"SQL query failed in executeRowOptionAsync: {err.Message}" + [ "err", err ] } let executeAsync rr props = @@ -178,8 +185,8 @@ type TableStatsRow = diskHuman : string rowsHuman : string } -let tableStats () : Ply> = - uply { +let tableStats () : Task> = + task { let! pageCount = Sql.query "PRAGMA page_count;" |> Sql.executeRowAsync (fun r -> r.int64 "page_count") @@ -203,8 +210,8 @@ let tableStats () : Ply> = let! rowCounts = tables - |> Ply.List.mapSequentially (fun table -> - uply { + |> Task.mapSequentially (fun table -> + task { let! rows = Sql.query $"SELECT COUNT(*) as count FROM \"{table}\";" |> Sql.executeRowAsync (fun read -> read.int64 "count") diff --git a/backend/src/LibExecution/Execution.fs b/backend/src/LibExecution/Execution.fs index f35e334739..1c4d13be8f 100644 --- a/backend/src/LibExecution/Execution.fs +++ b/backend/src/LibExecution/Execution.fs @@ -1,7 +1,6 @@ module LibExecution.Execution open System.Threading.Tasks -open FSharp.Control.Tasks open Prelude @@ -295,7 +294,7 @@ let dvalToTypeName (state : RT.ExecutionState) (dval : RT.Dval) : Task = // (state : RT.ExecutionState) // (expr : RT.Expr) // (id : Option) -// : Ply = +// : Task = // match id with // | None -> Ply "Unknown Expr" // | Some id -> @@ -314,8 +313,8 @@ let dvalToTypeName (state : RT.ExecutionState) (dval : RT.Dval) : Task = // expr // |> ignore -// let prettyPrint (expr : RT.Expr) : Ply = -// uply { +// let prettyPrint (expr : RT.Expr) : Task = +// task { // let fnName = // RT.FQFnName.fqPackage PackageRefs.Fn.PrettyPrinter.RuntimeTypes.expr // let args = NEList.singleton (RuntimeTypesToDarkTypes.Expr.toDT expr) @@ -327,7 +326,7 @@ let dvalToTypeName (state : RT.ExecutionState) (dval : RT.Dval) : Task = // match foundExpr with // | None -> -// uply { +// task { // let! pretty = prettyPrint expr // return $"Root Expr:\n{pretty}" // } @@ -337,11 +336,11 @@ let dvalToTypeName (state : RT.ExecutionState) (dval : RT.Dval) : Task = let executionPointToString (state : RT.ExecutionState) (ep : RT.ExecutionPoint) - : Ply = - uply { + : Task = + task { // CLEANUP improve here - // let handleFn (fn : Option) : Ply = - // uply { + // let handleFn (fn : Option) : Task = + // task { // match fn with // | None -> return $"" // | Some fn -> @@ -365,35 +364,37 @@ let executionPointToString /// - move this impl to darklang /// - consider accepting a VMState rather than the CallStack /// - generally tidy the output here +// Group consecutive identical entries with counts +let private groupConsecutiveWithCounts (parts : List) : List = + let rec groupConsecutive acc current count remaining = + match remaining with + | [] -> + // Add the final group + let countStr = if count = 1 then "" else $" (×{count})" + List.rev ((current + countStr) :: acc) + | head :: tail -> + if head = current then + // Same as current, increment count + groupConsecutive acc current (count + 1) tail + else + // Different, add current group and start new one + let countStr = if count = 1 then "" else $" (×{count})" + groupConsecutive ((current + countStr) :: acc) head 1 tail + + match parts with + | [] -> [] + | head :: tail -> groupConsecutive [] head 1 tail + let callStackString (state : RT.ExecutionState) (callStack : RT.CallStack) - : Ply = - uply { + : Task = + task { // First, convert all execution points to strings let! stringParts = - Ply.List.mapSequentially (fun ep -> executionPointToString state ep) callStack + Task.mapSequentially (fun ep -> executionPointToString state ep) callStack - // Group consecutive identical entries with counts - let rec groupConsecutive acc current count remaining = - match remaining with - | [] -> - // Add the final group - let countStr = if count = 1 then "" else $" (×{count})" - List.rev ((current + countStr) :: acc) - | head :: tail -> - if head = current then - // Same as current, increment count - groupConsecutive acc current (count + 1) tail - else - // Different, add current group and start new one - let countStr = if count = 1 then "" else $" (×{count})" - groupConsecutive ((current + countStr) :: acc) head 1 tail - - let groupedParts = - match stringParts with - | [] -> [] - | head :: tail -> groupConsecutive [] head 1 tail + let groupedParts = groupConsecutiveWithCounts stringParts // Build the final string let result = @@ -425,9 +426,9 @@ let rec rteToString (rteToDval : RT.RuntimeError.Error -> RT.Dval) (state : RT.ExecutionState) (rte : RT.RuntimeError.Error) - : Ply = + : Task = let r = rteToString rteToDval state - uply { + task { let errorMessageFn = RT.FQFnName.fqPackage ( PackageRefs.Fn.PrettyPrinter.RuntimeTypes.RuntimeError.toErrorMessage () diff --git a/backend/src/LibExecution/LibExecution.fsproj b/backend/src/LibExecution/LibExecution.fsproj index 49b504a52c..56f8c8120e 100644 --- a/backend/src/LibExecution/LibExecution.fsproj +++ b/backend/src/LibExecution/LibExecution.fsproj @@ -12,42 +12,20 @@ - - - - - - - + + + + - - - - - - - - - - - - - - - - - - - - - - - - - \ No newline at end of file + diff --git a/backend/src/LibExecution/paket.references b/backend/src/LibExecution/paket.references index 7c94307567..02a969583a 100644 --- a/backend/src/LibExecution/paket.references +++ b/backend/src/LibExecution/paket.references @@ -1,4 +1,3 @@ -Ply FSharp.Core FSharpPlus System.IO.Hashing \ No newline at end of file diff --git a/backend/src/LibHttpMiddleware/Http.fs b/backend/src/LibHttpMiddleware/Http.fs index 69f449a767..b82ee93c1e 100644 --- a/backend/src/LibHttpMiddleware/Http.fs +++ b/backend/src/LibHttpMiddleware/Http.fs @@ -53,8 +53,8 @@ module Response = let parseHttpResponseFields (state : RT.ExecutionState) (fields : Map) - : Ply = - uply { + : Task = + task { let code = Map.get "statusCode" fields let headers = Map.get "headers" fields let body = Map.get "body" fields @@ -127,7 +127,7 @@ module Response = match result with | RT.DRecord(RT.FQTypeName.Package hash, _, [], fields) -> if hash = RT.Hash(PackageRefs.Type.Stdlib.Http.response ()) then - return! parseHttpResponseFields state fields |> Ply.toTask + return! parseHttpResponseFields state fields else return! wrongTypeResponse state result diff --git a/backend/src/LibPackageManager/BranchOpPlayback.fs b/backend/src/LibPackageManager/BranchOpPlayback.fs index 5491e5c38f..20a3a5b8e5 100644 --- a/backend/src/LibPackageManager/BranchOpPlayback.fs +++ b/backend/src/LibPackageManager/BranchOpPlayback.fs @@ -1,7 +1,6 @@ module LibPackageManager.BranchOpPlayback open System.Threading.Tasks -open FSharp.Control.Tasks open Prelude open LibExecution.ProgramTypes diff --git a/backend/src/LibPackageManager/Branches.fs b/backend/src/LibPackageManager/Branches.fs index 90ed2dac86..6b13effc14 100644 --- a/backend/src/LibPackageManager/Branches.fs +++ b/backend/src/LibPackageManager/Branches.fs @@ -1,7 +1,6 @@ module LibPackageManager.Branches open System.Threading.Tasks -open FSharp.Control.Tasks open Prelude open LibExecution.ProgramTypes diff --git a/backend/src/LibPackageManager/Caching.fs b/backend/src/LibPackageManager/Caching.fs index b984c97fb5..7c51250386 100644 --- a/backend/src/LibPackageManager/Caching.fs +++ b/backend/src/LibPackageManager/Caching.fs @@ -1,16 +1,15 @@ module LibPackageManager.Caching open System.Threading.Tasks -open FSharp.Control.Tasks open System.Collections.Concurrent open Prelude -let withCache (f : 'key -> Ply>) = +let withCache (f : 'key -> Task>) = let cache = ConcurrentDictionary<'key, 'value>() fun (key : 'key) -> - uply { + task { let mutable cached = Unchecked.defaultof<'value> let inCache = cache.TryGetValue(key, &cached) if inCache then diff --git a/backend/src/LibPackageManager/DeferredResolver.fs b/backend/src/LibPackageManager/DeferredResolver.fs index 936afef46c..d03901cabf 100644 --- a/backend/src/LibPackageManager/DeferredResolver.fs +++ b/backend/src/LibPackageManager/DeferredResolver.fs @@ -9,6 +9,8 @@ /// it resolves Error names to Ok via PM lookups. module LibPackageManager.DeferredResolver +open System.Threading.Tasks + open Prelude open LibExecution.ProgramTypes @@ -67,18 +69,18 @@ let private reResolveNameResolution (branchId : PT.BranchId) (contextModules : List) (nr : PT.NameResolution<'a>) - (findInPM : (PT.BranchId * PT.PackageLocation) -> Ply>) + (findInPM : (PT.BranchId * PT.PackageLocation) -> Task>) (makePackage : Hash -> 'a) (parseName : string -> Result) - : Ply> = + : Task> = match nr.resolved with - | Ok _ -> Ply nr - | Error PT.NameResolutionError.InvalidName -> Ply nr + | Ok _ -> Task.FromResult nr + | Error PT.NameResolutionError.InvalidName -> Task.FromResult nr | Error PT.NameResolutionError.NotFound -> match List.splitLast nr.originalName with - | None -> Ply nr + | None -> Task.FromResult nr | Some(modules, lastName) -> - uply { + task { match parseName lastName with | Error _ -> return nr | Ok(name, version) -> @@ -88,12 +90,12 @@ let private reResolveNameResolution let candidates = namesToTry contextModules genericName let! result = - Ply.List.foldSequentially + Task.foldSequentially (fun acc (candidate : GenericName) -> match acc with - | Some _ -> Ply acc + | Some _ -> Task.FromResult acc | None -> - uply { + task { match candidate.modules with | [] -> return None | owner :: mods -> @@ -120,9 +122,9 @@ let private reResolveNameResolution let private reResolveTypeName (branchId : PT.BranchId) (contextModules : List) - (findType : (PT.BranchId * PT.PackageLocation) -> Ply>) + (findType : (PT.BranchId * PT.PackageLocation) -> Task>) (nr : PT.NameResolution) - : Ply> = + : Task> = reResolveNameResolution branchId contextModules @@ -135,9 +137,9 @@ let private reResolveTypeName let private reResolveFnName (branchId : PT.BranchId) (contextModules : List) - (findFn : (PT.BranchId * PT.PackageLocation) -> Ply>) + (findFn : (PT.BranchId * PT.PackageLocation) -> Task>) (nr : PT.NameResolution) - : Ply> = + : Task> = reResolveNameResolution branchId contextModules @@ -150,9 +152,9 @@ let private reResolveFnName let private reResolveValueName (branchId : PT.BranchId) (contextModules : List) - (findValue : (PT.BranchId * PT.PackageLocation) -> Ply>) + (findValue : (PT.BranchId * PT.PackageLocation) -> Task>) (nr : PT.NameResolution) - : Ply> = + : Task> = reResolveNameResolution branchId contextModules @@ -169,8 +171,8 @@ let rec private reResolveTypeRef (contextModules : List) (pm : PT.PackageManager) (typeRef : PT.TypeReference) - : Ply = - uply { + : Task = + task { match typeRef with | PT.TUnit | PT.TBool @@ -212,20 +214,20 @@ let rec private reResolveTypeRef let! first = reResolveTypeRef branchId contextModules pm first let! second = reResolveTypeRef branchId contextModules pm second let! rest = - Ply.List.mapSequentially (reResolveTypeRef branchId contextModules pm) rest + Task.mapSequentially (reResolveTypeRef branchId contextModules pm) rest return PT.TTuple(first, second, rest) | PT.TCustomType(nr, typeArgs) -> let! nr = reResolveTypeName branchId contextModules pm.findType nr let! typeArgs = - Ply.List.mapSequentially - (reResolveTypeRef branchId contextModules pm) - typeArgs + Task.mapSequentially (reResolveTypeRef branchId contextModules pm) typeArgs return PT.TCustomType(nr, typeArgs) | PT.TFn(args, ret) -> let! args = - Ply.NEList.mapSequentially (reResolveTypeRef branchId contextModules pm) args + Task.NEList.mapSequentially + (reResolveTypeRef branchId contextModules pm) + args let! ret = reResolveTypeRef branchId contextModules pm ret return PT.TFn(args, ret) } @@ -238,8 +240,8 @@ let rec private reResolveStringSegment (contextModules : List) (pm : PT.PackageManager) (segment : PT.StringSegment) - : Ply = - uply { + : Task = + task { match segment with | PT.StringText _ -> return segment | PT.StringInterpolation expr -> @@ -255,16 +257,16 @@ and private reResolveMatchCase (contextModules : List) (pm : PT.PackageManager) (case : PT.MatchCase) - : Ply = - uply { + : Task = + task { let! whenCondition = match case.whenCondition with | Some expr -> - uply { + task { let! e = reResolveExpr branchId contextModules pm expr return Some e } - | None -> Ply None + | None -> Task.FromResult None let! rhs = reResolveExpr branchId contextModules pm case.rhs return { pat = case.pat; whenCondition = whenCondition; rhs = rhs } @@ -278,8 +280,8 @@ and private reResolvePipeExpr (contextModules : List) (pm : PT.PackageManager) (pipeExpr : PT.PipeExpr) - : Ply = - uply { + : Task = + task { match pipeExpr with | PT.EPipeLambda(id, pats, body) -> let! body = reResolveExpr branchId contextModules pm body @@ -292,22 +294,20 @@ and private reResolvePipeExpr | PT.EPipeFnCall(id, nr, typeArgs, args) -> let! nr = reResolveFnName branchId contextModules pm.findFn nr let! typeArgs = - Ply.List.mapSequentially - (reResolveTypeRef branchId contextModules pm) - typeArgs + Task.mapSequentially (reResolveTypeRef branchId contextModules pm) typeArgs let! args = - Ply.List.mapSequentially (reResolveExpr branchId contextModules pm) args + Task.mapSequentially (reResolveExpr branchId contextModules pm) args return PT.EPipeFnCall(id, nr, typeArgs, args) | PT.EPipeEnum(id, nr, caseName, fields) -> let! nr = reResolveTypeName branchId contextModules pm.findType nr let! fields = - Ply.List.mapSequentially (reResolveExpr branchId contextModules pm) fields + Task.mapSequentially (reResolveExpr branchId contextModules pm) fields return PT.EPipeEnum(id, nr, caseName, fields) | PT.EPipeVariable(id, varName, args) -> let! args = - Ply.List.mapSequentially (reResolveExpr branchId contextModules pm) args + Task.mapSequentially (reResolveExpr branchId contextModules pm) args return PT.EPipeVariable(id, varName, args) } @@ -319,8 +319,8 @@ and private reResolveExpr (contextModules : List) (pm : PT.PackageManager) (expr : PT.Expr) - : Ply = - uply { + : Task = + task { match expr with | PT.EUnit _ | PT.EBool _ @@ -342,7 +342,7 @@ and private reResolveExpr | PT.EString(id, segments) -> let! segments = - Ply.List.mapSequentially + Task.mapSequentially (reResolveStringSegment branchId contextModules pm) segments return PT.EString(id, segments) @@ -353,25 +353,23 @@ and private reResolveExpr let! elseExpr = match elseExpr with | Some e -> - uply { + task { let! e = reResolveExpr branchId contextModules pm e return Some e } - | None -> Ply None + | None -> Task.FromResult None return PT.EIf(id, cond, thenExpr, elseExpr) | PT.EPipe(id, lhs, parts) -> let! lhs = reResolveExpr branchId contextModules pm lhs let! parts = - Ply.List.mapSequentially (reResolvePipeExpr branchId contextModules pm) parts + Task.mapSequentially (reResolvePipeExpr branchId contextModules pm) parts return PT.EPipe(id, lhs, parts) | PT.EMatch(id, arg, cases) -> let! arg = reResolveExpr branchId contextModules pm arg let! cases = - Ply.List.mapSequentially - (reResolveMatchCase branchId contextModules pm) - cases + Task.mapSequentially (reResolveMatchCase branchId contextModules pm) cases return PT.EMatch(id, arg, cases) | PT.ELet(id, pat, value, body) -> @@ -381,14 +379,14 @@ and private reResolveExpr | PT.EList(id, items) -> let! items = - Ply.List.mapSequentially (reResolveExpr branchId contextModules pm) items + Task.mapSequentially (reResolveExpr branchId contextModules pm) items return PT.EList(id, items) | PT.EDict(id, pairs) -> let! pairs = - Ply.List.mapSequentially + Task.mapSequentially (fun (k, v) -> - uply { + task { let! v = reResolveExpr branchId contextModules pm v return (k, v) }) @@ -399,17 +397,15 @@ and private reResolveExpr let! first = reResolveExpr branchId contextModules pm first let! second = reResolveExpr branchId contextModules pm second let! rest = - Ply.List.mapSequentially (reResolveExpr branchId contextModules pm) rest + Task.mapSequentially (reResolveExpr branchId contextModules pm) rest return PT.ETuple(id, first, second, rest) | PT.EApply(id, fnExpr, typeArgs, args) -> let! fnExpr = reResolveExpr branchId contextModules pm fnExpr let! typeArgs = - Ply.List.mapSequentially - (reResolveTypeRef branchId contextModules pm) - typeArgs + Task.mapSequentially (reResolveTypeRef branchId contextModules pm) typeArgs let! args = - Ply.NEList.mapSequentially (reResolveExpr branchId contextModules pm) args + Task.NEList.mapSequentially (reResolveExpr branchId contextModules pm) args return PT.EApply(id, fnExpr, typeArgs, args) | PT.EFnName(id, nr) -> @@ -428,13 +424,11 @@ and private reResolveExpr | PT.ERecord(id, nr, typeArgs, fields) -> let! nr = reResolveTypeName branchId contextModules pm.findType nr let! typeArgs = - Ply.List.mapSequentially - (reResolveTypeRef branchId contextModules pm) - typeArgs + Task.mapSequentially (reResolveTypeRef branchId contextModules pm) typeArgs let! fields = - Ply.List.mapSequentially + Task.mapSequentially (fun (name, expr) -> - uply { + task { let! expr = reResolveExpr branchId contextModules pm expr return (name, expr) }) @@ -448,9 +442,9 @@ and private reResolveExpr | PT.ERecordUpdate(id, record, updates) -> let! record = reResolveExpr branchId contextModules pm record let! updates = - Ply.NEList.mapSequentially + Task.NEList.mapSequentially (fun (name, expr) -> - uply { + task { let! expr = reResolveExpr branchId contextModules pm expr return (name, expr) }) @@ -460,11 +454,9 @@ and private reResolveExpr | PT.EEnum(id, nr, typeArgs, caseName, fields) -> let! nr = reResolveTypeName branchId contextModules pm.findType nr let! typeArgs = - Ply.List.mapSequentially - (reResolveTypeRef branchId contextModules pm) - typeArgs + Task.mapSequentially (reResolveTypeRef branchId contextModules pm) typeArgs let! fields = - Ply.List.mapSequentially (reResolveExpr branchId contextModules pm) fields + Task.mapSequentially (reResolveExpr branchId contextModules pm) fields return PT.EEnum(id, nr, typeArgs, caseName, fields) | PT.EValue(id, nr) -> @@ -485,8 +477,8 @@ let private reResolveTypeDefinition (contextModules : List) (pm : PT.PackageManager) (def : PT.TypeDeclaration.Definition) - : Ply = - uply { + : Task = + task { match def with | PT.TypeDeclaration.Alias typeRef -> let! typeRef = reResolveTypeRef branchId contextModules pm typeRef @@ -494,9 +486,9 @@ let private reResolveTypeDefinition | PT.TypeDeclaration.Record fields -> let! fields = - Ply.NEList.mapSequentially + Task.NEList.mapSequentially (fun (f : PT.TypeDeclaration.RecordField) -> - uply { + task { let! typ = reResolveTypeRef branchId contextModules pm f.typ return { f with typ = typ } }) @@ -505,13 +497,13 @@ let private reResolveTypeDefinition | PT.TypeDeclaration.Enum cases -> let! cases = - Ply.NEList.mapSequentially + Task.NEList.mapSequentially (fun (c : PT.TypeDeclaration.EnumCase) -> - uply { + task { let! fields = - Ply.List.mapSequentially + Task.mapSequentially (fun (f : PT.TypeDeclaration.EnumField) -> - uply { + task { let! typ = reResolveTypeRef branchId contextModules pm f.typ return { f with typ = typ } }) @@ -534,10 +526,10 @@ let reResolveType (owner : string) (modules : List) (t : PT.PackageType.PackageType) - : Ply = + : Task = let contextModules = owner :: modules - uply { + task { let! definition = reResolveTypeDefinition branchId contextModules pm t.declaration.definition @@ -552,16 +544,16 @@ let reResolveFn (owner : string) (modules : List) (f : PT.PackageFn.PackageFn) - : Ply = + : Task = let contextModules = owner :: modules - uply { + task { let! body = reResolveExpr branchId contextModules pm f.body let! parameters = - Ply.NEList.mapSequentially + Task.NEList.mapSequentially (fun (p : PT.PackageFn.Parameter) -> - uply { + task { let! typ = reResolveTypeRef branchId contextModules pm p.typ return { p with typ = typ } }) @@ -580,10 +572,10 @@ let reResolveValue (owner : string) (modules : List) (v : PT.PackageValue.PackageValue) - : Ply = + : Task = let contextModules = owner :: modules - uply { + task { let! body = reResolveExpr branchId contextModules pm v.body return { v with body = body } } diff --git a/backend/src/LibPackageManager/Inserts.fs b/backend/src/LibPackageManager/Inserts.fs index 1ab1c8d0c8..0281afd5bb 100644 --- a/backend/src/LibPackageManager/Inserts.fs +++ b/backend/src/LibPackageManager/Inserts.fs @@ -1,7 +1,6 @@ module LibPackageManager.Inserts open System.Threading.Tasks -open FSharp.Control.Tasks open Prelude open LibExecution.ProgramTypes diff --git a/backend/src/LibPackageManager/Merge.fs b/backend/src/LibPackageManager/Merge.fs index 88861f9bb1..948b3bd9f1 100644 --- a/backend/src/LibPackageManager/Merge.fs +++ b/backend/src/LibPackageManager/Merge.fs @@ -1,7 +1,6 @@ module LibPackageManager.Merge open System.Threading.Tasks -open FSharp.Control.Tasks open Prelude open LibExecution.ProgramTypes diff --git a/backend/src/LibPackageManager/PackageManager.fs b/backend/src/LibPackageManager/PackageManager.fs index 3b90478a32..02e15f846c 100644 --- a/backend/src/LibPackageManager/PackageManager.fs +++ b/backend/src/LibPackageManager/PackageManager.fs @@ -1,5 +1,7 @@ module LibPackageManager.PackageManager +open System.Threading.Tasks + open Prelude open LibExecution.ProgramTypes @@ -48,10 +50,11 @@ let rt : RT.PackageManager = persistBlob = PMRT.Blob.insert isHarmful = - fun branchId (RT.Hash h) -> Ply(Set.contains h (loadHarmfulForBranch branchId)) + fun branchId (RT.Hash h) -> + Task.FromResult(Set.contains h (loadHarmfulForBranch branchId)) init = - uply { + task { //eagerLoad return () } } @@ -98,7 +101,7 @@ let pt : PT.PackageManager = let chain = getBranchChain branchId PMPT.search chain query - init = uply { return () } } + init = task { return () } } /// Create an in-memory PackageManager from a list of PackageOps. @@ -229,20 +232,23 @@ let createInMemory (ops : List) : PT.PackageManager = Map.add id (loc :: existing) acc) Map.empty - { findType = fun (_, loc) -> Ply(Map.tryFind loc typeLocMap) - findValue = fun (_, loc) -> Ply(Map.tryFind loc valueLocMap) - findFn = fun (_, loc) -> Ply(Map.tryFind loc fnLocMap) + { findType = fun (_, loc) -> Task.FromResult(Map.tryFind loc typeLocMap) + findValue = fun (_, loc) -> Task.FromResult(Map.tryFind loc valueLocMap) + findFn = fun (_, loc) -> Task.FromResult(Map.tryFind loc fnLocMap) - getType = fun id -> Ply(Map.tryFind id typeMap) - getValue = fun id -> Ply(Map.tryFind id valueMap) - getFn = fun id -> Ply(Map.tryFind id fnMap) + getType = fun id -> Task.FromResult(Map.tryFind id typeMap) + getValue = fun id -> Task.FromResult(Map.tryFind id valueMap) + getFn = fun id -> Task.FromResult(Map.tryFind id fnMap) getTypeLocations = - fun _branchId id -> Ply(Map.tryFind id typeIdToLocs |> Option.defaultValue []) + fun _branchId id -> + Task.FromResult(Map.tryFind id typeIdToLocs |> Option.defaultValue []) getValueLocations = - fun _branchId id -> Ply(Map.tryFind id valueIdToLocs |> Option.defaultValue []) + fun _branchId id -> + Task.FromResult(Map.tryFind id valueIdToLocs |> Option.defaultValue []) getFnLocations = - fun _branchId id -> Ply(Map.tryFind id fnIdToLocs |> Option.defaultValue []) + fun _branchId id -> + Task.FromResult(Map.tryFind id fnIdToLocs |> Option.defaultValue []) // no need to support this for in-memory. search = @@ -276,13 +282,13 @@ let createInMemory (ops : List) : PT.PackageManager = Option.Some({ entity = f; location = loc } : PT.LocatedItem<_>) | [] -> Option.None) - Ply + Task.FromResult { PT.Search.SearchResults.submodules = [] types = typesWithLocs values = valuesWithLocs fns = fnsWithLocs } - init = uply { return () } } + init = task { return () } } /// Combine two PackageManagers: check `overlay` first, then fall back to `fallback`. @@ -293,7 +299,7 @@ let combine : PT.PackageManager = { findType = fun (branchId, loc) -> - uply { + task { match! overlay.findType (branchId, loc) with | Some id -> return Some id | None -> return! fallback.findType (branchId, loc) @@ -301,7 +307,7 @@ let combine findValue = fun (branchId, loc) -> - uply { + task { match! overlay.findValue (branchId, loc) with | Some id -> return Some id | None -> return! fallback.findValue (branchId, loc) @@ -309,7 +315,7 @@ let combine findFn = fun (branchId, loc) -> - uply { + task { match! overlay.findFn (branchId, loc) with | Some id -> return Some id | None -> return! fallback.findFn (branchId, loc) @@ -317,7 +323,7 @@ let combine getType = fun id -> - uply { + task { match! overlay.getType id with | Some t -> return Some t | None -> return! fallback.getType id @@ -325,7 +331,7 @@ let combine getValue = fun id -> - uply { + task { match! overlay.getValue id with | Some v -> return Some v | None -> return! fallback.getValue id @@ -333,7 +339,7 @@ let combine getFn = fun id -> - uply { + task { match! overlay.getFn id with | Some f -> return Some f | None -> return! fallback.getFn id @@ -341,7 +347,7 @@ let combine getTypeLocations = fun branchId id -> - uply { + task { let! overlayLocs = overlay.getTypeLocations branchId id let! fallbackLocs = fallback.getTypeLocations branchId id return overlayLocs @ fallbackLocs @@ -349,7 +355,7 @@ let combine getValueLocations = fun branchId id -> - uply { + task { let! overlayLocs = overlay.getValueLocations branchId id let! fallbackLocs = fallback.getValueLocations branchId id return overlayLocs @ fallbackLocs @@ -357,7 +363,7 @@ let combine getFnLocations = fun branchId id -> - uply { + task { let! overlayLocs = overlay.getFnLocations branchId id let! fallbackLocs = fallback.getFnLocations branchId id return overlayLocs @ fallbackLocs @@ -365,21 +371,24 @@ let combine search = fun (branchId, query) -> - uply { + task { // Combine search results from both - let! overlayResults = overlay.search (branchId, query) - let! fallbackResults = fallback.search (branchId, query) + let! (overlayResults : PT.Search.SearchResults) = + overlay.search (branchId, query) + let! (fallbackResults : PT.Search.SearchResults) = + fallback.search (branchId, query) - return - { PT.Search.SearchResults.submodules = + let combined : PT.Search.SearchResults = + { submodules = List.append overlayResults.submodules fallbackResults.submodules types = List.append overlayResults.types fallbackResults.types values = List.append overlayResults.values fallbackResults.values fns = List.append overlayResults.fns fallbackResults.fns } + return combined } init = - uply { + task { do! overlay.init do! fallback.init } } diff --git a/backend/src/LibPackageManager/PackageOpPlayback.fs b/backend/src/LibPackageManager/PackageOpPlayback.fs index 2ee10a1ed0..962811a258 100644 --- a/backend/src/LibPackageManager/PackageOpPlayback.fs +++ b/backend/src/LibPackageManager/PackageOpPlayback.fs @@ -5,7 +5,6 @@ module LibPackageManager.PackageOpPlayback open System.Threading.Tasks -open FSharp.Control.Tasks open Prelude open LibExecution.ProgramTypes diff --git a/backend/src/LibPackageManager/PackageRefsGenerator.fs b/backend/src/LibPackageManager/PackageRefsGenerator.fs index 3f318f0e1e..fbbe8ff7d9 100644 --- a/backend/src/LibPackageManager/PackageRefsGenerator.fs +++ b/backend/src/LibPackageManager/PackageRefsGenerator.fs @@ -2,6 +2,8 @@ /// PackageRefs.fs reads this file at startup. module LibPackageManager.PackageRefsGenerator +open System.Threading.Tasks + open Prelude open Fumble @@ -19,17 +21,14 @@ let private buildKey (itemType : string) (modules : string) (name : string) = /// Path to the source-tree copy of the hash file (committed to git). let private sourceTreePath = - System.IO.Path.Combine( - __SOURCE_DIRECTORY__, - "../LibExecution/package-ref-hashes.txt" - ) + System.IO.Path.Combine(__SOURCE_DIRECTORY__, "../Language/package-ref-hashes.txt") |> System.IO.Path.GetFullPath /// Query the DB for all current Darklang-owned locations and write /// `package-ref-hashes.txt` in the source tree. -let generate () : Ply = - uply { +let generate () : Task = + task { // Collect all referenced items from PackageRefs _lookup maps let typeRefKeys = PackageRefs.Type._lookup diff --git a/backend/src/LibPackageManager/ProgramTypes.fs b/backend/src/LibPackageManager/ProgramTypes.fs index fd1de3f268..d832be7bf7 100644 --- a/backend/src/LibPackageManager/ProgramTypes.fs +++ b/backend/src/LibPackageManager/ProgramTypes.fs @@ -1,7 +1,6 @@ module LibPackageManager.ProgramTypes open System.Threading.Tasks -open FSharp.Control.Tasks open Prelude open LibExecution.ProgramTypes @@ -54,8 +53,8 @@ let private findItem (itemType : string) (branchChain : List) (location : PT.PackageLocation) - : Ply> = - uply { + : Task> = + task { let modulesStr = String.concat "." location.modules let (branchFilter, branchParams) = buildBranchFilter branchChain let orderBy = buildBranchOrderBy branchChain @@ -88,8 +87,8 @@ let private getItem<'a> (lookupColumn : string) (deserialize : Hash -> byte[] -> 'a) (hash : Hash) - : Ply> = - uply { + : Task> = + task { let (Hash hashStr) = hash return! Sql.query @@ -107,8 +106,8 @@ let private getItemLocations (itemType : string) (branchChain : List) (hash : Hash) - : Ply> = - uply { + : Task> = + task { let (Hash hashStr) = hash let (branchFilter, branchParams) = buildBranchFilter branchChain let orderBy = buildBranchOrderBy branchChain @@ -152,8 +151,8 @@ module Fn = let search (branchChain : List) (query : PT.Search.SearchQuery) - : Ply = - uply { + : Task = + task { let currentModule = String.concat "." query.currentModule let (branchFilter, branchParams) = buildBranchFilter branchChain @@ -298,5 +297,7 @@ let search else Task.FromResult>> [] - return { submodules = submodules; types = types; values = values; fns = fns } + let result : PT.Search.SearchResults = + { submodules = submodules; types = types; values = values; fns = fns } + return result } diff --git a/backend/src/LibPackageManager/Propagation.fs b/backend/src/LibPackageManager/Propagation.fs index 9026d2d91b..b4debb544f 100644 --- a/backend/src/LibPackageManager/Propagation.fs +++ b/backend/src/LibPackageManager/Propagation.fs @@ -3,7 +3,6 @@ module LibPackageManager.Propagation open System.Threading.Tasks -open FSharp.Control.Tasks open Prelude open LibExecution.ProgramTypes @@ -22,8 +21,8 @@ type PropagationResult = /// Item-specific operations for retrieving, transforming, and creating ops type private ItemProcessingContext<'T> = { itemKind : PT.ItemKind - getItem : Hash -> Ply> // Given a Hash, fetch the full item definition - getLocations : Hash -> Ply> // Given a Hash, look up the item's PackageLocations + getItem : Hash -> Task> // Given a Hash, fetch the full item definition + getLocations : Hash -> Task> // Given a Hash, look up the item's PackageLocations transform : Map -> 'T -> 'T // Transforms the item by replacing old hashes with new hashes based on the mapping computeHash : 'T -> Hash // Compute hash for the transformed item withNewId : Hash -> 'T -> 'T // Assigns a new Hash to the item @@ -108,53 +107,53 @@ let private processItem<'T> /// Phase 1: Discover all items that need to be updated (transitive dependents) +let rec private discoverDependentsLoop + (branchChain : List) + (pending : List) + (processed : Set) + (accumulated : List) + : Task> = + task { + // filter out any pending hashes that are already processed + let toProcess = + pending |> List.filter (fun id -> not (Set.contains id processed)) + + match toProcess with + | [] -> return accumulated + | _ -> + // Add all toProcess hashes to the processed set so we won't visit them again + let newProcessed = + toProcess |> List.fold (fun acc id -> Set.add id acc) processed + + // for all these hashes, find every item that depends on any of them + let! batchDependents = PMQueries.getDependentsBatch branchChain toProcess + + // Filter the batch results: + // - Remove any that are already in the processed set (no cycles) + // - Deduplicate by itemHash + // - Convert to PackageDep { itemHash, itemKind } + let newDeps = + batchDependents + |> List.filter (fun d -> not (Set.contains d.itemHash newProcessed)) + |> List.distinctBy (fun d -> d.itemHash) + |> List.map (fun (d : PMQueries.BatchDependent) -> + { PMQueries.itemHash = d.itemHash; PMQueries.itemKind = d.itemKind }) + + let newPending = newDeps |> List.map (fun d -> d.itemHash) + let newAccumulated = accumulated @ newDeps + + return! + discoverDependentsLoop branchChain newPending newProcessed newAccumulated + } + let private discoverDependents (branchChain : List) (fromSourceHashes : List) (toSourceHash : Hash) : Task> = - task { - let rec loop - (pending : List) - (processed : Set) - (accumulated : List) - = - task { - // filter out any pending hashes that are already processed - let toProcess = - pending |> List.filter (fun id -> not (Set.contains id processed)) - - match toProcess with - | [] -> return accumulated - | _ -> - // Add all toProcess hashes to the processed set so we won't visit them again - let newProcessed = - toProcess |> List.fold (fun acc id -> Set.add id acc) processed - - // for all these hashes, find every item that depends on any of them - let! batchDependents = PMQueries.getDependentsBatch branchChain toProcess - - // Filter the batch results: - // - Remove any that are already in the processed set (no cycles) - // - Deduplicate by itemHash - // - Convert to PackageDep { itemHash, itemKind } - let newDeps = - batchDependents - |> List.filter (fun d -> not (Set.contains d.itemHash newProcessed)) - |> List.distinctBy (fun d -> d.itemHash) - |> List.map (fun (d : PMQueries.BatchDependent) -> - { PMQueries.itemHash = d.itemHash; PMQueries.itemKind = d.itemKind }) - - let newPending = newDeps |> List.map (fun d -> d.itemHash) - let newAccumulated = accumulated @ newDeps - - return! loop newPending newProcessed newAccumulated - } - - // Start with fromSourceHashes as pending, toSourceHash already processed - // (we don't want the source to be included as a dependent) - return! loop fromSourceHashes (Set.singleton toSourceHash) [] - } + // Start with fromSourceHashes as pending, toSourceHash already processed + // (we don't want the source to be included as a dependent) + discoverDependentsLoop branchChain fromSourceHashes (Set.singleton toSourceHash) [] /// Check if source item needs to be updated (for mutual recursion) diff --git a/backend/src/LibPackageManager/Purge.fs b/backend/src/LibPackageManager/Purge.fs index 3552927557..8127f2dce5 100644 --- a/backend/src/LibPackageManager/Purge.fs +++ b/backend/src/LibPackageManager/Purge.fs @@ -1,7 +1,6 @@ module LibPackageManager.Purge open System.Threading.Tasks -open FSharp.Control.Tasks open System.Collections.Concurrent open Prelude diff --git a/backend/src/LibPackageManager/Queries.fs b/backend/src/LibPackageManager/Queries.fs index f7f900867d..f66c633441 100644 --- a/backend/src/LibPackageManager/Queries.fs +++ b/backend/src/LibPackageManager/Queries.fs @@ -1,7 +1,6 @@ module LibPackageManager.Queries open System.Threading.Tasks -open FSharp.Control.Tasks open Prelude open LibExecution.ProgramTypes diff --git a/backend/src/LibPackageManager/Rebase.fs b/backend/src/LibPackageManager/Rebase.fs index 45084e2bf9..9fc9dd5ec9 100644 --- a/backend/src/LibPackageManager/Rebase.fs +++ b/backend/src/LibPackageManager/Rebase.fs @@ -1,7 +1,6 @@ module LibPackageManager.Rebase open System.Threading.Tasks -open FSharp.Control.Tasks open Prelude open LibExecution.ProgramTypes diff --git a/backend/src/LibPackageManager/RuntimeTypes.fs b/backend/src/LibPackageManager/RuntimeTypes.fs index 869f383d69..c19f0fd5b8 100644 --- a/backend/src/LibPackageManager/RuntimeTypes.fs +++ b/backend/src/LibPackageManager/RuntimeTypes.fs @@ -1,5 +1,7 @@ module LibPackageManager.RuntimeTypes +open System.Threading.Tasks + open Prelude open LibExecution.RuntimeTypes @@ -12,8 +14,8 @@ module BS = LibSerialization.Binary.Serialization module Type = - let get (hash : Hash) : Ply> = - uply { + let get (hash : Hash) : Task> = + task { let (Hash hashStr) = hash return! Sql.query @@ -29,8 +31,8 @@ module Type = module Value = - let get (hash : Hash) : Ply> = - uply { + let get (hash : Hash) : Task> = + task { let (Hash hashStr) = hash return! Sql.query @@ -45,8 +47,8 @@ module Value = } /// Find all value hashes that have the given ValueType (exact match) - let findByValueType (vt : RT.ValueType) : Ply> = - uply { + let findByValueType (vt : RT.ValueType) : Task> = + task { let vtBytes = BS.RT.ValueType.serialize vt return! Sql.query @@ -61,8 +63,8 @@ module Value = module Fn = - let get (hash : Hash) : Ply> = - uply { + let get (hash : Hash) : Task> = + task { let (Hash hashStr) = hash return! Sql.query @@ -80,8 +82,8 @@ module Fn = /// Content-addressed blob storage — bytes keyed by SHA-256 hash. module Blob = /// Look up bytes by hash. Returns [None] when the row doesn't exist. - let get (hash : string) : Ply> = - uply { + let get (hash : string) : Task> = + task { return! Sql.query """ @@ -96,8 +98,8 @@ module Blob = /// Insert bytes under [hash]. If the row already exists (same hash /// = same content, by content-addressing invariant), this is a no-op /// — `INSERT OR IGNORE` handles dedup. - let insert (hash : string) (bytes : byte[]) : Ply = - uply { + let insert (hash : string) (bytes : byte[]) : Task = + task { let! _ = Sql.query """ @@ -169,8 +171,8 @@ module Blob = /// deserialise passes plus one DELETE per orphan. Good enough for /// CLI-triggered sweeps at current scale; a reverse-index table /// is the natural next step when the DB grows past it. - let sweepOrphans () : Ply = - uply { + let sweepOrphans () : Task = + task { // Pull every materialised rt_dval — deserialise and collect // hashes referenced anywhere in the tree. let! valueRows = diff --git a/backend/src/LibPackageManager/Scripts.fs b/backend/src/LibPackageManager/Scripts.fs index eea95facab..8e34f349ff 100644 --- a/backend/src/LibPackageManager/Scripts.fs +++ b/backend/src/LibPackageManager/Scripts.fs @@ -1,7 +1,6 @@ module LibPackageManager.Scripts open System.Threading.Tasks -open FSharp.Control.Tasks open Microsoft.Data.Sqlite open Fumble open LibDB.Db diff --git a/backend/src/LibPackageManager/Seed.fs b/backend/src/LibPackageManager/Seed.fs index ed74911003..fc4a492219 100644 --- a/backend/src/LibPackageManager/Seed.fs +++ b/backend/src/LibPackageManager/Seed.fs @@ -11,7 +11,6 @@ module LibPackageManager.Seed open System.Threading.Tasks -open FSharp.Control.Tasks open Prelude open LibExecution.ProgramTypes @@ -161,8 +160,8 @@ let evaluateAllValues dbs = Map.empty secrets = [] } - let notify _ _ _ _ = uply { return () } - let sendException _ _ _ _ = uply { return () } + let notify _ _ _ _ = task { return () } + let sendException _ _ _ _ = task { return () } let exeState = Execution.createState diff --git a/backend/src/LibPackageManager/Stats.fs b/backend/src/LibPackageManager/Stats.fs index 18edeadf10..62c8e01578 100644 --- a/backend/src/LibPackageManager/Stats.fs +++ b/backend/src/LibPackageManager/Stats.fs @@ -1,7 +1,6 @@ module LibPackageManager.Stats open System.Threading.Tasks -open FSharp.Control.Tasks open Prelude @@ -13,8 +12,8 @@ open LibDB.Db type Stats = { types : int64; values : int64; fns : int64 } // Stats count total unique content items, not branch-specific views -let get () : Ply = - uply { +let get () : Task = + task { let countQuery table = Sql.query $"SELECT COUNT(DISTINCT hash) as count FROM {table}" |> Sql.executeRowAsync (fun read -> read.int64 "count") diff --git a/backend/src/LibPackageManager/WipRefresh.fs b/backend/src/LibPackageManager/WipRefresh.fs index ec35c69a5f..eadb24ae70 100644 --- a/backend/src/LibPackageManager/WipRefresh.fs +++ b/backend/src/LibPackageManager/WipRefresh.fs @@ -7,7 +7,6 @@ module LibPackageManager.WipRefresh open System.Threading.Tasks -open FSharp.Control.Tasks open Prelude @@ -17,6 +16,41 @@ module DR = LibPackageManager.DeferredResolver /// Re-resolve all items in Add+SetName pairs, using the location for context +let rec private processOps + (pm : PT.PackageManager) + (branchId : PT.BranchId) + (result : ResizeArray) + (remaining : List) + : Task = + task { + match remaining with + | PT.PackageOp.AddType t :: PT.PackageOp.SetName(loc, + (PT.PackageType _ as target)) :: rest -> + let! reResolved = DR.reResolveType pm branchId loc.owner loc.modules t + result.Add(PT.PackageOp.AddType reResolved) + result.Add(PT.PackageOp.SetName(loc, target)) + do! processOps pm branchId result rest + + | PT.PackageOp.AddFn f :: PT.PackageOp.SetName(loc, (PT.PackageFn _ as target)) :: rest -> + let! reResolved = DR.reResolveFn pm branchId loc.owner loc.modules f + result.Add(PT.PackageOp.AddFn reResolved) + result.Add(PT.PackageOp.SetName(loc, target)) + do! processOps pm branchId result rest + + | PT.PackageOp.AddValue v :: PT.PackageOp.SetName(loc, + (PT.PackageValue _ as target)) :: rest -> + let! reResolved = DR.reResolveValue pm branchId loc.owner loc.modules v + result.Add(PT.PackageOp.AddValue reResolved) + result.Add(PT.PackageOp.SetName(loc, target)) + do! processOps pm branchId result rest + + | op :: rest -> + result.Add(op) + do! processOps pm branchId result rest + + | [] -> () + } + let private reResolveAllItems (pm : PT.PackageManager) (branchId : PT.BranchId) @@ -24,45 +58,7 @@ let private reResolveAllItems : Task> = task { let result = ResizeArray() - - let rec processOps (remaining : List) = - task { - match remaining with - | PT.PackageOp.AddType t :: PT.PackageOp.SetName(loc, - (PT.PackageType _ as target)) :: rest -> - let! reResolved = - DR.reResolveType pm branchId loc.owner loc.modules t |> Ply.toTask - - result.Add(PT.PackageOp.AddType reResolved) - result.Add(PT.PackageOp.SetName(loc, target)) - do! processOps rest - - | PT.PackageOp.AddFn f :: PT.PackageOp.SetName(loc, - (PT.PackageFn _ as target)) :: rest -> - let! reResolved = - DR.reResolveFn pm branchId loc.owner loc.modules f |> Ply.toTask - - result.Add(PT.PackageOp.AddFn reResolved) - result.Add(PT.PackageOp.SetName(loc, target)) - do! processOps rest - - | PT.PackageOp.AddValue v :: PT.PackageOp.SetName(loc, - (PT.PackageValue _ as target)) :: rest -> - let! reResolved = - DR.reResolveValue pm branchId loc.owner loc.modules v |> Ply.toTask - - result.Add(PT.PackageOp.AddValue reResolved) - result.Add(PT.PackageOp.SetName(loc, target)) - do! processOps rest - - | op :: rest -> - result.Add(op) - do! processOps rest - - | [] -> () - } - - do! processOps ops + do! processOps pm branchId result ops return result |> Seq.toList } diff --git a/backend/src/LibParser/Canvas.fs b/backend/src/LibParser/Canvas.fs index 4511da53ea..88d61272f4 100644 --- a/backend/src/LibParser/Canvas.fs +++ b/backend/src/LibParser/Canvas.fs @@ -2,6 +2,7 @@ module LibParser.Canvas open FSharp.Compiler.Syntax +open System.Threading.Tasks open Prelude module RT = LibExecution.RuntimeTypes @@ -232,14 +233,14 @@ let toPT (pm : PT.PackageManager) (onMissing : NR.OnMissing) (m : WTCanvasModule) - : Ply = - uply { + : Task = + task { let currentModule = m.owner :: m.name let! typeOps = m.types - |> Ply.List.mapSequentially (fun wtType -> - uply { + |> Task.mapSequentially (fun wtType -> + task { let! ptType = WT2PT.PackageType.toPT pm onMissing currentModule wtType let location : PT.PackageLocation = { owner = wtType.name.owner @@ -250,12 +251,12 @@ let toPT [ PT.PackageOp.AddType ptType PT.PackageOp.SetName(location, PT.PackageType hash) ] }) - |> Ply.map List.flatten + |> Task.map List.flatten let! valueOps = m.values - |> Ply.List.mapSequentially (fun wtValue -> - uply { + |> Task.mapSequentially (fun wtValue -> + task { let! ptValue = WT2PT.PackageValue.toPT builtins pm onMissing currentModule wtValue let location : PT.PackageLocation = @@ -269,12 +270,12 @@ let toPT PT.PackageValue(Hashing.computeValueHash Hashing.Normal ptValue) ) ] }) - |> Ply.map List.flatten + |> Task.map List.flatten let! fnOps = m.fns - |> Ply.List.mapSequentially (fun wtFn -> - uply { + |> Task.mapSequentially (fun wtFn -> + task { let! ptFn = WT2PT.PackageFn.toPT builtins pm onMissing currentModule wtFn let location : PT.PackageLocation = { owner = wtFn.name.owner @@ -285,15 +286,15 @@ let toPT [ PT.PackageOp.AddFn ptFn PT.PackageOp.SetName(location, PT.PackageFn hash) ] }) - |> Ply.map List.flatten + |> Task.map List.flatten let! dbs = - m.dbs |> Ply.List.mapSequentially (WT2PT.DB.toPT pm onMissing currentModule) + m.dbs |> Task.mapSequentially (WT2PT.DB.toPT pm onMissing currentModule) let! handlers = m.handlers - |> Ply.List.mapSequentially (fun (spec, expr) -> - uply { + |> Task.mapSequentially (fun (spec, expr) -> + task { let spec = WT2PT.Handler.Spec.toPT spec let context = { WT2PT.Context.currentFnName = None @@ -307,7 +308,7 @@ let toPT let! exprs = m.exprs - |> Ply.List.mapSequentially ( + |> Task.mapSequentially ( let context = { WT2PT.Context.currentFnName = None WT2PT.Context.isInFunction = false @@ -330,9 +331,9 @@ let parse (onMissing : NR.OnMissing) (filename : string) (source : string) - : Ply = + : Task = - uply { + task { let parsedAsFSharp = parseAsFSharpSourceFile filename source let decls = diff --git a/backend/src/LibParser/NameResolver.fs b/backend/src/LibParser/NameResolver.fs index 23e1d68eda..1d47200de0 100644 --- a/backend/src/LibParser/NameResolver.fs +++ b/backend/src/LibParser/NameResolver.fs @@ -1,6 +1,7 @@ /// CLEANUP still feels like this can be tidied/shortened a bit. module LibParser.NameResolver +open System.Threading.Tasks open Prelude open LibExecution.ProgramTypes @@ -60,12 +61,12 @@ let resolveGenericName<'FQName, 'Builtin when 'Builtin : comparison> (currentModule : List) (given : NEList) (parseName : string -> Result) - (findInPM : (PT.BranchId * PT.PackageLocation) -> Ply>) + (findInPM : (PT.BranchId * PT.PackageLocation) -> Task>) (makePackageFQName : Hash -> 'FQName) (makeBuiltinFQName : string * int -> 'FQName) (builtinToRT : string * int -> 'Builtin) - : Ply> = - uply { + : Task> = + task { let originalName = NEList.toList given let notFoundError = Error NRE.NotFound let (modules, name) = NEList.splitLast given @@ -77,8 +78,8 @@ let resolveGenericName<'FQName, 'Builtin when 'Builtin : comparison> let genericName : GenericName = { modules = modules; name = name; version = version } - let tryResolve (nameToTry : GenericName) : Ply> = - uply { + let tryResolve (nameToTry : GenericName) : Task> = + task { match nameToTry.modules with | [] -> return Error() | owner :: modules -> @@ -101,12 +102,12 @@ let resolveGenericName<'FQName, 'Builtin when 'Builtin : comparison> } let! result = - Ply.List.foldSequentially + Task.foldSequentially (fun currentResult nameToTry -> match currentResult with - | Ok _ -> Ply currentResult + | Ok _ -> Task.FromResult currentResult | Error _ -> - uply { + task { match! tryResolve nameToTry with | Error() -> return currentResult | Ok success -> return Ok success @@ -128,7 +129,7 @@ let resolveTypeName (onMissing : OnMissing) (currentModule : List) (name : WT.Name) - : Ply> = + : Task> = let warning = "Builtin types don't exist" let emptyBuiltins = None // irrelevant for types @@ -147,7 +148,7 @@ let resolveTypeName currentModule given parseTypeName - packageManager.findType + (fun args -> packageManager.findType args) PT.FQTypeName.FQTypeName.Package (fun _ -> Exception.raiseInternal warning []) (fun _ -> Exception.raiseInternal warning []) @@ -160,10 +161,10 @@ let resolveValueName (onMissing : OnMissing) (currentModule : List) (name : WT.Name) - : Ply> = + : Task> = match name with | WT.KnownBuiltin(name, version) -> - Ply( + Task.FromResult( { originalName = [ name ] resolved = Ok(PT.FQValueName.fqBuiltIn name version) } : PT.NameResolution<_> @@ -175,7 +176,7 @@ let resolveValueName currentModule given FS2WT.Expr.parseFnName - packageManager.findValue + (fun args -> packageManager.findValue args) PT.FQValueName.FQValueName.Package (fun (n, v) -> PT.FQValueName.Builtin { name = n; version = v }) (fun (n, v) -> { RT.FQValueName.Builtin.name = n; version = v }) @@ -187,10 +188,10 @@ let resolveFnName (onMissing : OnMissing) (currentModule : List) (name : WT.Name) - : Ply> = + : Task> = match name with | WT.KnownBuiltin(n, v) -> - Ply( + Task.FromResult( { originalName = [ n ]; resolved = Ok(PT.FQFnName.fqBuiltIn n v) } : PT.NameResolution<_> ) @@ -201,7 +202,7 @@ let resolveFnName currentModule given FS2WT.Expr.parseFnName - packageManager.findFn + (fun args -> packageManager.findFn args) PT.FQFnName.FQFnName.Package (fun (n, v) -> PT.FQFnName.Builtin { name = n; version = v }) (fun (n, v) -> { RT.FQFnName.Builtin.name = n; version = v }) diff --git a/backend/src/LibParser/Package.fs b/backend/src/LibParser/Package.fs index d50e92db2a..d93dc273f1 100644 --- a/backend/src/LibParser/Package.fs +++ b/backend/src/LibParser/Package.fs @@ -2,6 +2,7 @@ module internal LibParser.Package open FSharp.Compiler.Syntax +open System.Threading.Tasks open Prelude open LibExecution.ProgramTypes @@ -108,8 +109,8 @@ let parse (onMissing : NR.OnMissing) (filename : string) (contents : string) - : Ply> = - uply { + : Task> = + task { match parseAsFSharpSourceFile filename contents with | ParsedImplFileInput(_, _, @@ -137,7 +138,7 @@ let parse let! fns = modul.fns - |> Ply.List.mapSequentially (fun fn -> + |> Task.mapSequentially (fun fn -> WT2PT.PackageFn.toPT builtins pm @@ -147,7 +148,7 @@ let parse let! types = modul.types - |> Ply.List.mapSequentially (fun typ -> + |> Task.mapSequentially (fun typ -> WT2PT.PackageType.toPT pm onMissing @@ -156,7 +157,7 @@ let parse let! values = modul.values - |> Ply.List.mapSequentially (fun value -> + |> Task.mapSequentially (fun value -> WT2PT.PackageValue.toPT builtins pm diff --git a/backend/src/LibParser/Parser.fs b/backend/src/LibParser/Parser.fs index 0b7c2ca2a6..3859b56c63 100644 --- a/backend/src/LibParser/Parser.fs +++ b/backend/src/LibParser/Parser.fs @@ -1,6 +1,7 @@ /// Entrypoint to parsing functions module LibParser.Parser +open System.Threading.Tasks open Prelude module FS2WT = FSharpToWrittenTypes @@ -26,7 +27,7 @@ let parsePTExpr (onMissing : NR.OnMissing) (filename : string) (code : string) - : Ply = + : Task = let context = { WT2PT.Context.currentFnName = None WT2PT.Context.isInFunction = false @@ -43,7 +44,7 @@ let parseSimple (onMissing : NR.OnMissing) (filename : string) (code : string) - : Ply = + : Task = parsePTExpr builtins pm onMissing filename code @@ -54,5 +55,5 @@ let parsePackageFile (onMissing : NR.OnMissing) (path : string) (contents : string) - : Ply> = + : Task> = Package.parse builtins pm onMissing path contents diff --git a/backend/src/LibParser/TestModule.fs b/backend/src/LibParser/TestModule.fs index a5b69f80e1..5bfe19bb6a 100644 --- a/backend/src/LibParser/TestModule.fs +++ b/backend/src/LibParser/TestModule.fs @@ -2,6 +2,7 @@ module LibParser.TestModule open FSharp.Compiler.Syntax +open System.Threading.Tasks open Prelude module FS2WT = FSharpToWrittenTypes @@ -247,14 +248,14 @@ let toPT (pm : PT.PackageManager) (onMissing : NR.OnMissing) (m : WTModule) - : Ply = - uply { + : Task = + task { let currentModule = owner :: m.name let! typeOps = m.types - |> Ply.List.mapSequentially (fun wtType -> - uply { + |> Task.mapSequentially (fun wtType -> + task { let! ptType = WT2PT.PackageType.toPT pm onMissing currentModule wtType let hash = Hashing.computeTypeHash Hashing.Normal ptType return @@ -264,12 +265,12 @@ let toPT PT.PackageType hash ) ] }) - |> Ply.map List.flatten + |> Task.map List.flatten let! valueOps = m.values - |> Ply.List.mapSequentially (fun wtValue -> - uply { + |> Task.mapSequentially (fun wtValue -> + task { let! ptValue = WT2PT.PackageValue.toPT builtins pm onMissing currentModule wtValue return @@ -279,12 +280,12 @@ let toPT PT.PackageValue(Hashing.computeValueHash Hashing.Normal ptValue) ) ] }) - |> Ply.map List.flatten + |> Task.map List.flatten let! fnOps = m.fns - |> Ply.List.mapSequentially (fun wtFn -> - uply { + |> Task.mapSequentially (fun wtFn -> + task { let! ptFn = WT2PT.PackageFn.toPT builtins pm onMissing currentModule wtFn let hash = Hashing.computeFnHash Hashing.Normal ptFn return @@ -294,15 +295,15 @@ let toPT PT.PackageFn hash ) ] }) - |> Ply.map List.flatten + |> Task.map List.flatten let! dbs = - m.dbs |> Ply.List.mapSequentially (WT2PT.DB.toPT pm onMissing currentModule) + m.dbs |> Task.mapSequentially (WT2PT.DB.toPT pm onMissing currentModule) let! (tests : List) = m.tests - |> Ply.List.mapSequentially (fun test -> - uply { + |> Task.mapSequentially (fun test -> + task { let context = { WT2PT.Context.currentFnName = None WT2PT.Context.isInFunction = false @@ -311,7 +312,7 @@ let toPT let exprToPT = WT2PT.Expr.toPT builtins pm onMissing currentModule context let! actual = exprToPT test.actual let! expected = - uply { + task { match test.expected with | WTExpectedExpr expected -> let! expected = exprToPT expected @@ -338,8 +339,8 @@ let parseTestFile (builtins : RT.Builtins) (pm : PT.PackageManager) (filename : string) - : Ply> = - uply { + : Task> = + task { let onMissing = NR.OnMissing.Allow let modulesWT = @@ -351,9 +352,7 @@ let parseTestFile // First pass: parse with empty PM, then compute real SCC-aware hashes let! firstPassModules = modulesWT - |> Ply.List.mapSequentially ( - toPT owner builtins PT.PackageManager.empty onMissing - ) + |> Task.mapSequentially (toPT owner builtins PT.PackageManager.empty onMissing) let firstPassOps = firstPassModules |> List.collect _.ops @@ -368,8 +367,7 @@ let parseTestFile iteration <- iteration + 1 let enhancedPM = LibPackageManager.PackageManager.withExtraOps pm currentOps let! newModules = - modulesWT - |> Ply.List.mapSequentially (toPT owner builtins enhancedPM onMissing) + modulesWT |> Task.mapSequentially (toPT owner builtins enhancedPM onMissing) let newRawOps = newModules |> List.collect _.ops let remapped = HS.remapSetNames newRawOps currentOps let newOps = HS.computeRealHashes remapped diff --git a/backend/src/LibParser/WrittenTypesToProgramTypes.fs b/backend/src/LibParser/WrittenTypesToProgramTypes.fs index eb2221104e..04715c71fd 100644 --- a/backend/src/LibParser/WrittenTypesToProgramTypes.fs +++ b/backend/src/LibParser/WrittenTypesToProgramTypes.fs @@ -1,6 +1,7 @@ /// Conversion functions from WrittenTypes to ProgramTypes module LibParser.WrittenTypesToProgramTypes +open System.Threading.Tasks open Prelude open LibExecution.ProgramTypes @@ -49,9 +50,9 @@ module TypeReference = (onMissing : NR.OnMissing) (currentModule : List) (t : WT.TypeReference) - : Ply = + : Task = let toPT = toPT pm onMissing currentModule - uply { + task { match t with | WT.TUnit -> return PT.TUnit | WT.TBool -> return PT.TBool @@ -72,29 +73,29 @@ module TypeReference = | WT.TUuid -> return PT.TUuid | WT.TBlob -> return PT.TBlob - | WT.TStream typ -> return! toPT typ |> Ply.map PT.TStream + | WT.TStream typ -> return! toPT typ |> Task.map PT.TStream - | WT.TList typ -> return! toPT typ |> Ply.map PT.TList + | WT.TList typ -> return! toPT typ |> Task.map PT.TList | WT.TTuple(firstType, secondType, otherTypes) -> let! firstType = toPT firstType let! secondType = toPT secondType - let! otherTypes = Ply.List.mapSequentially toPT otherTypes + let! otherTypes = Task.mapSequentially toPT otherTypes return PT.TTuple(firstType, secondType, otherTypes) - | WT.TDict typ -> return! toPT typ |> Ply.map PT.TDict + | WT.TDict typ -> return! toPT typ |> Task.map PT.TDict | WT.TCustomType(t, typeArgs) -> let! t = NR.resolveTypeName pm onMissing currentModule t - let! typeArgs = Ply.List.mapSequentially toPT typeArgs + let! typeArgs = Task.mapSequentially toPT typeArgs return PT.TCustomType(t, typeArgs) | WT.TFn(paramTypes, returnType) -> - let! paramTypes = Ply.NEList.mapSequentially toPT paramTypes + let! paramTypes = Task.NEList.mapSequentially toPT paramTypes let! returnType = toPT returnType return PT.TFn(paramTypes, returnType) - | WT.TDB typ -> return! toPT typ |> Ply.map PT.TDB + | WT.TDB typ -> return! toPT typ |> Task.map PT.TDB | WT.TVariable(name) -> return PT.TVariable(name) } @@ -241,9 +242,12 @@ module Expr = (currentModule : List) (names : List) (caseName : string) // used for errors - : Ply> = + : Task> = match names with - | [] -> Ply({ originalName = [ caseName ]; resolved = Error NRE.InvalidName }) + | [] -> + Task.FromResult( + { originalName = [ caseName ]; resolved = Error NRE.InvalidName } + ) | head :: tail -> let name = NEList.ofList head tail |> WT.Unresolved NR.resolveTypeName pm onMissing currentModule name @@ -255,9 +259,15 @@ module Expr = (currentModule : List) (context : Context) (e : WT.Expr) - : Ply = + : Task = let toPT ctx = toPT builtins pm onMissing currentModule ctx - uply { + let rec extractPath (expr : WT.Expr) : Option> = + match expr with + | WT.EVariable(_, name) -> Some(NEList.singleton name) + | WT.ERecordFieldAccess(_, inner, field) -> + extractPath inner |> Option.map (fun path -> NEList.pushBack field path) + | _ -> None + task { match e with | WT.EChar(id, char) -> return PT.EChar(id, char) | WT.EInt64(id, num) -> return PT.EInt64(id, num) @@ -272,7 +282,7 @@ module Expr = | WT.EUInt128(id, num) -> return PT.EUInt128(id, num) | WT.EString(id, segments) -> let! segments = - Ply.List.mapSequentially + Task.mapSequentially (stringSegmentToPT builtins pm onMissing currentModule context) segments return PT.EString(id, segments) @@ -314,13 +324,6 @@ module Expr = // When we have field access like `Module.fn`, try to resolve as qualified // function or value name first, since the parser treats dotted identifiers // as field access rather than qualified names. - let rec extractPath (expr : WT.Expr) : Option> = - match expr with - | WT.EVariable(_, name) -> Some(NEList.singleton name) - | WT.ERecordFieldAccess(_, inner, field) -> - extractPath inner |> Option.map (fun path -> NEList.pushBack field path) - | _ -> None - match extractPath obj with | Some basePath -> // If the first part of the path is a local binding or function arg, it's field access, not a global @@ -383,10 +386,10 @@ module Expr = return PT.EValue(id, valueName) | WT.EApply(id, (WT.EFnName(_, name) as fnName), typeArgs, args) -> let! processedTypeArgs = - Ply.List.mapSequentially + Task.mapSequentially (TypeReference.toPT pm onMissing currentModule) typeArgs - let! processedArgs = Ply.NEList.mapSequentially (toPT context) args + let! processedArgs = Task.NEList.mapSequentially (toPT context) args // Handle function calls with arguments, check for variable shadowing first match name with @@ -443,10 +446,10 @@ module Expr = | WT.EApply(id, name, typeArgs, args) -> let! name = toPT context name let! typeArgs = - Ply.List.mapSequentially + Task.mapSequentially (TypeReference.toPT pm onMissing currentModule) typeArgs - let! args = Ply.NEList.mapSequentially (toPT context) args + let! args = Task.NEList.mapSequentially (toPT context) args return PT.EApply(id, name, typeArgs, args) | WT.EFnName(id, name) -> @@ -486,7 +489,7 @@ module Expr = let! cond = toPT context cond let! thenExpr = toPT context thenExpr let! elseExpr = - uply { + task { match elseExpr with | Some value -> let! newValue = toPT context value @@ -495,19 +498,19 @@ module Expr = } return PT.EIf(id, cond, thenExpr, elseExpr) | WT.EList(id, exprs) -> - let! exprs = Ply.List.mapSequentially (toPT context) exprs + let! exprs = Task.mapSequentially (toPT context) exprs return PT.EList(id, exprs) | WT.ETuple(id, first, second, theRest) -> let! first = toPT context first let! second = toPT context second - let! theRest = Ply.List.mapSequentially (toPT context) theRest + let! theRest = Task.mapSequentially (toPT context) theRest return PT.ETuple(id, first, second, theRest) | WT.ERecord(id, typeName, fields) -> let! typeName = NR.resolveTypeName pm onMissing currentModule typeName let! fields = - Ply.List.mapSequentially + Task.mapSequentially (fun (fieldName, fieldExpr) -> - uply { + task { let! fieldExpr = toPT context fieldExpr return (fieldName, fieldExpr) }) @@ -518,8 +521,8 @@ module Expr = let! record = toPT context record let! updates = updates - |> Ply.NEList.mapSequentially (fun (name, expr) -> - uply { + |> Task.NEList.mapSequentially (fun (name, expr) -> + task { let! expr = toPT context expr return (name, expr) }) @@ -527,24 +530,24 @@ module Expr = | WT.EPipe(pipeID, expr1, rest) -> let! expr1 = toPT context expr1 let! rest = - Ply.List.mapSequentially + Task.mapSequentially (pipeExprToPT builtins pm onMissing currentModule context) rest return PT.EPipe(pipeID, expr1, rest) | WT.EEnum(id, typeName, caseName, exprs) -> let! typeName = resolveTypeName pm onMissing currentModule typeName caseName - let! exprs = Ply.List.mapSequentially (toPT context) exprs + let! exprs = Task.mapSequentially (toPT context) exprs let typeArgs = [] // TODO return PT.EEnum(id, typeName, typeArgs, caseName, exprs) | WT.EMatch(id, mexpr, cases) -> let! mexpr = toPT context mexpr let! cases = - Ply.List.mapSequentially + Task.mapSequentially (fun (case : WT.MatchCase) -> - uply { + task { let (patternContext, mp) = MatchPattern.toPT context case.pat let! whenCondition = - uply { + task { match case.whenCondition with | Some whenExpr -> let! whenExpr = toPT patternContext whenExpr @@ -565,9 +568,9 @@ module Expr = return PT.EInfix(id, Infix.toPT infix, arg1, arg2) | WT.EDict(id, pairs) -> let! pairs = - Ply.List.mapSequentially + Task.mapSequentially (fun (key, value) -> - uply { + task { let! value = toPT context value return (key, value) }) @@ -590,12 +593,12 @@ module Expr = (currentModule : List) (context : Context) (segment : WT.StringSegment) - : Ply = + : Task = match segment with - | WT.StringText text -> Ply(PT.StringText text) + | WT.StringText text -> Task.FromResult(PT.StringText text) | WT.StringInterpolation expr -> toPT builtins pm onMissing currentModule context expr - |> Ply.map (fun interpolated -> PT.StringInterpolation interpolated) + |> Task.map (fun interpolated -> PT.StringInterpolation interpolated) and pipeExprToPT (builtins : RT.Builtins) @@ -604,10 +607,10 @@ module Expr = (currentModule : List) (context : Context) (pipeExpr : WT.PipeExpr) - : Ply = + : Task = let toPT ctx = toPT builtins pm onMissing currentModule ctx - uply { + task { match pipeExpr with | WT.EPipeVariableOrFnCall(id, name) -> match context.currentFnName with @@ -696,7 +699,7 @@ module Expr = NR.OnMissing.Allow currentModule name - let! args = Ply.List.mapSequentially (toPT context) args + let! args = Task.mapSequentially (toPT context) args match fnName.resolved with | Ok _ -> return PT.EPipeFnCall(id, fnName, [], args) | Error _ -> return PT.EPipeVariable(id, varName, args) @@ -710,15 +713,15 @@ module Expr = currentModule name let! typeArgs = - Ply.List.mapSequentially + Task.mapSequentially (TypeReference.toPT pm onMissing currentModule) typeArgs - let! args = Ply.List.mapSequentially (toPT context) args + let! args = Task.mapSequentially (toPT context) args return PT.EPipeFnCall(id, fnName, typeArgs, args) | WT.EPipeEnum(id, typeName, caseName, fields) -> let! typeName = resolveTypeName pm onMissing currentModule typeName caseName - let! fields = Ply.List.mapSequentially (toPT context) fields + let! fields = Task.mapSequentially (toPT context) fields return PT.EPipeEnum(id, typeName, caseName, fields) } @@ -730,10 +733,12 @@ module TypeDeclaration = (onMissing : NR.OnMissing) (currentModule : List) (f : WT.TypeDeclaration.RecordField) - : Ply = - uply { + : Task = + task { let! typ = TypeReference.toPT pm onMissing currentModule f.typ - return { name = f.name; typ = typ; description = f.description } + let result : PT.TypeDeclaration.RecordField = + { name = f.name; typ = typ; description = f.description } + return result } module EnumField = @@ -742,10 +747,12 @@ module TypeDeclaration = (onMissing : NR.OnMissing) (currentModule : List) (f : WT.TypeDeclaration.EnumField) - : Ply = - uply { + : Task = + task { let! typ = TypeReference.toPT pm onMissing currentModule f.typ - return { typ = typ; label = f.label; description = f.description } + let result : PT.TypeDeclaration.EnumField = + { typ = typ; label = f.label; description = f.description } + return result } module EnumCase = @@ -754,13 +761,13 @@ module TypeDeclaration = (onMissing : NR.OnMissing) (currentModule : List) (c : WT.TypeDeclaration.EnumCase) - : Ply = - uply { + : Task = + task { let! fields = - Ply.List.mapSequentially - (EnumField.toPT pm onMissing currentModule) - c.fields - return { name = c.name; fields = fields; description = c.description } + Task.mapSequentially (EnumField.toPT pm onMissing currentModule) c.fields + let result : PT.TypeDeclaration.EnumCase = + { name = c.name; fields = fields; description = c.description } + return result } module Definition = @@ -769,8 +776,8 @@ module TypeDeclaration = (onMissing : NR.OnMissing) (currentModule : List) (d : WT.TypeDeclaration.Definition) - : Ply = - uply { + : Task = + task { match d with | WT.TypeDeclaration.Alias typ -> let! typ = TypeReference.toPT pm onMissing currentModule typ @@ -778,14 +785,14 @@ module TypeDeclaration = | WT.TypeDeclaration.Record fields -> let! fields = - Ply.NEList.mapSequentially + Task.NEList.mapSequentially (RecordField.toPT pm onMissing currentModule) fields return PT.TypeDeclaration.Record fields | WT.TypeDeclaration.Enum cases -> let! cases = - Ply.NEList.mapSequentially + Task.NEList.mapSequentially (EnumCase.toPT pm onMissing currentModule) cases return PT.TypeDeclaration.Enum cases @@ -797,10 +804,12 @@ module TypeDeclaration = (onMissing : NR.OnMissing) (currentModule : List) (d : WT.TypeDeclaration.T) - : Ply = - uply { + : Task = + task { let! def = Definition.toPT pm onMissing currentModule d.definition - return { typeParams = d.typeParams; definition = def } + let result : PT.TypeDeclaration.T = + { typeParams = d.typeParams; definition = def } + return result } @@ -824,12 +833,13 @@ module PackageType = (onMissing : NR.OnMissing) (currentModule : List) (pt : WT.PackageType.PackageType) - : Ply = - uply { + : Task = + task { let! declaration = TypeDeclaration.toPT pm onMissing currentModule pt.declaration - return + let result : PT.PackageType.PackageType = { hash = Hash ""; description = pt.description; declaration = declaration } + return result } module PackageValue = @@ -846,15 +856,17 @@ module PackageValue = (onMissing : NR.OnMissing) (currentModule : List) (c : WT.PackageValue.PackageValue) - : Ply = - uply { + : Task = + task { let context = { currentFnName = None isInFunction = false argMap = Map.empty localBindings = Set.empty } let! body = Expr.toPT builtins pm onMissing currentModule context c.body - return { hash = Hash ""; description = c.description; body = body } + let result : PT.PackageValue.PackageValue = + { hash = Hash ""; description = c.description; body = body } + return result } @@ -872,10 +884,12 @@ module PackageFn = (onMissing : NR.OnMissing) (currentModule : List) (p : WT.PackageFn.Parameter) - : Ply = - uply { + : Task = + task { let! typ = TypeReference.toPT pm onMissing currentModule p.typ - return { name = p.name; typ = typ; description = p.description } + let result : PT.PackageFn.Parameter = + { name = p.name; typ = typ; description = p.description } + return result } /// Walk a PT TypeReference collecting all TVariable names. @@ -913,10 +927,10 @@ module PackageFn = (onMissing : NR.OnMissing) (currentModule : List) (fn : WT.PackageFn.PackageFn) - : Ply = - uply { + : Task = + task { let! parameters = - Ply.NEList.mapSequentially + Task.NEList.mapSequentially (Parameter.toPT pm onMissing currentModule) fn.parameters let! returnType = TypeReference.toPT pm onMissing currentModule fn.returnType @@ -946,13 +960,14 @@ module PackageFn = withReturn |> List.filter (fun n -> not (List.contains n explicitTypeParams)) let allTypeParams = explicitTypeParams @ implicitTypeParams - return + let result : PT.PackageFn.PackageFn = { hash = Hash "" parameters = parameters returnType = returnType description = fn.description body = body typeParams = allTypeParams } + return result } @@ -964,10 +979,12 @@ module DB = (onMissing : NR.OnMissing) (currentModule : List) (db : WT.DB.T) - : Ply = - uply { + : Task = + task { let! typ = TypeReference.toPT pm onMissing currentModule db.typ - return { tlid = gid (); name = db.name; version = db.version; typ = typ } + let result : PT.DB.T = + { tlid = gid (); name = db.name; version = db.version; typ = typ } + return result } @@ -997,13 +1014,15 @@ module Handler = (onMissing : NR.OnMissing) (currentModule : List) (h : WT.Handler.T) - : Ply = - uply { + : Task = + task { let context = { currentFnName = None isInFunction = false argMap = Map.empty localBindings = Set.empty } let! ast = Expr.toPT builtins pm onMissing currentModule context h.ast - return { tlid = gid (); ast = ast; spec = Spec.toPT h.spec } + let result : PT.Handler.T = + { tlid = gid (); ast = ast; spec = Spec.toPT h.spec } + return result } diff --git a/backend/src/LibSerialization/Binary/Serialization.fs b/backend/src/LibSerialization/Binary/Serialization.fs index 2802c77893..f7bc71b131 100644 --- a/backend/src/LibSerialization/Binary/Serialization.fs +++ b/backend/src/LibSerialization/Binary/Serialization.fs @@ -4,7 +4,6 @@ module LibSerialization.Binary.Serialization open System open System.IO open System.Threading.Tasks -open FSharp.Control.Tasks open Prelude module RT = LibExecution.RuntimeTypes diff --git a/backend/src/LibService/FireAndForget.fs b/backend/src/LibService/FireAndForget.fs index 0e951fc269..4271ad020e 100644 --- a/backend/src/LibService/FireAndForget.fs +++ b/backend/src/LibService/FireAndForget.fs @@ -2,7 +2,6 @@ module LibService.FireAndForget open System.Threading.Tasks open System.Threading -open FSharp.Control.Tasks open Prelude diff --git a/backend/src/LibService/Kubernetes.fs b/backend/src/LibService/Kubernetes.fs index a3f0b6742a..7dad9f1454 100644 --- a/backend/src/LibService/Kubernetes.fs +++ b/backend/src/LibService/Kubernetes.fs @@ -3,7 +3,6 @@ /// See https://docs.microsoft.com/en-us/aspnet/core/host-and-deploy/health-checks module LibService.Kubernetes -open FSharp.Control.Tasks open System.Threading.Tasks open Microsoft.Extensions.DependencyInjection diff --git a/backend/src/LocalExec/BenchmarkScenarios.fs b/backend/src/LocalExec/BenchmarkScenarios.fs index 894d8ac53b..fc45a8feca 100644 --- a/backend/src/LocalExec/BenchmarkScenarios.fs +++ b/backend/src/LocalExec/BenchmarkScenarios.fs @@ -4,6 +4,8 @@ /// `Benchmarks.fs`. module LocalExec.BenchmarkScenarios +open System.Threading.Tasks + open Prelude module RT = LibExecution.RuntimeTypes @@ -77,8 +79,8 @@ let freshState () : RT.ExecutionState = builtins TestUtils.TestUtils.pmRT LibExecution.Execution.noTracing - (fun _ _ _ _ -> uply { return () }) - (fun _ _ _ _ -> uply { return () }) + (fun _ _ _ _ -> task { return () }) + (fun _ _ _ _ -> task { return () }) LibExecution.ProgramTypes.mainBranchId { canvasID = System.Guid.NewGuid() internalFnsAllowed = false @@ -184,8 +186,8 @@ let private streamToBlob (state : RT.ExecutionState) : List = let _, sample = measure (fun () -> let mutable yielded = false - let nextChunk (_max : int) : Ply> = - uply { + let nextChunk (_max : int) : Task> = + task { if yielded then return None else @@ -194,8 +196,8 @@ let private streamToBlob (state : RT.ExecutionState) : List = } let stream = Stream.newChunked VT.uint8 nextChunk None let collected = new System.IO.MemoryStream() - let rec drain () : Ply = - uply { + let rec drain () : Task = + task { let! chunk = Stream.readChunk 65536 stream match chunk with | Some bs -> @@ -203,7 +205,7 @@ let private streamToBlob (state : RT.ExecutionState) : List = return! drain () | None -> return () } - drain () |> Ply.toTask |> _.Wait() + (drain ()).Wait() ignore (Blob.newEphemeral state (collected.ToArray()))) mkResult "streamToBlob" size 1 "chunked-drain" sample) diff --git a/backend/src/LocalExec/Benchmarks.fs b/backend/src/LocalExec/Benchmarks.fs index de2eee6796..30a184d36e 100644 --- a/backend/src/LocalExec/Benchmarks.fs +++ b/backend/src/LocalExec/Benchmarks.fs @@ -18,7 +18,6 @@ module LocalExec.Benchmarks open System.Threading.Tasks -open FSharp.Control.Tasks open Prelude @@ -113,8 +112,8 @@ let private printSummary (results : List) : unit = print line -let runAll () : Ply> = - uply { +let runAll () : Task> = + task { let results = Scenarios.run (Scenarios.freshState ()) let timestamp = System.DateTime.UtcNow.ToString("yyyy-MM-ddTHH:mm:ssZ") let json = serializeSnapshot timestamp (gitCommit ()) results @@ -176,8 +175,8 @@ let private renderSnapshotBody (results : List) : List "" ]) -let render () : Ply> = - uply { +let render () : Task> = + task { let dir = resultsDir () let historyPath = System.IO.Path.Combine(dir, "history.jsonl") if not (System.IO.File.Exists(historyPath)) then diff --git a/backend/src/LocalExec/Builtins.fs b/backend/src/LocalExec/Builtins.fs index e4fe4c249d..909ce5dece 100644 --- a/backend/src/LocalExec/Builtins.fs +++ b/backend/src/LocalExec/Builtins.fs @@ -1,7 +1,6 @@ module LocalExec.Builtins open System.Threading.Tasks -open FSharp.Control.Tasks open Prelude diff --git a/backend/src/LocalExec/Canvas.fs b/backend/src/LocalExec/Canvas.fs index 574bd98093..97de10deda 100644 --- a/backend/src/LocalExec/Canvas.fs +++ b/backend/src/LocalExec/Canvas.fs @@ -2,7 +2,6 @@ module LocalExec.Canvas open System.Threading.Tasks -open FSharp.Control.Tasks open Prelude @@ -60,8 +59,8 @@ let purgeDataFromInternalSqlTables (id : CanvasID) : Task = let loadFromDisk (pm : PT.PackageManager) (canvasName : string) - : Ply> = - uply { + : Task> = + task { print $"Loading canvas {canvasName} from disk" let canvasDir = $"canvases/{canvasName}" @@ -93,7 +92,7 @@ let loadFromDisk do! LibCloud.Canvas.createWithExactID canvasID None domain let! tls = - uply { + task { let fileName = $"{canvasDir}/{config.Main}.dark" let source = System.IO.File.ReadAllText fileName diff --git a/backend/src/LocalExec/LoadPackagesFromDisk.fs b/backend/src/LocalExec/LoadPackagesFromDisk.fs index 139a474f53..f5bc77d414 100644 --- a/backend/src/LocalExec/LoadPackagesFromDisk.fs +++ b/backend/src/LocalExec/LoadPackagesFromDisk.fs @@ -2,7 +2,6 @@ module LocalExec.LoadPackagesFromDisk open System.Threading.Tasks -open FSharp.Control.Tasks open Prelude open LibExecution.ProgramTypes @@ -19,8 +18,8 @@ open Utils /// Reads and parses all .dark files in `packages` dir, /// failing upon any individual failure -let load (builtins : RT.Builtins) : Ply> = - uply { +let load (builtins : RT.Builtins) : Task> = + task { let filesWithContents = "/home/dark/app/packages" |> listDirectoryRecursive @@ -34,7 +33,7 @@ let load (builtins : RT.Builtins) : Ply> = let! (firstPassOps : List) = filesWithContents // TODO: parallelize - |> Ply.List.mapSequentially (fun (path, contents) -> + |> Task.mapSequentially (fun (path, contents) -> try debuG " parsing" path LibParser.Parser.parsePackageFile @@ -46,7 +45,7 @@ let load (builtins : RT.Builtins) : Ply> = with _ex -> debuG " FAILED to parse" path reraise ()) - |> Ply.map List.flatten + |> Task.map List.flatten debuG "phase 1" $"done, {List.length firstPassOps} ops" // -- Phase 2: Iterative re-parse until hashes converge -- @@ -69,14 +68,14 @@ let load (builtins : RT.Builtins) : Ply> = currentOps let! newRawOps = filesWithContents - |> Ply.List.mapSequentially (fun (path, contents) -> + |> Task.mapSequentially (fun (path, contents) -> LibParser.Parser.parsePackageFile builtins pm NR.OnMissing.ThrowError path contents) - |> Ply.map List.flatten + |> Task.map List.flatten let remapped = HS.remapSetNames newRawOps currentOps let newOps = HS.computeRealHashes remapped let newHashes = HS.extractAllHashes newOps diff --git a/backend/src/LocalExec/LocalExec.fs b/backend/src/LocalExec/LocalExec.fs index 97679f173a..6fec46b61b 100644 --- a/backend/src/LocalExec/LocalExec.fs +++ b/backend/src/LocalExec/LocalExec.fs @@ -2,7 +2,6 @@ module LocalExec.LocalExec open System.Threading.Tasks -open FSharp.Control.Tasks open Prelude open LibExecution.ProgramTypes @@ -26,8 +25,8 @@ let evaluateAllValues = LibPackageManager.Seed.evaluateAllValues module HandleCommand = - let reloadCanvas (name : string) : Ply> = - uply { + let reloadCanvas (name : string) : Task> = + task { print $"Reloading {name} canvas..." let! (canvasId, toplevels) = @@ -38,8 +37,8 @@ module HandleCommand = return Ok() } - let reloadCanvases () : Ply> = - uply { + let reloadCanvases () : Task> = + task { // CLEANUP fetch the list of canvases by 'ls canvases' equiv. // CLEANUP stop tossing the result let! _ = reloadCanvas "dark-packages" @@ -47,8 +46,8 @@ module HandleCommand = return Ok() } - let reloadPackages () : Ply> = - uply { + let reloadPackages () : Task> = + task { // Load packages from disk, ensuring all parse well let! ops = LoadPackagesFromDisk.load (Builtins.all ()) @@ -106,8 +105,8 @@ module HandleCommand = return Ok() } - let runMigrations () : Ply> = - uply { + let runMigrations () : Task> = + task { try print "Running migrations" Migrations.run () @@ -117,8 +116,8 @@ module HandleCommand = return Error $"Migration failed: {ex.Message}" } - let exportSeed (outputPath : string) : Ply> = - uply { + let exportSeed (outputPath : string) : Task> = + task { try do! LibPackageManager.Seed.export outputPath let size = System.IO.FileInfo(outputPath).Length / 1024L / 1024L @@ -128,8 +127,8 @@ module HandleCommand = return Error $"Export failed: {ex.Message}" } - let listMigrations () : Ply> = - uply { + let listMigrations () : Task> = + task { try print "Migrations needed:\n" Migrations.migrationsToRun () |> List.iter (fun name -> print $" - {name}") @@ -140,8 +139,8 @@ module HandleCommand = /// Scan `package_values.rt_dval` for referenced blob hashes and /// delete any `package_blobs` rows that aren't referenced. - let sweepBlobs () : Ply> = - uply { + let sweepBlobs () : Task> = + task { try print "Sweeping orphan package_blobs..." let! deleted = LibPackageManager.RuntimeTypes.Blob.sweepOrphans () @@ -171,7 +170,7 @@ let main (args : string[]) : int = let handleCommand (description : string) - (command : Ply>) + (command : Task>) : int = print $"Starting: {description}" match command.Result with diff --git a/backend/src/LocalExec/PackageRefsGenerator.fs b/backend/src/LocalExec/PackageRefsGenerator.fs index 5f0342b9fd..be46e32dc2 100644 --- a/backend/src/LocalExec/PackageRefsGenerator.fs +++ b/backend/src/LocalExec/PackageRefsGenerator.fs @@ -2,6 +2,7 @@ /// from the DB. PackageRefs.fs reads this file (as an embedded resource) at startup. module LocalExec.PackageRefsGenerator +open System.Threading.Tasks open Prelude open Fumble @@ -19,17 +20,14 @@ let private buildKey (itemType : string) (modules : string) (name : string) = /// Path to the source-tree copy of the hash file (committed to git). let private sourceTreePath = - System.IO.Path.Combine( - __SOURCE_DIRECTORY__, - "../LibExecution/package-ref-hashes.txt" - ) + System.IO.Path.Combine(__SOURCE_DIRECTORY__, "../Language/package-ref-hashes.txt") |> System.IO.Path.GetFullPath /// Query the DB for all current Darklang-owned locations and write /// `package-ref-hashes.txt` in the source tree. -let generate () : Ply = - uply { +let generate () : Task = + task { // Collect all referenced items from PackageRefs _lookup maps let typeRefKeys = PackageRefs.Type._lookup diff --git a/backend/src/Prelude/Exception.fs b/backend/src/Prelude/Exception.fs index df16a15996..a24995707a 100644 --- a/backend/src/Prelude/Exception.fs +++ b/backend/src/Prelude/Exception.fs @@ -1,8 +1,6 @@ module Exception open System.Threading.Tasks -open FSharp.Control.Tasks -open FSharp.Control.Tasks.Affine.Unsafe // ---------------------- // Exceptions diff --git a/backend/src/Prelude/Json.fs b/backend/src/Prelude/Json.fs index 779f9f6db0..a2e4a95480 100644 --- a/backend/src/Prelude/Json.fs +++ b/backend/src/Prelude/Json.fs @@ -1,7 +1,6 @@ module Json open System.Threading.Tasks -open FSharp.Control.Tasks open Prelude diff --git a/backend/src/Prelude/Ply.fs b/backend/src/Prelude/Ply.fs deleted file mode 100644 index 670a01d159..0000000000 --- a/backend/src/Prelude/Ply.fs +++ /dev/null @@ -1,249 +0,0 @@ -module Ply - -open System.Threading.Tasks -open FSharp.Control.Tasks -open FSharp.Control.Tasks.Affine.Unsafe - -type Ply<'a> = Ply.Ply<'a> -let uply = FSharp.Control.Tasks.Affine.Unsafe.uply - -let map (f : 'a -> 'b) (v : Ply<'a>) : Ply<'b> = - uply { - let! v = v - return f v - } - -let bind (f : 'a -> Ply<'b>) (v : Ply<'a>) : Ply<'b> = - uply { - let! v = v - return! f v - } - -let toTask (v : Ply<'a>) : Task<'a> = Ply.TplPrimitives.runPlyAsTask v - - -// These functions are sequential versions of List/Map functions like map/iter/etc. -// They await each list item before they process the next. This ensures each -// request in the list is processed to completion before the next one is done, -// making sure that, for example, a HttpClient call will finish before the next one -// starts. Will allow other requests to run which waiting. -module List = - let flatten (list : List>) : Ply> = - let rec loop (acc : Ply>) (xs : List>) = - uply { - let! acc = acc - - match xs with - | [] -> return List.rev acc - | x :: xs -> - let! x = x - return! loop (uply { return (x :: acc) }) xs - } - - loop (uply { return [] }) list - - let foldSequentially - (f : 'state -> 'a -> Ply<'state>) - (initial : 'state) - (list : List<'a>) - : Ply<'state> = - List.fold - (fun (accum : Ply<'state>) (arg : 'a) -> - uply { - let! accum = accum - return! f accum arg - }) - (Ply initial) - list - - let foldSequentiallyWithIndex - (f : int -> 'state -> 'a -> Ply<'state>) - (initial : 'state) - (list : List<'a>) - : Ply<'state> = - List.fold - (fun (accum : (Ply)) (arg : 'a) -> - uply { - let! (i, state) = accum - let! result = f i state arg - return (i + 1, result) - }) - (Ply((0, initial))) - list - |> map Tuple2.second - - - let mapSequentially (f : 'a -> Ply<'b>) (list : List<'a>) : Ply> = - list - |> foldSequentially - (fun (accum : List<'b>) (arg : 'a) -> - uply { - let! result = f arg - return result :: accum - }) - [] - |> map List.reverse - - let mapSequentiallyWithIndex - (f : int -> 'a -> Ply<'b>) - (list : List<'a>) - : Ply> = - list - |> foldSequentiallyWithIndex - (fun (i : int) (accum : List<'b>) (arg : 'a) -> - uply { - let! result = f i arg - return result :: accum - }) - [] - |> map List.rev - - let filterSequentially (f : 'a -> Ply) (list : List<'a>) : Ply> = - uply { - let! filtered = - List.fold - (fun (accum : Ply>) (arg : 'a) -> - uply { - let! (accum : List<'a>) = accum - let! keep = f arg - return (if keep then (arg :: accum) else accum) - }) - (Ply []) - list - - return List.rev filtered - } - - let iterSequentially (f : 'a -> Ply) (list : List<'a>) : Ply = - List.fold - (fun (accum : Ply) (arg : 'a) -> - uply { - do! accum // resolve the previous task before doing this one - return! f arg - }) - (Ply(())) - list - - let findSequentially (f : 'a -> Ply) (list : List<'a>) : Ply> = - List.fold - (fun (accum : Ply>) (arg : 'a) -> - uply { - match! accum with - | Some v -> return Some v - | None -> - let! result = f arg - return (if result then Some arg else None) - }) - (Ply None) - list - - let filterMapSequentially - (f : 'a -> Ply>) - (list : List<'a>) - : Ply> = - uply { - let! filtered = - List.fold - (fun (accum : Ply>) (arg : 'a) -> - uply { - let! (accum : List<'b>) = accum - let! keep = f arg - - let result = - match keep with - | Some v -> v :: accum - | None -> accum - - return result - }) - (Ply []) - list - - return List.rev filtered - } - -module NEList = - let mapSequentially - (f : 'a -> Ply<'b>) - (list : NEList.NEList<'a>) - : Ply> = - uply { - let! head = f list.head - let! tail = List.mapSequentially f list.tail - return NEList.ofList head tail - } - - -module Map = - let foldSequentially - (f : 'state -> 'key -> 'a -> Ply<'state>) - (initial : 'state) - (dict : Map<'key, 'a>) - : Ply<'state> = - Map.fold - (fun (accum : Ply<'state>) (key : 'key) (arg : 'a) -> - uply { - let! (accum : 'state) = accum - return! f accum key arg - }) - (Ply(initial)) - dict - - let mapSequentially - (f : 'a -> Ply<'b>) - (dict : Map<'key, 'a>) - : Ply> = - foldSequentially - (fun (accum : Map<'key, 'b>) (key : 'key) (arg : 'a) -> - uply { - let! result = f arg - return Map.add key result accum - }) - Map.empty - dict - - let filterSequentially - (f : 'key -> 'a -> Ply) - (dict : Map<'key, 'a>) - : Ply> = - foldSequentially - (fun (accum : Map<'key, 'a>) (key : 'key) (arg : 'a) -> - uply { - let! keep = f key arg - return (if keep then (Map.add key arg accum) else accum) - }) - Map.empty - dict - - let filterMapSequentially - (f : 'key -> 'a -> Ply>) - (dict : Map<'key, 'a>) - : Ply> = - foldSequentially - (fun (accum : Map<'key, 'b>) (key : 'key) (arg : 'a) -> - uply { - let! keep = f key arg - - let result = - match keep with - | Some v -> Map.add key v accum - | None -> accum - - return result - }) - Map.empty - dict - - -module Result = - let map (f : 'a -> Ply<'b>) (result : Result<'a, 'err>) : Ply> = - match result with - | Ok v -> map (fun v -> Ok v) (f v) - | Error err -> Ply(Error err) - - -module Option = - let map (f : 'a -> Ply<'b>) (option : Option<'a>) : Ply> = - match option with - | Some v -> map (fun v -> Some v) (f v) - | None -> Ply None diff --git a/backend/src/Prelude/Prelude.fs b/backend/src/Prelude/Prelude.fs index 9f3d6aab10..25f286693b 100644 --- a/backend/src/Prelude/Prelude.fs +++ b/backend/src/Prelude/Prelude.fs @@ -1,7 +1,6 @@ module Prelude open System.Threading.Tasks -open FSharp.Control.Tasks // ---------------------- // Fix a few functions everywhere @@ -46,9 +45,6 @@ type Metadata = Exception.Metadata type HashSet<'a> = HashSet.HashSet<'a> -type Ply<'a> = Ply.Ply<'a> -let uply = Ply.uply - type uuid = System.Guid type CanvasID = uuid type UserID = uuid @@ -163,8 +159,8 @@ let printTime (string : string) : unit = // Print the value of `a`. Note that since this is wrapped in a task, it must // resolve the task before it can print, which could lead to different ordering // of operations. -let debugPly (msg : string) (a : Ply.Ply<'a>) : Ply.Ply<'a> = - uply { +let debugPly (msg : string) (a : Task<'a>) : Task<'a> = + task { let! a = a NonBlockingConsole.writeLine $"DEBUG: {msg} ({a})" return a diff --git a/backend/src/Prelude/Prelude.fsproj b/backend/src/Prelude/Prelude.fsproj index 199432aac2..916c013f14 100644 --- a/backend/src/Prelude/Prelude.fsproj +++ b/backend/src/Prelude/Prelude.fsproj @@ -26,7 +26,6 @@ - diff --git a/backend/src/Prelude/Task.fs b/backend/src/Prelude/Task.fs index 57f76fba01..5f3bd8664d 100644 --- a/backend/src/Prelude/Task.fs +++ b/backend/src/Prelude/Task.fs @@ -1,7 +1,6 @@ module Task open System.Threading.Tasks -open FSharp.Control.Tasks let map (f : 'a -> 'b) (v : Task<'a>) : Task<'b> = task { @@ -33,6 +32,22 @@ let foldSequentially (Task.FromResult initial) list +let foldSequentiallyWithIndex + (f : int -> 'state -> 'a -> Task<'state>) + (initial : 'state) + (list : List<'a>) + : Task<'state> = + List.fold + (fun (accum : Task) (arg : 'a) -> + task { + let! (i, state) = accum + let! result = f i state arg + return (i + 1, result) + }) + (Task.FromResult(0, initial)) + list + |> map snd + let mapSequentially (f : 'a -> Task<'b>) (list : List<'a>) : Task> = list |> foldSequentially @@ -44,6 +59,17 @@ let mapSequentially (f : 'a -> Task<'b>) (list : List<'a>) : Task> = [] |> map List.rev +module NEList = + let mapSequentially + (f : 'a -> Task<'b>) + (list : NEList.NEList<'a>) + : Task> = + task { + let! head = f list.head + let! tail = mapSequentially f list.tail + return NEList.ofList head tail + } + let mapInParallel (f : 'a -> Task<'b>) (list : List<'a>) : Task> = List.map f list |> flatten diff --git a/backend/src/Prelude/Telemetry.fs b/backend/src/Prelude/Telemetry.fs index 02cd811b58..a9731cf557 100644 --- a/backend/src/Prelude/Telemetry.fs +++ b/backend/src/Prelude/Telemetry.fs @@ -12,6 +12,7 @@ /// F# and Dark traces appear in the same file and can be analyzed together. module Telemetry +open System.Threading.Tasks open System.Diagnostics /// Global mutable log path. Set early in startup. diff --git a/backend/src/Prelude/paket.references b/backend/src/Prelude/paket.references index 93a62bca6f..824bb72e69 100644 --- a/backend/src/Prelude/paket.references +++ b/backend/src/Prelude/paket.references @@ -1,4 +1,3 @@ -Ply FSharp.Core FSharpX.Extras FSharpPlus diff --git a/backend/src/LibExecution/AnalysisTypes.fs b/backend/src/Runtime/AnalysisTypes.fs similarity index 100% rename from backend/src/LibExecution/AnalysisTypes.fs rename to backend/src/Runtime/AnalysisTypes.fs diff --git a/backend/src/LibExecution/Blob.fs b/backend/src/Runtime/Blob.fs similarity index 70% rename from backend/src/LibExecution/Blob.fs rename to backend/src/Runtime/Blob.fs index b303c10557..524927c0e0 100644 --- a/backend/src/LibExecution/Blob.fs +++ b/backend/src/Runtime/Blob.fs @@ -14,6 +14,8 @@ /// operation; Dval shape-walking is just the means. module LibExecution.Blob +open System.Threading.Tasks + open Prelude open LibExecution.RuntimeTypes @@ -81,8 +83,8 @@ let popScope (exeState : ExecutionState) : unit = /// Resolve a BlobRef to its bytes. Ephemerals read from the VM store; /// persistent refs hit package_blobs via the ExecutionState's blob /// accessor. Shared by every builtin that dereferences a DBlob. -let readBytes (state : ExecutionState) (ref : BlobRef) : Ply.Ply = - uply { +let readBytes (state : ExecutionState) (ref : BlobRef) : Task = + task { match ref with | Ephemeral id -> let mutable bs : byte[] = null @@ -119,86 +121,89 @@ let readBytes (state : ExecutionState) (ref : BlobRef) : Ply.Ply = /// A captured trace holding a `DBlob(Ephemeral _)` deserialises in a /// fresh VM with the UUID intact but no bytes in that VM's blobStore, /// so the next `readBytes` raises "ephemeral blob not found". -/// Fix: thread a `promoteForCapture : Dval -> Ply` through the +/// Fix: thread a `promoteForCapture : Dval -> Task` through the /// Tracing.T record, wrap each storeXXX in promote-then-serialize. /// /// CLEANUP rebuilds container Dvals (Map.toList → walk → Map.ofList) /// even when no descendant blob promoted. Alloc-cheap in practice /// (~75KB regardless of input size), but a "did anything change" /// short-circuit would skip the round-trip in the common case. -let promote +let rec private promoteWalk (exeState : ExecutionState) - (insert : string -> byte[] -> Ply.Ply) + (insert : string -> byte[] -> Task) (dv : Dval) - : Ply.Ply = - uply { - let rec go (dv : Dval) : Ply.Ply = - uply { - match dv with - | DBlob(Ephemeral id) -> - let mutable bs : byte[] = null - if exeState.blobStore.TryGetValue(id, &bs) then - let h = sha256Hex bs - let n : int64 = System.Convert.ToInt64 bs.Length - do! insert h bs - return DBlob(Persistent(h, n)) - else - return - Exception.raiseInternal - "Ephemeral blob not found in store during promotion" - [ "id", id ] - | DBlob(Persistent _) - | DUnit - | DBool _ - | DInt8 _ - | DUInt8 _ - | DInt16 _ - | DUInt16 _ - | DInt32 _ - | DUInt32 _ - | DInt64 _ - | DUInt64 _ - | DInt128 _ - | DUInt128 _ - | DFloat _ - | DChar _ - | DString _ - | DDateTime _ - | DUuid _ - | DApplicable _ - | DDB _ - | DStream _ -> return dv - | DList(vt, items) -> - let! items' = items |> Ply.List.mapSequentially go - return DList(vt, items') - | DDict(vt, entries) -> - let! entries' = - entries - |> Map.toList - |> Ply.List.mapSequentially (fun (k, v) -> - uply { - let! v' = go v - return (k, v') - }) - return DDict(vt, Map.ofList entries') - | DTuple(a, b, rest) -> - let! a' = go a - let! b' = go b - let! rest' = rest |> Ply.List.mapSequentially go - return DTuple(a', b', rest') - | DRecord(src, rt, typeArgs, fields) -> - let! fields' = - fields - |> Map.toList - |> Ply.List.mapSequentially (fun (k, v) -> - uply { - let! v' = go v - return (k, v') - }) - return DRecord(src, rt, typeArgs, Map.ofList fields') - | DEnum(src, rt, typeArgs, caseName, fields) -> - let! fields' = fields |> Ply.List.mapSequentially go - return DEnum(src, rt, typeArgs, caseName, fields') - } - return! go dv + : Task = + task { + match dv with + | DBlob(Ephemeral id) -> + let mutable bs : byte[] = null + if exeState.blobStore.TryGetValue(id, &bs) then + let h = sha256Hex bs + let n : int64 = System.Convert.ToInt64 bs.Length + do! insert h bs + return DBlob(Persistent(h, n)) + else + return + Exception.raiseInternal + "Ephemeral blob not found in store during promotion" + [ "id", id ] + | DBlob(Persistent _) + | DUnit + | DBool _ + | DInt8 _ + | DUInt8 _ + | DInt16 _ + | DUInt16 _ + | DInt32 _ + | DUInt32 _ + | DInt64 _ + | DUInt64 _ + | DInt128 _ + | DUInt128 _ + | DFloat _ + | DChar _ + | DString _ + | DDateTime _ + | DUuid _ + | DApplicable _ + | DDB _ + | DStream _ -> return dv + | DList(vt, items) -> + let! items' = items |> Task.mapSequentially (promoteWalk exeState insert) + return DList(vt, items') + | DDict(vt, entries) -> + let! entries' = + entries + |> Map.toList + |> Task.mapSequentially (fun (k, v) -> + task { + let! v' = promoteWalk exeState insert v + return (k, v') + }) + return DDict(vt, Map.ofList entries') + | DTuple(a, b, rest) -> + let! a' = promoteWalk exeState insert a + let! b' = promoteWalk exeState insert b + let! rest' = rest |> Task.mapSequentially (promoteWalk exeState insert) + return DTuple(a', b', rest') + | DRecord(src, rt, typeArgs, fields) -> + let! fields' = + fields + |> Map.toList + |> Task.mapSequentially (fun (k, v) -> + task { + let! v' = promoteWalk exeState insert v + return (k, v') + }) + return DRecord(src, rt, typeArgs, Map.ofList fields') + | DEnum(src, rt, typeArgs, caseName, fields) -> + let! fields' = fields |> Task.mapSequentially (promoteWalk exeState insert) + return DEnum(src, rt, typeArgs, caseName, fields') } + +let promote + (exeState : ExecutionState) + (insert : string -> byte[] -> Task) + (dv : Dval) + : Task = + promoteWalk exeState insert dv diff --git a/backend/src/LibExecution/Builtin.fs b/backend/src/Runtime/Builtin.fs similarity index 100% rename from backend/src/LibExecution/Builtin.fs rename to backend/src/Runtime/Builtin.fs diff --git a/backend/src/LibExecution/Dval.fs b/backend/src/Runtime/Dval.fs similarity index 100% rename from backend/src/LibExecution/Dval.fs rename to backend/src/Runtime/Dval.fs diff --git a/backend/src/LibExecution/Interpreter.fs b/backend/src/Runtime/Interpreter.fs similarity index 95% rename from backend/src/LibExecution/Interpreter.fs rename to backend/src/Runtime/Interpreter.fs index 02c738e328..07570e2b06 100644 --- a/backend/src/LibExecution/Interpreter.fs +++ b/backend/src/Runtime/Interpreter.fs @@ -1,6 +1,8 @@ /// Interprets Dark instructions resulting in (tasks of) Dvals module LibExecution.Interpreter +open System.Threading.Tasks + open Prelude open RuntimeTypes module RTE = RuntimeError @@ -259,8 +261,11 @@ let rec checkAndExtractMatchPattern -let rec private executeInner (exeState : ExecutionState) (vm : VMState) : Ply = - uply { +let rec private executeInner + (exeState : ExecutionState) + (vm : VMState) + : Task = + task { let raiseRTE rte = raiseRTE vm.threadID rte let pendingCallArgs = System.Collections.Generic.Dictionary() @@ -273,13 +278,13 @@ let rec private executeInner (exeState : ExecutionState) (vm : VMState) : Ply Ply(snd vm.rootInstrData) + | Source -> Task.FromResult(snd vm.rootInstrData) | Lambda(parentContext, lambdaID) -> match Map.tryFind lambdaID vm.lambdaInstrDataCache with - | Some cached -> Ply cached + | Some cached -> Task.FromResult cached | None -> let lambda = match exeState.lambdaInstrCache.TryGetValue lambdaID with @@ -294,24 +299,24 @@ let rec private executeInner (exeState : ExecutionState) (vm : VMState) : Ply // we should error in some better way (CLEANUP) // , but the point is that callstacks shouldn't be created for builtin fn calls - raiseRTE (RTE.FnNotFound(FQFnName.fqBuiltin "builtin" 0)) + task { return raiseRTE (RTE.FnNotFound(FQFnName.fqBuiltin "builtin" 0)) } | Function(FQFnName.Package fn) -> - uply { + task { match exeState.packageFnInstrCache.TryGetValue fn with | true, cached -> return cached | false, _ -> match! exeState.fns.package fn with - | Some fn -> + | Some pkgFn -> let instrData = - { instructions = List.toArray fn.body.instructions - resultReg = fn.body.resultIn } - exeState.packageFnInstrCache[fn.hash] <- instrData + { instructions = List.toArray pkgFn.body.instructions + resultReg = pkgFn.body.resultIn } + exeState.packageFnInstrCache[pkgFn.hash] <- instrData return instrData | None -> return raiseRTE (RTE.FnNotFound(FQFnName.Package fn)) @@ -483,9 +488,8 @@ let rec private executeInner (exeState : ExecutionState) (vm : VMState) : Ply Ply.List.mapSequentially ( - TypeReference.toVT exeState.types currentFrame.typeSymbolTable - ) + |> Task.mapSequentially (fun t -> + TypeReference.toVT exeState.types currentFrame.typeSymbolTable t) let! record = TypeChecker.DvalCreator.record @@ -554,7 +558,8 @@ let rec private executeInner (exeState : ExecutionState) (vm : VMState) : Ply Ply.List.mapSequentially (TypeReference.toVT exeState.types tst) + |> Task.mapSequentially (fun t -> + TypeReference.toVT exeState.types tst t) let! newEnum = TypeChecker.DvalCreator.enum @@ -723,8 +728,8 @@ let rec private executeInner (exeState : ExecutionState) (vm : VMState) : Ply Ply.List.iterSequentially (fun ((pIndex, pName, pType), arg) -> - uply { + |> Task.iterSequentially (fun ((pIndex, pName, pType), arg) -> + task { match! typeCheckParam tst pIndex pName pType arg with | Ok updatedTst -> tst <- updatedTst @@ -745,7 +750,7 @@ let rec private executeInner (exeState : ExecutionState) (vm : VMState) : Ply match Map.find builtin exeState.fns.builtIn with - | None -> return RTE.FnNotFound(FQFnName.Builtin builtin) |> raiseRTE + | None -> RTE.FnNotFound(FQFnName.Builtin builtin) |> raiseRTE | Some fn -> // Step 1: resolve typeArgs against the OUTER tst so the // wrapper-pass-through pattern works (a wrapper body @@ -754,10 +759,11 @@ let rec private executeInner (exeState : ExecutionState) (vm : VMState) : Ply typeParamCount then - return handleWrongTypeArgCount typeParamCount typeArgCount + handleWrongTypeArgCount typeParamCount typeArgCount let! resolvedTypeArgsVT = typeArgs - |> Ply.List.mapSequentially (TypeReference.toVT exeState.types tst) + |> Task.mapSequentially (fun t -> + TypeReference.toVT exeState.types tst t) // Step 2: shadow this fn's free type-vars from the // inherited TST. Mirrors the package-fn path; without @@ -818,7 +824,7 @@ let rec private executeInner (exeState : ExecutionState) (vm : VMState) : Ply typeCheckParams let! result = - uply { + task { if argCount > paramCount then return handleTooManyArgs paramCount argCount else if argCount < paramCount then @@ -885,9 +891,9 @@ let rec private executeInner (exeState : ExecutionState) (vm : VMState) : Ply raiseRTE + RTE.DeprecatedItemHalted pkg |> raiseRTE match! exeState.fns.package pkg with - | None -> return RTE.FnNotFound(FQFnName.Package pkg) |> raiseRTE + | None -> RTE.FnNotFound(FQFnName.Package pkg) |> raiseRTE | Some fn -> // Step 1: resolve any explicit typeArgs against the // OUTER tst — they may reference outer-scope TVariables @@ -897,18 +903,18 @@ let rec private executeInner (exeState : ExecutionState) (vm : VMState) : Ply Ply [] // OK to omit type args entirely + | [], _ -> Task.FromResult [] // OK to omit type args entirely | _ -> - uply { + task { let typeParamCount, typeArgCount = (List.length fn.typeParams, List.length typeArgs) if typeArgCount <> typeParamCount then return handleWrongTypeArgCount typeParamCount typeArgCount - return! - typeArgs - |> Ply.List.mapSequentially ( - TypeReference.toVT exeState.types tst - ) + else + return! + typeArgs + |> Task.mapSequentially (fun t -> + TypeReference.toVT exeState.types tst t) } // Step 2: shadow this fn's free type-vars in the inherited @@ -983,7 +989,7 @@ let rec private executeInner (exeState : ExecutionState) (vm : VMState) : Ply typeCheckParams if argCount > paramCount then - return handleTooManyArgs paramCount argCount + handleTooManyArgs paramCount argCount else if argCount < paramCount then registers[putResultIn] <- { applicable with @@ -1074,7 +1080,7 @@ let rec private executeInner (exeState : ExecutionState) (vm : VMState) : Ply - uply { + task { let! fn = exeState.fns.package id match fn with | None -> return RTE.FnNotFound fnName |> raiseRTE @@ -1083,7 +1089,7 @@ let rec private executeInner (exeState : ExecutionState) (vm : VMState) : Ply let fn = Map.findUnsafe builtin exeState.fns.builtIn - Ply fn.returnType + Task.FromResult fn.returnType let tst = currentFrame.typeSymbolTable match! @@ -1096,15 +1102,14 @@ let rec private executeInner (exeState : ExecutionState) (vm : VMState) : Ply let! expectedVT = TypeReference.toVT exeState.types tst expectedReturnType - return - RuntimeError.Applications.FnResultNotExpectedType( - fnName, - expectedVT, - Dval.toValueType resultOfFrame, - resultOfFrame - ) - |> RuntimeError.Apply - |> raiseRTE + RuntimeError.Applications.FnResultNotExpectedType( + fnName, + expectedVT, + Dval.toValueType resultOfFrame, + resultOfFrame + ) + |> RuntimeError.Apply + |> raiseRTE // Record per-package-fn timing on frame return if vm.stats.enabled && vm.stats.detailedTiming then @@ -1154,8 +1159,8 @@ let rec private executeInner (exeState : ExecutionState) (vm : VMState) : Ply return dv - | None -> return Exception.raiseInternal "No finalResult found" [] + | None -> return (Exception.raiseInternal "No finalResult found" [] : Dval) } -and execute (exeState : ExecutionState) (vm : VMState) : Ply = +and execute (exeState : ExecutionState) (vm : VMState) : Task = executeInner exeState vm diff --git a/backend/src/LibExecution/ProgramTypesToRuntimeTypes.fs b/backend/src/Runtime/ProgramTypesToRuntimeTypes.fs similarity index 99% rename from backend/src/LibExecution/ProgramTypesToRuntimeTypes.fs rename to backend/src/Runtime/ProgramTypesToRuntimeTypes.fs index 7df9a65df9..c71dad579c 100644 --- a/backend/src/LibExecution/ProgramTypesToRuntimeTypes.fs +++ b/backend/src/Runtime/ProgramTypesToRuntimeTypes.fs @@ -1,6 +1,8 @@ /// Convert from ProgramTypes to RuntimeTypes module LibExecution.ProgramTypesToRuntimeTypes +open System.Threading.Tasks + open Prelude // Used for conversion functions @@ -1249,22 +1251,22 @@ module PackageManager = : RT.PackageManager = let toPT (RT.Hash h) : PT.Hash = PT.Hash h { getType = - fun id -> pm.getType (toPT id) |> Ply.map (Option.map PackageType.toRT) + fun id -> pm.getType (toPT id) |> Task.map (Option.map PackageType.toRT) getValue = fun id -> pm.getValue (toPT id) - |> Ply.map (Option.map (PackageValue.toRT builtinValues)) - getFn = fun id -> pm.getFn (toPT id) |> Ply.map (Option.map PackageFn.toRT) + |> Task.map (Option.map (PackageValue.toRT builtinValues)) + getFn = fun id -> pm.getFn (toPT id) |> Task.map (Option.map PackageFn.toRT) // PT PackageManager has no blob channel — it's purely location- // based name resolution. Transient wrappers return None; the // real blob lookup comes from the canonical RT PM. - getBlob = fun _ -> Ply None - persistBlob = fun _ _ -> uply { return () } + getBlob = fun _ -> Task.FromResult None + persistBlob = fun _ _ -> task { return () } // PT PackageManager doesn't surface deprecation state; transient // wrappers (tests, in-memory flows) have no branch chain anyway. - isHarmful = fun _ _ -> Ply false + isHarmful = fun _ _ -> Task.FromResult false init = pm.init } diff --git a/backend/src/LibExecution/RTQueryCompiler.fs b/backend/src/Runtime/RTQueryCompiler.fs similarity index 98% rename from backend/src/LibExecution/RTQueryCompiler.fs rename to backend/src/Runtime/RTQueryCompiler.fs index 4efe50dee7..7b37454497 100644 --- a/backend/src/LibExecution/RTQueryCompiler.fs +++ b/backend/src/Runtime/RTQueryCompiler.fs @@ -4,6 +4,8 @@ /// but we need RT to access lambda bodies when passed as variables rather than inline. module LibExecution.RTQueryCompiler +open System.Threading.Tasks + open Prelude module RT = RuntimeTypes @@ -75,8 +77,8 @@ let getSqlSpec let getFnBody (exeState : RT.ExecutionState) (pkgId : RT.FQFnName.Package) - : Ply.Ply> = - uply { + : Task> = + task { let! fn = exeState.fns.package pkgId return Option.map (fun (f : RT.PackageFn.PackageFn) -> f.body) fn } @@ -88,8 +90,8 @@ let partialEvaluate (fnName : RT.FQFnName.FQFnName) (typeArgs : List) (args : List) - : Ply.Ply = - uply { + : Task = + task { // Build instructions to call the function let fnReg = 0 let argRegs = [ 1 .. List.length args ] @@ -293,7 +295,7 @@ let rec inlineAndExecute Error "Max inline depth exceeded" else // Look up the function body synchronously - let fnBodyOpt = getFnBody exeState fnId |> Ply.toTask |> _.Result + let fnBodyOpt = (getFnBody exeState fnId).Result match fnBodyOpt with | None -> Error $"Function not found for inlining: {fnId}" | Some fnBody -> @@ -381,10 +383,7 @@ and executeInstruction let argDvals = args |> List.choose tryExtractDval if List.length argDvals = List.length args then // All args are Literals - partial evaluate - let result = - partialEvaluate exeState fnName typeArgs argDvals - |> Ply.toTask - |> _.Result + let result = (partialEvaluate exeState fnName typeArgs argDvals).Result Ok(state.withReg (createTo, Literal result)) else // Not all args are Literals - try to inline package functions diff --git a/backend/src/Runtime/Runtime.fsproj b/backend/src/Runtime/Runtime.fsproj new file mode 100644 index 0000000000..58a42185c4 --- /dev/null +++ b/backend/src/Runtime/Runtime.fsproj @@ -0,0 +1,32 @@ + + + + Library + net10.0 + 10.0 + false + true + true + + + + + + + + + + + + + + + + + + + + + + + diff --git a/backend/src/LibExecution/RuntimeTypes.fs b/backend/src/Runtime/RuntimeTypes.fs similarity index 96% rename from backend/src/LibExecution/RuntimeTypes.fs rename to backend/src/Runtime/RuntimeTypes.fs index af73c8b2cf..96422492e5 100644 --- a/backend/src/LibExecution/RuntimeTypes.fs +++ b/backend/src/Runtime/RuntimeTypes.fs @@ -6,6 +6,8 @@ /// (referring back to PT by index or something) module LibExecution.RuntimeTypes +open System.Threading.Tasks + open Prelude // Aliases for the .NET mutable collection types used across the runtime @@ -662,7 +664,7 @@ and [] Dval = /// until the enclosing [DStream] is drained via `readStreamNext` or /// `readStreamChunk`. /// -/// Mapped/Filtered hold pre-bound `Dval -> Ply<...>` closures rather +/// Mapped/Filtered hold pre-bound `Dval -> Task<...>` closures rather /// than the raw [Applicable]. The builtin wrapper (Stream.map etc.) /// closes over `exeState`/`vmState` when constructing the closure, so /// the drain path in Dval.fs stays decoupled from Execution — Dval.fs @@ -706,12 +708,12 @@ and [] StreamImpl = /// FileStream / etc. /// /// Optional `nextChunk` lets byte-stream producers avoid per-byte - /// Ply/Dval boxing. `nextChunk maxBytes` fills up to `maxBytes` into - /// a fresh byte[] and returns it (or None on exhaustion). Consumers - /// that want bulk bytes (`streamToBlob`, SSE-byte accumulator) take - /// this path; byte-by-byte `next` stays authoritative for element- - /// wise pulls (`streamNext` on `Stream`). Non-byte streams - /// leave this `None`. + /// state-machine/Dval boxing. `nextChunk maxBytes` fills up to + /// `maxBytes` into a fresh byte[] and returns it (or None on + /// exhaustion). Consumers that want bulk bytes (`streamToBlob`, + /// SSE-byte accumulator) take this path; byte-by-byte `next` stays + /// authoritative for element-wise pulls (`streamNext` on + /// `Stream`). Non-byte streams leave this `None`. /// /// TODO no backpressure: a producer faster than its consumer fills /// memory. Today HTTP is network-bounded and in-process producers @@ -720,12 +722,12 @@ and [] StreamImpl = /// if anyone adds a "buffer N elements ahead" or "merge multiple /// streams" combinator. | FromIO of - next : (unit -> Ply>) * + next : (unit -> Task>) * elemType : ValueType * disposer : (unit -> unit) option * - nextChunk : (int -> Ply>) option - | Mapped of src : StreamImpl * fn : (Dval -> Ply) * elemType : ValueType - | Filtered of src : StreamImpl * pred : (Dval -> Ply) + nextChunk : (int -> Task>) option + | Mapped of src : StreamImpl * fn : (Dval -> Task) * elemType : ValueType + | Filtered of src : StreamImpl * pred : (Dval -> Task) | Take of src : StreamImpl * n : int64 * remaining : int64 ref | Concat of streams : StreamImpl list ref @@ -733,7 +735,7 @@ and [] StreamImpl = override this.GetHashCode() : int = 0 -and DvalTask = Ply +and DvalTask = Task @@ -1246,37 +1248,37 @@ module PackageFn = /// (though, we'll likely demand deps. in the PM before committing something upstream...) type PackageManager = { - getType : FQTypeName.Package -> Ply> - getValue : FQValueName.Package -> Ply> - getFn : FQFnName.Package -> Ply> + getType : FQTypeName.Package -> Task> + getValue : FQValueName.Package -> Task> + getFn : FQFnName.Package -> Task> /// Content-addressed blob bytes by SHA-256 hash. Returns [None] /// for missing hashes. - getBlob : string -> Ply> + getBlob : string -> Task> /// Insert bytes into `package_blobs` keyed by SHA-256 hash. Uses /// INSERT OR IGNORE — same hash = same content (content-addressing /// invariant), so a second insert is a cheap no-op. - persistBlob : string -> byte[] -> Ply + persistBlob : string -> byte[] -> Task /// Is this package fn hash marked Harmful on the given branch chain? /// Branch-scoped because deprecation state flows through branches; the /// other PM lookups are content-addressed and need no branch. /// Only fns participate — see DeprecationKind.Harmful for why. - isHarmful : BranchId -> FQFnName.Package -> Ply + isHarmful : BranchId -> FQFnName.Package -> Task - init : Ply + init : Task } static member empty = - { getType = (fun _ -> Ply None) - getFn = (fun _ -> Ply None) - getValue = (fun _ -> Ply None) - getBlob = (fun _ -> Ply None) - persistBlob = (fun _ _ -> uply { return () }) - isHarmful = (fun _ _ -> Ply false) + { getType = (fun _ -> Task.FromResult None) + getFn = (fun _ -> Task.FromResult None) + getValue = (fun _ -> Task.FromResult None) + getBlob = (fun _ -> Task.FromResult None) + persistBlob = (fun _ _ -> task { return () }) + isHarmful = (fun _ _ -> Task.FromResult false) - init = uply { return () } } + init = task { return () } } /// Allows you to side-load a few 'extras' in-memory, along /// the normal fetching functionality. (Mostly helpful for tests) @@ -1293,17 +1295,17 @@ type PackageManager = { getType = fun id -> match Map.tryFind id typeMap with - | Some t -> Some t |> Ply + | Some t -> Task.FromResult(Some t) | None -> pm.getType id getValue = fun id -> match Map.tryFind id valueMap with - | Some v -> Some v |> Ply + | Some v -> Task.FromResult(Some v) | None -> pm.getValue id getFn = fun id -> match Map.tryFind id fnMap with - | Some f -> Some f |> Ply + | Some f -> Task.FromResult(Some f) | None -> pm.getFn id getBlob = pm.getBlob persistBlob = pm.persistBlob @@ -1654,9 +1656,9 @@ and TestContext = postTestExecutionHook : TestContext -> unit } -and ExceptionReporter = ExecutionState -> VMState -> Metadata -> exn -> Ply +and ExceptionReporter = ExecutionState -> VMState -> Metadata -> exn -> Task -and Notifier = ExecutionState -> VMState -> string -> Metadata -> Ply +and Notifier = ExecutionState -> VMState -> string -> Metadata -> Task /// All state set when starting an execution; non-changing /// (as opposed to the VMState, which changes as the execution progresses) @@ -1748,11 +1750,11 @@ and ExecutionState = } -and Types = { package : FQTypeName.Package -> Ply> } +and Types = { package : FQTypeName.Package -> Task> } and Values = { builtIn : Map - package : FQValueName.Package -> Ply> } + package : FQValueName.Package -> Task> } /// Blob-byte access wired onto the ExecutionState. `get` resolves a /// content-addressed hash to bytes (or None if the hash is missing); @@ -1760,28 +1762,28 @@ and Values = /// Needed inside builtins that manipulate blobs — eg. /// `Blob.toHex : Blob -> String` has to dereference its arg. and Blobs = - { get : string -> Ply>; persist : string -> byte[] -> Ply } + { get : string -> Task>; persist : string -> byte[] -> Task } and Functions = { builtIn : Map - package : FQFnName.Package -> Ply> + package : FQFnName.Package -> Task> /// `PackageManager.isHarmful` with the state's branchId pre-applied. - isHarmful : FQFnName.Package -> Ply + isHarmful : FQFnName.Package -> Task } module Types = - let empty = { package = (fun _ -> Ply None) } + let empty = { package = (fun _ -> Task.FromResult None) } let find (types : Types) (name : FQTypeName.FQTypeName) - : Ply> = + : Task> = match name with | FQTypeName.Package pkg -> - types.package pkg |> Ply.map (Option.map _.declaration) + types.package pkg |> Task.map (Option.map _.declaration) /// Swap concrete types for type parameters /// CLEANUP consider accepting a pre-zipped list instead @@ -1850,27 +1852,27 @@ module TypeReference = [ t ] ) - let rec unwrapAlias (types : Types) (typ : TypeReference) : Ply = + let rec unwrapAlias (types : Types) (typ : TypeReference) : Task = match typ with | TCustomType({ resolved = Ok outerTypeName }, outerTypeArgs) -> - uply { + task { match! Types.find types outerTypeName with | Some { definition = TypeDeclaration.Alias typ; typeParams = typeParams } -> let typ = Types.substitute typeParams outerTypeArgs typ return! unwrapAlias types typ | _ -> return typ } - | _ -> Ply typ + | _ -> Task.FromResult typ let rec toVT (types : Types) (tst : TypeSymbolTable) (typeRef : TypeReference) - : Ply = + : Task = let r = toVT types tst - uply { + task { match! unwrapAlias types typeRef with | TUnit -> return ValueType.Known KTUnit | TBool -> return ValueType.Known KTBool @@ -1898,7 +1900,7 @@ module TypeReference = | TTuple(first, second, theRest) -> let! first = r first let! second = r second - let! theRest = theRest |> Ply.List.mapSequentially r + let! theRest = theRest |> Task.mapSequentially r return KTTuple(first, second, theRest) |> ValueType.Known | TList inner -> let! inner = r inner @@ -1908,7 +1910,7 @@ module TypeReference = return ValueType.Known(KTDict inner) | TCustomType({ resolved = Ok typeName }, typeArgs) -> - let! typeArgs = typeArgs |> Ply.List.mapSequentially r + let! typeArgs = typeArgs |> Task.mapSequentially r return KTCustomType(typeName, typeArgs) |> ValueType.Known | TCustomType({ originalName = names; resolved = Error nre }, _) -> @@ -1918,7 +1920,7 @@ module TypeReference = return tst |> Map.get name |> Option.defaultValue ValueType.Unknown | TFn(args, result) -> - let! args = args |> Ply.NEList.mapSequentially r + let! args = args |> Task.NEList.mapSequentially r let! result = r result return KTFn(args, result) |> ValueType.Known @@ -2010,8 +2012,8 @@ module TypeReference = let consoleReporter : ExceptionReporter = fun _state _vm (metadata : Metadata) (exn : exn) -> - uply { printException "runtime-error" metadata exn } + task { printException "runtime-error" metadata exn } let consoleNotifier : Notifier = fun _state _vm msg tags -> - uply { print $"A notification happened in the runtime:\n {msg}\n {tags}\n\n" } + task { print $"A notification happened in the runtime:\n {msg}\n {tags}\n\n" } diff --git a/backend/src/LibExecution/Stream.fs b/backend/src/Runtime/Stream.fs similarity index 64% rename from backend/src/LibExecution/Stream.fs rename to backend/src/Runtime/Stream.fs index 5f45e41190..6f75777b59 100644 --- a/backend/src/LibExecution/Stream.fs +++ b/backend/src/Runtime/Stream.fs @@ -7,6 +7,8 @@ /// `RuntimeTypes.fs`. module LibExecution.Stream +open System.Threading.Tasks + open Prelude open LibExecution.RuntimeTypes @@ -38,15 +40,26 @@ let rec disposeImpl (impl : StreamImpl) : unit = /// full [disposeImpl] chain once (guarded by the shared `disposed` /// ref, so no double-fire if streamClose/drain-to-EOF already ran). /// +/// Carries a permit-1 SemaphoreSlim that the consumer paths +/// (`readNext`, `readChunk`) try to claim immediately. A second +/// concurrent consumer hits the contended path and raises a clean +/// `concurrent consumer` error rather than racing silently. Reachable +/// via the `lockObj : obj` slot on `DStream`; consumers cast back +/// through `Finalizer.consumerLock`. Disposed via `Dispose` from +/// the finalizer/streamClose chain so the OS handle is released. +/// /// Swallows disposer exceptions — finalizers that throw crash the /// process, and we'd rather leak on the pathological case than take /// down everything. type Finalizer(impl : StreamImpl, disposed : bool ref) = + let consumerLock = new System.Threading.SemaphoreSlim(1, 1) + member _.ConsumerLock = consumerLock override this.Finalize() = try if not disposed.Value then disposed.Value <- true disposeImpl impl + consumerLock.Dispose() with _ -> () @@ -64,6 +77,25 @@ let wrapImpl (impl : StreamImpl) : Dval = DStream(impl, disposed, Finalizer(impl, disposed) :> obj) +/// Try to claim the per-stream consumer lock without blocking. Used +/// by `readNext` and `readChunk` to detect concurrent consumers — +/// the second consumer hits the contended path and we raise a clean +/// error rather than racing on shared `disposed`/`carry` state. +/// +/// Cast back through the `Finalizer` because `DStream`'s `lockObj` +/// slot is `obj` (kept opaque so the lifecycle is always managed +/// through `wrapImpl`/`Finalizer`). +let private tryAcquireConsumerLock (lockObj : obj) : bool = + match lockObj with + | :? Finalizer as f -> f.ConsumerLock.Wait(0) + | _ -> true // unknown lock object — be permissive rather than crash + +let private releaseConsumerLock (lockObj : obj) : unit = + match lockObj with + | :? Finalizer as f -> f.ConsumerLock.Release() |> ignore + | _ -> () + + /// Mint a fresh DStream from a pull function. Convenience wrapper /// over [wrapImpl] for the common FromIO case. [disposer], when /// `Some`, is called once when the stream is drained to completion, @@ -73,7 +105,7 @@ let wrapImpl (impl : StreamImpl) : Dval = /// efficiently yield a whole chunk per pull. let newFromIO (elemType : ValueType) - (next : unit -> Ply.Ply>) + (next : unit -> Task>) (disposer : (unit -> unit) option) : Dval = wrapImpl (FromIO(next, elemType, disposer, None)) @@ -90,15 +122,15 @@ let newFromIO /// chunk buffer. let newChunked (elemType : ValueType) - (nextChunk : int -> Ply.Ply>) + (nextChunk : int -> Task>) (disposer : (unit -> unit) option) : Dval = // Maintain a small carry buffer so single-byte `next` pulls can // be served from the chunks that `nextChunk` returned. let carry = ref [||] let carryPos = ref 0 - let next () : Ply.Ply> = - uply { + let next () : Task> = + task { if carryPos.Value >= carry.Value.Length then // Refill from the underlying chunked producer. 8 KB mirrors // the socket-read buffer size we use across the codebase. @@ -127,8 +159,8 @@ let newChunked /// (Mapped/Filtered/Take/Concat) without re-entering the root's /// disposed flag — nested transforms share the wrapping DStream's /// lifecycle. -let rec private pullImpl (impl : StreamImpl) : Ply.Ply> = - uply { +let rec private pullImpl (impl : StreamImpl) : Task> = + task { match impl with | FromIO(next, _elemType, _disposer, _nextChunk) -> return! next () @@ -143,7 +175,7 @@ let rec private pullImpl (impl : StreamImpl) : Ply.Ply> = | Filtered(src, pred) -> // Pull from source until the predicate accepts or the source // runs dry. Written as a mutable loop rather than tail recursion - // so a long rejection run doesn't blow the Ply chain. + // so a long rejection run doesn't blow the state-machine chain. let mutable result : Option = None let mutable keepGoing = true while keepGoing do @@ -196,42 +228,43 @@ let rec private pullImpl (impl : StreamImpl) : Ply.Ply> = /// stream is exhausted; subsequent calls after exhaustion return /// [None] (single-consumer — once drained, stays drained). /// -/// No thread-affine lock: `pullImpl` awaits inside `fn v` / `pred v` -/// (via `Exe.executeApplicable`) and Ply continuations can resume on -/// a different thread, which makes `Monitor.Exit` throw -/// `SynchronizationLockException`. We rely on the single-threaded -/// Dark VM model for ordering instead — concurrent consumers of the -/// same stream have undefined output but never crash. -/// -/// TODO LATENT BUG: the single-consumer invariant is unenforced. -/// `disposed` only short-circuits AFTER drain; two callers entering -/// `readNext` concurrently on the same DStream interleave silently. -/// Cheap fix: a semaphore-with-permit-1 + raise on contention. -/// Proper fix: a Ply-aware lock that survives continuation awaits — -/// that's a Ply-internals refactor. Nothing in the codebase shares a -/// DStream across consumers today, but the type system doesn't -/// prevent it. +/// Single-consumer enforcement: each DStream carries a permit-1 +/// SemaphoreSlim on its `lockObj` (the `Finalizer`). `readNext` +/// claims the permit non-blockingly at entry; a second concurrent +/// consumer hits `Wait(0) = false` and we raise an internal error +/// rather than racing on shared `disposed`/transform-node state. +/// The permit is held across the inner `pullImpl` await — it's +/// released in the `finally`, so even a raised lambda inside `fn v` +/// / `pred v` can't strand the lock. /// -/// TODO per-element Ply continuation cost: every `next` allocates a +/// TODO per-element state-machine cost: every `next` allocates a /// state machine. A 1000-element pipeline with three transforms is /// ~3000 allocations. The chunked `nextChunk` fast path covers byte -/// streams; element-wise streams pay full cost. Real fix is replacing -/// Ply with something cheaper — either a custom `Future<'a>` struct -/// or a CPS interpreter with a fiber scheduler. -let readNext (dv : Dval) : Ply.Ply> = - uply { +/// streams; element-wise streams pay full cost. A future iteration +/// could replace `Task<'a>` on this hot path with a custom +/// `Future<'a>` struct or a CPS interpreter with a fiber scheduler. +let readNext (dv : Dval) : Task> = + task { match dv with - | DStream(impl, disposed, _lockObj) -> + | DStream(impl, disposed, lockObj) -> if disposed.Value then return None + else if not (tryAcquireConsumerLock lockObj) then + return + Exception.raiseInternal + "concurrent consumer on a single-consumer DStream" + [] else - let! result = pullImpl impl - match result with - | Some _ -> return result - | None -> - disposed.Value <- true - disposeImpl impl - return None + try + let! result = pullImpl impl + match result with + | Some _ -> return result + | None -> + disposed.Value <- true + disposeImpl impl + return None + finally + releaseConsumerLock lockObj | _ -> return Exception.raiseInternal "readNext: expected DStream" [] } @@ -246,47 +279,54 @@ let readNext (dv : Dval) : Ply.Ply> = /// Used by `streamToBlob` and SSE byte accumulators to amortise the /// Ply-continuation cost across whole chunks rather than paying it /// per byte. -let readChunk (maxBytes : int) (dv : Dval) : Ply.Ply> = - uply { +let readChunk (maxBytes : int) (dv : Dval) : Task> = + task { match dv with - | DStream(impl, disposed, _) -> + | DStream(impl, disposed, lockObj) -> if disposed.Value then return None + else if not (tryAcquireConsumerLock lockObj) then + return + Exception.raiseInternal + "concurrent consumer on a single-consumer DStream" + [] else - match impl with - | FromIO(_, _, _, Some nextChunk) -> - let! chunk = nextChunk maxBytes - match chunk with - | Some buf when buf.Length > 0 -> return Some buf + try + match impl with + | FromIO(_, _, _, Some nextChunk) -> + let! chunk = nextChunk maxBytes + match chunk with + | Some buf when buf.Length > 0 -> return Some buf + | _ -> + disposed.Value <- true + disposeImpl impl + return None | _ -> - disposed.Value <- true - disposeImpl impl - return None - | _ -> - // Fallback: pull byte-by-byte. Only pays off vs per-byte - // `readNext` if the caller really wants bulk bytes — - // transform chains lose the chunk optimisation but still - // drain correctly. - use collected = new System.IO.MemoryStream() - let mutable keepGoing = true - let mutable bytesSoFar = 0 - while keepGoing && bytesSoFar < maxBytes do - let! pulled = pullImpl impl - match pulled with - | Some(DUInt8 b) -> - collected.WriteByte b - bytesSoFar <- bytesSoFar + 1 - | Some _ -> - return + // Fallback: pull byte-by-byte. Only pays off vs per-byte + // `readNext` if the caller really wants bulk bytes — + // transform chains lose the chunk optimisation but still + // drain correctly. + use collected = new System.IO.MemoryStream() + let mutable keepGoing = true + let mutable bytesSoFar = 0 + while keepGoing && bytesSoFar < maxBytes do + let! pulled = pullImpl impl + match pulled with + | Some(DUInt8 b) -> + collected.WriteByte b + bytesSoFar <- bytesSoFar + 1 + | Some _ -> Exception.raiseInternal "readChunk: expected Stream element" [] - | None -> keepGoing <- false - if bytesSoFar = 0 then - disposed.Value <- true - disposeImpl impl - return None - else - return Some(collected.ToArray()) + | None -> keepGoing <- false + if bytesSoFar = 0 then + disposed.Value <- true + disposeImpl impl + return None + else + return Some(collected.ToArray()) + finally + releaseConsumerLock lockObj | _ -> return Exception.raiseInternal "readChunk: expected DStream" [] } diff --git a/backend/src/LibExecution/TypeChecker.fs b/backend/src/Runtime/TypeChecker.fs similarity index 94% rename from backend/src/LibExecution/TypeChecker.fs rename to backend/src/Runtime/TypeChecker.fs index 69d7652364..8e19865f3f 100644 --- a/backend/src/LibExecution/TypeChecker.fs +++ b/backend/src/Runtime/TypeChecker.fs @@ -2,6 +2,8 @@ /// Called by the interpreter, and a few other places module LibExecution.TypeChecker +open System.Threading.Tasks + open Prelude open RuntimeTypes module VT = ValueType @@ -22,10 +24,10 @@ let rec unifyValueType (pathSoFar : ReverseTypeCheckPath) (expected : TypeReference) (actual : ValueType) - : Ply> = + : Task> = let r = unifyValueType types - uply { + task { match expected, actual with | TVariable name, _ -> @@ -85,10 +87,10 @@ let rec unifyValueType let expected = tFirst :: tSecond :: tRest let actual = vFirst :: vSecond :: vRest return! - Ply.List.foldSequentiallyWithIndex + Task.foldSequentiallyWithIndex (fun i acc (e, a) -> match acc with - | Error _ -> Ply acc + | Error _ -> Task.FromResult acc | Ok tst -> r tst (TypeCheckPathPart.TupleAtIndex i :: pathSoFar) e a) (Ok tst) (List.zip expected actual) @@ -110,8 +112,8 @@ let rec unifyValueType | _, ValueType.Known(KTCustomType(typeNameV, typeArgsV)) -> if typeNameV <> typeNameT then return Error pathSoFar + // (this is really unexpected -- interpreter should prevent this) else if List.length typeArgsT <> List.length typeArgsV then - // (this is really unexpected -- interpreter should prevent this) return Error( TypeCheckPathPart.TypeArgLength( @@ -125,12 +127,12 @@ let rec unifyValueType let typeArgCount = List.length typeArgsT return! List.zip typeArgsT typeArgsV - |> Ply.List.foldSequentiallyWithIndex + |> Task.foldSequentiallyWithIndex (fun i acc (e, a) -> match acc with - | Error _path -> Ply acc + | Error _path -> Task.FromResult acc | Ok tst -> - uply { + task { let path = TypeCheckPathPart.TypeArg(typeNameT, i, typeArgCount) :: pathSoFar @@ -150,10 +152,10 @@ let rec unifyValueType List.zip (returnType :: (NEList.toList argTypes)) (vRet :: (NEList.toList vArgs)) - |> Ply.List.foldSequentially + |> Task.foldSequentially (fun acc (e, a) -> match acc with - | Error _path -> Ply acc + | Error _path -> Task.FromResult acc | Ok tst -> r tst pathSoFar e a) (Ok tst) @@ -169,8 +171,8 @@ let unify (tst : TypeSymbolTable) (expected : TypeReference) (actual : Dval) - : Ply> = - uply { + : Task> = + task { let actualType = Dval.toValueType actual match! unifyValueType types tst [] expected actualType with | Error path -> return path |> Error @@ -185,8 +187,11 @@ let rec resolveType (typeName : FQTypeName.FQTypeName) (typeArgs : List) // : (typeName * typeArgs * def) - : Ply * TypeDeclaration.Definition> = - uply { + : Task * + TypeDeclaration.Definition> + = + task { match! Types.find types typeName with | None -> return RTE.TypeNotFound typeName |> raiseRTE threadID | Some decl -> @@ -210,8 +215,8 @@ let rec resolveType // Map inner type args using target type's param names let! mappedInnerArgsVT = List.zip targetDecl.typeParams innerTypeArgs - |> Ply.List.mapSequentially (fun (targetParam, typeRef) -> - uply { + |> Task.mapSequentially (fun (targetParam, typeRef) -> + task { let! vt = TypeReference.toVT types tst typeRef return match typeRef with @@ -224,7 +229,7 @@ let rec resolveType return! resolveType types threadID tst innerTypeName [] - |> Ply.map (fun (resolvedName, _, def) -> + |> Task.map (fun (resolvedName, _, def) -> (resolvedName, mappedInnerArgsVT, def)) | _ -> return RTE.TypeNotFound typeName |> raiseRTE threadID @@ -249,8 +254,8 @@ let checkFnParam (paramName : string) (expected : TypeReference) (actual : Dval) - : Ply> = - uply { + : Task> = + task { let! expected = TypeReference.unwrapAlias types expected match! unify types tst expected actual with | Ok updatedTst -> return Ok updatedTst @@ -276,8 +281,8 @@ let checkFnResult (tst : TypeSymbolTable) (expected : TypeReference) (actual : Dval) - : Ply> = - uply { + : Task> = + task { let! expected = TypeReference.unwrapAlias types expected let! expectedVT = TypeReference.toVT types tst expected match! unify types tst expected actual with @@ -469,11 +474,11 @@ module DvalCreator = (threadID : ThreadID) (typeName : FQTypeName.FQTypeName) (typeArgs : List) - : Ply * NEList> = - uply { + task { let! (resolvedName, typeArgs, definition) = resolveType types threadID Map.empty typeName typeArgs @@ -496,8 +501,8 @@ module DvalCreator = (typeArgs : List) (caseName : string) (fields : List) - : Ply = - uply { + : Task = + task { // do basic resolution of aliases and type args let! (resolvedTypeName, typeArgs, caseDefs) = resolveEnumType types threadID sourceTypeName typeArgs @@ -533,9 +538,9 @@ module DvalCreator = // Process each field, updating type args as we learn more let! (typeArgs, fieldsInReverse, _updatedTst) = - Ply.List.foldSequentiallyWithIndex + Task.foldSequentiallyWithIndex (fun fieldIndex (typeArgs, fieldsInReverse, tst) (fieldDef, actualField) -> - uply { + task { let! expected = TypeReference.toVT types tst fieldDef match! unify types tst fieldDef actualField with | Error _path -> @@ -594,11 +599,11 @@ module DvalCreator = (threadID : ThreadID) (typeName : FQTypeName.FQTypeName) (typeArgs : List) - : Ply * NEList> = - uply { + task { let! (resolvedName, typeArgs, definition) = resolveType types threadID Map.empty typeName typeArgs @@ -623,8 +628,8 @@ module DvalCreator = (sourceTypeName : FQTypeName.FQTypeName) (typeArgs : List) (fields : List) - : Ply = - uply { + : Task = + task { let! (resolvedTypeName, resolvedTypeArgs, expectedFields) = resolveRecordType types threadID sourceTypeName typeArgs @@ -633,19 +638,17 @@ module DvalCreator = // Process each provided field let! (processedFields, finalTypeArgs, _updatedTST) = - Ply.List.foldSequentially + Task.foldSequentially (fun (fieldsSoFar, currentTypeArgs, tst) (fieldName, fieldValue) -> - uply { + task { // Basic validation if fieldName = "" then - return - RTE.Records.CreationEmptyKey |> RTE.Record |> raiseRTE threadID + RTE.Records.CreationEmptyKey |> RTE.Record |> raiseRTE threadID if Map.containsKey fieldName fieldsSoFar then - return - RTE.Records.CreationDuplicateField fieldName - |> RTE.Record - |> raiseRTE threadID + RTE.Records.CreationDuplicateField fieldName + |> RTE.Record + |> raiseRTE threadID // Find and validate field match expectedFields |> NEList.find (fun f -> f.name = fieldName) with @@ -736,8 +739,8 @@ module DvalCreator = (typeArgsBeforeUpdate : List) (currentFields : Map) (fieldUpdates : List) - : Ply = - uply { + : Task = + task { let! (_resolvedTypeName, resolvedTypeArgs, expectedFields) = resolveRecordType types threadID sourceTypeName [] @@ -746,9 +749,9 @@ module DvalCreator = |> List.map (fun (beforeUpdate, (name, _)) -> (name, beforeUpdate)) let! (updatedFields, finalTypeArgs, _updatedTST) = - Ply.List.foldSequentially + Task.foldSequentially (fun (fieldsSoFar, currentTypeArgs, tst) (fieldName, fieldValue) -> - uply { + task { if fieldName = "" then return RTE.Records.UpdateEmptyKey |> RTE.Record |> raiseRTE threadID diff --git a/backend/src/LibExecution/ValueType.fs b/backend/src/Runtime/ValueType.fs similarity index 100% rename from backend/src/LibExecution/ValueType.fs rename to backend/src/Runtime/ValueType.fs diff --git a/backend/src/Runtime/paket.references b/backend/src/Runtime/paket.references new file mode 100644 index 0000000000..d80dcf55f1 --- /dev/null +++ b/backend/src/Runtime/paket.references @@ -0,0 +1,3 @@ +FSharp.Core +FSharpPlus +System.IO.Hashing diff --git a/backend/testfiles/execution/cloud/internal.dark b/backend/testfiles/execution/cloud/internal.dark index 7a279a19b5..35644db778 100644 --- a/backend/testfiles/execution/cloud/internal.dark +++ b/backend/testfiles/execution/cloud/internal.dark @@ -14,7 +14,7 @@ module Documentation = module Infra = // correct number of tables - (Stdlib.Dict.size_v0 (Builtin.darkInternalInfraGetAndLogTableSizes_v0 ())) = 23L + (Stdlib.Dict.size_v0 (Builtin.darkInternalInfraGetAndLogTableSizes_v0 ())) = 21L // server build hash diff --git a/backend/tests/TestUtils/LibTest.fs b/backend/tests/TestUtils/LibTest.fs index 8fe09001f1..5c05d47db3 100644 --- a/backend/tests/TestUtils/LibTest.fs +++ b/backend/tests/TestUtils/LibTest.fs @@ -4,7 +4,6 @@ module TestUtils.LibTest // useful for testing open System.Threading.Tasks -open FSharp.Control.Tasks open Prelude open LibExecution.RuntimeTypes @@ -74,9 +73,9 @@ let fns () : List = |> (fun l -> l[0]) |> DChar |> Dval.optionSome KTChar - |> Ply + |> Task.FromResult else - Dval.optionNone KTChar |> Ply + Dval.optionNone KTChar |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -86,7 +85,10 @@ let fns () : List = { name = fn "testIncrementSideEffectCounter" 0 typeParams = [] parameters = - [ Param.make "passThru" (TVariable "a") "Ply which will be returned" ] + [ Param.make + "passThru" + (TVariable "a") + "Task.FromResult which will be returned" ] returnType = TVariable "a" description = "Increases the side effect counter by one, to test real-world side-effects. Returns its argument." @@ -94,7 +96,7 @@ let fns () : List = (function | state, _, _, [ arg ] -> state.test.sideEffectCount <- state.test.sideEffectCount + 1 - Ply(arg) + Task.FromResult arg | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -108,7 +110,8 @@ let fns () : List = description = "Return the value of the side-effect counter" fn = (function - | state, _, _, [ DUnit ] -> Ply(Dval.int64 state.test.sideEffectCount) + | state, _, _, [ DUnit ] -> + Task.FromResult(Dval.int64 state.test.sideEffectCount) | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -124,7 +127,7 @@ let fns () : List = (function | _, _, _, [ v; DString msg ] -> print $"{msg}: {v}" - Ply v + Task.FromResult v | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -139,7 +142,7 @@ let fns () : List = fn = (function | _, _, _, [ DString username ] -> - uply { + task { do! // This is unsafe. A user has canvases, and canvases have traces. It // will either break or cascade (haven't checked) @@ -175,7 +178,8 @@ let fns () : List = description = "Get the name of the canvas that's running" fn = (function - | state, _, _, [ DUnit ] -> state.program.canvasID |> DUuid |> Ply + | state, _, _, [ DUnit ] -> + state.program.canvasID |> DUuid |> Task.FromResult | _ -> incorrectArgs ()) sqlSpec = NotQueryable previewable = Pure @@ -190,7 +194,7 @@ let fns () : List = fn = (function | state, _, _, [ DInt64 count ] -> - uply { + task { state.test.expectedExceptionCount <- int count return DUnit } diff --git a/backend/tests/TestUtils/TestUtils.fs b/backend/tests/TestUtils/TestUtils.fs index bfe77a71f1..5137991304 100644 --- a/backend/tests/TestUtils/TestUtils.fs +++ b/backend/tests/TestUtils/TestUtils.fs @@ -4,7 +4,6 @@ module TestUtils.TestUtils open Expecto open System.Threading.Tasks -open FSharp.Control.Tasks open LibDB.Db @@ -143,55 +142,56 @@ let executionStateFor (allowLocalHttpAccess : bool) (dbs : Map) : Task = + let domains = [] //Canvas.domainsForCanvasID canvasID + + let program : RT.Program = + { canvasID = canvasID + internalFnsAllowed = internalFnsAllowed + dbs = dbs + secrets = [] } + + let testContext : RT.TestContext = + { sideEffectCount = 0 + exceptionReports = [] + expectedExceptionCount = 0 + postTestExecutionHook = + fun tc -> + let exceptionCountMatches = + tc.exceptionReports.Length = tc.expectedExceptionCount + + if not exceptionCountMatches then + List.iter + (fun (msg, stackTrace, metadata) -> + print + $"An error was reported in the runtime: \n {msg}\n{stackTrace}\n {metadata}\n\n") + tc.exceptionReports + Exception.raiseInternal + $"UNEXPECTED EXCEPTION COUNT in test {domains}" + [ "expectedExceptionCount", tc.expectedExceptionCount + "actualExceptionCount", tc.exceptionReports.Length + "reports", tc.exceptionReports ] } + + // Typically, exceptions thrown in tests have surprised us. Take these errors and + // catch them much closer to where they happen (usually in the function + // definition) + let rec exceptionReporter : RT.ExceptionReporter = + fun (state : RT.ExecutionState) vm metadata (exn : exn) -> + task { + let message = exn.Message + let stackTrace = exn.StackTrace + let metadata = Exception.toMetadata exn @ metadata + let inner = exn.InnerException + if not (isNull inner) then do! exceptionReporter state vm [] inner + state.test.exceptionReports <- + (message, stackTrace, metadata) :: state.test.exceptionReports + } + task { - let domains = [] //Canvas.domainsForCanvasID canvasID - - let program : RT.Program = - { canvasID = canvasID - internalFnsAllowed = internalFnsAllowed - dbs = dbs - secrets = [] } - - let testContext : RT.TestContext = - { sideEffectCount = 0 - exceptionReports = [] - expectedExceptionCount = 0 - postTestExecutionHook = - fun tc -> - let exceptionCountMatches = - tc.exceptionReports.Length = tc.expectedExceptionCount - - if not exceptionCountMatches then - List.iter - (fun (msg, stackTrace, metadata) -> - print - $"An error was reported in the runtime: \n {msg}\n{stackTrace}\n {metadata}\n\n") - tc.exceptionReports - Exception.raiseInternal - $"UNEXPECTED EXCEPTION COUNT in test {domains}" - [ "expectedExceptionCount", tc.expectedExceptionCount - "actualExceptionCount", tc.exceptionReports.Length - "reports", tc.exceptionReports ] } - - // Typically, exceptions thrown in tests have surprised us. Take these errors and - // catch them much closer to where they happen (usually in the function - // definition) - let rec exceptionReporter : RT.ExceptionReporter = - fun (state : RT.ExecutionState) vm metadata (exn : exn) -> - uply { - let message = exn.Message - let stackTrace = exn.StackTrace - let metadata = Exception.toMetadata exn @ metadata - let inner = exn.InnerException - if not (isNull inner) then do! exceptionReporter state vm [] inner - state.test.exceptionReports <- - (message, stackTrace, metadata) :: state.test.exceptionReports - } // For now, lets not track notifications, as often our tests explicitly trigger // things that notify, while Exceptions have historically been unexpected errors // in the tests and so are worth watching out for. - let notifier : RT.Notifier = fun _state _vm _msg _tags -> uply { return () } + let notifier : RT.Notifier = fun _state _vm _msg _tags -> task { return () } let builtins = if allowLocalHttpAccess then localBuiltIns pmPT else cloudBuiltIns pmPT @@ -250,8 +250,8 @@ let testManyTask (name : string) (fn : 'a -> Task<'b>) (values : List<'a * 'b>) }) values) -let testManyPly (name : string) (fn : 'a -> Ply<'b>) (values : List<'a * 'b>) = - testManyTask name (fn >> Ply.toTask) values +let testManyPly (name : string) (fn : 'a -> Task<'b>) (values : List<'a * 'b>) = + testManyTask name fn values let testMany2Task @@ -1516,8 +1516,8 @@ let configureLogging let unwrapExecutionResult (state : RT.ExecutionState) (exeResult : RT.ExecutionResult) - : Ply.Ply = - uply { + : Task = + task { match exeResult with | Ok dval -> return dval | Error(rte, callStack) -> @@ -1549,7 +1549,7 @@ let unwrapExecutionResult } let parsePTExpr (code : string) : Task = - uply { + task { let! (state : RT.ExecutionState) = let canvasID = System.Guid.NewGuid() executionStateFor pmPT canvasID false false Map.empty @@ -1568,4 +1568,3 @@ let parsePTExpr (code : string) : Task = return Exception.raiseInternal "Error converting Dval to PT.Expr" [] | _ -> return Exception.raiseInternal "Error executing parsePTExpr function" [] } - |> Ply.toTask diff --git a/backend/tests/Tests/AnalysisTypes.Tests.fs b/backend/tests/Tests/AnalysisTypes.Tests.fs index 22e0e0ebde..c00c29ae97 100644 --- a/backend/tests/Tests/AnalysisTypes.Tests.fs +++ b/backend/tests/Tests/AnalysisTypes.Tests.fs @@ -1,7 +1,6 @@ module Tests.AnalysisTypes open System.Threading.Tasks -open FSharp.Control.Tasks open Expecto open Prelude diff --git a/backend/tests/Tests/Blob.Tests.fs b/backend/tests/Tests/Blob.Tests.fs index d1a9b26875..f111e71e04 100644 --- a/backend/tests/Tests/Blob.Tests.fs +++ b/backend/tests/Tests/Blob.Tests.fs @@ -9,7 +9,6 @@ module Tests.Blob open Expecto open System.Threading.Tasks -open FSharp.Control.Tasks open Prelude open TestUtils.TestUtils @@ -44,8 +43,8 @@ let private freshState () : RT.ExecutionState = builtins pmRT Exe.noTracing - (fun _ _ _ _ -> uply { return () }) - (fun _ _ _ _ -> uply { return () }) + (fun _ _ _ _ -> task { return () }) + (fun _ _ _ _ -> task { return () }) PT.mainBranchId { canvasID = System.Guid.NewGuid() internalFnsAllowed = false @@ -67,8 +66,14 @@ let private persistentHash (dv : RT.Dval) : string = | RT.DBlob(RT.Persistent(h, _)) -> h | _ -> failtest $"expected DBlob(Persistent _), got {dv}" -let private noopInsert : string -> byte[] -> Ply = - fun _ _ -> uply { return () } +let private noopInsert : string -> byte[] -> Task = + fun _ _ -> task { return () } + +/// Bridge `LibPackageManager.RuntimeTypes.Blob.insert` (still typed +/// `Ply`) into the Task-shaped `insert` parameter that +/// `LibExecution.Blob.promote` now requires. +let private pmInsertTask (hash : string) (bytes : byte[]) : Task = + PMBlob.insert hash bytes let private uniquePayload (label : string) : byte[] = System.Text.Encoding.UTF8.GetBytes($"{label}-{System.Guid.NewGuid()}") @@ -110,7 +115,7 @@ let ephemeralRoundtrip = match dv with | RT.DBlob(RT.Ephemeral _) -> () | _ -> failtest $"expected DBlob(Ephemeral _), got {dv}" - let! bytes = Blob.readBytes state (dblobRef dv) |> Ply.toTask + let! bytes = Blob.readBytes state (dblobRef dv) Expect.equal bytes payload "roundtripped bytes match original" } @@ -121,8 +126,8 @@ let twoEphemeralsAreDistinct = let dv1 = Blob.newEphemeral state payload let dv2 = Blob.newEphemeral state payload Expect.notEqual (ephemeralId dv1) (ephemeralId dv2) "each mint gets a fresh uuid" - let! b1 = Blob.readBytes state (dblobRef dv1) |> Ply.toTask - let! b2 = Blob.readBytes state (dblobRef dv2) |> Ply.toTask + let! b1 = Blob.readBytes state (dblobRef dv1) + let! b2 = Blob.readBytes state (dblobRef dv2) Expect.equal b1 payload "first blob reads its bytes" Expect.equal b2 payload "second blob reads its bytes" } @@ -133,7 +138,7 @@ let missingEphemeralRaises = let bogusRef = RT.Ephemeral(System.Guid.NewGuid()) do! expectThrows "expected an exception on missing ephemeral id" (fun () -> - Blob.readBytes state bogusRef |> Ply.toTask :> Task<_>) + Blob.readBytes state bogusRef :> Task<_>) } @@ -246,8 +251,8 @@ let packageBlobInsertLookup = testTask "package_blobs: insert then get returns the same bytes" { let bytes = [| 10uy; 20uy; 30uy; 40uy; 50uy |] let hash = $"test-insert-lookup-{System.Guid.NewGuid()}" - do! PMBlob.insert hash bytes |> Ply.toTask - let! got = PMBlob.get hash |> Ply.toTask + do! PMBlob.insert hash bytes + let! got = PMBlob.get hash Expect.equal got (Some bytes) "get returns bytes for a freshly-inserted hash" } @@ -255,16 +260,16 @@ let packageBlobDedupesOnSameHash = testTask "package_blobs: second insert under same hash is a no-op" { let bytes = [| 1uy; 1uy; 2uy; 3uy; 5uy; 8uy |] let hash = $"test-dedup-{System.Guid.NewGuid()}" - do! PMBlob.insert hash bytes |> Ply.toTask + do! PMBlob.insert hash bytes // Different bytes under same hash must be ignored (content-addressing invariant). - do! PMBlob.insert hash [| 99uy; 99uy |] |> Ply.toTask - let! got = PMBlob.get hash |> Ply.toTask + do! PMBlob.insert hash [| 99uy; 99uy |] + let! got = PMBlob.get hash Expect.equal got (Some bytes) "INSERT OR IGNORE preserves the original bytes" } let packageBlobMissingHashReturnsNone = testTask "package_blobs: get on a missing hash returns None" { - let! got = PMBlob.get $"nonexistent-{System.Guid.NewGuid()}" |> Ply.toTask + let! got = PMBlob.get $"nonexistent-{System.Guid.NewGuid()}" Expect.equal got None "missing hash yields None" } @@ -278,14 +283,14 @@ let promotePersistsAndSwaps = let state = freshState () let payload = uniquePayload "promote-test" let ephemeral = Blob.newEphemeral state payload - let! promoted = Blob.promote state PMBlob.insert ephemeral |> Ply.toTask + let! promoted = Blob.promote state pmInsertTask ephemeral let expectedHash = Blob.sha256Hex payload match promoted with | RT.DBlob(RT.Persistent(h, n)) -> Expect.equal h expectedHash "hash matches SHA-256 of bytes" Expect.equal n (int64 payload.Length) "length matches" | _ -> failtest $"expected Persistent, got {promoted}" - let! row = PMBlob.get expectedHash |> Ply.toTask + let! row = PMBlob.get expectedHash Expect.equal row (Some payload) "package_blobs row exists with our bytes" } @@ -294,7 +299,7 @@ let promoteThenSerializeRoundtrips = let state = freshState () let payload = uniquePayload "promote-serialize" let ephemeral = Blob.newEphemeral state payload - let! promoted = Blob.promote state PMBlob.insert ephemeral |> Ply.toTask + let! promoted = Blob.promote state pmInsertTask ephemeral let restored = BS.RT.Dval.deserialize "dval" (BS.RT.Dval.serialize "dval" promoted) Expect.equal @@ -309,10 +314,10 @@ let promoteSameBytesTwiceDedups = let payload = uniquePayload "dedup-test" let eph1 = Blob.newEphemeral state payload let eph2 = Blob.newEphemeral state payload - let! p1 = Blob.promote state PMBlob.insert eph1 |> Ply.toTask - let! p2 = Blob.promote state PMBlob.insert eph2 |> Ply.toTask + let! p1 = Blob.promote state pmInsertTask eph1 + let! p2 = Blob.promote state pmInsertTask eph2 Expect.equal p1 p2 "two promotions of identical bytes share the hash" - let! row = PMBlob.get (Blob.sha256Hex payload) |> Ply.toTask + let! row = PMBlob.get (Blob.sha256Hex payload) Expect.equal row (Some payload) "row still contains original bytes" } @@ -321,8 +326,8 @@ let promotedBlobResolvesViaReadBlobBytes = let state = freshState () let payload = uniquePayload "resolve-test" let ephemeral = Blob.newEphemeral state payload - let! promoted = Blob.promote state PMBlob.insert ephemeral |> Ply.toTask - let! bytes = Blob.readBytes state (dblobRef promoted) |> Ply.toTask + let! promoted = Blob.promote state pmInsertTask ephemeral + let! bytes = Blob.readBytes state (dblobRef promoted) Expect.equal bytes payload "persistent blob resolves back to its bytes" } @@ -372,14 +377,13 @@ let queryableJsonRoundtrip = 2048L ) ) - let! json = QueryableJson.toJsonStringV0 types threadID original |> Ply.toTask + let! json = QueryableJson.toJsonStringV0 types threadID original Expect.stringContains json "\"type\":\"blob\"" "has blob envelope tag" Expect.stringContains json "\"hash\":\"e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855\"" "has the content hash" - let! restored = - QueryableJson.parseJsonV0 types threadID Map.empty RT.TBlob json |> Ply.toTask + let! restored = QueryableJson.parseJsonV0 types threadID Map.empty RT.TBlob json Expect.equal restored original "persistent blob survives queryable JSON" } @@ -392,8 +396,7 @@ let queryableJsonEphemeralRaises = do! expectThrows "ephemeral blob in queryable JSON should raise (promote first)" - (fun () -> - QueryableJson.toJsonStringV0 types threadID ephemeral |> Ply.toTask) + (fun () -> QueryableJson.toJsonStringV0 types threadID ephemeral) } let roundtrippableJsonPersistentRoundtrip = @@ -472,12 +475,11 @@ let promotedBlobsSurviveScopePop = let payload = [| 0xDEuy; 0xADuy; 0xBEuy; 0xEFuy |] Blob.pushScope state let eph = Blob.newEphemeral state payload - let! promoted = Blob.promote state pmRT.persistBlob eph |> Ply.toTask + let! promoted = Blob.promote state pmRT.persistBlob eph let hash = persistentHash promoted Blob.popScope state // Ephemeral bytes gone; persistent bytes survive in package_blobs. - let! bytes = - Blob.readBytes state (RT.Persistent(hash, int64 payload.Length)) |> Ply.toTask + let! bytes = Blob.readBytes state (RT.Persistent(hash, int64 payload.Length)) Expect.equal bytes payload "persistent bytes survive the pop" } @@ -520,7 +522,7 @@ let persistableRejectsEphemeralBlob = let persistableRejectsStream = test "isPersistable: DStream is not persistable" { - let next () : Ply> = uply { return None } + let next () : Task> = task { return None } let dv = Stream.newFromIO LibExecution.ValueType.int64 next None Expect.isFalse (Dval.isPersistable dv) "stream rejected" match Dval.nonPersistableReason dv with @@ -545,7 +547,7 @@ let persistableRejectsNestedBadShapes = ) Expect.isFalse (Dval.isPersistable list) "list with ephemeral blob rejected" - let next () : Ply> = uply { return None } + let next () : Task> = task { return None } let streamDv = Stream.newFromIO LibExecution.ValueType.int64 next None let typeName = RT.FQTypeName.fqPackage (LibExecution.PackageRefs.Type.Stdlib.option ()) @@ -571,8 +573,8 @@ let sweepDeletesOrphansButKeepsReferenced = let (RT.Hash fakeHashStr) = fakeHash try - do! PMBlob.insert refHash refBytes |> Ply.toTask - do! PMBlob.insert orphanHash orphanBytes |> Ply.toTask + do! PMBlob.insert refHash refBytes + do! PMBlob.insert orphanHash orphanBytes // Plant a package_value row whose rt_dval references refHash. let referencingDval = RT.DBlob(RT.Persistent(refHash, int64 refBytes.Length)) @@ -594,14 +596,14 @@ let sweepDeletesOrphansButKeepsReferenced = "value_type", Sql.bytes valueTypeBytes ] |> Sql.executeStatementAsync - let! deleted = PMBlob.sweepOrphans () |> Ply.toTask + let! deleted = PMBlob.sweepOrphans () Expect.isGreaterThanOrEqual deleted 1L "at least the orphan blob should have been swept" - let! refStill = PMBlob.get refHash |> Ply.toTask + let! refStill = PMBlob.get refHash Expect.isSome refStill "referenced blob stays in package_blobs" - let! orphanStill = PMBlob.get orphanHash |> Ply.toTask + let! orphanStill = PMBlob.get orphanHash Expect.isNone orphanStill "orphan blob was swept" finally // Clean up the planted package_values row even on assertion diff --git a/backend/tests/Tests/BranchOps.Tests.fs b/backend/tests/Tests/BranchOps.Tests.fs index c93e7b16f9..0f372e1c96 100644 --- a/backend/tests/Tests/BranchOps.Tests.fs +++ b/backend/tests/Tests/BranchOps.Tests.fs @@ -1,7 +1,6 @@ module Tests.BranchOps open System.Threading.Tasks -open FSharp.Control.Tasks open Expecto open Prelude diff --git a/backend/tests/Tests/Builtin.Tests.fs b/backend/tests/Tests/Builtin.Tests.fs index 376db74db6..acf7d0f997 100644 --- a/backend/tests/Tests/Builtin.Tests.fs +++ b/backend/tests/Tests/Builtin.Tests.fs @@ -6,7 +6,6 @@ module Tests.Builtin open Expecto open System.Threading.Tasks -open FSharp.Control.Tasks open Prelude diff --git a/backend/tests/Tests/BwdServer.Tests.fs b/backend/tests/Tests/BwdServer.Tests.fs index eb4ffef3d2..1b87ff0e16 100644 --- a/backend/tests/Tests/BwdServer.Tests.fs +++ b/backend/tests/Tests/BwdServer.Tests.fs @@ -11,7 +11,6 @@ let dataBasePath = "testfiles/data" open Expecto open System.Threading.Tasks -open FSharp.Control.Tasks open System.Net.Sockets open System.Text.Json @@ -193,8 +192,8 @@ let setupTestCanvas (testName : string) (test : Test) : Task // Handlers let! oplists = test.handlers - |> Ply.List.mapSequentially (fun handler -> - uply { + |> Task.mapSequentially (fun handler -> + task { let! source = parsePTExpr handler.code let spec = diff --git a/backend/tests/Tests/Canvas.Tests.fs b/backend/tests/Tests/Canvas.Tests.fs index 2c6d74be21..df8008a022 100644 --- a/backend/tests/Tests/Canvas.Tests.fs +++ b/backend/tests/Tests/Canvas.Tests.fs @@ -1,7 +1,6 @@ module Tests.Canvas open System.Threading.Tasks -open FSharp.Control.Tasks open Expecto open Fumble diff --git a/backend/tests/Tests/DvalRepr.Tests.fs b/backend/tests/Tests/DvalRepr.Tests.fs index 4ce4f43a36..7931284462 100644 --- a/backend/tests/Tests/DvalRepr.Tests.fs +++ b/backend/tests/Tests/DvalRepr.Tests.fs @@ -1,7 +1,6 @@ module Tests.DvalRepr open System.Threading.Tasks -open FSharp.Control.Tasks open Expecto open Prelude @@ -23,8 +22,8 @@ let toRepr (dval : RT.Dval) : string = builtins pmRT Exe.noTracing - (fun _ _ _ _ -> uply { return () }) - (fun _ _ _ _ -> uply { return () }) + (fun _ _ _ _ -> task { return () }) + (fun _ _ _ _ -> task { return () }) PT.mainBranchId { canvasID = System.Guid.NewGuid() internalFnsAllowed = false @@ -69,16 +68,22 @@ let queryableRoundtripsSuccessfullyInRecord RT.TypeDeclaration.Record( NEList.ofList { name = "field"; typ = fieldTyp } [] ) } } - packageType |> Some |> Ply + packageType |> Some |> Task.FromResult else pmRT.getType id } let! roundtripped = - record - |> DvalReprInternalQueryable.toJsonStringV0 types bogusThreadID - |> Ply.bind ( - DvalReprInternalQueryable.parseJsonV0 types bogusThreadID Map.empty typeRef - ) + task { + let! json = + DvalReprInternalQueryable.toJsonStringV0 types bogusThreadID record + return! + DvalReprInternalQueryable.parseJsonV0 + types + bogusThreadID + Map.empty + typeRef + json + } return Expect.RT.dvalEquality record roundtripped } diff --git a/backend/tests/Tests/Execution.Tests.fs b/backend/tests/Tests/Execution.Tests.fs index 396185d7c8..eb97944424 100644 --- a/backend/tests/Tests/Execution.Tests.fs +++ b/backend/tests/Tests/Execution.Tests.fs @@ -1,7 +1,6 @@ module Tests.Execution open System.Threading.Tasks -open FSharp.Control.Tasks open Expecto diff --git a/backend/tests/Tests/HttpClient.Tests.fs b/backend/tests/Tests/HttpClient.Tests.fs index ce8d02af2c..89250cb6ba 100644 --- a/backend/tests/Tests/HttpClient.Tests.fs +++ b/backend/tests/Tests/HttpClient.Tests.fs @@ -14,7 +14,6 @@ let versions = [ "v0" ] open Expecto open System.Threading.Tasks -open FSharp.Control.Tasks open System.IO open System.IO.Compression @@ -110,8 +109,8 @@ module Internal = let parseSingleTestFromFile (filename : string) (test : string) - : Ply = - uply { + : Task = + task { let! (state : RT.ExecutionState) = let canvasID = System.Guid.NewGuid() executionStateFor pmPT canvasID false false Map.empty @@ -213,7 +212,6 @@ let makeTest versionName filename = // compressed |> String.replace "LENGTH" (string response.body.Length) |> parseSingleTestFromFile "httpclient.tests.fs" - |> Ply.toTask // Run the handler (call the HTTP client) // Note: this will update the corresponding value in `testCases` with the @@ -241,12 +239,12 @@ let makeTest versionName filename = // Promote ephemeral blobs on both sides so two independently-built // Blobs with identical bytes (different UUIDs) compare equal. - let noopInsert _ _ = uply { return () } + let noopInsert _ _ = task { return () } let promoteIfOk r = task { match r with | Ok dv -> - let! p = LibExecution.Blob.promote exeState noopInsert dv |> Ply.toTask + let! p = LibExecution.Blob.promote exeState noopInsert dv return Ok p | Error _ -> return r } @@ -497,8 +495,8 @@ module StreamDvalTests = let buffer = Array.zeroCreate 8192 let mutable bufferLen = 0 let mutable bufferPos = 0 - let next () : Ply> = - uply { + let next () : Task> = + task { if bufferPos >= bufferLen then let! n = responseStream.ReadAsync(buffer, 0, buffer.Length) if n = 0 then @@ -528,7 +526,7 @@ module StreamDvalTests = use ms = new System.IO.MemoryStream() let mutable keepGoing = true while keepGoing do - let! pulled = Stream.readNext s |> Ply.toTask + let! pulled = Stream.readNext s match pulled with | Some(RT.DUInt8 b) -> ms.WriteByte b | Some _ -> Exception.raiseInternal "expected DUInt8" [] @@ -626,7 +624,7 @@ module StreamDvalTests = | _ -> failtest "expected DStream" Expect.isTrue disposerRan.Value "disposer runs on explicit close" // Subsequent pulls yield None. - let! after = Stream.readNext s |> Ply.toTask + let! after = Stream.readNext s Expect.equal after None "closed stream yields None" } ] diff --git a/backend/tests/Tests/Interpreter.Tests.fs b/backend/tests/Tests/Interpreter.Tests.fs index f67429b382..d190900cce 100644 --- a/backend/tests/Tests/Interpreter.Tests.fs +++ b/backend/tests/Tests/Interpreter.Tests.fs @@ -25,7 +25,7 @@ let tCheckVM let! exeState = executionStateFor TestValues.pm (System.Guid.NewGuid()) false false Map.empty - let! actual = LibExecution.Interpreter.execute exeState vmState |> Ply.toTask + let! actual = LibExecution.Interpreter.execute exeState vmState Expect.equal actual expectedInsts "" extraAssertions exeState vmState @@ -549,7 +549,7 @@ module Lambdas = E.Lambdas.Identity.unapplied |> PT2RT.Expr.toRT Map.empty 0 None |> RT.VMState.createWithoutTLID - let! lambdaDval = LibExecution.Interpreter.execute exeState vmA |> Ply.toTask + let! lambdaDval = LibExecution.Interpreter.execute exeState vmA let applicable = match lambdaDval with diff --git a/backend/tests/Tests/LibExecution.Tests.fs b/backend/tests/Tests/LibExecution.Tests.fs index 122a1ea331..eecb2f68b5 100644 --- a/backend/tests/Tests/LibExecution.Tests.fs +++ b/backend/tests/Tests/LibExecution.Tests.fs @@ -8,7 +8,6 @@ module Tests.LibExecution open Expecto open System.Threading.Tasks -open FSharp.Control.Tasks open Fumble open LibDB.Db @@ -53,8 +52,8 @@ let runtimeErrorMessage (state : RT.ExecutionState) (allegedRTE : RT.RuntimeError.Error) (callStack : RT.CallStack) - : Ply = - uply { + : Task = + task { let actual = RT2DT.RuntimeError.toDT allegedRTE let errorMessageFn = RT.FQFnName.fqPackage ( @@ -196,13 +195,12 @@ let t // test framework's structural `dvalEquality`. The no-op insert // means we don't persist to `package_blobs` — we only need the // hash to dedupe UUID identity. - let noopInsert _ _ = uply { return () } + let noopInsert _ _ = task { return () } let promoteIfOk (r : RT.ExecutionResult) : Task = task { match r with | Ok dv -> - let! promoted = - LibExecution.Blob.promote state noopInsert dv |> Ply.toTask + let! promoted = LibExecution.Blob.promote state noopInsert dv return Ok promoted | Error _ -> return r } @@ -249,8 +247,7 @@ let t None $"Expected runtime error `{expectedError}` but expression returned a value.\n\nTest location: {filename}:{lineNumber}" | Error(allegedRTE, callStack) -> - let! actualError = - runtimeErrorMessage state allegedRTE callStack |> Ply.toTask + let! actualError = runtimeErrorMessage state allegedRTE callStack return Expect.equal actualError expectedError "" | LibParser.TestModule.PTExpected.PTExpectedSqlError expectedSqlError -> @@ -263,8 +260,7 @@ let t None $"Expected SQL runtime error `{expectedSqlError}` but expression returned a value.\n\nTest location: {filename}:{lineNumber}" | Error(allegedRTE, callStack) -> - let! actualError = - runtimeErrorMessage state allegedRTE callStack |> Ply.toTask + let! actualError = runtimeErrorMessage state allegedRTE callStack let expected = LibExecution.RTQueryCompiler.errorTemplate + expectedSqlError return Expect.equal actualError expected "" diff --git a/backend/tests/Tests/LibParser.Tests.fs b/backend/tests/Tests/LibParser.Tests.fs index f89f0f025b..1b84874c71 100644 --- a/backend/tests/Tests/LibParser.Tests.fs +++ b/backend/tests/Tests/LibParser.Tests.fs @@ -25,7 +25,6 @@ let exprRTs = NR.OnMissing.Allow "libparser.tests.fs" testStr - |> Ply.toTask return Expect.PT.equalExprIgnoringIDs actual expectedExpr } diff --git a/backend/tests/Tests/NewParser.Tests.fs b/backend/tests/Tests/NewParser.Tests.fs index 26cd3e68bc..3ffbf59f89 100644 --- a/backend/tests/Tests/NewParser.Tests.fs +++ b/backend/tests/Tests/NewParser.Tests.fs @@ -9,7 +9,6 @@ module Tests.NewParser open System.Threading.Tasks -open FSharp.Control.Tasks open Expecto @@ -54,7 +53,7 @@ let t let args = NEList.singleton (RT.DString input) let! parseResult = LibExecution.Execution.executeFunction parseExeState parseFnName [] args - let! parseDval = unwrapExecutionResult parseExeState parseResult |> Ply.toTask + let! parseDval = unwrapExecutionResult parseExeState parseResult match parseDval with | RT.DEnum(tn, _, _, "Ok", [ RT.DTuple(sourceFile, opsList, []) ]) when @@ -75,7 +74,7 @@ let t let ppArgs = NEList.ofList (RT.DUuid PT.mainBranchId) [ sourceFile ] let! ppResult = LibExecution.Execution.executeFunction ppExeState prettyPrintFnName [] ppArgs - let! resultDval = unwrapExecutionResult ppExeState ppResult |> Ply.toTask + let! resultDval = unwrapExecutionResult ppExeState ppResult match resultDval with | RT.DString result -> diff --git a/backend/tests/Tests/Prelude.Tests.fs b/backend/tests/Tests/Prelude.Tests.fs index 6a369077a7..b8fdda6397 100644 --- a/backend/tests/Tests/Prelude.Tests.fs +++ b/backend/tests/Tests/Prelude.Tests.fs @@ -1,7 +1,6 @@ module Tests.Prelude open System.Threading.Tasks -open FSharp.Control.Tasks open Expecto open Prelude @@ -11,8 +10,8 @@ open TestUtils.TestUtils let asyncTests = // slow it down so later items might be run first - let delay (f : unit -> 'a) (i : int) : Ply<'a> = - uply { + let delay (f : unit -> 'a) (i : int) : Task<'a> = + task { do! Task.Delay(100 - (i * 10)) return (f ()) } @@ -21,23 +20,23 @@ let asyncTests = "sequential" [ testTask "mapSequentially" { let fn (i : int) = delay (fun () -> i + 1) i - let! result = Ply.List.mapSequentially fn [ 1; 2; 3; 4 ] |> Ply.toTask + let! result = Task.mapSequentially fn [ 1; 2; 3; 4 ] Expect.equal result [ 2; 3; 4; 5 ] "" } testTask "filterSequentially" { - let fn (i : int) = uply { return (i % 2) = 0 } - let! result = Ply.List.filterSequentially fn [ 1; 2; 3; 4 ] |> Ply.toTask + let fn (i : int) = task { return (i % 2) = 0 } + let! result = Task.filterSequentially fn [ 1; 2; 3; 4 ] Expect.equal result [ 2; 4 ] "" } testTask "findSequentially" { let fn (i : int) = delay (fun () -> i = 3) i - let! result = Ply.List.findSequentially fn [ 1; 2; 3; 4 ] |> Ply.toTask + let! result = Task.findSequentially fn [ 1; 2; 3; 4 ] Expect.equal result (Some 3) "" } testTask "iterSequentially" { let mutable state = [] let fn (i : int) = delay (fun () -> state <- i + 1 :: state) i - do! Ply.List.iterSequentially fn [ 1; 2; 3; 4 ] |> Ply.toTask + do! Task.iterSequentially fn [ 1; 2; 3; 4 ] Expect.equal state [ 5; 4; 3; 2 ] "" } ] diff --git a/backend/tests/Tests/Propagation.Tests.fs b/backend/tests/Tests/Propagation.Tests.fs index 5b8d9c6510..70a9c7d666 100644 --- a/backend/tests/Tests/Propagation.Tests.fs +++ b/backend/tests/Tests/Propagation.Tests.fs @@ -1,7 +1,6 @@ module Tests.Propagation open System.Threading.Tasks -open FSharp.Control.Tasks open Expecto open Prelude diff --git a/backend/tests/Tests/Serialization.DarkTypes.Tests.fs b/backend/tests/Tests/Serialization.DarkTypes.Tests.fs index 62ebac6e5a..a1a56b61ad 100644 --- a/backend/tests/Tests/Serialization.DarkTypes.Tests.fs +++ b/backend/tests/Tests/Serialization.DarkTypes.Tests.fs @@ -48,7 +48,6 @@ module RoundtripTests = Map.empty (RT.TCustomType(NR.ok typeName, [])) firstDT - |> Ply.toTask let msg = match typeChecked with diff --git a/backend/tests/Tests/Stream.Tests.fs b/backend/tests/Tests/Stream.Tests.fs index 7a56f0791c..40f2186fa3 100644 --- a/backend/tests/Tests/Stream.Tests.fs +++ b/backend/tests/Tests/Stream.Tests.fs @@ -8,7 +8,6 @@ module Tests.Stream open Expecto open System.Threading.Tasks -open FSharp.Control.Tasks open Prelude @@ -29,10 +28,10 @@ module RT2DT = LibExecution.RuntimeTypesToDarkTypes /// Pull-fn over a mutable list cell. Used to back streamOfList + /// streamImplOfList without duplicating the closure body. -let private listPullFn (items : List) : (unit -> Ply>) = +let private listPullFn (items : List) : (unit -> Task>) = let remaining = ref items fun () -> - uply { + task { match remaining.Value with | head :: tail -> remaining.Value <- tail @@ -59,8 +58,7 @@ let private streamImplOfList let private wrap (impl : RT.StreamImpl) : RT.Dval = Stream.wrapImpl impl -let private pull (s : RT.Dval) : Task> = - Stream.readNext s |> Ply.toTask +let private pull (s : RT.Dval) : Task> = Stream.readNext s /// Drain a stream to a list. Pulls until None. let private drain (s : RT.Dval) : Task> = @@ -68,7 +66,7 @@ let private drain (s : RT.Dval) : Task> = let acc = ResizeArray() let mutable keepGoing = true while keepGoing do - let! r = Stream.readNext s |> Ply.toTask + let! r = Stream.readNext s match r with | Some v -> acc.Add v | None -> keepGoing <- false @@ -88,15 +86,15 @@ let private binaryRoundtrip let r = new System.IO.BinaryReader(new System.IO.MemoryStream(ms.ToArray())) read r -let private intPredEven (dv : RT.Dval) : Ply = - uply { +let private intPredEven (dv : RT.Dval) : Task = + task { match dv with | RT.DInt64 i -> return i % 2L = 0L | _ -> return false } -let private intDouble (dv : RT.Dval) : Ply = - uply { +let private intDouble (dv : RT.Dval) : Task = + task { match dv with | RT.DInt64 i -> return RT.DInt64(i * 2L) | _ -> return RT.DInt64 0L @@ -297,8 +295,8 @@ let takeOverInfiniteSourceTerminates = // Producer counts up forever; Take must early-terminate without // pulling source past the limit. let counter = ref 0L - let next () : Ply> = - uply { + let next () : Task> = + task { counter.Value <- counter.Value + 1L return Some(RT.DInt64 counter.Value) } @@ -336,8 +334,8 @@ let composedTransformsAreLazy = // [4, 8, 12]. Source pulled past 6 to find the third even, but not // unboundedly — proves the pipeline is pull-driven. let counter = ref 0L - let next () : Ply> = - uply { + let next () : Task> = + task { counter.Value <- counter.Value + 1L return Some(RT.DInt64 counter.Value) } @@ -362,7 +360,7 @@ let composedTransformsAreLazy = let toValueTypeWalksTransforms = test "stream: Dval.toValueType returns the transform's element type" { let src = streamImplOfList [ RT.DInt64 1L ] VT.int64 - let toString (_ : RT.Dval) : Ply = uply { return RT.DString "x" } + let toString (_ : RT.Dval) : Task = task { return RT.DString "x" } let s = wrap (RT.Mapped(src, toString, VT.string)) Expect.equal (RT.Dval.toValueType s) @@ -409,8 +407,8 @@ let gcFinalizesMidDrainStream = let disposer () = disposerRan.Value <- true let dv = Stream.newFromIO VT.int64 next (Some disposer) // Pull 2 of 3 elements, then return the weak ref. - let pulled1 = (Stream.readNext dv |> Ply.toTask).Result - let pulled2 = (Stream.readNext dv |> Ply.toTask).Result + let pulled1 = (Stream.readNext dv).Result + let pulled2 = (Stream.readNext dv).Result Expect.equal pulled1 (Some(RT.DInt64 1L)) "first pull" Expect.equal pulled2 (Some(RT.DInt64 2L)) "second pull" System.WeakReference(dv) @@ -425,7 +423,7 @@ let gcSkipsFinalizerAfterStreamClose = test "stream: finalizer doesn't re-fire disposer when close already ran" { let disposeCount = ref 0 let makeWeakRef () : System.WeakReference = - let next () : Ply> = uply { return None } + let next () : Task> = task { return None } let disposer () = disposeCount.Value <- disposeCount.Value + 1 let dv = Stream.newFromIO VT.int64 next (Some disposer) // Replicate streamClose: flip disposed, walk impl chain. @@ -455,10 +453,10 @@ let gcSkipsFinalizerAfterStreamClose = // the same source via newStreamChunked's synthesised `next`. /// A nextChunk callback that yields each entry of `buffers` once, then None. -let private chunkPullFn (buffers : List) : (int -> Ply>) = +let private chunkPullFn (buffers : List) : (int -> Task>) = let remaining = ref buffers fun (_ : int) -> - uply { + task { match remaining.Value with | head :: tail -> remaining.Value <- tail @@ -471,8 +469,8 @@ let chunkedDrainMatchesByteDrain = "chunked drain: readStreamChunk returns the same bytes readStreamNext would" { let buf = [| 0x01uy; 0x02uy; 0x03uy; 0x04uy; 0x05uy; 0x06uy; 0x07uy; 0x08uy |] let s = Stream.newChunked VT.uint8 (chunkPullFn [ buf ]) None - let! first = Stream.readChunk 4096 s |> Ply.toTask - let! second = Stream.readChunk 4096 s |> Ply.toTask + let! first = Stream.readChunk 4096 s + let! second = Stream.readChunk 4096 s Expect.equal first (Some buf) "first chunk comes through intact" Expect.equal second None "second call returns None on exhaustion" } @@ -498,13 +496,69 @@ let chunkedDrainFallsBackToByteWise = VT.uint8 (listPullFn [ RT.DUInt8 0xAAuy; RT.DUInt8 0xBBuy; RT.DUInt8 0xCCuy ]) None - let! chunk = Stream.readChunk 4096 s |> Ply.toTask + let! chunk = Stream.readChunk 4096 s Expect.equal chunk (Some [| 0xAAuy; 0xBBuy; 0xCCuy |]) "all bytes collected" - let! after = Stream.readChunk 4096 s |> Ply.toTask + let! after = Stream.readChunk 4096 s Expect.equal after None "exhausted" } +// ───────────────────────────────────────────────────────────────────── +// Concurrent-consumer guard +// ───────────────────────────────────────────────────────────────────── +// Each DStream carries a permit-1 SemaphoreSlim on its lockObj; the +// reader paths claim it non-blockingly at entry, hold it across the +// inner pull, and release it in `finally`. A second consumer entering +// while the first is mid-pull hits the contended path and we raise a +// clean error rather than racing on shared `disposed`/transform state. + +/// A pull function that blocks on a TaskCompletionSource so we can +/// wedge a `readNext` at the await point and let a second consumer +/// race against it. +let private gatedPullFn + (gate : TaskCompletionSource) + (item : RT.Dval) + : (unit -> Task>) = + let yielded = ref false + fun () -> + task { + if yielded.Value then + return None + else + do! gate.Task + yielded.Value <- true + return Some item + } + +let concurrentReadNextRaises = + testTask "stream: second readNext while the first is mid-pull raises" { + let gate = TaskCompletionSource() + let s = Stream.newFromIO VT.int64 (gatedPullFn gate (RT.DInt64 7L)) None + + // Kick off the first pull. It will park inside the gated callback + // until we set the gate, holding the consumer permit the whole time. + let firstPull = Stream.readNext s + + // Give the scheduler a moment to step into the await — without this + // the second pull can sometimes start before the first acquires the + // semaphore, which would let it through legitimately. + do! Task.Delay 10 + + let mutable raised = false + try + let! _ = Stream.readNext s + () + with _ -> + raised <- true + Expect.isTrue raised "second concurrent readNext should raise" + + // Release the first pull — it should still complete cleanly. + gate.SetResult() + let! firstResult = firstPull + Expect.equal firstResult (Some(RT.DInt64 7L)) "first pull completes after gate" + } + + let tests = testList "stream" @@ -535,4 +589,5 @@ let tests = gcSkipsFinalizerAfterStreamClose chunkedDrainMatchesByteDrain chunkedDrainAlsoServesByteNext - chunkedDrainFallsBackToByteWise ] + chunkedDrainFallsBackToByteWise + concurrentReadNextRaises ] diff --git a/backend/tests/Tests/TestValues.fs b/backend/tests/Tests/TestValues.fs index f6fe9d25a2..ae74389c24 100644 --- a/backend/tests/Tests/TestValues.fs +++ b/backend/tests/Tests/TestValues.fs @@ -1,5 +1,7 @@ module Tests.TestValues +open System.Threading.Tasks + open Prelude open TestUtils.TestUtils @@ -821,6 +823,6 @@ let pm : PT.PackageManager = |> Map.ofList { PT.PackageManager.empty with - getType = fun id -> Ply(Map.tryFind id typeMap) - getValue = fun id -> Ply(Map.tryFind id valueMap) - getFn = fun id -> Ply(Map.tryFind id fnMap) } + getType = fun id -> Task.FromResult(Map.tryFind id typeMap) + getValue = fun id -> Task.FromResult(Map.tryFind id valueMap) + getFn = fun id -> Task.FromResult(Map.tryFind id fnMap) } diff --git a/backend/tests/Tests/Tests.fs b/backend/tests/Tests/Tests.fs index 002f608c1b..3c4210b757 100644 --- a/backend/tests/Tests/Tests.fs +++ b/backend/tests/Tests/Tests.fs @@ -10,7 +10,12 @@ open Prelude module PT = LibExecution.ProgramTypes let initSerializers () = - BwdServer.Server.initSerializers () + // (was: BwdServer.Server.initSerializers ()) — BwdServer disabled; inline the equivalents. + Json.Vanilla.allow + "RoundtrippableSerializationFormatV0.Dval" + Json.Vanilla.allow> + "Canvas.loadJsonFromDisk" + Json.Vanilla.allow "Canvas.loadJsonFromDisk" // These are serializers used in the tests that are not used in the main program Json.Vanilla.allow> "tests" @@ -28,6 +33,14 @@ let main (args : string array) : int = (LibCloud.Init.init name).Result (LibCloudExecution.Init.init name).Result + // Init the unified event log so test-suite milestones land alongside + // build-server / CLI events. Per-case detail still goes to fsharp-tests.log + // for humans to scroll through. + let eventLogPath = + System.IO.Path.Combine(LibConfig.Config.logDir, "telemetry.jsonl") + Telemetry.init eventLogPath + Telemetry.event "test.suite.start" [ ("name", name) ] + initSerializers () // Grow the DB from seed if needed. Builtins are deferred (constructed after @@ -51,7 +64,7 @@ let main (args : string array) : int = Tests.DvalRepr.tests Tests.LibParser.tests Tests.NewParser.tests - Tests.HttpClient.tests + // Tests.HttpClient.tests — disabled with BwdServer // package manager Tests.Propagation.tests @@ -68,7 +81,7 @@ let main (args : string array) : int = *) // cloud - Tests.BwdServer.tests + // Tests.BwdServer.tests — disabled with BwdServer Tests.Canvas.tests Tests.Routing.tests Tests.BinarySerialization.tests @@ -82,8 +95,9 @@ let main (args : string array) : int = Tests.Stream.tests ] let cancelationTokenSource = new System.Threading.CancellationTokenSource() - let bwdServerTestsTask = Tests.BwdServer.init cancelationTokenSource.Token - let httpClientTestsTask = Tests.HttpClient.init cancelationTokenSource.Token + // BwdServer + HttpClient test scaffolding disabled with BwdServer. + // let bwdServerTestsTask = Tests.BwdServer.init cancelationTokenSource.Token + // let httpClientTestsTask = Tests.HttpClient.init cancelationTokenSource.Token // Generate this so that we can see if the format has changed in a git diff BinarySerialization.generateTestFiles () @@ -94,10 +108,14 @@ let main (args : string array) : int = let exitCode = runTestsWithCLIArgs [ Allow_Duplicate_Names ] args (testList "tests" tests) + Telemetry.event + "test.suite.end" + [ ("exitCode", string exitCode); ("name", name) ] + NonBlockingConsole.wait () // flush stdout cancelationTokenSource.Cancel() - bwdServerTestsTask.Wait() - httpClientTestsTask.Wait() + // bwdServerTestsTask.Wait() + // httpClientTestsTask.Wait() exitCode with e -> printException "Outer exception" [] e diff --git a/backend/tests/Tests/Tests.fsproj b/backend/tests/Tests/Tests.fsproj index 3888b377ab..8786acfdd4 100644 --- a/backend/tests/Tests/Tests.fsproj +++ b/backend/tests/Tests/Tests.fsproj @@ -24,7 +24,8 @@ - + + @@ -45,14 +46,16 @@ - + + - + + diff --git a/benchmarks/results/history.jsonl b/benchmarks/results/history.jsonl index ad3cc084a7..351f6ce0e7 100644 --- a/benchmarks/results/history.jsonl +++ b/benchmarks/results/history.jsonl @@ -6,3 +6,5 @@ { "timestamp": "2026-04-25T12:34:14Z", "commit": "1360debe774bcf8496c95c4e3f039a60c1f9f83b", "results": [ { "scenario": "fileRead", "inputBytes": 1024, "allocBytes": 88408, "elapsedMs": 0, "dvalNodes": 1, "note": "ok" }, { "scenario": "fileRead", "inputBytes": 100000, "allocBytes": 179320, "elapsedMs": 0, "dvalNodes": 1, "note": "ok" }, { "scenario": "fileRead", "inputBytes": 1000000, "allocBytes": 1081960, "elapsedMs": 0, "dvalNodes": 1, "note": "ok" }, { "scenario": "fileRead", "inputBytes": 10000000, "allocBytes": 10077576, "elapsedMs": 4, "dvalNodes": 1, "note": "ok" }, { "scenario": "fileRead", "inputBytes": 38000000, "allocBytes": 38073568, "elapsedMs": 17, "dvalNodes": 1, "note": "ok" }, { "scenario": "httpBody", "inputBytes": 100000, "allocBytes": 326800, "elapsedMs": 5, "dvalNodes": 1, "note": "simulated-handler" }, { "scenario": "httpBody", "inputBytes": 1000000, "allocBytes": 2077600, "elapsedMs": 1, "dvalNodes": 1, "note": "simulated-handler" }, { "scenario": "httpBody", "inputBytes": 10000000, "allocBytes": 20077544, "elapsedMs": 8, "dvalNodes": 1, "note": "simulated-handler" }, { "scenario": "hexEncode", "inputBytes": 1000000, "allocBytes": 4080328, "elapsedMs": 4, "dvalNodes": 1, "note": "ok" }, { "scenario": "base64Encode", "inputBytes": 1000000, "allocBytes": 2746000, "elapsedMs": 2, "dvalNodes": 1, "note": "ok" }, { "scenario": "manyBlobs/100x1024B", "inputBytes": 102400, "allocBytes": 118808, "elapsedMs": 0, "dvalNodes": 100, "note": "intra-scope; per-blob overhead amortised over count" }, { "scenario": "manyBlobs/1000x1024B", "inputBytes": 1024000, "allocBytes": 421376, "elapsedMs": 1, "dvalNodes": 1000, "note": "intra-scope; per-blob overhead amortised over count" }, { "scenario": "manyBlobs/10000x256B", "inputBytes": 2560000, "allocBytes": 3062704, "elapsedMs": 9, "dvalNodes": 10000, "note": "intra-scope; per-blob overhead amortised over count" }, { "scenario": "blobEqualityEphemeral", "inputBytes": 100000, "allocBytes": 90200, "elapsedMs": 9, "dvalNodes": 1, "note": "promote+hash both sides" }, { "scenario": "blobEqualityEphemeral", "inputBytes": 1000000, "allocBytes": 76768, "elapsedMs": 1, "dvalNodes": 1, "note": "promote+hash both sides" }, { "scenario": "blobEqualityEphemeral", "inputBytes": 10000000, "allocBytes": 77552, "elapsedMs": 9, "dvalNodes": 1, "note": "promote+hash both sides" }, { "scenario": "streamToBlob", "inputBytes": 100000, "allocBytes": 277856, "elapsedMs": 3, "dvalNodes": 1, "note": "chunked-drain" }, { "scenario": "streamToBlob", "inputBytes": 1000000, "allocBytes": 2077856, "elapsedMs": 0, "dvalNodes": 1, "note": "chunked-drain" }, { "scenario": "streamToBlob", "inputBytes": 10000000, "allocBytes": 20077856, "elapsedMs": 9, "dvalNodes": 1, "note": "chunked-drain" }, { "scenario": "multipart/10x1024B", "inputBytes": 10240, "allocBytes": 130608, "elapsedMs": 0, "dvalNodes": 11, "note": "concat" }, { "scenario": "multipart/100x10240B", "inputBytes": 1024000, "allocBytes": 3719616, "elapsedMs": 1, "dvalNodes": 101, "note": "concat" }, { "scenario": "multipart/50x100000B", "inputBytes": 5000000, "allocBytes": 17782192, "elapsedMs": 6, "dvalNodes": 51, "note": "concat" } ]} { "timestamp": "2026-04-27T16:46:05Z", "commit": "ec3093ce4dd575529933a22a53e26745c8ee451b", "results": [ { "scenario": "fileRead", "inputBytes": 1024, "allocBytes": 88400, "elapsedMs": 0, "dvalNodes": 1, "note": "ok" }, { "scenario": "fileRead", "inputBytes": 100000, "allocBytes": 179312, "elapsedMs": 0, "dvalNodes": 1, "note": "ok" }, { "scenario": "fileRead", "inputBytes": 1000000, "allocBytes": 1073728, "elapsedMs": 0, "dvalNodes": 1, "note": "ok" }, { "scenario": "fileRead", "inputBytes": 10000000, "allocBytes": 10073568, "elapsedMs": 5, "dvalNodes": 1, "note": "ok" }, { "scenario": "fileRead", "inputBytes": 38000000, "allocBytes": 38073568, "elapsedMs": 18, "dvalNodes": 1, "note": "ok" }, { "scenario": "httpBody", "inputBytes": 100000, "allocBytes": 335256, "elapsedMs": 5, "dvalNodes": 1, "note": "simulated-handler" }, { "scenario": "httpBody", "inputBytes": 1000000, "allocBytes": 2082048, "elapsedMs": 0, "dvalNodes": 1, "note": "simulated-handler" }, { "scenario": "httpBody", "inputBytes": 10000000, "allocBytes": 20073592, "elapsedMs": 9, "dvalNodes": 1, "note": "simulated-handler" }, { "scenario": "hexEncode", "inputBytes": 1000000, "allocBytes": 4071536, "elapsedMs": 4, "dvalNodes": 1, "note": "ok" }, { "scenario": "base64Encode", "inputBytes": 1000000, "allocBytes": 2744248, "elapsedMs": 2, "dvalNodes": 1, "note": "ok" }, { "scenario": "manyBlobs/100x1024B", "inputBytes": 102400, "allocBytes": 122744, "elapsedMs": 0, "dvalNodes": 100, "note": "intra-scope; per-blob overhead amortised over count" }, { "scenario": "manyBlobs/1000x1024B", "inputBytes": 1024000, "allocBytes": 231784, "elapsedMs": 0, "dvalNodes": 1000, "note": "intra-scope; per-blob overhead amortised over count" }, { "scenario": "manyBlobs/10000x256B", "inputBytes": 2560000, "allocBytes": 3079832, "elapsedMs": 10, "dvalNodes": 10000, "note": "intra-scope; per-blob overhead amortised over count" }, { "scenario": "blobEqualityEphemeral", "inputBytes": 100000, "allocBytes": 90200, "elapsedMs": 9, "dvalNodes": 1, "note": "promote+hash both sides" }, { "scenario": "blobEqualityEphemeral", "inputBytes": 1000000, "allocBytes": 67352, "elapsedMs": 0, "dvalNodes": 1, "note": "promote+hash both sides" }, { "scenario": "blobEqualityEphemeral", "inputBytes": 10000000, "allocBytes": 77552, "elapsedMs": 9, "dvalNodes": 1, "note": "promote+hash both sides" }, { "scenario": "streamToBlob", "inputBytes": 100000, "allocBytes": 277856, "elapsedMs": 3, "dvalNodes": 1, "note": "chunked-drain" }, { "scenario": "streamToBlob", "inputBytes": 1000000, "allocBytes": 2077856, "elapsedMs": 0, "dvalNodes": 1, "note": "chunked-drain" }, { "scenario": "streamToBlob", "inputBytes": 10000000, "allocBytes": 20077856, "elapsedMs": 9, "dvalNodes": 1, "note": "chunked-drain" }, { "scenario": "multipart/10x1024B", "inputBytes": 10240, "allocBytes": 125840, "elapsedMs": 0, "dvalNodes": 11, "note": "concat" }, { "scenario": "multipart/100x10240B", "inputBytes": 1024000, "allocBytes": 3725360, "elapsedMs": 0, "dvalNodes": 101, "note": "concat" }, { "scenario": "multipart/50x100000B", "inputBytes": 5000000, "allocBytes": 17778000, "elapsedMs": 5, "dvalNodes": 51, "note": "concat" } ]} { "timestamp": "2026-04-27T20:23:33Z", "commit": "948dd41e593539211ec87b4e3b0d3ed976bcfc41", "results": [ { "scenario": "fileRead", "inputBytes": 1024, "allocBytes": 88408, "elapsedMs": 0, "dvalNodes": 1, "note": "ok" }, { "scenario": "fileRead", "inputBytes": 100000, "allocBytes": 179320, "elapsedMs": 0, "dvalNodes": 1, "note": "ok" }, { "scenario": "fileRead", "inputBytes": 1000000, "allocBytes": 1081960, "elapsedMs": 0, "dvalNodes": 1, "note": "ok" }, { "scenario": "fileRead", "inputBytes": 10000000, "allocBytes": 10073568, "elapsedMs": 4, "dvalNodes": 1, "note": "ok" }, { "scenario": "fileRead", "inputBytes": 38000000, "allocBytes": 38073568, "elapsedMs": 18, "dvalNodes": 1, "note": "ok" }, { "scenario": "httpBody", "inputBytes": 100000, "allocBytes": 326800, "elapsedMs": 5, "dvalNodes": 1, "note": "simulated-handler" }, { "scenario": "httpBody", "inputBytes": 1000000, "allocBytes": 2077600, "elapsedMs": 1, "dvalNodes": 1, "note": "simulated-handler" }, { "scenario": "httpBody", "inputBytes": 10000000, "allocBytes": 20082048, "elapsedMs": 9, "dvalNodes": 1, "note": "simulated-handler" }, { "scenario": "hexEncode", "inputBytes": 1000000, "allocBytes": 4067920, "elapsedMs": 4, "dvalNodes": 1, "note": "ok" }, { "scenario": "base64Encode", "inputBytes": 1000000, "allocBytes": 2740240, "elapsedMs": 2, "dvalNodes": 1, "note": "ok" }, { "scenario": "manyBlobs/100x1024B", "inputBytes": 102400, "allocBytes": 123000, "elapsedMs": 0, "dvalNodes": 100, "note": "intra-scope; per-blob overhead amortised over count" }, { "scenario": "manyBlobs/1000x1024B", "inputBytes": 1024000, "allocBytes": 419536, "elapsedMs": 1, "dvalNodes": 1000, "note": "intra-scope; per-blob overhead amortised over count" }, { "scenario": "manyBlobs/10000x256B", "inputBytes": 2560000, "allocBytes": 2201064, "elapsedMs": 11, "dvalNodes": 10000, "note": "intra-scope; per-blob overhead amortised over count" }, { "scenario": "blobEqualityEphemeral", "inputBytes": 100000, "allocBytes": 90200, "elapsedMs": 11, "dvalNodes": 1, "note": "promote+hash both sides" }, { "scenario": "blobEqualityEphemeral", "inputBytes": 1000000, "allocBytes": 68568, "elapsedMs": 2, "dvalNodes": 1, "note": "promote+hash both sides" }, { "scenario": "blobEqualityEphemeral", "inputBytes": 10000000, "allocBytes": 81744, "elapsedMs": 9, "dvalNodes": 1, "note": "promote+hash both sides" }, { "scenario": "streamToBlob", "inputBytes": 100000, "allocBytes": 282048, "elapsedMs": 3, "dvalNodes": 1, "note": "chunked-drain" }, { "scenario": "streamToBlob", "inputBytes": 1000000, "allocBytes": 2082048, "elapsedMs": 0, "dvalNodes": 1, "note": "chunked-drain" }, { "scenario": "streamToBlob", "inputBytes": 10000000, "allocBytes": 20082048, "elapsedMs": 9, "dvalNodes": 1, "note": "chunked-drain" }, { "scenario": "multipart/10x1024B", "inputBytes": 10240, "allocBytes": 130608, "elapsedMs": 0, "dvalNodes": 11, "note": "concat" }, { "scenario": "multipart/100x10240B", "inputBytes": 1024000, "allocBytes": 3725616, "elapsedMs": 0, "dvalNodes": 101, "note": "concat" }, { "scenario": "multipart/50x100000B", "inputBytes": 5000000, "allocBytes": 18836088, "elapsedMs": 7, "dvalNodes": 51, "note": "concat" } ]} +{ "timestamp": "2026-04-28T16:23:55Z", "commit": "d74408f1e22e19351acfa8c4d8786227b600015a", "results": [ { "scenario": "fileRead", "inputBytes": 1024, "allocBytes": 16400, "elapsedMs": 0, "dvalNodes": 1, "note": "ok" }, { "scenario": "fileRead", "inputBytes": 100000, "allocBytes": 98528, "elapsedMs": 0, "dvalNodes": 1, "note": "ok" }, { "scenario": "fileRead", "inputBytes": 1000000, "allocBytes": 1001672, "elapsedMs": 2, "dvalNodes": 1, "note": "ok" }, { "scenario": "fileRead", "inputBytes": 10000000, "allocBytes": 10001688, "elapsedMs": 4, "dvalNodes": 1, "note": "ok" }, { "scenario": "fileRead", "inputBytes": 38000000, "allocBytes": 38001688, "elapsedMs": 18, "dvalNodes": 1, "note": "ok" }, { "scenario": "httpBody", "inputBytes": 100000, "allocBytes": 265464, "elapsedMs": 6, "dvalNodes": 1, "note": "simulated-handler" }, { "scenario": "httpBody", "inputBytes": 1000000, "allocBytes": 2008064, "elapsedMs": 1, "dvalNodes": 1, "note": "simulated-handler" }, { "scenario": "httpBody", "inputBytes": 10000000, "allocBytes": 20008064, "elapsedMs": 9, "dvalNodes": 1, "note": "simulated-handler" }, { "scenario": "hexEncode", "inputBytes": 1000000, "allocBytes": 4000944, "elapsedMs": 4, "dvalNodes": 1, "note": "ok" }, { "scenario": "base64Encode", "inputBytes": 1000000, "allocBytes": 2674712, "elapsedMs": 2, "dvalNodes": 1, "note": "ok" }, { "scenario": "manyBlobs/100x1024B", "inputBytes": 102400, "allocBytes": 32616, "elapsedMs": 0, "dvalNodes": 100, "note": "intra-scope; per-blob overhead amortised over count" }, { "scenario": "manyBlobs/1000x1024B", "inputBytes": 1024000, "allocBytes": 392920, "elapsedMs": 1, "dvalNodes": 1000, "note": "intra-scope; per-blob overhead amortised over count" }, { "scenario": "manyBlobs/10000x256B", "inputBytes": 2560000, "allocBytes": 3105464, "elapsedMs": 11, "dvalNodes": 10000, "note": "intra-scope; per-blob overhead amortised over count" }, { "scenario": "streamToBlob", "inputBytes": 100000, "allocBytes": 216448, "elapsedMs": 3, "dvalNodes": 1, "note": "chunked-drain" }, { "scenario": "streamToBlob", "inputBytes": 1000000, "allocBytes": 2012256, "elapsedMs": 1, "dvalNodes": 1, "note": "chunked-drain" }, { "scenario": "streamToBlob", "inputBytes": 10000000, "allocBytes": 20008064, "elapsedMs": 9, "dvalNodes": 1, "note": "chunked-drain" }, { "scenario": "multipart/10x1024B", "inputBytes": 10240, "allocBytes": 56048, "elapsedMs": 0, "dvalNodes": 11, "note": "concat" }, { "scenario": "multipart/100x10240B", "inputBytes": 1024000, "allocBytes": 3661360, "elapsedMs": 1, "dvalNodes": 101, "note": "concat" }, { "scenario": "multipart/50x100000B", "inputBytes": 5000000, "allocBytes": 17720600, "elapsedMs": 6, "dvalNodes": 51, "note": "concat" } ]} +{ "timestamp": "2026-04-28T22:22:11Z", "commit": "481496d96b33b2cdff7c7633ae412cba10986c9f", "results": [ { "scenario": "fileRead", "inputBytes": 1024, "allocBytes": 16400, "elapsedMs": 0, "dvalNodes": 1, "note": "ok" }, { "scenario": "fileRead", "inputBytes": 100000, "allocBytes": 98528, "elapsedMs": 0, "dvalNodes": 1, "note": "ok" }, { "scenario": "fileRead", "inputBytes": 1000000, "allocBytes": 1001672, "elapsedMs": 2, "dvalNodes": 1, "note": "ok" }, { "scenario": "fileRead", "inputBytes": 10000000, "allocBytes": 9997496, "elapsedMs": 4, "dvalNodes": 1, "note": "ok" }, { "scenario": "fileRead", "inputBytes": 38000000, "allocBytes": 38001688, "elapsedMs": 18, "dvalNodes": 1, "note": "ok" }, { "scenario": "httpBody", "inputBytes": 100000, "allocBytes": 265464, "elapsedMs": 6, "dvalNodes": 1, "note": "simulated-handler" }, { "scenario": "httpBody", "inputBytes": 1000000, "allocBytes": 2008064, "elapsedMs": 0, "dvalNodes": 1, "note": "simulated-handler" }, { "scenario": "httpBody", "inputBytes": 10000000, "allocBytes": 20008064, "elapsedMs": 9, "dvalNodes": 1, "note": "simulated-handler" }, { "scenario": "hexEncode", "inputBytes": 1000000, "allocBytes": 4000944, "elapsedMs": 4, "dvalNodes": 1, "note": "ok" }, { "scenario": "base64Encode", "inputBytes": 1000000, "allocBytes": 2678904, "elapsedMs": 2, "dvalNodes": 1, "note": "ok" }, { "scenario": "manyBlobs/100x1024B", "inputBytes": 102400, "allocBytes": 36808, "elapsedMs": 0, "dvalNodes": 100, "note": "intra-scope; per-blob overhead amortised over count" }, { "scenario": "manyBlobs/1000x1024B", "inputBytes": 1024000, "allocBytes": 392432, "elapsedMs": 1, "dvalNodes": 1000, "note": "intra-scope; per-blob overhead amortised over count" }, { "scenario": "manyBlobs/10000x256B", "inputBytes": 2560000, "allocBytes": 3046912, "elapsedMs": 11, "dvalNodes": 10000, "note": "intra-scope; per-blob overhead amortised over count" }, { "scenario": "streamToBlob", "inputBytes": 100000, "allocBytes": 216448, "elapsedMs": 4, "dvalNodes": 1, "note": "chunked-drain" }, { "scenario": "streamToBlob", "inputBytes": 1000000, "allocBytes": 2012256, "elapsedMs": 0, "dvalNodes": 1, "note": "chunked-drain" }, { "scenario": "streamToBlob", "inputBytes": 10000000, "allocBytes": 20012256, "elapsedMs": 9, "dvalNodes": 1, "note": "chunked-drain" }, { "scenario": "multipart/10x1024B", "inputBytes": 10240, "allocBytes": 51840, "elapsedMs": 0, "dvalNodes": 11, "note": "concat" }, { "scenario": "multipart/100x10240B", "inputBytes": 1024000, "allocBytes": 3661360, "elapsedMs": 1, "dvalNodes": 101, "note": "concat" }, { "scenario": "multipart/50x100000B", "inputBytes": 5000000, "allocBytes": 17720600, "elapsedMs": 6, "dvalNodes": 51, "note": "concat" } ]} diff --git a/packages/darklang/cli/docs/for-ai-internal.dark b/packages/darklang/cli/docs/for-ai-internal.dark index c9fb949f43..a15c5d4c00 100644 --- a/packages/darklang/cli/docs/for-ai-internal.dark +++ b/packages/darklang/cli/docs/for-ai-internal.dark @@ -5,7 +5,10 @@ let content () : String = ## Directories backend/src/ # F# source - LibExecution/ # execution engine + Language/ # PT (ProgramTypes) — what programs look like + Runtime/ # RT, Interpreter, Dval, Builtin, TypeChecker, Blob, Stream + DarkTypes/ # value <-> Dark-side encoding (DvalDecoder + *ToDarkTypes) + LibExecution/ # umbrella; just Execution.fs (orchestrator) LibParser/ # parser LibPackageManager/ # package DB, branches, SCM ops BuiltinExecution/ # builtin impls @@ -17,10 +20,38 @@ let content () : String = rundir/logs/ # log files scripts/ # build scripts -## Builds - DON'T MANUALLY REBUILD -Auto-rebuilds on save. Watch logs: +## LibExecution layering (Language → Runtime → DarkTypes → umbrella) + Language deps: Prelude only — DarkDateTime, PackageRefs (shared + primitives), ProgramTypes, ProgramTypesAst, ProgramTypesParser + Runtime deps: Prelude, Language — RuntimeTypes, ValueType, Blob, Stream, + Dval, Builtin, TypeChecker, Interpreter, AnalysisTypes, + RTQueryCompiler, ProgramTypesToRuntimeTypes + DarkTypes deps: Prelude, Language, Runtime — DvalDecoder, CommonToDarkTypes, + RuntimeTypesToDarkTypes, ProgramTypesToDarkTypes + LibExecution umbrella, just Execution.fs; downstream consumers reference + this and pick up the three sub-projects transitively. +F# `module LibExecution.X` declarations are unchanged across files, so the +namespace path `LibExecution.RuntimeTypes` etc. still resolves regardless of +which assembly the type lives in. + +## BwdServer disabled +BwdServer is commented out in fsdark.sln and Tests.fsproj. The source is +still on disk; restore by un-commenting the Project, ConfigurationPlatforms +and NestedProjects entries in fsdark.sln, plus the ProjectReference and +test-file Compile entries in Tests.fsproj. ``BwdServer.Tests.fs`` and +``HttpClient.Tests.fs`` are also skipped from compile while it's off. + +## Builds — VS Code starts the watcher; agents compile explicitly +The container post-start does a one-shot compile so binaries are fresh. +The auto-rebuild watcher is started by ``.vscode/tasks.json`` on +``folderOpen`` — i.e. only when a human attaches VS Code. An agent that +wants the watcher can run: + ./scripts/build/_build-server --watch +Otherwise compile on demand: + ./scripts/build/_dotnet-wrapper build --no-restore --configuration Debug fsdark.sln +Watch logs (humans): packages-canvas.log # .dark reload (~10s) - build-server.log # F# build (~1min) + build-server.log # F# build (~30-45s); auto-rotates above 5 MB ## Tests ./scripts/run-backend-tests @@ -75,17 +106,29 @@ branch chain for name resolution. Items are global (content-addressed), locations (name bindings) are branch-scoped. ## Log Files (rundir/logs/) -When something goes wrong, check these logs: +Two parallel views of the same activity: + +**Per-component .log files** (humans, streaming visual feedback): cli.log # CLI runtime issues lsp.log # LSP input/output packages-canvas.log # .dark file loading from disk - build-server.log # F# build issues, high-level errors + build-server.log # F# build output; auto-rotates above 5 MB + fsharp-tests.log # full Expecto test output migrations.log # migration issues (if recently changed) +**telemetry.jsonl** (unified structured event log — agents grep this): + One JSON object per line (`{event, wall, ms?, ctx}`). Currently fed by + CLI startup, build-server cycles (`build.compile.start|end|fail`, + `build.initial.start|end|fail`), and Tests entry point + (`test.suite.start|end`). Single grep target instead of folklore about + which .log file holds which signal. + Add new emitters via `Telemetry.event "foo.bar" [("k", "v")]` in F# + (Prelude.Telemetry) or the `emit_event` helper in scripts/build/_build-server. + ## PackageRefs stale-hash (bootstrap gotcha) -backend/src/LibExecution/package-ref-hashes.txt (not in git). Empty = tolerated; +backend/src/Language/package-ref-hashes.txt (not in git). Empty = tolerated; non-empty with missing key = "PackageRefs: X hash not found" crash at startup. -Fix after adding a new ref: `> backend/src/LibExecution/package-ref-hashes.txt && +Fix after adding a new ref: `> backend/src/Language/package-ref-hashes.txt && ./scripts/build/reload-packages` ## Name Resolution (see also: `docs for-ai`) diff --git a/scripts/build/_build-server b/scripts/build/_build-server index b627a19fd3..91c1053e0c 100755 --- a/scripts/build/_build-server +++ b/scripts/build/_build-server @@ -5,13 +5,77 @@ # .circleci/config.yml. Generally, if you add something to one of these # files, there's an equivalent to be added in .circleci/config.yml. +import datetime +import json +import os import subprocess import sys import threading +import time import signal run_tests = False +# Path to the log this process is being redirected into by the caller +# (see scripts/devcontainer/_vscode-post-start-command). We rotate it in-place +# so the caller's open append-FD stays valid: kernel O_APPEND seeks to EOF +# before each write, so even after we shrink the file the next append lands +# at the new EOF. +BUILD_LOG_PATH = "/home/dark/app/rundir/logs/build-server.log" +BUILD_LOG_MAX_BYTES = 5_000_000 # rotate above ~5 MB +BUILD_LOG_KEEP_BYTES = 500_000 # keep the most recent ~500 KB on rotate + + +def rotate_build_log_if_needed(): + try: + if not os.path.exists(BUILD_LOG_PATH): + return + size = os.path.getsize(BUILD_LOG_PATH) + if size <= BUILD_LOG_MAX_BYTES: + return + # Read the tail we want to keep, then rewrite the file in place. + with open(BUILD_LOG_PATH, "rb") as f: + f.seek(max(0, size - BUILD_LOG_KEEP_BYTES)) + tail = f.read() + header = ( + b"\n--- build-server.log rotated; older content discarded " + b"(threshold " + + str(BUILD_LOG_MAX_BYTES).encode() + + b" B, kept last " + + str(len(tail)).encode() + + b" B) ---\n" + ) + with open(BUILD_LOG_PATH, "rb+") as f: + f.seek(0) + f.write(header + tail) + f.truncate(len(header) + len(tail)) + except Exception: + # Best-effort; never let rotation kill the build server. + pass + + +# Unified structured event log: shared with F# Prelude.Telemetry, which +# already writes to this file. Adding build-server events here means every +# build cycle is greppable alongside CLI / Tests / migration events without +# tailing five separate log files. Humans still get the full per-component +# build output via stdout → build-server.log; this is the structured shadow. +EVENT_LOG_PATH = "/home/dark/app/rundir/logs/telemetry.jsonl" + + +def emit_event(name, ctx=None): + try: + line = { + "event": name, + "wall": datetime.datetime.now(datetime.timezone.utc) + .strftime("%Y-%m-%dT%H:%M:%S.") + f"{datetime.datetime.now().microsecond // 1000:03d}Z", + "ctx": ctx or {}, + } + os.makedirs(os.path.dirname(EVENT_LOG_PATH), exist_ok=True) + with open(EVENT_LOG_PATH, "a") as f: + f.write(json.dumps(line, separators=(",", ":")) + "\n") + except Exception: + pass + # When compiling code, use the optimized version of the build. This causes # --optimize to be passed to the compile script. optimize = False @@ -61,10 +125,18 @@ def compile_project(name): def compile(files): fileStr = " ".join(files) flags = getFlags() + emit_event("build.compile.start", {"fileCount": str(len(files))}) + start = time.time() try: - return run(f"scripts/build/compile {flags} {fileStr}") + ok = run(f"scripts/build/compile {flags} {fileStr}") + emit_event( + "build.compile.end" if ok else "build.compile.fail", + {"ms": str(int((time.time() - start) * 1000)), "fileCount": str(len(files))}, + ) + return ok except: print(f"Tried to compile too many files. Length was {len(fileStr)}") + emit_event("build.compile.overflow", {"fileCount": str(len(files))}) return compile_project("all") @@ -115,7 +187,13 @@ def main(): should_run_tests = True def initial_compile(): + emit_event("build.initial.start", {}) + start = time.time() success = compile_project("all") + emit_event( + "build.initial.end" if success else "build.initial.fail", + {"ms": str(int((time.time() - start) * 1000))}, + ) print("--------------------------") if success: print("-- Initial compile succeeded") @@ -125,6 +203,8 @@ def main(): return success + rotate_build_log_if_needed() + run_or_fail("scripts/devcontainer/_write-config-file") run_or_fail("scripts/devcontainer/_allow-docker-access") run_or_fail("scripts/devcontainer/_create-app-directories") @@ -148,6 +228,7 @@ def main(): ignored = set(["/home/dark/app/" + f for f in ignored]) filter = watchfiles.DefaultFilter(ignore_paths=ignored) for changes in watchfiles.watch("/home/dark/app/", watch_filter=filter): + rotate_build_log_if_needed() changes = [f for (_, f) in changes] compile(changes) diff --git a/scripts/devcontainer/_vscode-post-start-command b/scripts/devcontainer/_vscode-post-start-command index f823c5c0ee..3fcc04c492 100755 --- a/scripts/devcontainer/_vscode-post-start-command +++ b/scripts/devcontainer/_vscode-post-start-command @@ -22,13 +22,19 @@ log "=== Build started at $(date) ===" log "Fetching and building tree-sitter library" ./scripts/build/build-tree-sitter.sh 2>&1 | tee -a "$LOG_FILE" -log "Starting build server" +log "Running initial compile" git config --global --add safe.directory /home/dark/app -nohup ./scripts/build/_build-server --compile --watch &>> "$LOG_FILE" & +# Container start does a one-shot compile so the binaries are fresh for any +# CLI/test invocations from outside the editor. The watcher is started by +# VS Code's tasks.json on folderOpen (see .vscode/tasks.json), so a container +# without an editor attached doesn't burn CPU re-watching files. Agents that +# explicitly want the watcher can run `./scripts/build/_build-server --watch`. +nohup ./scripts/build/_build-server --compile &>> "$LOG_FILE" & -# It seems that if we don't sleep here, the server does not start properly in all cases +# Give the background compile time to register before VS Code starts its +# folderOpen tasks. sleep 2 -log "Build server started" +log "Initial compile launched in background" diff --git a/scripts/run-in-docker b/scripts/run-in-docker index 1607c33a94..e4b863bb91 100755 --- a/scripts/run-in-docker +++ b/scripts/run-in-docker @@ -44,7 +44,16 @@ USER="$(id -u):$gid" if [ -t 0 ] ; then docker exec -it "${NAME}" "${ARGS[@]}" ; -else - # Replace any in-container filenames with host filenames (stdout + stderr) +elif [ -p /dev/stdin ] || [ -f /dev/stdin ] || [ -s /dev/stdin ] ; +then + # stdin is a pipe / regular file / non-empty source — forward it, + # rewriting host paths to in-container paths along the way. { cat <&0 | fix_dir_stdin | docker exec -i "${NAME}" "${ARGS[@]}" 2>&1 1>&3 3>&- | fix_dir_stdout; } 3>&1 1>&2 | fix_dir_stdout +else + # stdin is /dev/null, an empty socket, or otherwise has no readable + # bytes. Skip the `cat <&0` shim — it would block forever on a socket + # that never sees EOF (caught when ``run_in_background`` Bash calls + # invoke the build scripts; ``cat`` on the agent-runtime stdin socket + # never gets EOF and the docker exec child sits idle behind it). + { docker exec -i "${NAME}" "${ARGS[@]}" &1 1>&3 3>&- | fix_dir_stdout; } 3>&1 1>&2 | fix_dir_stdout fi