From 02296e2cc44b78379e21bf555c9d1c757adf91cd Mon Sep 17 00:00:00 2001 From: Steffen Forkmann Date: Tue, 30 Jan 2018 09:20:23 +0100 Subject: [PATCH 1/2] Create regression test for https://github.com/SAFE-Stack/SAFE-BookStore/issues/283 --- .../TaskCompuationExpression.fs | 316 ++++++++++++++++++ .../ComputationExpressions/env.lst | 1 + 2 files changed, 317 insertions(+) create mode 100644 tests/fsharpqa/Source/Conformance/Expressions/DataExpressions/ComputationExpressions/TaskCompuationExpression.fs diff --git a/tests/fsharpqa/Source/Conformance/Expressions/DataExpressions/ComputationExpressions/TaskCompuationExpression.fs b/tests/fsharpqa/Source/Conformance/Expressions/DataExpressions/ComputationExpressions/TaskCompuationExpression.fs new file mode 100644 index 00000000000..4abd6acac77 --- /dev/null +++ b/tests/fsharpqa/Source/Conformance/Expressions/DataExpressions/ComputationExpressions/TaskCompuationExpression.fs @@ -0,0 +1,316 @@ +// #Regression #Conformance #DataExpressions #ComputationExpressions +// Regression test for Fhttps://github.com/SAFE-Stack/SAFE-BookStore/issues/283 +// + +// Tasks.fs - TPL task computation expressions for F# +// +// Written in 2016 by Robert Peele (humbobst@gmail.com) +// Original: https://github.com/rspeele/TaskBuilder.fs/blob/master/TaskBuilder.fs +// +// To the extent possible under law, the author(s) have dedicated all copyright and related and neighboring rights +// to this software to the public domain worldwide. This software is distributed without any warranty. +// +// You should have received a copy of the CC0 Public Domain Dedication along with this software. +// If not, see . +// +// This is a slightly modified version to better fit an ASP.NET Core Giraffe web application. + +namespace Giraffe + +open System +open System.Threading.Tasks +open System.Runtime.CompilerServices + +// This module is not really obsolete, but it's not intended to be referenced directly from user code. +// However, it can't be private because it is used within inline functions that *are* user-visible. +// Marking it as obsolete is a workaround to hide it from auto-completion tools. +[] +module TaskBuilder = + /// Represents the state of a computation: + /// either awaiting something with a continuation, + /// or completed with a return value. + type Step<'a> = + | Await of ICriticalNotifyCompletion * (unit -> Step<'a>) + | Return of 'a + /// We model tail calls explicitly, but still can't run them without O(n) memory usage. + | ReturnFrom of 'a Task + /// Implements the machinery of running a `Step<'m, 'm>` as a task returning a continuation task. + and StepStateMachine<'a>(firstStep) as this = + let methodBuilder = AsyncTaskMethodBuilder<'a Task>() + /// The continuation we left off awaiting on our last MoveNext(). + let mutable continuation = fun () -> firstStep + /// Returns next pending awaitable or null if exiting (including tail call). + let nextAwaitable() = + try + match continuation() with + | Return r -> + methodBuilder.SetResult(Task.FromResult(r)) + null + | ReturnFrom t -> + methodBuilder.SetResult(t) + null + | Await (await, next) -> + continuation <- next + await + with + | exn -> + methodBuilder.SetException(exn) + null + let mutable self = this + + /// Start execution as a `Task>`. + member __.Run() = + methodBuilder.Start(&self) + methodBuilder.Task + + interface IAsyncStateMachine with + /// Proceed to one of three states: result, failure, or awaiting. + /// If awaiting, MoveNext() will be called again when the awaitable completes. + member __.MoveNext() = + let mutable await = nextAwaitable() + if not (isNull await) then + // Tell the builder to call us again when this thing is done. + methodBuilder.AwaitUnsafeOnCompleted(&await, &self) + member __.SetStateMachine(_) = () // Doesn't really apply since we're a reference type. + + let unwrapException (agg : AggregateException) = + let inners = agg.InnerExceptions + if inners.Count = 1 then inners.[0] + else agg :> Exception + + /// Used to represent no-ops like the implicit empty "else" branch of an "if" expression. + let zero = Return () + + /// Used to return a value. + let inline ret (x : 'a) = Return x + + type Binder<'out> = + // We put the output generic parameter up here at the class level, so it doesn't get subject to + // inline rules. If we put it all in the inline function, then the compiler gets confused at the + // below and demands that the whole function either is limited to working with (x : obj), or must + // be inline itself. + // + // let yieldThenReturn (x : 'a) = + // task { + // do! Task.Yield() + // return x + // } + + static member inline GenericAwait< ^abl, ^awt, ^inp + when ^abl : (member GetAwaiter : unit -> ^awt) + and ^awt :> ICriticalNotifyCompletion + and ^awt : (member get_IsCompleted : unit -> bool) + and ^awt : (member GetResult : unit -> ^inp) > + (abl : ^abl, continuation : ^inp -> 'out Step) : 'out Step = + let awt = (^abl : (member GetAwaiter : unit -> ^awt)(abl)) // get an awaiter from the awaitable + if (^awt : (member get_IsCompleted : unit -> bool)(awt)) then // shortcut to continue immediately + continuation (^awt : (member GetResult : unit -> ^inp)(awt)) + else + Await (awt, fun () -> continuation (^awt : (member GetResult : unit -> ^inp)(awt))) + + static member inline GenericAwaitConfigureFalse< ^tsk, ^abl, ^awt, ^inp + when ^tsk : (member ConfigureAwait : bool -> ^abl) + and ^abl : (member GetAwaiter : unit -> ^awt) + and ^awt :> ICriticalNotifyCompletion + and ^awt : (member get_IsCompleted : unit -> bool) + and ^awt : (member GetResult : unit -> ^inp) > + (tsk : ^tsk, continuation : ^inp -> 'out Step) : 'out Step = + let abl = (^tsk : (member ConfigureAwait : bool -> ^abl)(tsk, false)) + Binder<'out>.GenericAwait(abl, continuation) + + /// Special case of the above for `Task<'a>`. Have to write this out by hand to avoid confusing the compiler + /// trying to decide between satisfying the constraints with `Task` or `Task<'a>`. + let inline bindTask (task : 'a Task) (continuation : 'a -> Step<'b>) = + let awt = task.GetAwaiter() + if awt.IsCompleted then // Proceed to the next step based on the result we already have. + continuation(awt.GetResult()) + else // Await and continue later when a result is available. + Await (awt, (fun () -> continuation(awt.GetResult()))) + + /// Special case of the above for `Task<'a>`, for the context-insensitive builder. + /// Have to write this out by hand to avoid confusing the compiler thinking our built-in bind method + /// defined on the builder has fancy generic constraints on inp and out parameters. + let inline bindTaskConfigureFalse (task : 'a Task) (continuation : 'a -> Step<'b>) = + let awt = task.ConfigureAwait(false).GetAwaiter() + if awt.IsCompleted then // Proceed to the next step based on the result we already have. + continuation(awt.GetResult()) + else // Await and continue later when a result is available. + Await (awt, (fun () -> continuation(awt.GetResult()))) + + /// Chains together a step with its following step. + /// Note that this requires that the first step has no result. + /// This prevents constructs like `task { return 1; return 2; }`. + let rec combine (step : Step) (continuation : unit -> Step<'b>) = + match step with + | Return _ -> continuation() + | ReturnFrom t -> + Await (t.GetAwaiter(), continuation) + | Await (awaitable, next) -> + Await (awaitable, fun () -> combine (next()) continuation) + + /// Builds a step that executes the body while the condition predicate is true. + let whileLoop (cond : unit -> bool) (body : unit -> Step) = + if cond() then + // Create a self-referencing closure to test whether to repeat the loop on future iterations. + let rec repeat () = + if cond() then + let body = body() + match body with + | Return _ -> repeat() + | ReturnFrom t -> Await(t.GetAwaiter(), repeat) + | Await (awaitable, next) -> + Await (awaitable, fun () -> combine (next()) repeat) + else zero + // Run the body the first time and chain it to the repeat logic. + combine (body()) repeat + else zero + + /// Wraps a step in a try/with. This catches exceptions both in the evaluation of the function + /// to retrieve the step, and in the continuation of the step (if any). + let rec tryWith(step : unit -> Step<'a>) (catch : exn -> Step<'a>) = + try + match step() with + | Return _ as i -> i + | ReturnFrom t -> + let awaitable = t.GetAwaiter() + Await(awaitable, fun () -> + try + awaitable.GetResult() |> Return + with + | exn -> catch exn) + | Await (awaitable, next) -> Await (awaitable, fun () -> tryWith next catch) + with + | exn -> catch exn + + /// Wraps a step in a try/finally. This catches exceptions both in the evaluation of the function + /// to retrieve the step, and in the continuation of the step (if any). + let rec tryFinally (step : unit -> Step<'a>) fin = + let step = + try step() + // Important point: we use a try/with, not a try/finally, to implement tryFinally. + // The reason for this is that if we're just building a continuation, we definitely *shouldn't* + // execute the `fin()` part yet -- the actual execution of the asynchronous code hasn't completed! + with + | _ -> + fin() + reraise() + match step with + | Return _ as i -> + fin() + i + | ReturnFrom t -> + let awaitable = t.GetAwaiter() + Await(awaitable, fun () -> + try + awaitable.GetResult() |> Return + with + | _ -> + fin() + reraise()) + | Await (awaitable, next) -> + Await (awaitable, fun () -> tryFinally next fin) + + /// Implements a using statement that disposes `disp` after `body` has completed. + let inline using (disp : #IDisposable) (body : _ -> Step<'a>) = + // A using statement is just a try/finally with the finally block disposing if non-null. + tryFinally + (fun () -> body disp) + (fun () -> if not (isNull (box disp)) then disp.Dispose()) + + /// Implements a loop that runs `body` for each element in `sequence`. + let forLoop (sequence : 'a seq) (body : 'a -> Step) = + // A for loop is just a using statement on the sequence's enumerator... + using (sequence.GetEnumerator()) + // ... and its body is a while loop that advances the enumerator and runs the body on each element. + (fun e -> whileLoop e.MoveNext (fun () -> body e.Current)) + + /// Runs a step as a task -- with a short-circuit for immediately completed steps. + let run (firstStep : unit -> Step<'a>) = + try + match firstStep() with + | Return x -> Task.FromResult(x) + | ReturnFrom t -> t + | Await _ as step -> StepStateMachine<'a>(step).Run().Unwrap() // sadly can't do tail recursion + // Any exceptions should go on the task, rather than being thrown from this call. + // This matches C# behavior where you won't see an exception until awaiting the task, + // even if it failed before reaching the first "await". + with + | exn -> + let src = new TaskCompletionSource<_>() + src.SetException(exn) + src.Task + + /// Builds a `System.Threading.Tasks.Task<'a>` similarly to a C# async/await method, but with + /// all awaited tasks automatically configured *not* to resume on the captured context. + /// This is often preferable when writing library code that is not context-aware, but undesirable when writing + /// e.g. code that must interact with user interface controls on the same thread as its caller. + type ContextInsensitiveTaskBuilder() = + // These methods are consistent between the two builders. + // Unfortunately, inline members do not work with inheritance. + member inline __.Delay(f : unit -> Step<_>) = f + member inline __.Run(f : unit -> Step<'m>) = run f + member inline __.Zero() = zero + member inline __.Return(x) = ret x + member inline __.ReturnFrom(task : _ Task) = ReturnFrom task + member inline __.Combine(step : unit Step, continuation) = combine step continuation + member inline __.While(condition : unit -> bool, body : unit -> unit Step) = whileLoop condition body + member inline __.For(sequence : _ seq, body : _ -> unit Step) = forLoop sequence body + member inline __.TryWith(body : unit -> _ Step, catch : exn -> _ Step) = tryWith body catch + member inline __.TryFinally(body : unit -> _ Step, fin : unit -> unit) = tryFinally body fin + member inline __.Using(disp : #IDisposable, body : #IDisposable -> _ Step) = using disp body + // End of consistent methods -- the following methods are different between + // `TaskBuilder` and `ContextInsensitiveTaskBuilder`! + + // We have to have a dedicated overload for Task<'a> so the compiler doesn't get confused. + // Everything else can use bindGenericAwaitable via an extension member (defined later). + member inline __.Bind(task : 'a Task, continuation : 'a -> 'b Step) : 'b Step = + bindTaskConfigureFalse task continuation + + // Async overload bind + member inline __.Bind(work : 'a Async, continuation : 'a -> 'b Step) : 'b Step = + let task = Async.StartAsTask work + bindTaskConfigureFalse task continuation + +// Don't warn about our use of the "obsolete" module we just defined (see notes at start of file). +#nowarn "44" + +[] +module Tasks = + /// Builds a `System.Threading.Tasks.Task<'a>` similarly to a C# async/await method, but with + /// all awaited tasks automatically configured *not* to resume on the captured context. + /// This is often preferable when writing library code that is not context-aware, but undesirable when writing + /// e.g. code that must interact with user interface controls on the same thread as its caller. + let task = TaskBuilder.ContextInsensitiveTaskBuilder() + + // These are fallbacks when the Bind and ReturnFrom on the builder object itself don't apply. + // This is how we support binding arbitrary task-like types. + type TaskBuilder.ContextInsensitiveTaskBuilder with + member inline this.ReturnFrom(taskLike) = + TaskBuilder.Binder<_>.GenericAwait(taskLike, TaskBuilder.ret) + member inline this.Bind(taskLike, continuation : _ -> 'a TaskBuilder.Step) : 'a TaskBuilder.Step = + TaskBuilder.Binder<'a>.GenericAwait(taskLike, continuation) + + [] + module HigherPriorityBinds = + // When it's possible for these to work, the compiler should prefer them since they shadow the ones above. + type TaskBuilder.ContextInsensitiveTaskBuilder with + member inline this.ReturnFrom(configurableTaskLike) = + TaskBuilder.Binder<_>.GenericAwaitConfigureFalse(configurableTaskLike, TaskBuilder.ret) + member inline this.Bind(configurableTaskLike, continuation : _ -> 'a TaskBuilder.Step) : 'a TaskBuilder.Step = + TaskBuilder.Binder<'a>.GenericAwaitConfigureFalse(configurableTaskLike, continuation) + +module Test = + + type Book = { + Name: string + } + + let get<'a> (connectionString:string) (name:string) = task { + let book : 'a = { Name = name } |> unbox + return book + } + + let t = task { + let! book = get "abc" "The Neverending Story" + printfn "%s" book.Name + } \ No newline at end of file diff --git a/tests/fsharpqa/Source/Conformance/Expressions/DataExpressions/ComputationExpressions/env.lst b/tests/fsharpqa/Source/Conformance/Expressions/DataExpressions/ComputationExpressions/env.lst index f9dfe24dbc4..66a518d2ecd 100644 --- a/tests/fsharpqa/Source/Conformance/Expressions/DataExpressions/ComputationExpressions/env.lst +++ b/tests/fsharpqa/Source/Conformance/Expressions/DataExpressions/ComputationExpressions/env.lst @@ -1,6 +1,7 @@ SOURCE=CombineResults01.fs SCFLAGS=-a # CombineResults01.fs SOURCE=ForLoop01.fs # ForLoop01.fs SOURCE=Regressions01.fs # Regressions01.fs + SOURCE=TaskCompuationExpression.fs # TaskCompuationExpression.fs SOURCE=MinMaxValuesInLoop01.fs # MinMaxValuesInLoop01.fs SOURCE=MinMaxValuesInLoop02.fs # MinMaxValuesInLoop02.fs From 390c904db3a38d14506d2d4b6f21cd654e5866fb Mon Sep 17 00:00:00 2001 From: Steffen Forkmann Date: Wed, 31 Jan 2018 08:53:13 +0100 Subject: [PATCH 2/2] Revert "Revert #1650 (and #3366) (#4173)" This reverts commit f9893b6ad7c90aea37fe25e721840f8ea2033075. --- src/fsharp/ConstraintSolver.fs | 58 +++++++++++-------- .../OverloadingMembers/OverloadsAndSRTPs01.fs | 38 ------------ .../OverloadingMembers/RecursiveOverload01.fs | 26 --------- .../SlowOverloadResolution.fs | 4 +- .../OverloadingMembers/env.lst | 2 - 5 files changed, 36 insertions(+), 92 deletions(-) delete mode 100644 tests/fsharpqa/Source/Conformance/DeclarationElements/MemberDefinitions/OverloadingMembers/OverloadsAndSRTPs01.fs delete mode 100644 tests/fsharpqa/Source/Conformance/DeclarationElements/MemberDefinitions/OverloadingMembers/RecursiveOverload01.fs diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index 9758d9859b4..336eea3e28a 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -370,6 +370,7 @@ let ShowAccessDomain ad = // Solve exception NonRigidTypar of DisplayEnv * string option * range * TType * TType * range +exception LocallyAbortOperationThatFailsToResolveOverload exception LocallyAbortOperationThatLosesAbbrevs let localAbortD = ErrorD LocallyAbortOperationThatLosesAbbrevs @@ -738,19 +739,19 @@ and solveTypMeetsTyparConstraints (csenv:ConstraintSolverEnv) ndeep m2 trace ty | Some destTypar -> AddConstraint csenv ndeep m2 trace destTypar (TyparConstraint.DefaultsTo(priority, dty, m)) - | TyparConstraint.SupportsNull m2 -> SolveTypSupportsNull csenv ndeep m2 trace ty - | TyparConstraint.IsEnum(underlying, m2) -> SolveTypIsEnum csenv ndeep m2 trace ty underlying - | TyparConstraint.SupportsComparison(m2) -> SolveTypeSupportsComparison csenv ndeep m2 trace ty - | TyparConstraint.SupportsEquality(m2) -> SolveTypSupportsEquality csenv ndeep m2 trace ty + | TyparConstraint.SupportsNull m2 -> SolveTypSupportsNull csenv ndeep m2 trace ty + | TyparConstraint.IsEnum(underlying, m2) -> SolveTypIsEnum csenv ndeep m2 trace ty underlying + | TyparConstraint.SupportsComparison(m2) -> SolveTypeSupportsComparison csenv ndeep m2 trace ty + | TyparConstraint.SupportsEquality(m2) -> SolveTypSupportsEquality csenv ndeep m2 trace ty | TyparConstraint.IsDelegate(aty, bty, m2) -> SolveTypIsDelegate csenv ndeep m2 trace ty aty bty - | TyparConstraint.IsNonNullableStruct m2 -> SolveTypIsNonNullableValueType csenv ndeep m2 trace ty - | TyparConstraint.IsUnmanaged m2 -> SolveTypIsUnmanaged csenv ndeep m2 trace ty - | TyparConstraint.IsReferenceType m2 -> SolveTypIsReferenceType csenv ndeep m2 trace ty - | TyparConstraint.RequiresDefaultConstructor m2 -> SolveTypRequiresDefaultConstructor csenv ndeep m2 trace ty + | TyparConstraint.IsNonNullableStruct m2 -> SolveTypIsNonNullableValueType csenv ndeep m2 trace ty + | TyparConstraint.IsUnmanaged m2 -> SolveTypIsUnmanaged csenv ndeep m2 trace ty + | TyparConstraint.IsReferenceType m2 -> SolveTypIsReferenceType csenv ndeep m2 trace ty + | TyparConstraint.RequiresDefaultConstructor m2 -> SolveTypRequiresDefaultConstructor csenv ndeep m2 trace ty | TyparConstraint.SimpleChoice(tys, m2) -> SolveTypChoice csenv ndeep m2 trace ty tys | TyparConstraint.CoercesTo(ty2, m2) -> SolveTypSubsumesTypKeepAbbrevs csenv ndeep m2 trace None ty2 ty - | TyparConstraint.MayResolveMember(traitInfo, m2) -> - SolveMemberConstraint csenv false ndeep m2 trace traitInfo ++ (fun _ -> CompleteD) + | TyparConstraint.MayResolveMember(traitInfo, m2) -> + SolveMemberConstraint csenv false false ndeep m2 trace traitInfo ++ (fun _ -> CompleteD) ))) @@ -760,7 +761,6 @@ and SolveTypEqualsTyp (csenv:ConstraintSolverEnv) ndeep m2 (trace: OptionalTrace let ndeep = ndeep + 1 let aenv = csenv.EquivEnv let g = csenv.g - if ty1 === ty2 then CompleteD else match cxsln with | Some (traitInfo, traitSln) when traitInfo.Solution.IsNone -> @@ -768,6 +768,8 @@ and SolveTypEqualsTyp (csenv:ConstraintSolverEnv) ndeep m2 (trace: OptionalTrace TransactMemberConstraintSolution traitInfo trace traitSln | _ -> () + if ty1 === ty2 then CompleteD else + let canShortcut = not trace.HasTrace let sty1 = stripTyEqnsA csenv.g canShortcut ty1 let sty2 = stripTyEqnsA csenv.g canShortcut ty2 @@ -941,7 +943,7 @@ and SolveDimensionlessNumericType (csenv:ConstraintSolverEnv) ndeep m2 trace ty /// We pretend int and other types support a number of operators. In the actual IL for mscorlib they /// don't, however the type-directed static optimization rules in the library code that makes use of this /// will deal with the problem. -and SolveMemberConstraint (csenv:ConstraintSolverEnv) permitWeakResolution ndeep m2 trace (TTrait(tys,nm,memFlags,argtys,rty,sln)) : OperationResult = +and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload permitWeakResolution ndeep m2 trace (TTrait(tys, nm, memFlags, argtys, rty, sln)): OperationResult = // Do not re-solve if already solved if sln.Value.IsSome then ResultD true else let g = csenv.g @@ -1298,9 +1300,12 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) permitWeakResolution ndeep let frees = GetFreeTyparsOfMemberConstraint csenv traitInfo // If there's nothing left to learn then raise the errors - (if (permitWeakResolution && isNil support) || isNil frees then errors - // Otherwise re-record the trait waiting for canonicalization - else AddMemberConstraint csenv ndeep m2 trace traitInfo support frees) ++ (fun () -> ResultD TTraitUnsolved) + (if (permitWeakResolution && isNil support) || isNil frees then errors + // Otherwise re-record the trait waiting for canonicalization + else AddMemberConstraint csenv ndeep m2 trace traitInfo support frees) ++ (fun () -> + match errors with + | ErrorResult (_, UnresolvedOverloading _) when not ignoreUnresolvedOverload && (not (nm = "op_Explicit" || nm = "op_Implicit")) -> ErrorD LocallyAbortOperationThatFailsToResolveOverload + | _ -> ResultD TTraitUnsolved) ) ++ (fun res -> RecordMemberConstraintSolution csenv.SolverState m trace traitInfo res)) @@ -1442,7 +1447,7 @@ and SolveRelevantMemberConstraintsForTypar (csenv:ConstraintSolverEnv) ndeep per cxs |> AtLeastOneD (fun (traitInfo, m2) -> let csenv = { csenv with m = m2 } - SolveMemberConstraint csenv permitWeakResolution (ndeep+1) m2 trace traitInfo) + SolveMemberConstraint csenv true permitWeakResolution (ndeep+1) m2 trace traitInfo) and CanonicalizeRelevantMemberConstraints (csenv:ConstraintSolverEnv) ndeep trace tps = SolveRelevantMemberConstraints csenv ndeep true trace tps @@ -1957,10 +1962,12 @@ and CanMemberSigsMatchUpToCheck // to allow us to report the outer types involved in the constraint and private SolveTypSubsumesTypWithReport (csenv:ConstraintSolverEnv) ndeep m trace cxsln ty1 ty2 = TryD (fun () -> SolveTypSubsumesTypKeepAbbrevs csenv ndeep m trace cxsln ty1 ty2) - (fun res -> - match csenv.eContextInfo with - | ContextInfo.RuntimeTypeTest isOperator -> - // test if we can cast other way around + (function + | LocallyAbortOperationThatFailsToResolveOverload -> CompleteD + | res -> + match csenv.eContextInfo with + | ContextInfo.RuntimeTypeTest isOperator -> + // test if we can cast other way around match CollectThenUndo (fun newTrace -> SolveTypSubsumesTypKeepAbbrevs csenv ndeep m (OptionalTrace.WithTrace newTrace) cxsln ty2 ty1) with | OkResult _ -> ErrorD (ErrorsFromAddingSubsumptionConstraint(csenv.g, csenv.DisplayEnv, ty1, ty2, res, ContextInfo.DowncastUsedInsteadOfUpcast isOperator, m)) | _ -> ErrorD (ErrorsFromAddingSubsumptionConstraint(csenv.g, csenv.DisplayEnv, ty1, ty2, res, ContextInfo.NoContext, m)) @@ -1968,7 +1975,9 @@ and private SolveTypSubsumesTypWithReport (csenv:ConstraintSolverEnv) ndeep m tr and private SolveTypEqualsTypWithReport (csenv:ConstraintSolverEnv) ndeep m trace cxsln ty1 ty2 = TryD (fun () -> SolveTypEqualsTypKeepAbbrevsWithCxsln csenv ndeep m trace cxsln ty1 ty2) - (fun res -> ErrorD (ErrorFromAddingTypeEquation(csenv.g, csenv.DisplayEnv, ty1, ty2, res, m))) + (function + | LocallyAbortOperationThatFailsToResolveOverload -> CompleteD + | res -> ErrorD (ErrorFromAddingTypeEquation(csenv.g, csenv.DisplayEnv, ty1, ty2, res, m))) and ArgsMustSubsumeOrConvert (csenv:ConstraintSolverEnv) @@ -2534,7 +2543,7 @@ let AddCxTypeMustSubsumeType contextInfo denv css m trace ty1 ty2 = |> RaiseOperationResult let AddCxMethodConstraint denv css m trace traitInfo = - TryD (fun () -> SolveMemberConstraint (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) false 0 m trace traitInfo ++ (fun _ -> CompleteD)) + TryD (fun () -> SolveMemberConstraint (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) true false 0 m trace traitInfo ++ (fun _ -> CompleteD)) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult @@ -2592,7 +2601,7 @@ let CodegenWitnessThatTypSupportsTraitConstraint tcVal g amap m (traitInfo:Trait InfoReader = new InfoReader(g, amap) } let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m (DisplayEnv.Empty g) - SolveMemberConstraint csenv true 0 m NoTrace traitInfo ++ (fun _res -> + SolveMemberConstraint csenv true true 0 m NoTrace traitInfo ++ (fun _res -> let sln = match traitInfo.Solution with | None -> Choice4Of4() @@ -2717,4 +2726,5 @@ let IsApplicableMethApprox g amap m (minfo:MethInfo) availObjTy = |> CommitOperationResult | _ -> true else - true \ No newline at end of file + true + diff --git a/tests/fsharpqa/Source/Conformance/DeclarationElements/MemberDefinitions/OverloadingMembers/OverloadsAndSRTPs01.fs b/tests/fsharpqa/Source/Conformance/DeclarationElements/MemberDefinitions/OverloadingMembers/OverloadsAndSRTPs01.fs deleted file mode 100644 index 842d049dc9f..00000000000 --- a/tests/fsharpqa/Source/Conformance/DeclarationElements/MemberDefinitions/OverloadingMembers/OverloadsAndSRTPs01.fs +++ /dev/null @@ -1,38 +0,0 @@ -// #Conformance #DeclarationElements #MemberDefinitions #Overloading -// Exotic case from F#+ https://github.com/gusty/FSharpPlus - -module Applicatives = - open System - - type Ap = Ap with - static member inline Invoke (x:'T) : '``Applicative<'T>`` = - let inline call (mthd : ^M, output : ^R) = ((^M or ^R) : (static member Return: _*_ -> _) output, mthd) - call (Ap, Unchecked.defaultof<'``Applicative<'T>``>) x - static member inline InvokeOnInstance (x:'T) = (^``Applicative<'T>`` : (static member Return: ^T -> ^``Applicative<'T>``) x) - static member inline Return (r:'R , _:obj) = Ap.InvokeOnInstance :_ -> 'R - static member Return (_:seq<'a> , Ap ) = fun x -> Seq.singleton x : seq<'a> - static member Return (_:Tuple<'a>, Ap ) = fun x -> Tuple x : Tuple<'a> - static member Return (_:'r -> 'a , Ap ) = fun k _ -> k : 'a -> 'r -> _ - - let inline result (x:'T) = Ap.Invoke x - - let inline (<*>) (f:'``Applicative<'T->'U>``) (x:'``Applicative<'T>``) : '``Applicative<'U>`` = - (( ^``Applicative<'T->'U>`` or ^``Applicative<'T>`` or ^``Applicative<'U>``) : (static member (<*>): _*_ -> _) f, x) - - let inline (+) (a:'Num) (b:'Num) :'Num = a + b - - type ZipList<'s> = ZipList of 's seq with - static member Return (x:'a) = ZipList (Seq.initInfinite (fun _ -> x)) - static member (<*>) (ZipList (f:seq<'a->'b>), ZipList x) = ZipList (Seq.zip f x |> Seq.map (fun (f, x) -> f x)) :ZipList<'b> - - type Ii = Ii - type Idiomatic = Idiomatic with - static member inline ($) (Idiomatic, si) = fun sfi x -> (Idiomatic $ x) (sfi <*> si) - static member ($) (Idiomatic, Ii) = id - let inline idiomatic a b = (Idiomatic $ b) a - let inline iI x = (idiomatic << result) x - - let res1n2n3 = iI (+) (result 0M ) (ZipList [1M;2M;3M]) Ii - let res2n3n4 = iI (+) (result LanguagePrimitives.GenericOne) (ZipList [1 ;2 ;3 ]) Ii - - exit 0 \ No newline at end of file diff --git a/tests/fsharpqa/Source/Conformance/DeclarationElements/MemberDefinitions/OverloadingMembers/RecursiveOverload01.fs b/tests/fsharpqa/Source/Conformance/DeclarationElements/MemberDefinitions/OverloadingMembers/RecursiveOverload01.fs deleted file mode 100644 index e8d9355ad44..00000000000 --- a/tests/fsharpqa/Source/Conformance/DeclarationElements/MemberDefinitions/OverloadingMembers/RecursiveOverload01.fs +++ /dev/null @@ -1,26 +0,0 @@ -// #Conformance #DeclarationElements #MemberDefinitions #Overloading -// Originally from https://gist.github.com/gusty/b6fac370bff36a665d75 -type FoldArgs<'t> = FoldArgs of ('t -> 't -> 't) - -let inline foldArgs f (x:'t) (y:'t) :'rest = (FoldArgs f $ Unchecked.defaultof<'rest>) x y - -type FoldArgs<'t> with - static member inline ($) (FoldArgs f, _:'t-> 'rest) = fun (a:'t) -> f a >> foldArgs f - static member ($) (FoldArgs f, _:'t ) = f - -let test1() = - let x:int = foldArgs (+) 2 3 - let y:int = foldArgs (+) 2 3 4 - let z:int = foldArgs (+) 2 3 4 5 - let d:decimal = foldArgs (+) 2M 3M 4M - let e:string = foldArgs (+) "h" "e" "l" "l" "o" - let f:float = foldArgs (+) 2. 3. 4. - - let mult3Numbers a b c = a * b * c - let res2 = mult3Numbers 3 (foldArgs (+) 3 4) (foldArgs (+) 2 2 3 3) - () - -// Run the test -test1() - -exit 0 \ No newline at end of file diff --git a/tests/fsharpqa/Source/Conformance/DeclarationElements/MemberDefinitions/OverloadingMembers/SlowOverloadResolution.fs b/tests/fsharpqa/Source/Conformance/DeclarationElements/MemberDefinitions/OverloadingMembers/SlowOverloadResolution.fs index 0f6d5f43532..5737cdebf2c 100644 --- a/tests/fsharpqa/Source/Conformance/DeclarationElements/MemberDefinitions/OverloadingMembers/SlowOverloadResolution.fs +++ b/tests/fsharpqa/Source/Conformance/DeclarationElements/MemberDefinitions/OverloadingMembers/SlowOverloadResolution.fs @@ -1,6 +1,6 @@ // #Conformance #DeclarationElements #MemberDefinitions #Overloading // https://github.com/Microsoft/visualfsharp/issues/351 - slow overlaod resolution -//No overloads match +//This value is not a function and cannot be applied type Switcher = Switcher let inline checker< ^s, ^r when (^s or ^r) : (static member pass : ^r -> unit)> (s : ^s) (r : ^r) = () @@ -22,4 +22,4 @@ let main argv = let res : unit = format () "text" 5 "more text" () printfn "%A" res System.Console.ReadKey() - 0 // return an integer exit code \ No newline at end of file + 0 // return an integer exit code diff --git a/tests/fsharpqa/Source/Conformance/DeclarationElements/MemberDefinitions/OverloadingMembers/env.lst b/tests/fsharpqa/Source/Conformance/DeclarationElements/MemberDefinitions/OverloadingMembers/env.lst index e123d552e69..7a3e95f230e 100644 --- a/tests/fsharpqa/Source/Conformance/DeclarationElements/MemberDefinitions/OverloadingMembers/env.lst +++ b/tests/fsharpqa/Source/Conformance/DeclarationElements/MemberDefinitions/OverloadingMembers/env.lst @@ -27,8 +27,6 @@ NOMONO,NoMT SOURCE=ConsumeOverloadGenericMethods.fs SCFLAGS="-r:lib.dll" PRECMD= SOURCE=InferenceForLambdaArgs.fs # InferenceForLambdaArgs.fs SOURCE=SlowOverloadResolution.fs # SlowOverloadResolution.fs - SOURCE=RecursiveOverload01.fs # RecursiveOverload01.fs - SOURCE=OverloadsAndSRTPs01.fs # OverloadsAndSRTPs01.fs SOURCE=E_OverloadCurriedFunc.fs # E_OverloadCurriedFunc.fs SOURCE=NoWarningWhenOverloadingInSubClass01.fs SCFLAGS="--warnaserror" # NoWarningWhenOverloadingInSubClass01.fs