diff --git a/CHANGELOG.md b/CHANGELOG.md index 1945fc6..5f026ca 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,6 +3,7 @@ All notable changes to FScript are documented in this file. ## [Unreleased] +- Added native `Task.spawn` and `Task.await` support with `'a task` types for concurrent thunk execution. ## [0.67.1] diff --git a/README.md b/README.md index 5dcfcdc..2f25db9 100644 --- a/README.md +++ b/README.md @@ -143,6 +143,7 @@ Useful samples: - [`samples/types-showcase.fss`](samples/types-showcase.fss) - [`samples/patterns-and-collections.fss`](samples/patterns-and-collections.fss) - [`samples/quicksort.fss`](samples/quicksort.fss) +- [`samples/parallel-quicksort.fss`](samples/parallel-quicksort.fss) - [`samples/tree.fss`](samples/tree.fss) - [`samples/mutual-recursion.fss`](samples/mutual-recursion.fss) - [`samples/imports-and-exports.fss`](samples/imports-and-exports.fss) @@ -168,7 +169,7 @@ Each extern declares: - implementation. Built-in host extern families include `Fs.*`, `Json.*`, `Xml.*`, `Regex.*`, hashing, GUIDs, and `print`. -`List.*`, `Map.*`, and `Option.*` are provided by the embedded stdlib prelude. +`Task.*`, `List.*`, `Map.*`, and `Option.*` are provided by the embedded stdlib prelude. For details and extension workflow, see [`docs/specs/external-functions.md`](docs/specs/external-functions.md). diff --git a/docs/guides/getting-started-tutorial.md b/docs/guides/getting-started-tutorial.md index 7fe10e9..9d06e82 100644 --- a/docs/guides/getting-started-tutorial.md +++ b/docs/guides/getting-started-tutorial.md @@ -361,6 +361,7 @@ let rec fib n = FScript ships with a preloaded stdlib focused on functional collection workflows. Common families: +- `Task.*` - `List.*` - `Option.*` - `Map.*` @@ -377,6 +378,16 @@ let m = { ["a"] = 1; ["b"] = 2 } let hasA = m |> Map.containsKey "a" ``` +Concurrent task example: + +```fsharp +let pending = Task.spawn (fun _ -> 40 + 2) +let answer = Task.await pending +print $"{answer}" +``` + +Tasks use the native type form `'a task`. Spawned thunks run concurrently, `Task.await` synchronizes on the result, and task failures remain fatal runtime errors. + Full reference: - [`docs/specs/stdlib-functions.md`](../specs/stdlib-functions.md) diff --git a/docs/specs/sandbox-and-security.md b/docs/specs/sandbox-and-security.md index ca238c7..8833f58 100644 --- a/docs/specs/sandbox-and-security.md +++ b/docs/specs/sandbox-and-security.md @@ -7,6 +7,8 @@ This document defines the security model for running FScript programs with host - FScript executes in-process inside the host .NET application. - Language-level side effects occur through registered externs. - Host configuration determines the effective capability surface. +- `Task.spawn` runs FScript thunks concurrently on the host runtime thread pool. +- Concurrent task side effects may interleave with the main script and with other tasks. ## Host context and filesystem boundary - Host context includes: @@ -35,6 +37,8 @@ Filesystem extern behavior: - Extern invocation checks arity and argument type-shape. - Data/IO externs frequently model operational failures as `None` values. - Script type misuse raises `TypeException`/`EvalException`. +- Task failures are fatal runtime errors, consistent with foreground evaluation. +- Programs that finish with unawaited tasks fail at runtime instead of silently detaching background work. ## Resource-governance model - Evaluator execution currently relies on host/runtime process limits. diff --git a/docs/specs/stdlib-functions.md b/docs/specs/stdlib-functions.md index 94b2694..3cbf663 100644 --- a/docs/specs/stdlib-functions.md +++ b/docs/specs/stdlib-functions.md @@ -6,6 +6,7 @@ This document lists the functions available in the embedded FScript prelude (std The stdlib is loaded automatically by `FScript.Language` before user scripts. ## Modules +- `Task` - `List` - `Option` - `Map` @@ -55,6 +56,16 @@ The stdlib is loaded automatically by `FScript.Language` before user scripts. - `Some : 'a -> 'a option` - `None : 'a option` +### Tasks +- Module functions: + - `Task.spawn : (unit -> 'a) -> 'a task` + - `Task.await : 'a task -> 'a` +- Description: + - `Task.spawn` schedules a thunk for concurrent execution and returns an opaque task handle immediately + - `Task.await` waits for completion and returns the result value + - task failures are fatal runtime errors + - ending a program with unawaited tasks is a runtime error + ### Records - Field access: `record.Field` - Signature: `{ Field: 'a; ... } -> 'a` @@ -91,6 +102,10 @@ The stdlib is loaded automatically by `FScript.Language` before user scripts. - `Option.isSome : 'a option -> bool` - `Option.map : ('a -> 'b) -> 'a option -> 'b option` +## Task +- `Task.spawn : (unit -> 'a) -> 'a task` +- `Task.await : 'a task -> 'a` + ## Map - `Map.empty : 'v map` Alias of `{}`. diff --git a/docs/specs/supported-types.md b/docs/specs/supported-types.md index 2daa9a2..fe40d86 100644 --- a/docs/specs/supported-types.md +++ b/docs/specs/supported-types.md @@ -12,6 +12,7 @@ This document specifies the value and type system used by the interpreter. ## Composite/container types - List: `'a list` +- Task: `'a task` - Tuple: `(t1 * t2 * ...)` - Option: `'a option` - Map (string-keyed alias): `'a map` @@ -68,6 +69,16 @@ This document specifies the value and type system used by the interpreter. - `Some : 'a -> 'a option` - `None : 'a option` +### Tasks +- Type form: `'a task` +- Construction and observation: + - `Task.spawn : (unit -> 'a) -> 'a task` + - `Task.await : 'a task -> 'a` +- Notes: + - tasks are opaque runtime handles + - spawned thunks execute concurrently + - side effects may interleave across tasks + ## Function types - Functions use curried arrow types: - `t1 -> t2` @@ -117,6 +128,7 @@ This document specifies the value and type system used by the interpreter. - `VRecord` - `VMap` - `VOption` +- `VTask` - `VUnionCase`, `VUnionCtor` - `VClosure` - `VExternal` diff --git a/samples/parallel-quicksort.fss b/samples/parallel-quicksort.fss new file mode 100644 index 0000000..1698010 --- /dev/null +++ b/samples/parallel-quicksort.fss @@ -0,0 +1,40 @@ +let rec quicksort values = + match values with + | [] -> [] + | pivot :: rest -> + let smaller = rest |> List.filter (fun value -> value < pivot) + let equal = rest |> List.filter (fun value -> value = pivot) + let greater = rest |> List.filter (fun value -> value > pivot) + (quicksort smaller) @ [pivot] @ equal @ (quicksort greater) + +let rec parallel_quicksort values = + match values with + | [] -> [] + | [single] -> [single] + | pivot :: rest -> + let smaller = rest |> List.filter (fun value -> value < pivot) + let equal = rest |> List.filter (fun value -> value = pivot) + let greater = rest |> List.filter (fun value -> value > pivot) + + let sort_smaller = + Task.spawn (fun _ -> parallel_quicksort smaller) + + let sorted_greater = parallel_quicksort greater + let sorted_smaller = Task.await sort_smaller + sorted_smaller @ [pivot] @ equal @ sorted_greater + +let rec is_sorted values = + match values with + | [] -> true + | [_] -> true + | first :: second :: tail -> (first <= second) && (is_sorted (second :: tail)) + +let input = [9; 2; 8; 2; 4; 7; 1; 6; 3; 5; 3; 10; 0; 12; 11] +let sequential = quicksort input +let parallel = parallel_quicksort input + +print $"parallel quicksort input : {input}" +print $"sequential quicksort output : {sequential}" +print $"parallel quicksort output : {parallel}" +print $"same result : {sequential = parallel}" +print $"parallel output is sorted : {is_sorted parallel}" diff --git a/src/FScript.CSharpInterop/LanguageServer/LspHandlers.fs b/src/FScript.CSharpInterop/LanguageServer/LspHandlers.fs index f6e9cea..2984143 100644 --- a/src/FScript.CSharpInterop/LanguageServer/LspHandlers.fs +++ b/src/FScript.CSharpInterop/LanguageServer/LspHandlers.fs @@ -112,6 +112,12 @@ module LspHandlers = "fun"; "raise"; "import"; "export"; "qualified" ] |> Set.ofList + let private builtinTypeTokenSet = + [ "unit"; "int"; "float"; "bool"; "string" + "list"; "option"; "map"; "task" + "Environment"; "FsKind" ] + |> Set.ofList + let private classifyToken (line: string) (startIndex: int) (token: string) = let isFunctionCallToken () = let mutable i = startIndex + token.Length @@ -120,6 +126,7 @@ module LspHandlers = i < line.Length && line[i] = '(' if keywordSet.Contains(token) then 0 + elif builtinTypeTokenSet.Contains(token) then 4 elif token.Length > 1 && token.StartsWith("\"") && token.EndsWith("\"") then 1 elif token |> Seq.forall Char.IsDigit then 2 elif isFunctionCallToken () then 3 diff --git a/src/FScript.CSharpInterop/LanguageServer/LspSymbols.fs b/src/FScript.CSharpInterop/LanguageServer/LspSymbols.fs index fe8ca07..50cc3f2 100644 --- a/src/FScript.CSharpInterop/LanguageServer/LspSymbols.fs +++ b/src/FScript.CSharpInterop/LanguageServer/LspSymbols.fs @@ -20,6 +20,7 @@ module LspSymbols = | TBool -> "bool" | TString -> "string" | TList t1 -> sprintf "%s list" (postfixArg t1) + | TTask t1 -> sprintf "%s task" (postfixArg t1) | TTuple ts -> ts |> List.map go |> String.concat " * " |> sprintf "(%s)" | TRecord fields -> fields @@ -67,6 +68,8 @@ module LspSymbols = "String.concat", [ "separator"; "values" ] "String.split", [ "separator"; "source" ] "String.endsWith", [ "suffix"; "source" ] + "Task.spawn", [ "thunk" ] + "Task.await", [ "task" ] "List.empty", [] "List.map", [ "mapper"; "values" ] "List.iter", [ "iterator"; "values" ] diff --git a/src/FScript.Language/BuiltinFunctions.fs b/src/FScript.Language/BuiltinFunctions.fs index cb7008b..7341f39 100644 --- a/src/FScript.Language/BuiltinFunctions.fs +++ b/src/FScript.Language/BuiltinFunctions.fs @@ -39,6 +39,11 @@ module BuiltinFunctions = | [ VList value ] -> value | _ -> fail $"{functionName} expects (list)" + let private expectTask functionName args = + match args with + | [ VTask value ] -> value + | _ -> fail $"{functionName} expects (task)" + let private asStringKey functionName value = match value with | VString key -> MKString key @@ -255,6 +260,27 @@ module BuiltinFunctions = | [ VString suffix; VString source ] -> VBool (source.EndsWith(suffix, StringComparison.Ordinal)) | _ -> fail "String.endsWith expects (string, string)") } + let private builtinTaskSpawn : ExternalFunction = + { Name = "Task.spawn" + Scheme = scheme "Task.spawn" + Arity = 1 + Impl = + (fun ctx args -> + match args with + | [ thunk ] -> ctx.SpawnTask thunk + | _ -> fail "Task.spawn expects (thunk)") } + + let private builtinTaskAwait : ExternalFunction = + { Name = "Task.await" + Scheme = scheme "Task.await" + Arity = 1 + Impl = + (fun ctx args -> + let _ = expectTask "Task.await" args + match args with + | [ task ] -> ctx.AwaitTask task + | _ -> fail "Task.await expects (task)") } + let private builtinListEmpty : ExternalFunction = { Name = "List.empty" Scheme = scheme "List.empty" @@ -689,6 +715,8 @@ module BuiltinFunctions = builtinStringConcat builtinStringSplit builtinStringEndsWith + builtinTaskSpawn + builtinTaskAwait builtinListEmpty builtinListMap builtinListIter diff --git a/src/FScript.Language/BuiltinSignatures.fs b/src/FScript.Language/BuiltinSignatures.fs index 80c80b2..e32a45c 100644 --- a/src/FScript.Language/BuiltinSignatures.fs +++ b/src/FScript.Language/BuiltinSignatures.fs @@ -18,6 +18,8 @@ module BuiltinSignatures = "String.concat", Forall([], TFun(TString, TFun(TList TString, TString))) "String.split", Forall([], TFun(TString, TFun(TString, TList TString))) "String.endsWith", Forall([], TFun(TString, TFun(TString, TBool))) + "Task.spawn", Forall([ 0 ], TFun(TFun(TUnit, TVar 0), TTask(TVar 0))) + "Task.await", Forall([ 0 ], TFun(TTask(TVar 0), TVar 0)) "List.empty", Forall([ 0 ], TList(TVar 0)) "List.map", Forall([ 0; 1 ], TFun(TFun(TVar 0, TVar 1), TFun(TList(TVar 0), TList(TVar 1)))) "List.iter", Forall([ 0 ], TFun(TFun(TVar 0, TUnit), TFun(TList(TVar 0), TUnit))) @@ -60,6 +62,7 @@ module BuiltinSignatures = |> Map.keys |> Seq.filter (fun name -> name.StartsWith("List.", System.StringComparison.Ordinal) + || name.StartsWith("Task.", System.StringComparison.Ordinal) || name.StartsWith("Option.", System.StringComparison.Ordinal) || name.StartsWith("Map.", System.StringComparison.Ordinal)) |> Set.ofSeq diff --git a/src/FScript.Language/Eval.fs b/src/FScript.Language/Eval.fs index 7f5da8a..b0db01e 100644 --- a/src/FScript.Language/Eval.fs +++ b/src/FScript.Language/Eval.fs @@ -1,11 +1,34 @@ namespace FScript.Language module Eval = + open System.Threading.Tasks + type ProgramState = { TypeDefs: Map Env: Env LastValue: Value } + type private RuntimeState = + { SyncRoot: obj + PendingTasks: ResizeArray + mutable BackgroundFailure: EvalError option } + + let private unknownSpan = Span.mk (Span.pos 0 0) (Span.pos 0 0) + + let private wrapTaskFailure (error: EvalError) = + { Message = $"Task failed: {error.Message}" + Span = error.Span } + + let private wrapUnexpectedTaskFailure (ex: exn) = + { Message = $"Task failed: {ex.Message}" + Span = unknownSpan } + + let private raiseIfBackgroundFailed (runtime: RuntimeState) = + lock runtime.SyncRoot (fun () -> + match runtime.BackgroundFailure with + | Some error -> raise (EvalException error) + | None -> ()) + let private literalToValue lit = match lit with | LInt v -> VInt v @@ -45,6 +68,7 @@ module Eval = | VUnionCase (_, caseName, None) -> caseName | VUnionCase (_, caseName, Some value) -> sprintf "%s %s" caseName (valueToInterpolationString value) | VTypeToken t -> sprintf "" (Types.typeToString t) + | VTask _ -> "" | VClosure _ -> "" | VUnionCtor (_, caseName) -> sprintf "" caseName | VExternal _ -> "" @@ -77,6 +101,7 @@ module Eval = | Some xv, Some yv -> valueEquals xv yv | _ -> false | VTypeToken tx, VTypeToken ty -> tx = ty + | VTask tx, VTask ty -> obj.ReferenceEquals(tx, ty) | _ -> false let private mapKeyToValue (key: MapKey) : Value = @@ -104,6 +129,7 @@ module Eval = resolveTypeList ts |> Option.map TTuple | TRFun _ -> None | TRPostfix (inner, "list") -> resolve inner |> Option.map TList + | TRPostfix (inner, "task") -> resolve inner |> Option.map TTask | TRPostfix (inner, "option") -> resolve inner |> Option.map TOption | TRPostfix (inner, "map") -> resolve inner |> Option.map (fun t -> TMap (TString, t)) | TRPostfix _ -> None @@ -143,6 +169,7 @@ module Eval = | TBool, VBool _ -> true | TString, VString _ -> true | TList inner, VList items -> items |> List.forall (fun v -> valueHasType v inner) + | TTask _, VTask _ -> true | TTuple inner, VTuple items -> inner.Length = items.Length && List.forall2 valueHasType items inner | TOption inner, VOption None -> true @@ -308,30 +335,85 @@ module Eval = if valueMatchesTypeRef typeDefs tref v then Some Map.empty else None | _ -> None - let rec private applyFunctionValue - (eval: Map -> Env -> Expr -> Value) + let rec private createExternContext (runtime: RuntimeState) (typeDefs: Map) (span: Span) : ExternalCallContext = + { Apply = applyFunctionValue runtime evalExpr typeDefs span + SpawnTask = spawnTaskValue runtime typeDefs + AwaitTask = awaitTaskValue runtime + CheckRuntime = fun () -> raiseIfBackgroundFailed runtime } + + and private spawnTaskValue (runtime: RuntimeState) (typeDefs: Map) (thunk: Value) : Value = + raiseIfBackgroundFailed runtime + let worker = + try + Task.Run(fun () -> + try + let result = applyFunctionValue runtime evalExpr typeDefs unknownSpan thunk VUnit + TaskSucceeded result + with + | EvalException error -> + let taskError = wrapTaskFailure error + lock runtime.SyncRoot (fun () -> + if runtime.BackgroundFailure.IsNone then + runtime.BackgroundFailure <- Some taskError) + TaskFailed taskError + | ex -> + let taskError = wrapUnexpectedTaskFailure ex + lock runtime.SyncRoot (fun () -> + if runtime.BackgroundFailure.IsNone then + runtime.BackgroundFailure <- Some taskError) + TaskFailed taskError) + with + | ex -> + raise (EvalException (wrapUnexpectedTaskFailure ex)) + + let handle = { Worker = worker; Awaited = false } + lock runtime.SyncRoot (fun () -> runtime.PendingTasks.Add(handle)) + VTask handle + + and private awaitTaskValue (runtime: RuntimeState) (taskValue: Value) : Value = + raiseIfBackgroundFailed runtime + match taskValue with + | VTask handle -> + handle.Awaited <- true + match handle.Worker.GetAwaiter().GetResult() with + | TaskSucceeded value -> + raiseIfBackgroundFailed runtime + value + | TaskFailed error -> + lock runtime.SyncRoot (fun () -> + if runtime.BackgroundFailure.IsNone then + runtime.BackgroundFailure <- Some error) + raise (EvalException error) + | _ -> + raise (EvalException { Message = "Task.await expects a task"; Span = unknownSpan }) + + and private applyFunctionValue + (runtime: RuntimeState) + (eval: RuntimeState -> Map -> Env -> Expr -> Value) (typeDefs: Map) (span: Span) (fnValue: Value) (argValue: Value) : Value = + raiseIfBackgroundFailed runtime match fnValue with | VClosure (argName, body, closureEnv) -> let env' = closureEnv.Value |> Map.add argName argValue - eval typeDefs env' body + eval runtime typeDefs env' body | VUnionCtor (typeName, caseName) -> VUnionCase(typeName, caseName, Some argValue) | VExternal (ext, args) -> let args' = argValue :: args if args'.Length = ext.Arity then - ext.Impl { Apply = applyFunctionValue eval typeDefs span } (args' |> List.rev) + ext.Impl (createExternContext runtime typeDefs span) (args' |> List.rev) elif args'.Length < ext.Arity then VExternal (ext, args') else raise (EvalException { Message = sprintf "External function '%s' received too many arguments" ext.Name; Span = span }) | _ -> raise (EvalException { Message = "Attempted to apply non-function"; Span = span }) - let rec private evalExpr (typeDefs: Map) (env: Env) (expr: Expr) : Value = + and private evalExpr (runtime: RuntimeState) (typeDefs: Map) (env: Env) (expr: Expr) : Value = + raiseIfBackgroundFailed runtime match expr with | EUnit _ -> VUnit | ELiteral (lit, _) -> literalToValue lit @@ -340,27 +422,27 @@ module Eval = | Some v -> v | None -> raise (EvalException { Message = sprintf "Unbound variable '%s'" name; Span = span }) | EParen (inner, _) -> - evalExpr typeDefs env inner + evalExpr runtime typeDefs env inner | ELambda (param, body, _) -> VClosure (param.Name, body, ref env) | EApply (fn, arg, span) -> - let fVal = evalExpr typeDefs env fn - let aVal = evalExpr typeDefs env arg - applyFunctionValue evalExpr typeDefs span fVal aVal + let fVal = evalExpr runtime typeDefs env fn + let aVal = evalExpr runtime typeDefs env arg + applyFunctionValue runtime evalExpr typeDefs span fVal aVal | EIf (cond, tExpr, fExpr, span) -> - match evalExpr typeDefs env cond with - | VBool true -> evalExpr typeDefs env tExpr - | VBool false -> evalExpr typeDefs env fExpr + match evalExpr runtime typeDefs env cond with + | VBool true -> evalExpr runtime typeDefs env tExpr + | VBool false -> evalExpr runtime typeDefs env fExpr | _ -> raise (EvalException { Message = "Condition must be bool"; Span = span }) | ERaise (valueExpr, span) -> - match evalExpr typeDefs env valueExpr with + match evalExpr runtime typeDefs env valueExpr with | VString message -> raise (EvalException { Message = message; Span = span }) | _ -> raise (EvalException { Message = "raise expects a string"; Span = span }) | EFor (name, source, body, span) -> - match evalExpr typeDefs env source with + match evalExpr runtime typeDefs env source with | VList items -> for item in items do let env' = env |> Map.add name item - evalExpr typeDefs env' body |> ignore + evalExpr runtime typeDefs env' body |> ignore VUnit | _ -> raise (EvalException { Message = "For loop source must be list"; Span = span }) | ELet (name, value, body, isRec, _, span) -> @@ -370,24 +452,24 @@ module Eval = let recEnv = ref env let selfValue : Value = VClosure (param.Name, lambdaBody, recEnv) recEnv.Value <- env |> Map.add name selfValue - evalExpr typeDefs recEnv.Value body + evalExpr runtime typeDefs recEnv.Value body | _ -> raise (EvalException { Message = "let rec requires a function binding"; Span = span }) else - let v = evalExpr typeDefs env value + let v = evalExpr runtime typeDefs env value let env' = env |> Map.add name v - evalExpr typeDefs env' body + evalExpr runtime typeDefs env' body | ELetPattern (pattern, value, body, span) -> - let v = evalExpr typeDefs env value + let v = evalExpr runtime typeDefs env value match patternMatch typeDefs pattern v with | Some bindings -> let env' = Map.fold (fun acc k value -> Map.add k value acc) env bindings - evalExpr typeDefs env' body + evalExpr runtime typeDefs env' body | None -> raise (EvalException { Message = "Let pattern did not match value"; Span = span }) | ELetRecGroup (bindings, body, span) -> if bindings.IsEmpty then - evalExpr typeDefs env body + evalExpr runtime typeDefs env body else let recEnv = ref env let recEntries = @@ -403,9 +485,9 @@ module Eval = raise (EvalException { Message = "let rec requires a function binding"; Span = span })) let finalEnv = recEntries |> List.fold (fun acc (name, value) -> Map.add name value acc) env recEnv.Value <- finalEnv - evalExpr typeDefs finalEnv body + evalExpr runtime typeDefs finalEnv body | EMatch (scrutinee, cases, span) -> - let v = evalExpr typeDefs env scrutinee + let v = evalExpr runtime typeDefs env scrutinee let rec tryCases cs = match cs with | [] -> raise (EvalException { Message = "No match cases matched"; Span = span }) @@ -415,19 +497,19 @@ module Eval = let env' = Map.fold (fun acc k v -> Map.add k v acc) env bindings match guard with | Some guardExpr -> - match evalExpr typeDefs env' guardExpr with - | VBool true -> evalExpr typeDefs env' body + match evalExpr runtime typeDefs env' guardExpr with + | VBool true -> evalExpr runtime typeDefs env' body | VBool false -> tryCases rest | _ -> raise (EvalException { Message = "Match guard must evaluate to bool"; Span = span }) | None -> - evalExpr typeDefs env' body + evalExpr runtime typeDefs env' body | None -> tryCases rest tryCases cases | EList (items, _) -> - items |> List.map (evalExpr typeDefs env) |> VList + items |> List.map (evalExpr runtime typeDefs env) |> VList | ERange (startExpr, endExpr, span) -> - let startValue = evalExpr typeDefs env startExpr - let endValue = evalExpr typeDefs env endExpr + let startValue = evalExpr runtime typeDefs env startExpr + let endValue = evalExpr runtime typeDefs env endExpr match startValue, endValue with | VInt s, VInt e -> let step = if s <= e then 1L else -1L @@ -439,15 +521,15 @@ module Eval = VList (build [] s) | _ -> raise (EvalException { Message = "Range endpoints must be int"; Span = span }) | ETuple (items, _) -> - items |> List.map (evalExpr typeDefs env) |> VTuple + items |> List.map (evalExpr runtime typeDefs env) |> VTuple | ERecord (fields, _) -> fields - |> List.map (fun (name, valueExpr) -> name, evalExpr typeDefs env valueExpr) + |> List.map (fun (name, valueExpr) -> name, evalExpr runtime typeDefs env valueExpr) |> Map.ofList |> VRecord | EStructuralRecord (fields, _) -> fields - |> List.map (fun (name, valueExpr) -> name, evalExpr typeDefs env valueExpr) + |> List.map (fun (name, valueExpr) -> name, evalExpr runtime typeDefs env valueExpr) |> Map.ofList |> VRecord | EMap (entries, _) -> @@ -461,18 +543,18 @@ module Eval = |> List.fold (fun (acc: Map) entry -> match entry with | MEKeyValue (keyExpr, valueExpr) -> - let keyValue = evalExpr typeDefs env keyExpr + let keyValue = evalExpr runtime typeDefs env keyExpr match keyValue with | VString _ | VInt _ -> let key = valueToMapKey (Ast.spanOfExpr keyExpr) keyValue - let value = evalExpr typeDefs env valueExpr + let value = evalExpr runtime typeDefs env valueExpr acc.Add(key, value) | _ -> // Type checker guarantees string/int keys for map literals. raise (EvalException { Message = "Map literal keys must be string or int"; Span = Ast.spanOfExpr keyExpr }) | MESpread spreadExpr -> - match evalExpr typeDefs env spreadExpr with + match evalExpr runtime typeDefs env spreadExpr with | VMap spreadMap -> mergeWithLeftPrecedence acc spreadMap | _ -> // Type checker guarantees spread operands are maps. @@ -480,24 +562,24 @@ module Eval = (Map.empty) VMap evaluated | ERecordUpdate (target, updates, span) -> - match evalExpr typeDefs env target with + match evalExpr runtime typeDefs env target with | VRecord fields -> let updated = updates |> List.fold (fun acc (name, valueExpr) -> if Map.containsKey name acc then - Map.add name (evalExpr typeDefs env valueExpr) acc + Map.add name (evalExpr runtime typeDefs env valueExpr) acc else raise (EvalException { Message = sprintf "Record field '%s' not found" name; Span = span })) fields VRecord updated | _ -> raise (EvalException { Message = "Record update requires a record value"; Span = span }) | EStructuralRecordUpdate (target, updates, span) -> - match evalExpr typeDefs env target with + match evalExpr runtime typeDefs env target with | VRecord fields -> let updated = updates |> List.fold (fun acc (name, valueExpr) -> - Map.add name (evalExpr typeDefs env valueExpr) acc) fields + Map.add name (evalExpr runtime typeDefs env valueExpr) acc) fields VRecord updated | _ -> raise (EvalException { Message = "Structural record update requires a record value"; Span = span }) | EFieldGet (target, fieldName, span) -> @@ -507,22 +589,22 @@ module Eval = match env.TryFind qualifiedName with | Some value -> value | None -> - match evalExpr typeDefs env target with + match evalExpr runtime typeDefs env target with | VRecord fields -> match fields.TryFind fieldName with | Some fieldValue -> fieldValue | None -> raise (EvalException { Message = sprintf "Record field '%s' not found" fieldName; Span = span }) | _ -> raise (EvalException { Message = "Field access requires a record value"; Span = span }) | _ -> - match evalExpr typeDefs env target with + match evalExpr runtime typeDefs env target with | VRecord fields -> match fields.TryFind fieldName with | Some value -> value | None -> raise (EvalException { Message = sprintf "Record field '%s' not found" fieldName; Span = span }) | _ -> raise (EvalException { Message = "Field access requires a record value"; Span = span }) | EIndexGet (target, keyExpr, span) -> - let targetValue = evalExpr typeDefs env target - let keyValue = evalExpr typeDefs env keyExpr + let targetValue = evalExpr runtime typeDefs env target + let keyValue = evalExpr runtime typeDefs env keyExpr match targetValue, keyValue with | VList values, VInt index -> let rec loop remaining current = @@ -542,20 +624,20 @@ module Eval = | _ -> raise (EvalException { Message = "Index access requires a list or map value"; Span = span }) | ECons (head, tail, span) -> - let h = evalExpr typeDefs env head - let t = evalExpr typeDefs env tail + let h = evalExpr runtime typeDefs env head + let t = evalExpr runtime typeDefs env tail match t with | VList xs -> VList (h :: xs) | _ -> raise (EvalException { Message = "Right side of '::' must be list"; Span = span }) | EAppend (a, b, span) -> - let av = evalExpr typeDefs env a - let bv = evalExpr typeDefs env b + let av = evalExpr runtime typeDefs env a + let bv = evalExpr runtime typeDefs env b match av, bv with | VList xs, VList ys -> VList (xs @ ys) | _ -> raise (EvalException { Message = "Both sides of '@' must be lists"; Span = span }) | EBinOp (op, a, b, span) -> - let av = evalExpr typeDefs env a - let bv = evalExpr typeDefs env b + let av = evalExpr runtime typeDefs env a + let bv = evalExpr runtime typeDefs env b let arith fInt fFloat = match av, bv with | VInt x, VInt y -> VInt (fInt x y) @@ -563,7 +645,7 @@ module Eval = | _ -> raise (EvalException { Message = "Numeric operands required"; Span = span }) match op with | "|>" -> - applyFunctionValue evalExpr typeDefs span bv av + applyFunctionValue runtime evalExpr typeDefs span bv av | "+" -> arith ( + ) ( + ) | "-" -> arith ( - ) ( - ) | "*" -> arith ( * ) ( * ) @@ -613,7 +695,7 @@ module Eval = | VList xs, VList ys -> VList (xs @ ys) | _ -> raise (EvalException { Message = "Both sides of '@' must be lists"; Span = span }) | _ -> raise (EvalException { Message = sprintf "Unknown operator %s" op; Span = span }) - | ESome (value, _) -> VOption (Some (evalExpr typeDefs env value)) + | ESome (value, _) -> VOption (Some (evalExpr runtime typeDefs env value)) | ENone _ -> VOption None | ETypeOf (name, span) -> match typeDefs.TryFind name with @@ -630,20 +712,24 @@ module Eval = match part with | IPText text -> sb.Append(text) |> ignore | IPExpr pexpr -> - let rendered = evalExpr typeDefs env pexpr |> valueToInterpolationString + let rendered = evalExpr runtime typeDefs env pexpr |> valueToInterpolationString sb.Append(rendered) |> ignore VString (sb.ToString()) let invokeValue (typeDefs: Map) (fnValue: Value) (args: Value list) : Value = - let span = Span.mk (Span.pos 0 0) (Span.pos 0 0) + let runtime = + { SyncRoot = obj () + PendingTasks = ResizeArray() + BackgroundFailure = None } + let applyExternal (ext: ExternalFunction) (existingArgsRev: Value list) (newArgs: Value list) = let allArgs = (existingArgsRev |> List.rev) @ newArgs if allArgs.Length = ext.Arity then - ext.Impl { Apply = applyFunctionValue evalExpr typeDefs span } allArgs + ext.Impl (createExternContext runtime typeDefs unknownSpan) allArgs elif allArgs.Length < ext.Arity then VExternal (ext, allArgs |> List.rev) else - raise (EvalException { Message = sprintf "External function '%s' received too many arguments" ext.Name; Span = span }) + raise (EvalException { Message = sprintf "External function '%s' received too many arguments" ext.Name; Span = unknownSpan }) let rec applyMany (currentValue: Value) (remainingArgs: Value list) = match currentValue, remainingArgs with @@ -661,17 +747,20 @@ module Eval = envAcc, exprAcc, argsAcc let boundEnv, boundBody, argsLeft = bindLambdaChain initialEnv body tailArgs - let evaluated = evalExpr typeDefs boundEnv boundBody + let evaluated = evalExpr runtime typeDefs boundEnv boundBody applyMany evaluated argsLeft | value, nextArg :: tailArgs -> - let next = applyFunctionValue evalExpr typeDefs span value nextArg + let next = applyFunctionValue runtime evalExpr typeDefs unknownSpan value nextArg applyMany next tailArgs applyMany fnValue args let evalProgramWithExternsState (externs: ExternalFunction list) (program: TypeInfer.TypedProgram) : ProgramState = let reserved = BuiltinSignatures.builtinReservedNames - let unknownSpan = Span.mk (Span.pos 0 0) (Span.pos 0 0) + let runtime = + { SyncRoot = obj () + PendingTasks = ResizeArray() + BackgroundFailure = None } externs |> List.tryFind (fun ext -> Set.contains ext.Name reserved) @@ -734,6 +823,7 @@ module Eval = | TRTuple ts -> ts |> List.map (fromRef stack) |> TTuple | TRFun (a, b) -> TFun(fromRef stack a, fromRef stack b) | TRPostfix (inner, "list") -> TList (fromRef stack inner) + | TRPostfix (inner, "task") -> TTask (fromRef stack inner) | TRPostfix (inner, "option") -> TOption (fromRef stack inner) | TRPostfix (inner, "map") -> TMap (TString, fromRef stack inner) | TRPostfix (_, suffix) -> @@ -778,8 +868,7 @@ module Eval = [ caseName, value $"{typeName}.{caseName}", value ])) - let externContext = - { Apply = applyFunctionValue evalExpr typeDefs unknownSpan } + let externContext = createExternContext runtime typeDefs unknownSpan let mutable env : Env = (BuiltinFunctions.builtinExterns @ externs) @@ -794,6 +883,7 @@ module Eval = |> List.fold (fun acc (name, value) -> acc.Add(name, value)) env let mutable lastValue = VUnit for stmt in program do + raiseIfBackgroundFailed runtime match stmt with | TypeInfer.TSType _ -> () @@ -809,10 +899,10 @@ module Eval = | _ -> raise (EvalException { Message = "let rec requires a function binding"; Span = span }) else - let v = evalExpr typeDefs env expr + let v = evalExpr runtime typeDefs env expr env <- env |> Map.add name v | TypeInfer.TSLetPattern(pattern, expr, _, _, span) -> - let v = evalExpr typeDefs env expr + let v = evalExpr runtime typeDefs env expr match patternMatch typeDefs pattern v with | Some bindings -> env <- Map.fold (fun acc k value -> Map.add k value acc) env bindings @@ -835,7 +925,19 @@ module Eval = recEnv.Value <- finalEnv env <- finalEnv | TypeInfer.TSExpr texpr -> - lastValue <- evalExpr typeDefs env texpr.Expr + lastValue <- evalExpr runtime typeDefs env texpr.Expr + + raiseIfBackgroundFailed runtime + + let unawaitedCount = + runtime.PendingTasks + |> Seq.filter (fun handle -> not handle.Awaited) + |> Seq.length + + if unawaitedCount > 0 then + let noun = if unawaitedCount = 1 then "task" else "tasks" + raise (EvalException { Message = $"Program completed with {unawaitedCount} unawaited {noun}"; Span = unknownSpan }) + { TypeDefs = typeDefs Env = env LastValue = lastValue } diff --git a/src/FScript.Language/Parser.fs b/src/FScript.Language/Parser.fs index f05498b..937ed2d 100644 --- a/src/FScript.Language/Parser.fs +++ b/src/FScript.Language/Parser.fs @@ -283,6 +283,9 @@ module Parser = | Ident "map" -> stream.Next() |> ignore t <- TRPostfix(t, "map") + | Ident "task" -> + stream.Next() |> ignore + t <- TRPostfix(t, "task") | _ -> loop <- false t diff --git a/src/FScript.Language/Pretty.fs b/src/FScript.Language/Pretty.fs index c06c6e4..2e66bbc 100644 --- a/src/FScript.Language/Pretty.fs +++ b/src/FScript.Language/Pretty.fs @@ -50,6 +50,7 @@ module Pretty = | VUnionCase (_, caseName, None) -> caseName | VUnionCase (_, caseName, Some v) -> sprintf "%s %s" caseName (valueToString v) | VTypeToken t -> sprintf "" (Types.typeToString t) + | VTask _ -> "" | VClosure (argName, body, _) -> let args = closureParameters argName body sprintf "" (String.concat " " args) diff --git a/src/FScript.Language/TypeInfer.fs b/src/FScript.Language/TypeInfer.fs index 9f85f0f..ef27a76 100644 --- a/src/FScript.Language/TypeInfer.fs +++ b/src/FScript.Language/TypeInfer.fs @@ -13,6 +13,7 @@ module TypeInfer = | Some mapped -> applyType s mapped | None -> t | TList t1 -> TList (applyType s t1) + | TTask t1 -> TTask (applyType s t1) | TTuple ts -> TTuple (ts |> List.map (applyType s)) | TRecord fields -> TRecord (fields |> Map.map (fun _ t1 -> applyType s t1)) | TMap (tk, tv) -> TMap (applyType s tk, applyType s tv) @@ -49,6 +50,7 @@ module TypeInfer = | TTypeToken, TTypeToken -> emptySubst | TNamed x, TNamed y when x = y -> emptySubst | TList x, TList y -> uni seen' x y + | TTask x, TTask y -> uni seen' x y | TTuple xs, TTuple ys -> if xs.Length <> ys.Length then raise (TypeException { Message = "Tuple arity mismatch"; Span = span }) @@ -109,6 +111,7 @@ module TypeInfer = match t with | TVar v -> freshMap |> Map.tryFind v |> Option.defaultValue t | TList a -> TList (subst a) + | TTask a -> TTask (subst a) | TTuple ts -> TTuple (ts |> List.map subst) | TRecord fields -> TRecord (fields |> Map.map (fun _ t1 -> subst t1)) | TMap (k, v) -> TMap (subst k, subst v) @@ -311,6 +314,7 @@ module TypeInfer = | TRTuple ts -> ts |> List.map (annotationTypeFromRef typeDefs span) |> TTuple | TRFun (a, b) -> TFun(annotationTypeFromRef typeDefs span a, annotationTypeFromRef typeDefs span b) | TRPostfix (inner, "list") -> TList (annotationTypeFromRef typeDefs span inner) + | TRPostfix (inner, "task") -> TTask (annotationTypeFromRef typeDefs span inner) | TRPostfix (inner, "option") -> TOption (annotationTypeFromRef typeDefs span inner) | TRPostfix (inner, "map") -> TMap (TString, annotationTypeFromRef typeDefs span inner) | TRPostfix (_, suffix) -> @@ -366,6 +370,7 @@ module TypeInfer = let resolved = typeFromRef decls stack inner match suffix with | "list" -> TList resolved + | "task" -> TTask resolved | "option" -> TOption resolved | "map" -> TMap (TString, resolved) | _ -> raise (TypeException { Message = $"Unknown type suffix '{suffix}'"; Span = unknownSpan }) @@ -515,6 +520,7 @@ module TypeInfer = | _ -> raise (TypeException { Message = $"Map key type must be string, got {Types.typeToString keyType}"; Span = span }) | TList inner -> loop inner + | TTask inner -> loop inner | TTuple items -> items |> List.iter loop | TRecord fields -> fields |> Map.values |> Seq.iter loop | TOption inner -> loop inner diff --git a/src/FScript.Language/Types.fs b/src/FScript.Language/Types.fs index ddec3f5..4523f5c 100644 --- a/src/FScript.Language/Types.fs +++ b/src/FScript.Language/Types.fs @@ -10,6 +10,7 @@ type Type = | TBool | TString | TList of Type + | TTask of Type | TTuple of Type list | TRecord of Map | TMap of Type * Type @@ -35,6 +36,7 @@ module Types = match t with | TUnit | TInt | TFloat | TBool | TString -> Set.empty | TList t1 -> ftvType t1 + | TTask t1 -> ftvType t1 | TTuple ts -> ts |> List.map ftvType |> List.fold Set.union Set.empty | TRecord fields -> fields |> Map.values |> Seq.map ftvType |> Seq.fold Set.union Set.empty | TMap (tk, tv) -> Set.union (ftvType tk) (ftvType tv) @@ -62,6 +64,7 @@ module Types = | TBool -> "bool" | TString -> "string" | TList t1 -> sprintf "%s list" (postfixArg t1) + | TTask t1 -> sprintf "%s task" (postfixArg t1) | TTuple ts -> ts |> List.map go |> String.concat " * " |> sprintf "(%s)" | TRecord fields -> fields diff --git a/src/FScript.Language/Value.fs b/src/FScript.Language/Value.fs index 497b8b3..6277b31 100644 --- a/src/FScript.Language/Value.fs +++ b/src/FScript.Language/Value.fs @@ -1,5 +1,7 @@ namespace FScript.Language +open System.Threading.Tasks + type MapKey = | MKString of string | MKInt of int64 @@ -18,11 +20,23 @@ type Value = | VUnionCase of string * string * Value option | VUnionCtor of string * string | VTypeToken of Type + | VTask of TaskHandle | VClosure of string * Expr * Env ref | VExternal of ExternalFunction * Value list +and TaskOutcome = + | TaskSucceeded of Value + | TaskFailed of EvalError + +and TaskHandle = + { Worker: Task + mutable Awaited: bool } + and ExternalCallContext = - { Apply: Value -> Value -> Value } + { Apply: Value -> Value -> Value + SpawnTask: Value -> Value + AwaitTask: Value -> Value + CheckRuntime: unit -> unit } and ExternalFunction = { Name: string diff --git a/src/FScript.Runtime/Decode.fs b/src/FScript.Runtime/Decode.fs index 642284f..016c2b2 100644 --- a/src/FScript.Runtime/Decode.fs +++ b/src/FScript.Runtime/Decode.fs @@ -78,6 +78,7 @@ module internal HostDecode = | TNamed _ | TUnion _ | TTypeToken + | TTask _ | TFun _ | TVar _ -> None | _ -> None @@ -137,6 +138,7 @@ module internal HostDecode = | TNamed _ | TUnion _ | TTypeToken + | TTask _ | TFun _ | TVar _ -> None @@ -194,6 +196,7 @@ module internal HostEncode = | VUnionCase _ | VUnionCtor _ | VTypeToken _ + | VTask _ | VClosure _ | VExternal _ -> None @@ -241,6 +244,7 @@ module internal HostEncode = | VUnionCase _ | VUnionCtor _ | VTypeToken _ + | VTask _ | VClosure _ | VExternal _ -> false diff --git a/src/FScript.TypeProvider/Contract.fs b/src/FScript.TypeProvider/Contract.fs index 7a47a88..405d762 100644 --- a/src/FScript.TypeProvider/Contract.fs +++ b/src/FScript.TypeProvider/Contract.fs @@ -180,6 +180,8 @@ module Contract = | TList inner -> recurse $"{typePath} list item" inner |> Result.map SupportedType.List + | TTask inner -> + Error $"{typePath}: task types are not supported in exported signatures." | TOption inner -> recurse $"{typePath} option value" inner |> Result.map SupportedType.Option diff --git a/tests/FScript.Language.Tests/EvalTests.fs b/tests/FScript.Language.Tests/EvalTests.fs index 88deacb..220d0f1 100644 --- a/tests/FScript.Language.Tests/EvalTests.fs +++ b/tests/FScript.Language.Tests/EvalTests.fs @@ -569,3 +569,25 @@ type EvalTests () = match Helpers.eval "let display x = x\nnameof display" with | VString "display" -> () | _ -> Assert.Fail("Expected function name") + + [] + member _.``Evaluates task await result`` () = + match Helpers.eval "Task.await (Task.spawn (fun _ -> 41 + 1))" with + | VInt 42L -> () + | _ -> Assert.Fail("Expected awaited task result") + + [] + member _.``Evaluates multiple tasks with captured values`` () = + match Helpers.eval "let base = 10\nlet a = Task.spawn (fun _ -> base + 1)\nlet b = Task.spawn (fun _ -> base + 2)\n(Task.await a, Task.await b)" with + | VTuple [ VInt 11L; VInt 12L ] -> () + | _ -> Assert.Fail("Expected awaited tuple results") + + [] + member _.``Reports runtime error for failed task`` () = + let act () = Helpers.eval "Task.await (Task.spawn (fun _ -> raise \"boom\"))" |> ignore + act |> should throw typeof + + [] + member _.``Reports runtime error for unawaited task`` () = + let act () = Helpers.eval "Task.spawn (fun _ -> 1)" |> ignore + act |> should throw typeof diff --git a/tests/FScript.Language.Tests/TypeInferenceTests.fs b/tests/FScript.Language.Tests/TypeInferenceTests.fs index 7379b27..d68feb8 100644 --- a/tests/FScript.Language.Tests/TypeInferenceTests.fs +++ b/tests/FScript.Language.Tests/TypeInferenceTests.fs @@ -684,6 +684,32 @@ type TypeInferenceTests () = | TypeInfer.TSExpr te -> te.Type |> should equal TString | _ -> Assert.Fail("Expected expression") + [] + member _.``Infers task spawn and await`` () = + match Helpers.infer "Task.spawn (fun _ -> 1)" |> List.last with + | TypeInfer.TSExpr te -> te.Type |> should equal (TTask TInt) + | _ -> Assert.Fail("Expected task expression") + + match Helpers.infer "Task.await (Task.spawn (fun _ -> \"x\"))" |> List.last with + | TypeInfer.TSExpr te -> te.Type |> should equal TString + | _ -> Assert.Fail("Expected awaited expression") + + [] + member _.``Accepts task type annotation`` () = + let typed = Helpers.infer "let await_int (t: int task) = Task.await t" + match typed.Head with + | TypeInfer.TSLet (_, _, t, _, _, _) -> + t |> should equal (TFun (TTask TInt, TInt)) + | _ -> Assert.Fail("Expected let binding") + + [] + member _.``Rejects invalid task builtin arguments`` () = + let spawnAct () = Helpers.infer "Task.spawn 1" |> ignore + spawnAct |> should throw typeof + + let awaitAct () = Helpers.infer "Task.await 1" |> ignore + awaitAct |> should throw typeof + [] member _.``Allows non-string interpolation placeholder`` () = let typed = Helpers.infer "$\"value={1}\"" diff --git a/tests/FScript.LanguageServer.Tests/CSharpServerCoreTests.cs b/tests/FScript.LanguageServer.Tests/CSharpServerCoreTests.cs index 7821d15..b2c188b 100644 --- a/tests/FScript.LanguageServer.Tests/CSharpServerCoreTests.cs +++ b/tests/FScript.LanguageServer.Tests/CSharpServerCoreTests.cs @@ -7,6 +7,27 @@ namespace FScript.LanguageServer.Tests; [TestFixture] public sealed class CSharpServerCoreTests { + private static List<(int line, int start, int length, int tokenType)> DecodeSemanticTokens(JsonArray data) + { + var result = new List<(int line, int start, int length, int tokenType)>(); + var line = 0; + var start = 0; + + for (var i = 0; i + 4 < data.Count; i += 5) + { + var deltaLine = data[i]?.GetValue() ?? 0; + var deltaStart = data[i + 1]?.GetValue() ?? 0; + var length = data[i + 2]?.GetValue() ?? 0; + var tokenType = data[i + 3]?.GetValue() ?? 0; + + line += deltaLine; + start = deltaLine == 0 ? start + deltaStart : deltaStart; + result.Add((line, start, length, tokenType)); + } + + return result; + } + [Test] public void CSharp_server_initialize_returns_capabilities() { @@ -316,6 +337,107 @@ public void CSharp_server_completion_uses_member_insertText_for_dotted_prefix() } } + [Test] + public void CSharp_server_completion_includes_Task_members_for_dotted_prefix() + { + var client = LspClient.StartCSharp(); + try + { + LspTestFixture.Initialize(client); + + var uri = "file:///tmp/csharp-completion-task-dotted-prefix.fss"; + var source = "let _ = Task.aw\n"; + var didOpenParams = new JsonObject + { + ["textDocument"] = new JsonObject + { + ["uri"] = uri, + ["languageId"] = "fscript", + ["version"] = 1, + ["text"] = source + } + }; + LspClient.SendNotification(client, "textDocument/didOpen", didOpenParams); + _ = LspClient.ReadUntil(client, 10_000, msg => msg["method"]?.GetValue() == "textDocument/publishDiagnostics"); + + var requestParams = new JsonObject + { + ["textDocument"] = new JsonObject { ["uri"] = uri }, + ["position"] = new JsonObject { ["line"] = 0, ["character"] = 16 } + }; + + LspClient.SendRequest(client, 601, "textDocument/completion", requestParams); + var response = LspClient.ReadUntil(client, 10_000, msg => msg["id"] is JsonValue idv && idv.TryGetValue(out var id) && id == 601); + var items = ((response["result"] as JsonObject)?["items"] as JsonArray) ?? new JsonArray(); + + var taskAwaitItem = items + .OfType() + .FirstOrDefault(item => string.Equals(item["label"]?.GetValue(), "Task.await", StringComparison.Ordinal)); + + Assert.That(taskAwaitItem, Is.Not.Null, "Expected Task.await completion item at dotted prefix."); + Assert.That(taskAwaitItem!["insertText"]?.GetValue(), Is.EqualTo("await")); + Assert.That(taskAwaitItem["detail"]?.GetValue(), Does.Contain("'a task -> 'a")); + } + finally + { + try { LspTestFixture.Shutdown(client); } catch { } + LspClient.Stop(client); + } + } + + [Test] + public void CSharp_server_semantic_tokens_classify_task_types_and_functions() + { + var client = LspClient.StartCSharp(); + try + { + LspTestFixture.Initialize(client); + + var uri = "file:///tmp/csharp-semantic-task-test.fss"; + var source = "let run (value: int task) = Task.await value\n"; + var didOpenParams = new JsonObject + { + ["textDocument"] = new JsonObject + { + ["uri"] = uri, + ["languageId"] = "fscript", + ["version"] = 1, + ["text"] = source + } + }; + LspClient.SendNotification(client, "textDocument/didOpen", didOpenParams); + _ = LspClient.ReadUntil(client, 10_000, msg => msg["method"]?.GetValue() == "textDocument/publishDiagnostics"); + + var semanticParams = new JsonObject + { + ["textDocument"] = new JsonObject { ["uri"] = uri } + }; + + LspClient.SendRequest(client, 602, "textDocument/semanticTokens/full", semanticParams); + var response = LspClient.ReadUntil(client, 10_000, msg => msg["id"] is JsonValue idv && idv.TryGetValue(out var id) && id == 602); + var data = ((response["result"] as JsonObject)?["data"] as JsonArray) ?? new JsonArray(); + var tokens = DecodeSemanticTokens(data); + + var taskSuffixToken = tokens.FirstOrDefault(token => + token.line == 0 && + token.start == source.IndexOf("task", StringComparison.Ordinal) && + token.length == "task".Length); + + var taskAwaitToken = tokens.FirstOrDefault(token => + token.line == 0 && + token.start == source.IndexOf("Task.await", StringComparison.Ordinal) && + token.length == "Task.await".Length); + + Assert.That(taskSuffixToken.tokenType, Is.EqualTo(4), "Expected 'task' suffix to be classified as a type token."); + Assert.That(taskAwaitToken.tokenType, Is.EqualTo(3), "Expected Task.await to be classified as a function token."); + } + finally + { + try { LspTestFixture.Shutdown(client); } catch { } + LspClient.Stop(client); + } + } + [Test] public void CSharp_server_inlayHints_do_not_pollute_type_declaration_lines() { diff --git a/tests/FScript.Runtime.Tests/HostTestHelpers.fs b/tests/FScript.Runtime.Tests/HostTestHelpers.fs index fa99f37..5a1ba51 100644 --- a/tests/FScript.Runtime.Tests/HostTestHelpers.fs +++ b/tests/FScript.Runtime.Tests/HostTestHelpers.fs @@ -8,8 +8,19 @@ module HostTestHelpers = let private noApply _ _ = failwith "Function application callback is not available in this test helper" + let private noSpawnTask _ = + failwith "Task spawning callback is not available in this test helper" + + let private noAwaitTask _ = + failwith "Task await callback is not available in this test helper" + let invoke (ext: ExternalFunction) (args: Value list) = - ext.Impl { Apply = noApply } args + ext.Impl + { Apply = noApply + SpawnTask = noSpawnTask + AwaitTask = noAwaitTask + CheckRuntime = fun () -> () } + args let withTempRoot (name: string) (run: string -> unit) = let root = Path.Combine(Path.GetTempPath(), name, Guid.NewGuid().ToString("N")) diff --git a/website/docs/language/tasks-and-concurrency.md b/website/docs/language/tasks-and-concurrency.md new file mode 100644 index 0000000..f264699 --- /dev/null +++ b/website/docs/language/tasks-and-concurrency.md @@ -0,0 +1,85 @@ +--- +id: tasks-and-concurrency +title: Tasks and Concurrency +slug: /language/tasks-and-concurrency +--- + +FScript supports concurrent thunk execution through the built-in `Task` module. + +## Task type + +Task values use the native postfix type form: + +```fsharp +'a task +``` + +Examples: + +```fsharp +int task +string list task +``` + +Tasks are opaque handles. You create them with `Task.spawn` and observe them with `Task.await`. + +## Spawning work + +`Task.spawn` schedules a thunk for concurrent execution and returns immediately. + +```fsharp +let work = + Task.spawn (fun _ -> 21 * 2) +``` + +Signature: + +```fsharp +Task.spawn : (unit -> 'a) -> 'a task +``` + +FScript writes `unit -> 'a` in the type, and you typically express that thunk as `fun _ -> ...`. + +## Awaiting results + +Use `Task.await` to wait for completion and extract the result value. + +```fsharp +let work = Task.spawn (fun _ -> 21 * 2) +let answer = Task.await work +print $"{answer}" +``` + +Signature: + +```fsharp +Task.await : 'a task -> 'a +``` + +## Concurrency model + +- Spawned thunks run concurrently on the host runtime thread pool. +- Side effects may interleave across tasks and with the main script. +- `Task.await` is the explicit synchronization point for a task result. + +## Failure model + +FScript errors are fatal. Tasks follow the same rule. + +- If a spawned thunk fails, the task has failed. +- `Task.await` on that task fails the script with the same fatal runtime error. +- Finishing a program with unawaited tasks is also a runtime error. + +There is no catch/recovery mechanism in FScript today. + +## Example + +```fsharp +let a = Task.spawn (fun _ -> 40 + 2) +let b = Task.spawn (fun _ -> 10 * 3) + +let result = (Task.await a, Task.await b) +print $"{result}" +``` + +For a larger example, see [`samples/parallel-quicksort.fss`](https://github.com/MagnusOpera/FScript/blob/main/samples/parallel-quicksort.fss). diff --git a/website/docs/reference/native-types-reference.md b/website/docs/reference/native-types-reference.md index eab12bc..0beb97f 100644 --- a/website/docs/reference/native-types-reference.md +++ b/website/docs/reference/native-types-reference.md @@ -6,6 +6,22 @@ slug: /reference/native-types This page describes the built-in data shapes that are part of the language itself rather than stdlib modules. +## Tasks + +Type form: `'a task` + +| Form | Signature | Description | +| --- | --- | --- | +| `Task.spawn (fun _ -> expr)` | `(unit -> 'a) -> 'a task` | Starts concurrent work and returns a task handle. | +| `Task.await taskValue` | `'a task -> 'a` | Waits for completion and returns the task result. | + +```fsharp +let pending = Task.spawn (fun _ -> 40 + 2) +let answer = Task.await pending +``` + +Tasks are opaque values. They do not expose indexers or fields. + ## Lists Type form: `'a list` diff --git a/website/docs/reference/stdlib-reference.md b/website/docs/reference/stdlib-reference.md index c2fc976..137563f 100644 --- a/website/docs/reference/stdlib-reference.md +++ b/website/docs/reference/stdlib-reference.md @@ -8,6 +8,7 @@ This is the quick lookup page for the built-in FScript surface. ## Modules +- [`Task`](../stdlib/task) - [`List`](../stdlib/list) - [`Option`](../stdlib/option) - [`Map`](../stdlib/map) @@ -20,16 +21,18 @@ This is the quick lookup page for the built-in FScript surface. ## Native types -- [`list`, `map`, `option`, tuples, records, unions`](/manual/reference/native-types) +- [`task`, `list`, `map`, `option`, tuples, records, unions`](/manual/reference/native-types) ## Core built-in groups +- `Task.*` - `List.*` - `Option.*` - `Map.*` - `String.*` - parsing helpers: `Int.tryParse`, `Float.tryParse`, `Bool.tryParse` - scalar formatters: `Int.toString`, `Float.toString`, `Bool.toString` +- concurrency helpers: `Task.spawn`, `Task.await` - environment types/values: `Environment`, `FsKind`, `Env` - top-level functions: `print`, `ignore` diff --git a/website/docs/stdlib/overview.md b/website/docs/stdlib/overview.md index 9435779..9566224 100644 --- a/website/docs/stdlib/overview.md +++ b/website/docs/stdlib/overview.md @@ -10,6 +10,7 @@ Everything in this section is available in every script without imports. ## Modules +- `Task` - `List` - `Option` - `Map` @@ -28,6 +29,8 @@ Everything in this section is available in every script without imports. - Functions are curried. - Pipe-friendly usage is preferred. +- Task values use the native `'a task` type form. +- `Task.spawn` starts concurrent work and `Task.await` synchronizes on the result. - Map keys are always `string` (map indexer type is fixed to string). - Many parsing/indexing operations return `option` instead of throwing. @@ -40,6 +43,7 @@ Everything in this section is available in every script without imports. - [Built-ins](./builtins) for `Env`, `Environment`, `FsKind`, `print`, and `ignore` - [Native Types Reference](/manual/reference/native-types) for list/map indexers and native type access forms +- [Task Module](./task) - [List Module](./list) - [Option Module](./option) - [Map Module](./map) diff --git a/website/docs/stdlib/task.md b/website/docs/stdlib/task.md new file mode 100644 index 0000000..7f43ade --- /dev/null +++ b/website/docs/stdlib/task.md @@ -0,0 +1,56 @@ +--- +id: stdlib-task +title: Task Module +slug: /stdlib/task +--- + +The `Task` module provides the built-in task API for concurrent execution. + +## Task type + +Task values use the native postfix type form: + +```fsharp +'a task +``` + +## `Task.spawn : (unit -> 'a) -> 'a task` + +Schedules a thunk for concurrent execution and returns an opaque task handle immediately. + +```fsharp +let pending = + Task.spawn (fun _ -> "done") +``` + +Notes: + +- The thunk is represented as a `unit -> 'a` function. +- In script code that usually appears as `fun _ -> ...`. +- The returned task can be awaited later. + +## `Task.await : 'a task -> 'a` + +Waits for a task to complete and returns its result. + +```fsharp +let pending = Task.spawn (fun _ -> 40 + 2) +let answer = Task.await pending +``` + +## Runtime behavior + +- Spawned thunks run concurrently. +- Side effects such as `print` may interleave. +- Task failures are fatal runtime errors. +- A script cannot finish with unawaited tasks. + +## Example + +```fsharp +let left = Task.spawn (fun _ -> [1; 2; 3] |> List.map (fun n -> n * 2)) +let right = [10; 20; 30] |> List.map (fun n -> n + 1) + +let combined = (Task.await left) @ right +print $"{combined}" +``` diff --git a/website/sidebars.ts b/website/sidebars.ts index b0274c8..73fbcb7 100644 --- a/website/sidebars.ts +++ b/website/sidebars.ts @@ -17,6 +17,7 @@ const sidebars: SidebarsConfig = { 'language/indentation-and-layout', 'language/control-flow', 'language/collections', + 'language/tasks-and-concurrency', 'language/pattern-matching', 'language/type-system', 'language/structural-vs-named-annotations', @@ -47,6 +48,7 @@ const sidebars: SidebarsConfig = { items: [ 'stdlib/stdlib-overview', 'stdlib/stdlib-builtins', + 'stdlib/stdlib-task', 'stdlib/stdlib-list', 'stdlib/stdlib-option', 'stdlib/stdlib-map',