diff --git a/src/Fable.Transforms/Babel/Fable2Babel.fs b/src/Fable.Transforms/Babel/Fable2Babel.fs index 89ad79c781..f72d32e3a7 100644 --- a/src/Fable.Transforms/Babel/Fable2Babel.fs +++ b/src/Fable.Transforms/Babel/Fable2Babel.fs @@ -47,6 +47,7 @@ type Context = TailCallOpportunity: ITailCallOpportunity option OptimizeTailCall: unit -> unit ScopedTypeParams: Set + BoundTypes: Map ForcedIdents: Set } @@ -2451,17 +2452,35 @@ but thanks to the optimisation done below we get | Some(TransformExpr com ctx thisArg) -> callFunction com ctx range callee callInfo.GenericArgs (thisArg :: args) - let transformCurriedApply com ctx range (TransformExpr com ctx applied) args = - (applied, args) - ||> List.fold (fun expr arg -> - match arg with - // TODO: If arg type is unit but it's an expression with potential - // side-effects, we need to extract it and execute it before the call - | Fable.Value(Fable.UnitConstant, _) -> [] - | Fable.IdentExpr ident when ident.Type = Fable.Unit -> [] - | TransformExpr com ctx arg -> [ arg ] - |> callFunction com ctx range expr [] + let transformCurriedApply (com: IBabelCompiler) ctx range (applied: Fable.Expr) args = + // decision: declaration types preserve generic unit arguments despite specialized identifier types at call sites + let appliedType = + match applied with + // invariant: FSharp2Fable makes local names unique within a declaration (getIdentUniqueName) + | MaybeCasted(Fable.IdentExpr id) -> Map.tryFind id.Name ctx.BoundTypes |> Option.defaultValue id.Type + | _ -> applied.Type + + let applied = com.TransformAsExpr(ctx, applied) + + ((applied, appliedType), args) + ||> List.fold (fun (expr, calleeType) arg -> + let argType, returnType = + match calleeType with + | Fable.LambdaType(argType, returnType) -> Some argType, returnType + | _ -> None, Fable.Any + + let args = + match arg, argType with + | _, Some argType when argType <> Fable.Unit -> [ com.TransformAsExpr(ctx, arg) ] + // TODO: If arg type is unit but it's an expression with potential + // side-effects, we need to extract it and execute it before the call + | Fable.Value(Fable.UnitConstant, _), _ -> [] + | Fable.IdentExpr ident, _ when ident.Type = Fable.Unit -> [] + | TransformExpr com ctx arg, _ -> [ arg ] + + callFunction com ctx range expr [] args, returnType ) + |> fst let transformCallAsStatements com ctx range typ returnStrategy callee callInfo = let argsLen (i: Fable.CallInfo) = @@ -3197,6 +3216,7 @@ but thanks to the optimisation done below we get | Fable.Let(ident, value, body) -> if ctx.HoistVars [ ident ] then let assignment = transformBindingAsExpr com ctx ident value + let ctx = { ctx with BoundTypes = Map.add ident.Name ident.Type ctx.BoundTypes } Expression.sequenceExpression ([| assignment; com.TransformAsExpr(ctx, body) |]) else @@ -3204,6 +3224,13 @@ but thanks to the optimisation done below we get | Fable.LetRec(bindings, body) -> if ctx.HoistVars(List.map fst bindings) then + let ctx = + { ctx with + BoundTypes = + (ctx.BoundTypes, bindings) + ||> List.fold (fun types (id, _) -> Map.add id.Name id.Type types) + } + let values = bindings |> List.mapToArray (fun (id, value) -> transformBindingAsExpr com ctx id value) @@ -3310,10 +3337,18 @@ but thanks to the optimisation done below we get | Fable.Let(ident, value, body) -> let binding = transformBindingAsStatements com ctx ident value + let ctx = { ctx with BoundTypes = Map.add ident.Name ident.Type ctx.BoundTypes } Array.append binding (transformAsStatements com ctx returnStrategy body) | Fable.LetRec(bindings, body) -> + let ctx = + { ctx with + BoundTypes = + (ctx.BoundTypes, bindings) + ||> List.fold (fun types (id, _) -> Map.add id.Name id.Type types) + } + let bindings = bindings |> Seq.collect (fun (i, v) -> transformBindingAsStatements com ctx i v) @@ -3419,6 +3454,9 @@ but thanks to the optimisation done below we get { ctx with TailCallOpportunity = tailcallChance OptimizeTailCall = fun () -> isTailCallOptimized <- true + BoundTypes = + (ctx.BoundTypes, args) + ||> List.fold (fun types id -> Map.add id.Name id.Type types) } let returnStrategy = @@ -5052,6 +5090,7 @@ module Compiler = TailCallOpportunity = None OptimizeTailCall = fun () -> () ScopedTypeParams = Set.empty + BoundTypes = Map.empty ForcedIdents = Set.empty } diff --git a/src/Fable.Transforms/Python/Fable2Python.Transforms.fs b/src/Fable.Transforms/Python/Fable2Python.Transforms.fs index cfbe4a9ebd..d0bb7480da 100644 --- a/src/Fable.Transforms/Python/Fable2Python.Transforms.fs +++ b/src/Fable.Transforms/Python/Fable2Python.Transforms.fs @@ -3374,8 +3374,15 @@ let transformFunction args = [ Arg.arg (Identifier("__unit"), annotation = unitType) ], defaults = [ unitDefault ] ) - // No args but has tail-call args: skip __unit, tcArgs are sufficient - | [], _, _ -> Arguments.arguments (args = tcArgs, defaults = tcDefaults) + // invariant: a runtime unit argument never overwrites a captured TCO default + | [], _, _ -> + let unitType = com.GetImportExpr(ctx, getLibPath com "util", "Unit") + let unitName = getUniqueNameInDeclarationScope ctx "__unit" + + Arguments.arguments ( + args = Arg.arg (Identifier unitName, annotation = unitType) :: tcArgs, + defaults = unitDefault :: tcDefaults + ) // Single generic/unit arg with no tail-call args: keep it with () default | [ arg ], true, [] -> Arguments.arguments (args = args, defaults = [ unitDefault ]) // Single generic/unit arg with tail-call args: keep arg (body may reference it) diff --git a/src/Fable.Transforms/Python/Replacements.fs b/src/Fable.Transforms/Python/Replacements.fs index 85a42fb297..1513e1a161 100644 --- a/src/Fable.Transforms/Python/Replacements.fs +++ b/src/Fable.Transforms/Python/Replacements.fs @@ -3675,6 +3675,13 @@ let asyncBuilder (com: ICompiler) (ctx: Context) r t (i: CallInfo) (thisArg: Exp let asyncs com (ctx: Context) r t (i: CallInfo) (_: Expr option) (args: Expr list) = match i.CompiledName with + | "FromContinuations" when + (match t with + | Fable.DeclaredType(_, [ Fable.Unit ]) -> true + | _ -> false) + -> + Helper.LibCall(com, "async_", "from_continuations_unit", t, args, i.SignatureArgTypes, ?loc = r) + |> Some | "Start" -> Helper.LibCall(com, "async_", "start", t, args, i.SignatureArgTypes, ?loc = r) |> Some diff --git a/src/fable-library-py/fable_library/async_.py b/src/fable-library-py/fable_library/async_.py index 0ef88fb89b..faed9113f8 100644 --- a/src/fable-library-py/fable_library/async_.py +++ b/src/fable-library-py/fable_library/async_.py @@ -188,6 +188,21 @@ def cont(ctx: IAsyncContext[T]) -> None: return protected_cont(cont) +def from_continuations_unit( + f: Callable[ + [tuple[Callable[[], None], Callable[[Exception], None], Callable[[OperationCanceledError], None]]], + None, + ], +) -> Async[None]: + def cont(ctx: IAsyncContext[None]) -> None: + def success(value: None = None) -> None: + ctx.on_success(value) + + f((success, ctx.on_error, ctx.on_cancel)) + + return protected_cont(cont) + + def await_task[T](task: Awaitable[T]) -> Async[T]: """Return an asynchronous computation that will wait for the given task to complete and return its result. diff --git a/tests/Beam/AsyncTests.fs b/tests/Beam/AsyncTests.fs index f1ebea0b34..c2011b6662 100644 --- a/tests/Beam/AsyncTests.fs +++ b/tests/Beam/AsyncTests.fs @@ -757,3 +757,25 @@ let ``test Async.AwaitEvent with cancelAction invokes it on cancellation`` () = equal true cancelCalled #endif +[] +let ``test FromContinuations unit and generic values`` () = + let fromValue value = Async.FromContinuations(fun (ok, _, _) -> ok value) + let mutable completed = 0 + let unitWork: Async = Async.FromContinuations(fun (ok, _, _) -> ok ()) + Async.StartWithContinuations(unitWork, (fun () -> completed <- completed + 1), raise, raise) + Async.StartWithContinuations(fromValue (), (fun () -> completed <- completed + 1), raise, raise) + Async.StartWithContinuations(fromValue 42, (fun value -> equal 42 value; completed <- completed + 1), raise, raise) + equal 3 completed + +[] +let ``test unit continuations preserve captured callbacks`` () = + let mutable calls = 0 + let rec genericDeadline callback value remaining = + if remaining > 0 then genericDeadline callback value (remaining - 1) + else Async.StartWithContinuations(async { return value }, (fun result -> callback result), raise, raise) + let rec unitDeadline (callback: unit -> unit) remaining = + if remaining > 0 then unitDeadline callback (remaining - 1) + else Async.StartWithContinuations(async { return () }, (fun () -> callback ()), raise, raise) + genericDeadline (fun () -> calls <- calls + 1) () 2 + unitDeadline (fun () -> calls <- calls + 1) 2 + equal 2 calls diff --git a/tests/Js/Main/AsyncTests.fs b/tests/Js/Main/AsyncTests.fs index 5127510cf8..448326ad15 100644 --- a/tests/Js/Main/AsyncTests.fs +++ b/tests/Js/Main/AsyncTests.fs @@ -47,6 +47,67 @@ let asyncMap f a = async { let tests = testList "Async" [ + testCase "FromContinuations unit and generic values" <| fun () -> + let fromValue value = Async.FromContinuations(fun (ok, _, _) -> ok value) + let mutable completed = 0 + let unitWork: Async = Async.FromContinuations(fun (ok, _, _) -> ok ()) + Async.StartWithContinuations(unitWork, (fun () -> completed <- completed + 1), raise, raise) + Async.StartWithContinuations(fromValue (), (fun () -> completed <- completed + 1), raise, raise) + Async.StartWithContinuations(fromValue 42, (fun value -> equal 42 value; completed <- completed + 1), raise, raise) + equal 3 completed + + testCase "Generic unit continuations work through recursive bindings and aliases" <| fun () -> + let mutable recurse = true + let rec fromValue value = + if recurse then + recurse <- false + fromValue value + else Async.FromContinuations(fun (ok, _, _) -> ok value) + let alias = fromValue + let mutable completed = 0 + Async.StartWithContinuations(fromValue (), (fun () -> completed <- completed + 1), raise, raise) + recurse <- true + Async.StartWithContinuations(alias (), (fun () -> completed <- completed + 1), raise, raise) + Async.StartWithContinuations(alias 42, (fun value -> equal 42 value; completed <- completed + 1), raise, raise) + equal 3 completed + + testCase "Generic unit continuations work through tuple pattern bindings" <| fun () -> + let fromValue, fromOther = + (fun (value: 'T) -> Async.FromContinuations(fun (ok, _, _) -> ok value)), + (fun (value: 'U) -> Async.FromContinuations(fun (ok, _, _) -> ok value)) + let mutable completed = 0 + Async.StartWithContinuations(fromValue (), (fun () -> completed <- completed + 1), raise, raise) + Async.StartWithContinuations(fromValue 42, (fun value -> equal 42 value; completed <- completed + 1), raise, raise) + Async.StartWithContinuations(fromOther (), (fun () -> completed <- completed + 1), raise, raise) + Async.StartWithContinuations(fromOther "a", (fun value -> equal "a" value; completed <- completed + 1), raise, raise) + equal 4 completed + + testCase "Generic unit continuations work inside nested lambdas and object expressions" <| fun () -> + let fromValue value = Async.FromContinuations(fun (ok, _, _) -> ok value) + let mutable completed = 0 + let startUnit () = Async.StartWithContinuations(fromValue (), (fun () -> completed <- completed + 1), raise, raise) + let disposable = + { new IDisposable with + member _.Dispose() = + Async.StartWithContinuations(fromValue (), (fun () -> completed <- completed + 1), raise, raise) } + startUnit () + startUnit () + disposable.Dispose() + Async.StartWithContinuations(fromValue 42, (fun value -> equal 42 value; completed <- completed + 1), raise, raise) + equal 4 completed + + testCase "Unit continuations preserve captured callbacks" <| fun () -> + let mutable calls = 0 + let rec genericDeadline callback value remaining = + if remaining > 0 then genericDeadline callback value (remaining - 1) + else Async.StartWithContinuations(async { return value }, (fun result -> callback result), raise, raise) + let rec unitDeadline (callback: unit -> unit) remaining = + if remaining > 0 then unitDeadline callback (remaining - 1) + else Async.StartWithContinuations(async { return () }, (fun () -> callback ()), raise, raise) + genericDeadline (fun () -> calls <- calls + 1) () 2 + unitDeadline (fun () -> calls <- calls + 1) 2 + equal 2 calls + testCase "Simple async translates without exception" <| fun () -> async { return () } |> Async.StartImmediate diff --git a/tests/Python/TestAsync.fs b/tests/Python/TestAsync.fs index d6666d7dde..cb701222d1 100644 --- a/tests/Python/TestAsync.fs +++ b/tests/Python/TestAsync.fs @@ -678,3 +678,31 @@ let ``test Async.AwaitEvent with cancelAction invokes it on cancellation`` () = }, cts.Token) cts.Cancel() equal true cancelCalled + +[] +let ``test FromContinuations unit and generic values`` () = + let fromValue value = Async.FromContinuations(fun (ok, _, _) -> ok value) + let mutable completed = 0 + let unitWork: Async = Async.FromContinuations(fun (ok, _, _) -> ok ()) + Async.StartWithContinuations(unitWork, (fun () -> completed <- completed + 1), raise, raise) + Async.StartWithContinuations(fromValue (), (fun () -> completed <- completed + 1), raise, raise) + Async.StartWithContinuations(fromValue 42, (fun value -> equal 42 value; completed <- completed + 1), raise, raise) + equal 3 completed + +[] +let ``test unit continuations preserve captured callbacks`` () = + let mutable calls = 0 + let rec genericDeadline callback value remaining = + if remaining > 0 then genericDeadline callback value (remaining - 1) + else Async.StartWithContinuations(async { return value }, (fun result -> callback result), raise, raise) + let rec unitDeadline (callback: unit -> unit) remaining = + if remaining > 0 then unitDeadline callback (remaining - 1) + else Async.StartWithContinuations(async { return () }, (fun () -> callback ()), raise, raise) + genericDeadline (fun () -> calls <- calls + 1) () 2 + unitDeadline (fun () -> calls <- calls + 1) 2 + let rec namedUnitCapture (__unit: int) remaining = + if remaining > 0 then namedUnitCapture __unit (remaining - 1) + else Async.StartWithContinuations(async { return () }, (fun () -> calls <- calls + __unit), raise, raise) + namedUnitCapture 3 2 + equal 5 calls +