From 81c0b7d81a2398362be8ac56c458e7ce589a07e6 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Mon, 20 Jan 2020 17:47:33 +0000 Subject: [PATCH 1/6] fix 5580 and better encapsulate constraint solver --- src/fsharp/ConstraintSolver.fs | 212 ++++++++++++++++++++----- src/fsharp/ConstraintSolver.fsi | 127 ++++++++------- src/fsharp/TypeChecker.fs | 58 ++----- tests/fsharp/tests.fs | 6 + 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 ++++++++++ 8 files changed, 381 insertions(+), 138 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 diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index 0360d253dd1..1bc72707f67 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -429,6 +429,34 @@ let ShowAccessDomain ad = exception NonRigidTypar of displayEnv: DisplayEnv * string option * range * TType * TType * range +/// Signal that there is still an unresolved overload in the constraint problem. Leave the +/// unresolved overload constraint in the tree and skip any further process related to the +/// overall constraint being added. +/// +/// NOTE: This local-abort is a mistake which has crept into F# type inference, +/// and its status is currently under review, though we have to be very careful before changing +/// anything. +/// +/// Here is the history (as of 20 Jan 2020): +/// 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 VS2015. +/// +/// 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 addition of the local abort when an SRTP method overload constraint has not +/// been resolved is sound w.r.t. the method overload constraint itself, because that constraint +/// will be subject to further processing at a later point. +/// +/// It appears possible, however, that the local abort may, however, result in the skipping +/// other processing associated with the assertion of an overall constraint (e.g. the +/// processing related to each element of a tuple. +/// + exception LocallyAbortOperationThatFailsToResolveOverload exception LocallyAbortOperationThatLosesAbbrevs @@ -929,8 +957,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 +1088,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 +1481,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 -> @@ -2677,16 +2709,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 +2754,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 +2775,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 +2811,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 +2835,135 @@ 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 () -> trackErrors { + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv 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))) + (function + | LocallyAbortOperationThatFailsToResolveOverload -> CompleteD + | 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))) + TryD (fun () -> + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv + SolveTypeSupportsNull csenv 0 m trace ty) + (function + | LocallyAbortOperationThatFailsToResolveOverload -> CompleteD + | 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))) + TryD (fun () -> + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv + SolveTypeSupportsComparison csenv 0 m trace ty) + (function + | LocallyAbortOperationThatFailsToResolveOverload -> CompleteD + | 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))) + TryD (fun () -> + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv + SolveTypeSupportsEquality csenv 0 m trace ty) + (function + | LocallyAbortOperationThatFailsToResolveOverload -> CompleteD + | 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))) + TryD (fun () -> + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv + SolveTypeRequiresDefaultConstructor csenv 0 m trace ty) + (function + | LocallyAbortOperationThatFailsToResolveOverload -> CompleteD + | 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))) + TryD (fun () -> + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv + SolveTypeIsReferenceType csenv 0 m trace ty) + (function + | LocallyAbortOperationThatFailsToResolveOverload -> CompleteD + | 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))) + TryD (fun () -> + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv + SolveTypeIsNonNullableValueType csenv 0 m trace ty) + (function + | LocallyAbortOperationThatFailsToResolveOverload -> CompleteD + | 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))) + TryD (fun () -> + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv + SolveTypeIsUnmanaged csenv 0 m trace ty) + (function + | LocallyAbortOperationThatFailsToResolveOverload -> CompleteD + | 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))) + TryD (fun () -> + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv + SolveTypeIsEnum csenv 0 m trace ty underlying) + (function + | LocallyAbortOperationThatFailsToResolveOverload -> CompleteD + | 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))) + TryD (fun () -> + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv + SolveTypeIsDelegate csenv 0 m trace ty aty bty) + (function + | LocallyAbortOperationThatFailsToResolveOverload -> CompleteD + | res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult +let AddCxTyparDefaultsTo denv css m ctxtInfo tp ridx ty = + TryD (fun () -> + let csenv = MakeConstraintSolverEnv ctxtInfo css m denv + AddConstraint csenv 0 m NoTrace tp (TyparConstraint.DefaultsTo(ridx, ty, m))) + (function + | LocallyAbortOperationThatFailsToResolveOverload -> CompleteD + | 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 (fun () -> SolveTyparEqualsType csenv 0 m NoTrace ty1 ty2) + (function + | LocallyAbortOperationThatFailsToResolveOverload -> CompleteD + | 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 @@ -2959,17 +3077,31 @@ let ChooseTyparSolutionAndSolve css denv tp = 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))) + (function + | LocallyAbortOperationThatFailsToResolveOverload -> CompleteD + | err -> ErrorD(ErrorFromApplyingDefault(g, denv, tp, max, err, m))) |> RaiseOperationResult let CheckDeclaredTypars denv css m typars1 typars2 = TryD (fun () -> CollectThenUndo (fun trace -> - SolveTypeEqualsTypeEqns (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m (WithTrace trace) None + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv + SolveTypeEqualsTypeEqns csenv 0 m (WithTrace trace) None (List.map mkTyparTy typars1) (List.map mkTyparTy typars2))) - (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) + (function + | LocallyAbortOperationThatFailsToResolveOverload -> CompleteD + | 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 (fun () -> CanonicalizeRelevantMemberConstraints csenv 0 NoTrace tps) + (function + | LocallyAbortOperationThatFailsToResolveOverload -> CompleteD + | 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/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..74481a0dde3 100644 --- a/tests/fsharp/tests.fs +++ b/tests/fsharp/tests.fs @@ -2660,6 +2660,12 @@ 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 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..26ce2f9ca1d --- /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 Neg177.Superpower.Transformer.Transform : ^r * Neg177.TargetA.TargetA * Neg177.Superpower.Transformer -> (Neg177.TargetA.TransformerKind -> ^r) when (Neg177.TargetA.TargetA or ^r) : (static member Transform : ^r * Neg177.TargetA.TargetA -> Neg177.TargetA.TransformerKind -> ^r)'. Type constraint mismatch. The type + 'Neg177.TargetA.M1 Microsoft.FSharp.Core.[]' +is not compatible with type + ''a' +. +neg117.fs(79,18,79,59): ilxgen error FS0041: Possible overload: 'static member Neg177.Superpower.Transformer.Transform : ^f * Neg177.TargetB.TargetB * Neg177.Superpower.Transformer -> (Neg177.TargetB.TransformerKind -> ^f) when (Neg177.TargetB.TargetB or ^f) : (static member Transform : ^f * Neg177.TargetB.TargetB -> Neg177.TargetB.TransformerKind -> ^f)'. Type constraint mismatch. The type + 'Neg177.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..ddc8f2787a4 --- /dev/null +++ b/tests/fsharp/typecheck/sigs/neg117.fs @@ -0,0 +1,82 @@ +module Neg177 + +#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 From e3575cdc3f10cc3456142754a380abf108ec01ce Mon Sep 17 00:00:00 2001 From: Don Syme Date: Mon, 20 Jan 2020 18:05:18 +0000 Subject: [PATCH 2/6] fix 5580 and better encapsulate constraint solver --- src/fsharp/ConstraintSolver.fs | 47 +++++++++++++++++----------------- 1 file changed, 23 insertions(+), 24 deletions(-) diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index 1bc72707f67..2c59a38d73d 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -433,30 +433,29 @@ exception NonRigidTypar of displayEnv: DisplayEnv * string option * range * TTyp /// unresolved overload constraint in the tree and skip any further process related to the /// overall constraint being added. /// -/// NOTE: This local-abort is a mistake which has crept into F# type inference, -/// and its status is currently under review, though we have to be very careful before changing -/// anything. -/// -/// Here is the history (as of 20 Jan 2020): -/// 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 VS2015. -/// -/// 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 addition of the local abort when an SRTP method overload constraint has not -/// been resolved is sound w.r.t. the method overload constraint itself, because that constraint -/// will be subject to further processing at a later point. -/// -/// It appears possible, however, that the local abort may, however, result in the skipping -/// other processing associated with the assertion of an overall constraint (e.g. the -/// processing related to each element of a tuple. -/// - +// NOTE: This local-abort is a mistake which has crept into F# type inference, +// and its status is currently under review, though we have to be very careful before changing +// anything. +// +// Here is the history (as of 20 Jan 2020): +// 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 VS2015. +// +// 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 addition of the local abort when an SRTP method overload constraint has not +// been resolved is sound w.r.t. the method overload constraint itself, because that constraint +// will be subject to further processing at a later point. +// +// It appears possible, however, that the local abort may, however, result in the skipping +// other processing associated with the assertion of an overall constraint (e.g. the +// processing related to each element of a tuple. +// exception LocallyAbortOperationThatFailsToResolveOverload exception LocallyAbortOperationThatLosesAbbrevs From 9da7765cd8cce5d207f51e2357823a422df4c938 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Mon, 20 Jan 2020 18:22:08 +0000 Subject: [PATCH 3/6] fix 5580 and better encapsulate constraint solver --- src/fsharp/ConstraintSolver.fs | 209 +++++++++++++++------------------ 1 file changed, 93 insertions(+), 116 deletions(-) diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index 2c59a38d73d..59dd25a1d58 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -429,15 +429,15 @@ let ShowAccessDomain ad = exception NonRigidTypar of displayEnv: DisplayEnv * string option * range * TType * TType * range -/// Signal that there is still an unresolved overload in the constraint problem. Leave the -/// unresolved overload constraint in the tree and skip any further process related to the -/// overall constraint being added. +/// 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: This local-abort is a mistake which has crept into F# type inference, -// and its status is currently under review, though we have to be very careful before changing -// anything. +// 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 (as of 20 Jan 2020): +// 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 VS2015. // @@ -448,16 +448,20 @@ exception NonRigidTypar of displayEnv: DisplayEnv * string option * range * TTyp // change, and the revert was abandoned before release in https://github.com/dotnet/fsharp/pull/4348 // // Comments on soundness: -// The addition of the local abort when an SRTP method overload constraint has not -// been resolved is sound w.r.t. the method overload constraint itself, because that constraint +// The use of the abort is normally sound because the SRTP constraint // will be subject to further processing at a later point. // -// It appears possible, however, that the local abort may, however, result in the skipping -// other processing associated with the assertion of an overall constraint (e.g. the -// processing related to each element of a tuple. -// -exception LocallyAbortOperationThatFailsToResolveOverload +// 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 @@ -1528,7 +1532,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 } @@ -2214,25 +2218,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) @@ -2839,106 +2841,85 @@ let AddCxTypeMustSubsumeType contextInfo denv css m trace ty1 ty2 = |> RaiseOperationResult let AddCxMethodConstraint denv css m trace traitInfo = - TryD (fun () -> + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv + TryD_IgnoreAbortForFailedOverloadResolution + (fun () -> trackErrors { - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv do! SolveMemberConstraint csenv true false 0 m trace traitInfo |> OperationResult.ignore }) - (function - | LocallyAbortOperationThatFailsToResolveOverload -> CompleteD - | res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) + (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let AddCxTypeMustSupportNull denv css m trace ty = - TryD (fun () -> - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - SolveTypeSupportsNull csenv 0 m trace ty) - (function - | LocallyAbortOperationThatFailsToResolveOverload -> CompleteD - | 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 () -> - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - SolveTypeSupportsComparison csenv 0 m trace ty) - (function - | LocallyAbortOperationThatFailsToResolveOverload -> CompleteD - | 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 () -> - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - SolveTypeSupportsEquality csenv 0 m trace ty) - (function - | LocallyAbortOperationThatFailsToResolveOverload -> CompleteD - | 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 () -> - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - SolveTypeRequiresDefaultConstructor csenv 0 m trace ty) - (function - | LocallyAbortOperationThatFailsToResolveOverload -> CompleteD - | 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 () -> - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - SolveTypeIsReferenceType csenv 0 m trace ty) - (function - | LocallyAbortOperationThatFailsToResolveOverload -> CompleteD - | 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 () -> - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - SolveTypeIsNonNullableValueType csenv 0 m trace ty) - (function - | LocallyAbortOperationThatFailsToResolveOverload -> CompleteD - | 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 () -> - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - SolveTypeIsUnmanaged csenv 0 m trace ty) - (function - | LocallyAbortOperationThatFailsToResolveOverload -> CompleteD - | 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 () -> - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - SolveTypeIsEnum csenv 0 m trace ty underlying) - (function - | LocallyAbortOperationThatFailsToResolveOverload -> CompleteD - | 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 () -> - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - SolveTypeIsDelegate csenv 0 m trace ty aty bty) - (function - | LocallyAbortOperationThatFailsToResolveOverload -> CompleteD - | 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 = - TryD (fun () -> - let csenv = MakeConstraintSolverEnv ctxtInfo css m denv - AddConstraint csenv 0 m NoTrace tp (TyparConstraint.DefaultsTo(ridx, ty, m))) - (function - | LocallyAbortOperationThatFailsToResolveOverload -> CompleteD - | res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) + 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 = @@ -2954,12 +2935,12 @@ let ApplyTyparDefaultAtPriority denv css priority (tp: Typar) = let ty1 = mkTyparTy tp if not tp.IsSolved && not (typeEquiv css.g ty1 ty2) then let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - TryD (fun () -> SolveTyparEqualsType csenv 0 m NoTrace ty1 ty2) - (function - | LocallyAbortOperationThatFailsToResolveOverload -> CompleteD - | res -> - SolveTypeAsError denv css m ty1 - ErrorD(ErrorFromApplyingDefault(css.g, denv, tp, ty2, res, m))) + 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 | _ -> ()) @@ -3069,38 +3050,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) - (function - | LocallyAbortOperationThatFailsToResolveOverload -> CompleteD - | 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 -> - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv SolveTypeEqualsTypeEqns csenv 0 m (WithTrace trace) None (List.map mkTyparTy typars1) (List.map mkTyparTy typars2))) - (function - | LocallyAbortOperationThatFailsToResolveOverload -> CompleteD - | 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 (fun () -> CanonicalizeRelevantMemberConstraints csenv 0 NoTrace tps) - (function - | LocallyAbortOperationThatFailsToResolveOverload -> CompleteD - | res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) + 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 From 20a8d697e34e7fdfac77d552c5ae294a0e00873e Mon Sep 17 00:00:00 2001 From: Don Syme Date: Mon, 20 Jan 2020 18:27:00 +0000 Subject: [PATCH 4/6] fix 5580 and better encapsulate constraint solver --- src/fsharp/ConstraintSolver.fs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index 59dd25a1d58..96135a22380 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 From a553fb9621187e7ade475b9557a68e3494cf7861 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Tue, 21 Jan 2020 21:29:27 +0000 Subject: [PATCH 5/6] add new tests --- src/fsharp/ConstraintSolver.fs | 2 +- tests/fsharp/tests.fs | 6 ++++ tests/fsharp/typecheck/sigs/neg117.bsl | 8 +++--- tests/fsharp/typecheck/sigs/neg117.fs | 2 +- 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 ++++++++++++++++++++++++++ 8 files changed, 114 insertions(+), 6 deletions(-) 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 96135a22380..59b10f7be71 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -449,7 +449,7 @@ exception NonRigidTypar of displayEnv: DisplayEnv * string option * range * TTyp // // 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 VS2015. +// 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. diff --git a/tests/fsharp/tests.fs b/tests/fsharp/tests.fs index 74481a0dde3..e88033a5a2a 100644 --- a/tests/fsharp/tests.fs +++ b/tests/fsharp/tests.fs @@ -2666,6 +2666,12 @@ module TypecheckTests = [] 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/neg117.bsl b/tests/fsharp/typecheck/sigs/neg117.bsl index 26ce2f9ca1d..49c2665190b 100644 --- a/tests/fsharp/typecheck/sigs/neg117.bsl +++ b/tests/fsharp/typecheck/sigs/neg117.bsl @@ -1,12 +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 Neg177.Superpower.Transformer.Transform : ^r * Neg177.TargetA.TargetA * Neg177.Superpower.Transformer -> (Neg177.TargetA.TransformerKind -> ^r) when (Neg177.TargetA.TargetA or ^r) : (static member Transform : ^r * Neg177.TargetA.TargetA -> Neg177.TargetA.TransformerKind -> ^r)'. Type constraint mismatch. The type - 'Neg177.TargetA.M1 Microsoft.FSharp.Core.[]' +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 Neg177.Superpower.Transformer.Transform : ^f * Neg177.TargetB.TargetB * Neg177.Superpower.Transformer -> (Neg177.TargetB.TransformerKind -> ^f) when (Neg177.TargetB.TargetB or ^f) : (static member Transform : ^f * Neg177.TargetB.TargetB -> Neg177.TargetB.TransformerKind -> ^f)'. Type constraint mismatch. The type - 'Neg177.TargetA.M1 Microsoft.FSharp.Core.[]' +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 index ddc8f2787a4..a5de1db5a25 100644 --- a/tests/fsharp/typecheck/sigs/neg117.fs +++ b/tests/fsharp/typecheck/sigs/neg117.fs @@ -1,4 +1,4 @@ -module Neg177 +module Neg117 #nowarn "64" // This construct causes code to be less generic than indicated by the type annotations. 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 From 5f141d45c53adeccddf327d317833554d629d133 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Wed, 22 Jan 2020 13:12:15 +0000 Subject: [PATCH 6/6] nudge CI --- src/fsharp/IlxGen.fs | 1 - 1 file changed, 1 deletion(-) 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 -