From b8c748c69c4fca42d2dc66024388d6e7b69a7971 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Wed, 22 Jan 2020 13:37:18 +0000 Subject: [PATCH] fix 5580 and better encapsulate constraint solver (#8294) * fix 5580 and better encapsulate constraint solver * fix 5580 and better encapsulate constraint solver * fix 5580 and better encapsulate constraint solver * fix 5580 and better encapsulate constraint solver * add new tests * nudge CI --- src/fsharp/ConstraintSolver.fs | 244 ++++++++++++++++++------- src/fsharp/ConstraintSolver.fsi | 127 +++++++------ src/fsharp/IlxGen.fs | 1 - src/fsharp/TypeChecker.fs | 58 ++---- tests/fsharp/tests.fs | 12 ++ tests/fsharp/typecheck/sigs/neg116.bsl | 12 ++ tests/fsharp/typecheck/sigs/neg116.fs | 10 + tests/fsharp/typecheck/sigs/neg117.bsl | 12 ++ tests/fsharp/typecheck/sigs/neg117.fs | 82 +++++++++ tests/fsharp/typecheck/sigs/neg118.bsl | 12 ++ tests/fsharp/typecheck/sigs/neg118.fs | 28 +++ tests/fsharp/typecheck/sigs/neg119.bsl | 22 +++ tests/fsharp/typecheck/sigs/neg119.fs | 40 ++++ 13 files changed, 498 insertions(+), 162 deletions(-) create mode 100644 tests/fsharp/typecheck/sigs/neg116.bsl create mode 100644 tests/fsharp/typecheck/sigs/neg116.fs create mode 100644 tests/fsharp/typecheck/sigs/neg117.bsl create mode 100644 tests/fsharp/typecheck/sigs/neg117.fs create mode 100644 tests/fsharp/typecheck/sigs/neg118.bsl create mode 100644 tests/fsharp/typecheck/sigs/neg118.fs create mode 100644 tests/fsharp/typecheck/sigs/neg119.bsl create mode 100644 tests/fsharp/typecheck/sigs/neg119.fs diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index 0360d253dd1..59b10f7be71 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -27,9 +27,19 @@ // can-unify predicates used in method overload resolution and trait constraint // satisfaction. // +// The two main principles are: +// 1. Ensure any solution that is found is sound (no logic is skipped), +// 2. Because of method overloading and SRTP constraints and other constructs, processing of +// constraints is algorithmic and must proceed in a definite, fixed order. +// Once we start doing resolutions in a particular order we must keep doing them +// in the same order. +// +// There is little use of back-tracking/undo or "retry" in the constraint solver, except in the +// limited case ofs of SRTP solving and method overloading, and some other adhoc limited cases +// like checking for "printf" format strings. As a result there are cases involving +// method overloading and SRTP that the solver "can't solve". This is intentional and by-design. //------------------------------------------------------------------------- - module internal FSharp.Compiler.ConstraintSolver open Internal.Utilities.Collections @@ -429,8 +439,39 @@ let ShowAccessDomain ad = exception NonRigidTypar of displayEnv: DisplayEnv * string option * range * TType * TType * range -exception LocallyAbortOperationThatFailsToResolveOverload +/// Signal that there is still an unresolved overload in the constraint problem. The +/// unresolved overload constraint remains in the constraint state, and we skip any +/// further processing related to whichever overall adjustment to constraint solver state +/// is being processed. +/// +// NOTE: The addition of this abort+skip appears to be a mistake which has crept into F# type inference, +// and its status is currently under review. See https://github.com/dotnet/fsharp/pull/8294 and others. +// +// Here is the history: +// 1. The local abort was added as part of an attempted performance optimization https://github.com/dotnet/fsharp/pull/1650 +// This change was released in the VS2017 GA release. +// +// 2. However, it also impacts the logic of type inference, by skipping checking. +// Because of this an attempt was made to revert it in https://github.com/dotnet/fsharp/pull/4173. +// +// Unfortunately, existing code had begun to depend on the new behaviours enabled by the +// change, and the revert was abandoned before release in https://github.com/dotnet/fsharp/pull/4348 +// +// Comments on soundness: +// The use of the abort is normally sound because the SRTP constraint +// will be subject to further processing at a later point. +// +// However, it seems likely that the abort may result in other processing associated +// with an overall constraint being skipped (e.g. the processing related to subsequent elements +// of a tuple constraint). +exception AbortForFailedOverloadResolution + +/// This is used at (nearly all) entry points into the constraint solver to make sure that the +/// AbortForFailedOverloadResolution is caught and processing continues. +let inline TryD_IgnoreAbortForFailedOverloadResolution f1 f2 = + TryD f1 (function AbortForFailedOverloadResolution -> CompleteD | exn -> f2 exn) +/// Represents a very local condition where we prefer to report errors before stripping type abbreviations. exception LocallyAbortOperationThatLosesAbbrevs let localAbortD = ErrorD LocallyAbortOperationThatLosesAbbrevs @@ -929,8 +970,9 @@ and private SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 trace cxsln t // Back out of expansions of type abbreviations to give improved error messages. // Note: any "normalization" of equations on type variables must respect the trace parameter TryD (fun () -> SolveTypeEqualsType csenv ndeep m2 trace cxsln ty1 ty2) - (function LocallyAbortOperationThatLosesAbbrevs -> ErrorD(ConstraintSolverTypesNotInEqualityRelation(csenv.DisplayEnv, ty1, ty2, csenv.m, m2, csenv.eContextInfo)) - | err -> ErrorD err) + (function + | LocallyAbortOperationThatLosesAbbrevs -> ErrorD(ConstraintSolverTypesNotInEqualityRelation(csenv.DisplayEnv, ty1, ty2, csenv.m, m2, csenv.eContextInfo)) + | err -> ErrorD err) and SolveTypeEqualsTypeEqns csenv ndeep m2 trace cxsln origl1 origl2 = match origl1, origl2 with @@ -1059,8 +1101,9 @@ and SolveTypeSubsumesType (csenv: ConstraintSolverEnv) ndeep m2 (trace: Optional and SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m2 trace cxsln ty1 ty2 = let denv = csenv.DisplayEnv TryD (fun () -> SolveTypeSubsumesType csenv ndeep m2 trace cxsln ty1 ty2) - (function LocallyAbortOperationThatLosesAbbrevs -> ErrorD(ConstraintSolverTypesNotInSubsumptionRelation(denv, ty1, ty2, csenv.m, m2)) - | err -> ErrorD err) + (function + | LocallyAbortOperationThatLosesAbbrevs -> ErrorD(ConstraintSolverTypesNotInSubsumptionRelation(denv, ty1, ty2, csenv.m, m2)) + | err -> ErrorD err) //------------------------------------------------------------------------- // Solve and record non-equality constraints @@ -1451,7 +1494,9 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload Some(CalledMeth(csenv.InfoReader, None, false, FreshenMethInfo, m, AccessibleFromEverywhere, minfo, minst, minst, None, objtys, [(callerArgs, [])], false, false, None))) let methOverloadResult, errors = - trace.CollectThenUndoOrCommit (fun (a, _) -> Option.isSome a) (fun trace -> ResolveOverloading csenv (WithTrace trace) nm ndeep (Some traitInfo) (0, 0) AccessibleFromEverywhere calledMethGroup false (Some rty)) + trace.CollectThenUndoOrCommit + (fun (a, _) -> Option.isSome a) + (fun trace -> ResolveOverloading csenv (WithTrace trace) nm ndeep (Some traitInfo) (0, 0) AccessibleFromEverywhere calledMethGroup false (Some rty)) match anonRecdPropSearch, recdPropSearch, methOverloadResult with | Some (anonInfo, tinst, i), None, None -> @@ -1497,7 +1542,7 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload match errors with | ErrorResult (_, UnresolvedOverloading _) when not ignoreUnresolvedOverload && (not (nm = "op_Explicit" || nm = "op_Implicit")) -> - return! ErrorD LocallyAbortOperationThatFailsToResolveOverload + return! ErrorD AbortForFailedOverloadResolution | _ -> return TTraitUnsolved } @@ -2183,25 +2228,23 @@ and CanMemberSigsMatchUpToCheck // "ty2 casts to ty1" // "a value of type ty2 can be used where a value of type ty1 is expected" and private SolveTypeSubsumesTypeWithReport (csenv: ConstraintSolverEnv) ndeep m trace cxsln ty1 ty2 = - TryD (fun () -> SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m trace cxsln ty1 ty2) - (function - | LocallyAbortOperationThatFailsToResolveOverload -> CompleteD - | res -> - match csenv.eContextInfo with - | ContextInfo.RuntimeTypeTest isOperator -> - // test if we can cast other way around - match CollectThenUndo (fun newTrace -> SolveTypeSubsumesTypeKeepAbbrevs 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)) - | _ -> ErrorD (ErrorsFromAddingSubsumptionConstraint(csenv.g, csenv.DisplayEnv, ty1, ty2, res, csenv.eContextInfo, m))) + TryD_IgnoreAbortForFailedOverloadResolution + (fun () -> SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m trace cxsln ty1 ty2) + (fun res -> + match csenv.eContextInfo with + | ContextInfo.RuntimeTypeTest isOperator -> + // test if we can cast other way around + match CollectThenUndo (fun newTrace -> SolveTypeSubsumesTypeKeepAbbrevs 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)) + | _ -> ErrorD (ErrorsFromAddingSubsumptionConstraint(csenv.g, csenv.DisplayEnv, ty1, ty2, res, csenv.eContextInfo, m))) // ty1: actual // ty2: expected and private SolveTypeEqualsTypeWithReport (csenv: ConstraintSolverEnv) ndeep m trace cxsln actual expected = - TryD (fun () -> SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m trace cxsln actual expected) - (function - | LocallyAbortOperationThatFailsToResolveOverload -> CompleteD - | res -> ErrorD (ErrorFromAddingTypeEquation(csenv.g, csenv.DisplayEnv, actual, expected, res, m))) + TryD_IgnoreAbortForFailedOverloadResolution + (fun () -> SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m trace cxsln actual expected) + (fun res -> ErrorD (ErrorFromAddingTypeEquation(csenv.g, csenv.DisplayEnv, actual, expected, res, m))) and ArgsMustSubsumeOrConvert (csenv: ConstraintSolverEnv) @@ -2677,16 +2720,22 @@ and ResolveOverloading | None -> None, errors +let ResolveOverloadingForCall denv css m methodName ndeep cx callerArgCounts ad calledMethGroup permitOptArgs reqdRetTyOpt = + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv + ResolveOverloading csenv NoTrace methodName ndeep cx callerArgCounts ad calledMethGroup permitOptArgs reqdRetTyOpt /// This is used before analyzing the types of arguments in a single overload resolution let UnifyUniqueOverloading - (csenv: ConstraintSolverEnv) + denv + css + m callerArgCounts methodName ad (calledMethGroup: CalledMeth list) reqdRetTy // The expected return type, if known = + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv let m = csenv.m // See what candidates we have based on name and arity let candidates = calledMethGroup |> List.filter (fun cmeth -> cmeth.IsCandidate(m, ad)) @@ -2716,15 +2765,17 @@ let UnifyUniqueOverloading | _ -> ResultD false -let EliminateConstraintsForGeneralizedTypars csenv (trace: OptionalTrace) (generalizedTypars: Typars) = - // Remove the global constraints where this type variable appears in the support of the constraint - generalizedTypars - |> List.iter (fun tp -> +/// Remove the global constraints where these type variables appear in the support of the constraint +let EliminateConstraintsForGeneralizedTypars denv css m (trace: OptionalTrace) (generalizedTypars: Typars) = + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv + for tp in generalizedTypars do let tpn = tp.Stamp let cxst = csenv.SolverState.ExtraCxs let cxs = cxst.FindAll tpn - cxs |> List.iter (fun cx -> trace.Exec (fun () -> cxst.Remove tpn) (fun () -> (csenv.SolverState.ExtraCxs.Add (tpn, cx)))) - ) + for cx in cxs do + trace.Exec + (fun () -> cxst.Remove tpn) + (fun () -> (csenv.SolverState.ExtraCxs.Add (tpn, cx))) //------------------------------------------------------------------------- @@ -2735,7 +2786,8 @@ let EliminateConstraintsForGeneralizedTypars csenv (trace: OptionalTrace) (gener //------------------------------------------------------------------------- let AddCxTypeEqualsType contextInfo denv css m actual expected = - SolveTypeEqualsTypeWithReport (MakeConstraintSolverEnv contextInfo css m denv) 0 m NoTrace None actual expected + let csenv = MakeConstraintSolverEnv contextInfo css m denv + SolveTypeEqualsTypeWithReport csenv 0 m NoTrace None actual expected |> RaiseOperationResult let UndoIfFailed f = @@ -2770,17 +2822,23 @@ let UndoIfFailedOrWarnings f = false let AddCxTypeEqualsTypeUndoIfFailed denv css m ty1 ty2 = - UndoIfFailed (fun trace -> SolveTypeEqualsTypeKeepAbbrevs (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m (WithTrace trace) ty1 ty2) + UndoIfFailed (fun trace -> + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv + SolveTypeEqualsTypeKeepAbbrevs csenv 0 m (WithTrace trace) ty1 ty2) let AddCxTypeEqualsTypeUndoIfFailedOrWarnings denv css m ty1 ty2 = - UndoIfFailedOrWarnings (fun trace -> SolveTypeEqualsTypeKeepAbbrevs (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m (WithTrace trace) ty1 ty2) + UndoIfFailedOrWarnings (fun trace -> + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv + SolveTypeEqualsTypeKeepAbbrevs csenv 0 m (WithTrace trace) ty1 ty2) let AddCxTypeEqualsTypeMatchingOnlyUndoIfFailed denv css m ty1 ty2 = let csenv = { MakeConstraintSolverEnv ContextInfo.NoContext css m denv with MatchingOnly = true } UndoIfFailed (fun trace -> SolveTypeEqualsTypeKeepAbbrevs csenv 0 m (WithTrace trace) ty1 ty2) let AddCxTypeMustSubsumeTypeUndoIfFailed denv css m ty1 ty2 = - UndoIfFailed (fun trace -> SolveTypeSubsumesTypeKeepAbbrevs (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m (WithTrace trace) None ty1 ty2) + UndoIfFailed (fun trace -> + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv + SolveTypeSubsumesTypeKeepAbbrevs csenv 0 m (WithTrace trace) None ty1 ty2) let AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed denv css m ty1 ty2 = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv @@ -2788,64 +2846,114 @@ let AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed denv css m ty1 ty2 = UndoIfFailed (fun trace -> SolveTypeSubsumesTypeKeepAbbrevs csenv 0 m (WithTrace trace) None ty1 ty2) let AddCxTypeMustSubsumeType contextInfo denv css m trace ty1 ty2 = - SolveTypeSubsumesTypeWithReport (MakeConstraintSolverEnv contextInfo css m denv) 0 m trace None ty1 ty2 + let csenv = MakeConstraintSolverEnv contextInfo css m denv + SolveTypeSubsumesTypeWithReport csenv 0 m trace None ty1 ty2 |> RaiseOperationResult let AddCxMethodConstraint denv css m trace traitInfo = - TryD (fun () -> + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv + TryD_IgnoreAbortForFailedOverloadResolution + (fun () -> trackErrors { do! - SolveMemberConstraint (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) true false 0 m trace traitInfo + SolveMemberConstraint csenv true false 0 m trace traitInfo |> OperationResult.ignore }) - (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) + (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let AddCxTypeMustSupportNull denv css m trace ty = - TryD (fun () -> SolveTypeSupportsNull (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) - (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv + TryD_IgnoreAbortForFailedOverloadResolution + (fun () -> SolveTypeSupportsNull csenv 0 m trace ty) + (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let AddCxTypeMustSupportComparison denv css m trace ty = - TryD (fun () -> SolveTypeSupportsComparison (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) - (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv + TryD_IgnoreAbortForFailedOverloadResolution + (fun () -> SolveTypeSupportsComparison csenv 0 m trace ty) + (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let AddCxTypeMustSupportEquality denv css m trace ty = - TryD (fun () -> SolveTypeSupportsEquality (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) - (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv + TryD_IgnoreAbortForFailedOverloadResolution + (fun () -> SolveTypeSupportsEquality csenv 0 m trace ty) + (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let AddCxTypeMustSupportDefaultCtor denv css m trace ty = - TryD (fun () -> SolveTypeRequiresDefaultConstructor (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) - (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv + TryD_IgnoreAbortForFailedOverloadResolution + (fun () -> SolveTypeRequiresDefaultConstructor csenv 0 m trace ty) + (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let AddCxTypeIsReferenceType denv css m trace ty = - TryD (fun () -> SolveTypeIsReferenceType (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) - (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv + TryD_IgnoreAbortForFailedOverloadResolution + (fun () -> SolveTypeIsReferenceType csenv 0 m trace ty) + (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let AddCxTypeIsValueType denv css m trace ty = - TryD (fun () -> SolveTypeIsNonNullableValueType (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) - (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv + TryD_IgnoreAbortForFailedOverloadResolution + (fun () -> SolveTypeIsNonNullableValueType csenv 0 m trace ty) + (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let AddCxTypeIsUnmanaged denv css m trace ty = - TryD (fun () -> SolveTypeIsUnmanaged (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) - (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv + TryD_IgnoreAbortForFailedOverloadResolution + (fun () -> SolveTypeIsUnmanaged csenv 0 m trace ty) + (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let AddCxTypeIsEnum denv css m trace ty underlying = - TryD (fun () -> SolveTypeIsEnum (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty underlying) - (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv + TryD_IgnoreAbortForFailedOverloadResolution + (fun () -> SolveTypeIsEnum csenv 0 m trace ty underlying) + (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let AddCxTypeIsDelegate denv css m trace ty aty bty = - TryD (fun () -> SolveTypeIsDelegate (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty aty bty) - (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv + TryD_IgnoreAbortForFailedOverloadResolution + (fun () -> SolveTypeIsDelegate csenv 0 m trace ty aty bty) + (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) + |> RaiseOperationResult + +let AddCxTyparDefaultsTo denv css m ctxtInfo tp ridx ty = + let csenv = MakeConstraintSolverEnv ctxtInfo css m denv + TryD_IgnoreAbortForFailedOverloadResolution + (fun () -> AddConstraint csenv 0 m NoTrace tp (TyparConstraint.DefaultsTo(ridx, ty, m))) + (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult +let SolveTypeAsError denv css m ty = + let ty2 = NewErrorType () + assert((destTyparTy css.g ty2).IsFromError) + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv + SolveTypeEqualsTypeKeepAbbrevs csenv 0 m NoTrace ty ty2 |> ignore + +let ApplyTyparDefaultAtPriority denv css priority (tp: Typar) = + tp.Constraints |> List.iter (fun tpc -> + match tpc with + | TyparConstraint.DefaultsTo(priority2, ty2, m) when priority2 = priority -> + let ty1 = mkTyparTy tp + if not tp.IsSolved && not (typeEquiv css.g ty1 ty2) then + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv + TryD_IgnoreAbortForFailedOverloadResolution + (fun () -> + SolveTyparEqualsType csenv 0 m NoTrace ty1 ty2) + (fun res -> + SolveTypeAsError denv css m ty1 + ErrorD(ErrorFromApplyingDefault(css.g, denv, tp, ty2, res, m))) + |> RaiseOperationResult + | _ -> ()) + let CodegenWitnessThatTypeSupportsTraitConstraint tcVal g amap m (traitInfo: TraitConstraintInfo) argExprs = trackErrors { let css = { g = g @@ -2952,24 +3060,34 @@ let CodegenWitnessThatTypeSupportsTraitConstraint tcVal g amap m (traitInfo: Tra | Choice5Of5 () -> ResultD None } - let ChooseTyparSolutionAndSolve css denv tp = let g = css.g let amap = css.amap let max, m = ChooseTyparSolutionAndRange g amap tp let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - TryD (fun () -> SolveTyparEqualsType csenv 0 m NoTrace (mkTyparTy tp) max) - (fun err -> ErrorD(ErrorFromApplyingDefault(g, denv, tp, max, err, m))) + TryD_IgnoreAbortForFailedOverloadResolution + (fun () -> SolveTyparEqualsType csenv 0 m NoTrace (mkTyparTy tp) max) + (fun err -> ErrorD(ErrorFromApplyingDefault(g, denv, tp, max, err, m))) |> RaiseOperationResult - let CheckDeclaredTypars denv css m typars1 typars2 = - TryD (fun () -> + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv + TryD_IgnoreAbortForFailedOverloadResolution + (fun () -> CollectThenUndo (fun trace -> - SolveTypeEqualsTypeEqns (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m (WithTrace trace) None + SolveTypeEqualsTypeEqns csenv 0 m (WithTrace trace) None (List.map mkTyparTy typars1) (List.map mkTyparTy typars2))) - (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) + (fun res -> + ErrorD (ErrorFromAddingConstraint(denv, res, m))) + |> RaiseOperationResult + +let CanonicalizePartialInferenceProblem css denv m tps = + // Canonicalize constraints prior to generalization + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv + TryD_IgnoreAbortForFailedOverloadResolution + (fun () -> CanonicalizeRelevantMemberConstraints csenv 0 NoTrace tps) + (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult /// An approximation used during name resolution for intellisense to eliminate extension members which will not diff --git a/src/fsharp/ConstraintSolver.fsi b/src/fsharp/ConstraintSolver.fsi index 6aa40c6ea96..8fdaabf82cf 100644 --- a/src/fsharp/ConstraintSolver.fsi +++ b/src/fsharp/ConstraintSolver.fsi @@ -17,32 +17,32 @@ open FSharp.Compiler.MethodCalls open FSharp.Compiler.InfoReader /// Create a type variable representing the use of a "_" in F# code -val NewAnonTypar : TyparKind * range * TyparRigidity * TyparStaticReq * TyparDynamicReq -> Typar +val NewAnonTypar: TyparKind * range * TyparRigidity * TyparStaticReq * TyparDynamicReq -> Typar /// Create an inference type variable -val NewInferenceType : unit -> TType +val NewInferenceType: unit -> TType /// Create an inference type variable for the kind of a byref pointer -val NewByRefKindInferenceType : TcGlobals -> range -> TType +val NewByRefKindInferenceType: TcGlobals -> range -> TType /// Create an inference type variable representing an error condition when checking an expression -val NewErrorType : unit -> TType +val NewErrorType: unit -> TType /// Create an inference type variable representing an error condition when checking a measure -val NewErrorMeasure : unit -> Measure +val NewErrorMeasure: unit -> Measure /// Create a list of inference type variables, one for each element in the input list -val NewInferenceTypes : 'a list -> TType list +val NewInferenceTypes: 'a list -> TType list /// Given a set of formal type parameters and their constraints, make new inference type variables for /// each and ensure that the constraints on the new type variables are adjusted to refer to these. -val FreshenAndFixupTypars : range -> TyparRigidity -> Typars -> TType list -> Typars -> Typars * TyparInst * TType list +val FreshenAndFixupTypars: range -> TyparRigidity -> Typars -> TType list -> Typars -> Typars * TyparInst * TType list -val FreshenTypeInst : range -> Typars -> Typars * TyparInst * TType list +val FreshenTypeInst: range -> Typars -> Typars * TyparInst * TType list -val FreshenTypars : range -> Typars -> TType list +val FreshenTypars: range -> Typars -> TType list -val FreshenMethInfo : range -> MethInfo -> TType list +val FreshenMethInfo: range -> MethInfo -> TType list [] /// Information about the context of a type equation. @@ -114,53 +114,70 @@ type TcValF = (ValRef -> ValUseFlag -> TType list -> range -> Expr * TType) type ConstraintSolverState = static member New: TcGlobals * Import.ImportMap * InfoReader * TcValF -> ConstraintSolverState -type ConstraintSolverEnv - -val BakedInTraitConstraintNames : Set - -val MakeConstraintSolverEnv : ContextInfo -> ConstraintSolverState -> range -> DisplayEnv -> ConstraintSolverEnv +val BakedInTraitConstraintNames: Set [] type Trace type OptionalTrace = -| NoTrace -| WithTrace of Trace - -val SimplifyMeasuresInTypeScheme : TcGlobals -> bool -> Typars -> TType -> TyparConstraint list -> Typars -val SolveTyparEqualsType : ConstraintSolverEnv -> int -> range -> OptionalTrace -> TType -> TType -> OperationResult -val SolveTypeEqualsTypeKeepAbbrevs : ConstraintSolverEnv -> int -> range -> OptionalTrace -> TType -> TType -> OperationResult - -/// Canonicalize constraints prior to generalization -val CanonicalizeRelevantMemberConstraints : ConstraintSolverEnv -> int -> OptionalTrace -> Typars -> OperationResult - -val ResolveOverloading : ConstraintSolverEnv -> OptionalTrace -> string -> ndeep: int -> TraitConstraintInfo option -> int * int -> AccessorDomain -> CalledMeth list -> bool -> TType option -> CalledMeth option * OperationResult -val UnifyUniqueOverloading : ConstraintSolverEnv -> int * int -> string -> AccessorDomain -> CalledMeth list -> TType -> OperationResult -val EliminateConstraintsForGeneralizedTypars : ConstraintSolverEnv -> OptionalTrace -> Typars -> unit - -val CheckDeclaredTypars : DisplayEnv -> ConstraintSolverState -> range -> Typars -> Typars -> unit - -val AddConstraint : ConstraintSolverEnv -> int -> Range.range -> OptionalTrace -> Typar -> TyparConstraint -> OperationResult -val AddCxTypeEqualsType : ContextInfo -> DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> unit -val AddCxTypeEqualsTypeUndoIfFailed : DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> bool -val AddCxTypeEqualsTypeUndoIfFailedOrWarnings : DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> bool -val AddCxTypeEqualsTypeMatchingOnlyUndoIfFailed : DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> bool -val AddCxTypeMustSubsumeType : ContextInfo -> DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> TType -> unit -val AddCxTypeMustSubsumeTypeUndoIfFailed : DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> bool -val AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed : DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> bool -val AddCxMethodConstraint : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TraitConstraintInfo -> unit -val AddCxTypeMustSupportNull : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit -val AddCxTypeMustSupportComparison : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit -val AddCxTypeMustSupportEquality : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit -val AddCxTypeMustSupportDefaultCtor : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit -val AddCxTypeIsReferenceType : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit -val AddCxTypeIsValueType : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit -val AddCxTypeIsUnmanaged : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit -val AddCxTypeIsEnum : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> TType -> unit -val AddCxTypeIsDelegate : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> TType -> TType -> unit - -val CodegenWitnessThatTypeSupportsTraitConstraint : TcValF -> TcGlobals -> ImportMap -> range -> TraitConstraintInfo -> Expr list -> OperationResult - -val ChooseTyparSolutionAndSolve : ConstraintSolverState -> DisplayEnv -> Typar -> unit - -val IsApplicableMethApprox : TcGlobals -> ImportMap -> range -> MethInfo -> TType -> bool + | NoTrace + | WithTrace of Trace + +val SimplifyMeasuresInTypeScheme: TcGlobals -> bool -> Typars -> TType -> TyparConstraint list -> Typars + +val ResolveOverloadingForCall: DisplayEnv -> ConstraintSolverState -> range -> string -> ndeep: int -> TraitConstraintInfo option -> int * int -> AccessorDomain -> CalledMeth list -> bool -> TType option -> CalledMeth option * OperationResult + +val UnifyUniqueOverloading: DisplayEnv -> ConstraintSolverState -> range -> int * int -> string -> AccessorDomain -> CalledMeth list -> TType -> OperationResult + +/// Remove the global constraints where these type variables appear in the support of the constraint +val EliminateConstraintsForGeneralizedTypars: DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> Typars -> unit + +val CheckDeclaredTypars: DisplayEnv -> ConstraintSolverState -> range -> Typars -> Typars -> unit + +val AddCxTypeEqualsType: ContextInfo -> DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> unit + +val AddCxTypeEqualsTypeUndoIfFailed: DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> bool + +val AddCxTypeEqualsTypeUndoIfFailedOrWarnings: DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> bool + +val AddCxTypeEqualsTypeMatchingOnlyUndoIfFailed: DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> bool + +val AddCxTypeMustSubsumeType: ContextInfo -> DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> TType -> unit + +val AddCxTypeMustSubsumeTypeUndoIfFailed: DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> bool + +val AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed: DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> bool + +val AddCxMethodConstraint: DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TraitConstraintInfo -> unit + +val AddCxTypeMustSupportNull: DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit + +val AddCxTypeMustSupportComparison: DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit + +val AddCxTypeMustSupportEquality: DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit + +val AddCxTypeMustSupportDefaultCtor: DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit + +val AddCxTypeIsReferenceType: DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit + +val AddCxTypeIsValueType: DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit + +val AddCxTypeIsUnmanaged: DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit + +val AddCxTypeIsEnum: DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> TType -> unit + +val AddCxTypeIsDelegate: DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> TType -> TType -> unit + +val AddCxTyparDefaultsTo: DisplayEnv -> ConstraintSolverState -> range -> ContextInfo -> Typar -> int -> TType -> unit + +val SolveTypeAsError: DisplayEnv -> ConstraintSolverState -> range -> TType -> unit + +val ApplyTyparDefaultAtPriority: DisplayEnv -> ConstraintSolverState -> priority: int -> Typar -> unit + +val CodegenWitnessThatTypeSupportsTraitConstraint: TcValF -> TcGlobals -> ImportMap -> range -> TraitConstraintInfo -> Expr list -> OperationResult + +val ChooseTyparSolutionAndSolve: ConstraintSolverState -> DisplayEnv -> Typar -> unit + +val IsApplicableMethApprox: TcGlobals -> ImportMap -> range -> MethInfo -> TType -> bool + +val CanonicalizePartialInferenceProblem: ConstraintSolverState -> DisplayEnv -> range -> Typars -> unit \ No newline at end of file diff --git a/src/fsharp/IlxGen.fs b/src/fsharp/IlxGen.fs index bae42ad081f..412d1a62ac3 100644 --- a/src/fsharp/IlxGen.fs +++ b/src/fsharp/IlxGen.fs @@ -7754,4 +7754,3 @@ type IlxAssemblyGenerator(amap: ImportMap, tcGlobals: TcGlobals, tcVal: Constrai /// Invert the compilation of the given value and return its current dynamic value and its compiled System.Type member __.LookupGeneratedValue (ctxt, v) = LookupGeneratedValue amap ctxt ilxGenEnv v - diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs index 6609d5ad959..c8880576868 100644 --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -2284,13 +2284,6 @@ module GeneralizationHelpers = ConstraintSolver.ChooseTyparSolutionAndSolve cenv.css denv tp) generalizedTypars - let CanonicalizePartialInferenceProblem (cenv, denv, m) tps = - // Canonicalize constraints prior to generalization - let csenv = (MakeConstraintSolverEnv ContextInfo.NoContext cenv.css m denv) - TryD (fun () -> ConstraintSolver.CanonicalizeRelevantMemberConstraints csenv 0 NoTrace tps) - (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) - |> RaiseOperationResult - let ComputeAndGeneralizeGenericTypars (cenv, denv: DisplayEnv, m, @@ -2333,8 +2326,7 @@ module GeneralizationHelpers = generalizedTypars |> List.iter (SetTyparRigid cenv.g denv m) // Generalization removes constraints related to generalized type variables - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext cenv.css m denv - EliminateConstraintsForGeneralizedTypars csenv NoTrace generalizedTypars + EliminateConstraintsForGeneralizedTypars denv cenv.css m NoTrace generalizedTypars generalizedTypars @@ -4333,8 +4325,7 @@ let rec TcTyparConstraint ridx cenv newOk checkCxs occ (env: TcEnv) tpenv c = | WhereTyparDefaultsToType(tp, ty, m) -> let ty', tpenv = TcTypeAndRecover cenv newOk checkCxs occ env tpenv ty let tp', tpenv = TcTypar cenv env newOk tpenv tp - let csenv = MakeConstraintSolverEnv env.eContextInfo cenv.css m env.DisplayEnv - AddConstraint csenv 0 m NoTrace tp' (TyparConstraint.DefaultsTo(ridx, ty', m)) |> CommitOperationResult + AddCxTyparDefaultsTo env.DisplayEnv cenv.css m env.eContextInfo tp' ridx ty' tpenv | WhereTyparSubtypeOfType(tp, ty, m) -> @@ -5595,11 +5586,7 @@ and TcPatterns warnOnUpper cenv env vFlags s argTys args = assert (List.length args = List.length argTys) List.mapFold (fun s (ty, pat) -> TcPat warnOnUpper cenv env None vFlags s ty pat) s (List.zip argTys args) - -and solveTypAsError cenv denv m ty = - let ty2 = NewErrorType () - assert((destTyparTy cenv.g ty2).IsFromError) - SolveTypeEqualsTypeKeepAbbrevs (MakeConstraintSolverEnv ContextInfo.NoContext cenv.css m denv) 0 m NoTrace ty ty2 |> ignore +and solveTypAsError cenv denv m ty = ConstraintSolver.SolveTypeAsError denv cenv.css m ty and RecordNameAndTypeResolutions_IdeallyWithoutHavingOtherEffects cenv env tpenv expr = // This function is motivated by cases like @@ -6782,7 +6769,7 @@ and TcObjectExprBinding cenv (env: TcEnv) implty tpenv (absSlotInfo, bind) = | _ -> declaredTypars // Canonicalize constraints prior to generalization - GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv, denv, m) declaredTypars + ConstraintSolver.CanonicalizePartialInferenceProblem cenv.css denv m declaredTypars let freeInEnv = GeneralizationHelpers.ComputeUngeneralizableTypars env @@ -9638,7 +9625,7 @@ and TcLookupThen cenv overallTy env tpenv mObjExpr objExpr objExprTy longId dela // Canonicalize inference problem prior to '.' lookup on variable types if isTyparTy cenv.g objExprTy then - GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv, env.DisplayEnv, mExprAndLongId) (freeInTypeLeftToRight cenv.g false objExprTy) + ConstraintSolver.CanonicalizePartialInferenceProblem cenv.css env.DisplayEnv mExprAndLongId (freeInTypeLeftToRight cenv.g false objExprTy) let item, mItem, rest, afterResolution = ResolveExprDotLongIdentAndComputeRange cenv.tcSink cenv.nameResolver mExprAndLongId ad env.NameEnv objExprTy longId findFlag false let mExprAndItem = unionRanges mObjExpr mItem @@ -10089,8 +10076,7 @@ and TcMethodApplication yield makeOneCalledMeth (minfo, pinfoOpt, false) ] let uniquelyResolved = - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext cenv.css mMethExpr denv - UnifyUniqueOverloading csenv callerArgCounts methodName ad preArgumentTypeCheckingCalledMethGroup returnTy + UnifyUniqueOverloading denv cenv.css mMethExpr callerArgCounts methodName ad preArgumentTypeCheckingCalledMethGroup returnTy uniquelyResolved, preArgumentTypeCheckingCalledMethGroup @@ -10182,17 +10168,15 @@ and TcMethodApplication CalledMeth(cenv.infoReader, Some(env.NameEnv), isCheckingAttributeCall, FreshenMethInfo, mMethExpr, ad, minfo, minst, callerTyArgs, pinfoOpt, callerObjArgTys, callerArgs, usesParamArrayConversion, true, objTyOpt)) let callerArgCounts = (unnamedCurriedCallerArgs.Length, namedCurriedCallerArgs.Length) - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext cenv.css mMethExpr denv // Commit unassociated constraints prior to member overload resolution where there is ambiguity // about the possible target of the call. if not uniquelyResolved then - GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv, denv, mItem) + ConstraintSolver.CanonicalizePartialInferenceProblem cenv.css denv mItem (//freeInTypeLeftToRight cenv.g false returnTy @ (unnamedCurriedCallerArgs |> List.collectSquared (fun callerArg -> freeInTypeLeftToRight cenv.g false callerArg.Type))) - let result, errors = - ResolveOverloading csenv NoTrace methodName 0 None callerArgCounts ad postArgumentTypeCheckingCalledMethGroup true (Some returnTy) + let result, errors = ResolveOverloadingForCall denv cenv.css mMethExpr methodName 0 None callerArgCounts ad postArgumentTypeCheckingCalledMethGroup true (Some returnTy) match afterResolution, result with | AfterResolution.DoNothing, _ -> () @@ -11150,7 +11134,7 @@ and TcLetBinding cenv isUse env containerInfo declKind tpenv (synBinds, synBinds // Canonicalize constraints prior to generalization let denv = env.DisplayEnv - GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv, denv, synBindsRange) + ConstraintSolver.CanonicalizePartialInferenceProblem cenv.css denv synBindsRange (checkedBinds |> List.collect (fun tbinfo -> let (CheckedBindingInfo(_, _, _, _, flex, _, _, _, tauTy, _, _, _, _, _)) = tbinfo let (ExplicitTyparInfo(_, declaredTypars, _)) = flex @@ -12025,7 +12009,7 @@ and TcIncrementalLetRecGeneralization cenv scopem else let supportForBindings = newGeneralizableBindings |> List.collect (TcLetrecComputeSupportForBinding cenv) - GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv, denv, scopem) supportForBindings + ConstraintSolver.CanonicalizePartialInferenceProblem cenv.css denv scopem supportForBindings let generalizedTyparsL = newGeneralizableBindings |> List.map (TcLetrecComputeAndGeneralizeGenericTyparsForBinding cenv denv freeInEnv) @@ -17530,27 +17514,15 @@ let ApplyDefaults cenv g denvAtEnd m mexpr extraAttribs = try let unsolved = FSharp.Compiler.FindUnsolved.UnsolvedTyparsOfModuleDef g cenv.amap denvAtEnd (mexpr, extraAttribs) - GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv, denvAtEnd, m) unsolved + ConstraintSolver.CanonicalizePartialInferenceProblem cenv.css denvAtEnd m unsolved - let applyDefaults priority = - unsolved |> List.iter (fun tp -> + // The priority order comes from the order of declaration of the defaults in FSharp.Core. + for priority = 10 downto 0 do + unsolved |> List.iter (fun tp -> if not tp.IsSolved then // Apply the first default. If we're defaulting one type variable to another then // the defaults will be propagated to the new type variable. - tp.Constraints |> List.iter (fun tpc -> - match tpc with - | TyparConstraint.DefaultsTo(priority2, ty2, m) when priority2 = priority -> - let ty1 = mkTyparTy tp - if not tp.IsSolved && not (typeEquiv cenv.g ty1 ty2) then - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext cenv.css m denvAtEnd - TryD (fun () -> ConstraintSolver.SolveTyparEqualsType csenv 0 m NoTrace ty1 ty2) - (fun e -> solveTypAsError cenv denvAtEnd m ty1 - ErrorD(ErrorFromApplyingDefault(g, denvAtEnd, tp, ty2, e, m))) - |> RaiseOperationResult - | _ -> ())) - - for priority = 10 downto 0 do - applyDefaults priority + ConstraintSolver.ApplyTyparDefaultAtPriority denvAtEnd cenv.css priority tp) // OK, now apply defaults for any unsolved HeadTypeStaticReq unsolved |> List.iter (fun tp -> diff --git a/tests/fsharp/tests.fs b/tests/fsharp/tests.fs index 2247c318f6a..e88033a5a2a 100644 --- a/tests/fsharp/tests.fs +++ b/tests/fsharp/tests.fs @@ -2660,6 +2660,18 @@ module TypecheckTests = [] let ``type check neg115`` () = singleNegTest (testConfig "typecheck/sigs") "neg115" + [] + let ``type check neg116`` () = singleNegTest (testConfig "typecheck/sigs") "neg116" + + [] + let ``type check neg117`` () = singleNegTest (testConfig "typecheck/sigs") "neg117" + + [] + let ``type check neg118`` () = singleNegTest (testConfig "typecheck/sigs") "neg118" + + [] + let ``type check neg119`` () = singleNegTest (testConfig "typecheck/sigs") "neg119" + [] let ``type check neg_anon_1`` () = singleNegTest (testConfig "typecheck/sigs") "neg_anon_1" diff --git a/tests/fsharp/typecheck/sigs/neg116.bsl b/tests/fsharp/typecheck/sigs/neg116.bsl new file mode 100644 index 00000000000..8bd4930a304 --- /dev/null +++ b/tests/fsharp/typecheck/sigs/neg116.bsl @@ -0,0 +1,12 @@ + +neg116.fs(10,44,10,45): typecheck error FS0043: No overloads match for method 'op_Multiply'. The available overloads are shown below. +neg116.fs(10,44,10,45): typecheck error FS0043: Possible overload: 'static member Polynomial.( * ) : s:Complex * p:Polynomial -> Polynomial'. Type constraint mismatch. The type + 'float' +is not compatible with type + 'Complex' +. +neg116.fs(10,44,10,45): typecheck error FS0043: Possible overload: 'static member Polynomial.( * ) : s:decimal * p:Polynomial -> Polynomial'. Type constraint mismatch. The type + 'float' +is not compatible with type + 'decimal' +. diff --git a/tests/fsharp/typecheck/sigs/neg116.fs b/tests/fsharp/typecheck/sigs/neg116.fs new file mode 100644 index 00000000000..fff55619afe --- /dev/null +++ b/tests/fsharp/typecheck/sigs/neg116.fs @@ -0,0 +1,10 @@ +module Neg116 + +type Complex = unit + +type Polynomial () = + static member (*) (s: decimal, p: Polynomial) : Polynomial = failwith "" + static member (*) (s: Complex, p: Polynomial) : Polynomial = failwith "" + +module Foo = + let test t (p: Polynomial) = (1.0 - t) * p diff --git a/tests/fsharp/typecheck/sigs/neg117.bsl b/tests/fsharp/typecheck/sigs/neg117.bsl new file mode 100644 index 00000000000..49c2665190b --- /dev/null +++ b/tests/fsharp/typecheck/sigs/neg117.bsl @@ -0,0 +1,12 @@ + +neg117.fs(79,18,79,59): ilxgen error FS0041: No overloads match for method 'Transform'. The available overloads are shown below. +neg117.fs(79,18,79,59): ilxgen error FS0041: Possible overload: 'static member Neg117.Superpower.Transformer.Transform : ^r * Neg117.TargetA.TargetA * Neg117.Superpower.Transformer -> (Neg117.TargetA.TransformerKind -> ^r) when (Neg117.TargetA.TargetA or ^r) : (static member Transform : ^r * Neg117.TargetA.TargetA -> Neg117.TargetA.TransformerKind -> ^r)'. Type constraint mismatch. The type + 'Neg117.TargetA.M1 Microsoft.FSharp.Core.[]' +is not compatible with type + ''a' +. +neg117.fs(79,18,79,59): ilxgen error FS0041: Possible overload: 'static member Neg117.Superpower.Transformer.Transform : ^f * Neg117.TargetB.TargetB * Neg117.Superpower.Transformer -> (Neg117.TargetB.TransformerKind -> ^f) when (Neg117.TargetB.TargetB or ^f) : (static member Transform : ^f * Neg117.TargetB.TargetB -> Neg117.TargetB.TransformerKind -> ^f)'. Type constraint mismatch. The type + 'Neg117.TargetA.M1 Microsoft.FSharp.Core.[]' +is not compatible with type + ''a' +. diff --git a/tests/fsharp/typecheck/sigs/neg117.fs b/tests/fsharp/typecheck/sigs/neg117.fs new file mode 100644 index 00000000000..a5de1db5a25 --- /dev/null +++ b/tests/fsharp/typecheck/sigs/neg117.fs @@ -0,0 +1,82 @@ +module Neg117 + +#nowarn "64" // This construct causes code to be less generic than indicated by the type annotations. + +module TargetA = + + [] + type TransformerKind = + | A + | B + + type M1 = int + + type M2 = float + + type Target() = + + member __.TransformM1 (kind: TransformerKind) : M1[] option = [| 0 |] |> Some + member __.TransformM2 (kind: TransformerKind) : M2[] option = [| 1. |] |> Some + + type TargetA = + + static member instance : Target option = None + + static member inline Transform(_: ^r, _: TargetA) = fun (kind:TransformerKind) -> TargetA.instance.Value.TransformM1 kind : ^r + static member inline Transform(_: ^r, _: TargetA) = fun (kind:TransformerKind) -> TargetA.instance.Value.TransformM2 kind : ^r + + static member inline Transform(kind: TransformerKind) = + let inline call2(a:^a, b:^b) = ((^a or ^b) : (static member Transform: _ * _ -> _) b, a) + let inline call (a: 'a) = fun (x: 'x) -> call2(a, Unchecked.defaultof<'r>) x : 'r + call Unchecked.defaultof kind + + let inline Transform kind = TargetA.Transform kind + +module TargetB = + [] + type TransformerKind = + | C + | D + + type M1 = | M1 + + type M2 = | M2 + + type Target() = + + member __.TransformM1 (kind: TransformerKind) = [| M1 |] |> Some + member __.TransformM2 (kind: TransformerKind) = [| M2 |] |> Some + + type TargetB = + + static member instance : Target option = None + + static member inline Transform(_: ^r, _: TargetB) = fun (kind:TransformerKind) -> TargetB.instance.Value.TransformM1 kind : ^r + static member inline Transform(_: ^r, _: TargetB) = fun (kind:TransformerKind) -> TargetB.instance.Value.TransformM2 kind : ^r + + static member inline Transform(kind: TransformerKind) = + let inline call2(a:^a, b:^b) = ((^a or ^b) : (static member Transform: _ * _ -> _) b, a) + let inline call (a: 'a) = fun (x: 'x) -> call2(a, Unchecked.defaultof<'r>) x : 'r + call Unchecked.defaultof kind + let inline Transform kind = TargetB.Transform kind + +module Superpower = + + type Transformer = + + static member inline Transform(_: ^f, _: TargetB.TargetB, _: Transformer) = + fun x -> TargetB.Transform x : ^f + + static member inline Transform(_: ^r, _: TargetA.TargetA, _: Transformer) = + fun x -> TargetA.Transform x : ^r + + static member inline YeahTransform kind = + let inline call2(a:^a, b:^b, c: ^c) = ((^a or ^b or ^c) : (static member Transform: _ * _ * _ -> _) c, b, a) + let inline call (a: 'a) = fun (x: 'x) -> call2(a, Unchecked.defaultof<_>, Unchecked.defaultof<'r>) x : 'r + call Unchecked.defaultof kind + +module Examples = + let a kind = Superpower.Transformer.YeahTransform kind : TargetA.M1[] + let b = Superpower.Transformer.YeahTransform TargetA.TransformerKind.A : TargetA.M2[] option + let c = Superpower.Transformer.YeahTransform TargetB.TransformerKind.C : TargetB.M1[] option + let d = Superpower.Transformer.YeahTransform TargetA.TransformerKind.A : TargetA.M1[] option diff --git a/tests/fsharp/typecheck/sigs/neg118.bsl b/tests/fsharp/typecheck/sigs/neg118.bsl new file mode 100644 index 00000000000..7b70803cc6c --- /dev/null +++ b/tests/fsharp/typecheck/sigs/neg118.bsl @@ -0,0 +1,12 @@ + +neg118.fs(18,21,18,37): typecheck error FS0003: This value is not a function and cannot be applied. + +neg118.fs(19,21,19,37): typecheck error FS0003: This value is not a function and cannot be applied. + +neg118.fs(20,21,20,39): typecheck error FS0003: This value is not a function and cannot be applied. + +neg118.fs(21,21,21,41): typecheck error FS0003: This value is not a function and cannot be applied. + +neg118.fs(22,21,22,39): typecheck error FS0003: This value is not a function and cannot be applied. + +neg118.fs(25,51,25,67): typecheck error FS0003: This value is not a function and cannot be applied. diff --git a/tests/fsharp/typecheck/sigs/neg118.fs b/tests/fsharp/typecheck/sigs/neg118.fs new file mode 100644 index 00000000000..fb951db31c4 --- /dev/null +++ b/tests/fsharp/typecheck/sigs/neg118.fs @@ -0,0 +1,28 @@ +module Neg118 + +// This is the example provided by Gustavo Leon in https://github.com/dotnet/fsharp/pull/4173 +// The code is potentially valid and, if that PR had been accepted, would compile. +// It's being added as a negative test case to capture the fact that it currently +// fails to compile. + +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) + () + + diff --git a/tests/fsharp/typecheck/sigs/neg119.bsl b/tests/fsharp/typecheck/sigs/neg119.bsl new file mode 100644 index 00000000000..9f13a88643a --- /dev/null +++ b/tests/fsharp/typecheck/sigs/neg119.bsl @@ -0,0 +1,22 @@ + +neg119.fs(40,20,40,22): typecheck error FS0071: Type constraint mismatch when applying the default type 'obj' for a type inference variable. No overloads match for method 'Return'. The available overloads are shown below. Consider adding further type constraints +neg119.fs(40,20,40,22): typecheck error FS0071: Possible overload: 'static member Applicatives.Ap.Return : ('r -> 'a) * Ap:Applicatives.Ap -> (('a -> 'r -> 'a2) -> 'a3 -> 'a -> 'r -> 'a2)'. Type constraint mismatch. The type + 'obj' +is not compatible with type + ''a -> 'b' +. +neg119.fs(40,20,40,22): typecheck error FS0071: Possible overload: 'static member Applicatives.Ap.Return : System.Tuple<'a> * Ap:Applicatives.Ap -> ('a -> System.Tuple<'a>)'. Type constraint mismatch. The type + 'obj' +is not compatible with type + 'System.Tuple<'a>' +. +neg119.fs(40,20,40,22): typecheck error FS0071: Possible overload: 'static member Applicatives.Ap.Return : seq<'a> * Ap:Applicatives.Ap -> ('a -> seq<'a>)'. Type constraint mismatch. The type + 'obj' +is not compatible with type + 'seq<'a>' +. +neg119.fs(40,20,40,22): typecheck error FS0071: Possible overload: 'static member Applicatives.Ap.Return : r: ^R * obj -> ('a1 -> ^R) when ^R : (static member Return : 'a1 -> ^R)'. Type constraint mismatch. The type + 'obj' +is not compatible with type + ''a' +. diff --git a/tests/fsharp/typecheck/sigs/neg119.fs b/tests/fsharp/typecheck/sigs/neg119.fs new file mode 100644 index 00000000000..46d64d49395 --- /dev/null +++ b/tests/fsharp/typecheck/sigs/neg119.fs @@ -0,0 +1,40 @@ +module Neg119 + +// This is an example provided by Gustavo Leon in https://github.com/dotnet/fsharp/pull/4173 +// The code is potentially valid and, if that PR had been accepted, would compile. +// It's being added as a negative test case to capture the fact that it currently +// fails to compile. + +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