diff --git a/src/fsharp/CompileOps.fs b/src/fsharp/CompileOps.fs index 0d8ea5a3fa..7eeff03e7a 100755 --- a/src/fsharp/CompileOps.fs +++ b/src/fsharp/CompileOps.fs @@ -200,7 +200,7 @@ let GetRangeOfError(err:PhasedError) = | NonVirtualAugmentationOnNullValuedType(m) | NonRigidTypar(_,_,_,_,_,m) | ConstraintSolverTupleDiffLengths(_,_,_,m,_) - | ConstraintSolverInfiniteTypes(_,_,_,m,_) + | ConstraintSolverInfiniteTypes(_,_,_,_,m,_) | ConstraintSolverMissingConstraint(_,_,_,m,_) | ConstraintSolverTypesNotInEqualityRelation(_,_,_,m,_) | ConstraintSolverError(_,m,_) @@ -602,10 +602,18 @@ let OutputPhasedErrorR (os:System.Text.StringBuilder) (err:PhasedError) = os.Append(ConstraintSolverTupleDiffLengthsE().Format tl1.Length tl2.Length) |> ignore (if m.StartLine <> m2.StartLine then os.Append(SeeAlsoE().Format (stringOfRange m)) |> ignore) - | ConstraintSolverInfiniteTypes(denv,t1,t2,m,m2) -> - // REVIEW: consider if we need to show _cxs (the type parameter constrants) + | ConstraintSolverInfiniteTypes(contextInfo,denv,t1,t2,m,m2) -> + // REVIEW: consider if we need to show _cxs (the type parameter constraints) let t1, t2, _cxs = NicePrint.minimalStringsOfTwoTypes denv t1 t2 os.Append(ConstraintSolverInfiniteTypesE().Format t1 t2) |> ignore + + match contextInfo with + | ContextInfo.ReturnInComputationExpression -> + os.Append(" " + FSComp.SR.returnUsedInsteadOfReturnBang()) |> ignore + | ContextInfo.YieldInComputationExpression -> + os.Append(" " + FSComp.SR.yieldUsedInsteadOfYieldBang()) |> ignore + | _ -> () + (if m.StartLine <> m2.StartLine then os.Append(SeeAlsoE().Format (stringOfRange m)) |> ignore ) | ConstraintSolverMissingConstraint(denv,tpr,tpc,m,m2) -> diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index 728ed9de68..cfe592e1c2 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -128,13 +128,17 @@ type ContextInfo = | RecordFields /// The type equation comes from the verification of a tuple in record fields. | TupleInRecordFields +/// The type equation comes from a return in a computation expression. +| ReturnInComputationExpression +/// The type equation comes from a yield in a computation expression. +| YieldInComputationExpression /// The type equation comes from a runtime type test. | RuntimeTypeTest of bool /// The type equation comes from an downcast where a upcast could be used. | DowncastUsedInsteadOfUpcast of bool exception ConstraintSolverTupleDiffLengths of DisplayEnv * TType list * TType list * range * range -exception ConstraintSolverInfiniteTypes of DisplayEnv * TType * TType * range * range +exception ConstraintSolverInfiniteTypes of ContextInfo * DisplayEnv * TType * TType * range * range exception ConstraintSolverTypesNotInEqualityRelation of DisplayEnv * TType * TType * range * range exception ConstraintSolverTypesNotInSubsumptionRelation of DisplayEnv * TType * TType * range * range exception ConstraintSolverMissingConstraint of DisplayEnv * Tast.Typar * Tast.TyparConstraint * range * range @@ -177,6 +181,7 @@ type ConstraintSolverState = type ConstraintSolverEnv = { SolverState: ConstraintSolverState; + eContextInfo: ContextInfo MatchingOnly : bool m: range; EquivEnv: TypeEquivEnv; @@ -186,9 +191,10 @@ type ConstraintSolverEnv = member csenv.g = csenv.SolverState.g member csenv.amap = csenv.SolverState.amap -let MakeConstraintSolverEnv css m denv = +let MakeConstraintSolverEnv contextInfo css m denv = { SolverState=css; m=m; + eContextInfo = contextInfo // Indicates that when unifiying ty1 = ty2, only type variables in ty1 may be solved MatchingOnly=false; EquivEnv=TypeEquivEnv.Empty; @@ -655,8 +661,8 @@ let rec SolveTyparEqualsTyp (csenv:ConstraintSolverEnv) ndeep m2 trace ty1 ty = // The types may still be equivalent due to abbreviations, which we are trying not to eliminate if typeEquiv csenv.g ty1 ty then CompleteD else - // The famous 'occursCheck' check to catch things like 'a = list<'a> - if occursCheck csenv.g r ty then ErrorD (ConstraintSolverInfiniteTypes(denv,ty1,ty,m,m2)) else + // The famous 'occursCheck' check to catch "infinite types" like 'a = list<'a> - see also https://github.com/Microsoft/visualfsharp/issues/1170 + if occursCheck csenv.g r ty then ErrorD (ConstraintSolverInfiniteTypes(csenv.eContextInfo,denv,ty1,ty,m,m2)) else // Note: warn _and_ continue! CheckWarnIfRigid csenv ty1 r ty ++ (fun () -> @@ -1926,16 +1932,16 @@ and private DefinitelyEquiv (csenv:ConstraintSolverEnv) isConstraint calledArg ( // Assert a subtype constraint, and wrap an ErrorsFromAddingSubsumptionConstraint error around any failure // to allow us to report the outer types involved in the constraint -and private SolveTypSubsumesTypWithReport contextInfo (csenv:ConstraintSolverEnv) ndeep m trace ty1 ty2 = +and private SolveTypSubsumesTypWithReport (csenv:ConstraintSolverEnv) ndeep m trace ty1 ty2 = TryD (fun () -> SolveTypSubsumesTypKeepAbbrevs csenv ndeep m trace ty1 ty2) (fun res -> - match contextInfo with + match csenv.eContextInfo with | ContextInfo.RuntimeTypeTest isOperator -> // test if we can cast other way around match CollectThenUndo (fun newTrace -> SolveTypSubsumesTypKeepAbbrevs csenv ndeep m (OptionalTrace.WithTrace newTrace) 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,contextInfo,m))) + | _ -> ErrorD (ErrorsFromAddingSubsumptionConstraint(csenv.g,csenv.DisplayEnv,ty1,ty2,res,csenv.eContextInfo,m))) and private SolveTypEqualsTypWithReport contextInfo (csenv:ConstraintSolverEnv) ndeep m trace ty1 ty2 = TryD (fun () -> SolveTypEqualsTypKeepAbbrevs csenv ndeep m trace ty1 ty2) @@ -1951,8 +1957,8 @@ and ArgsMustSubsumeOrConvert let g = csenv.g let m = callerArg.Range - let calledArgTy = AdjustCalledArgType csenv.InfoReader isConstraint calledArg callerArg - SolveTypSubsumesTypWithReport ContextInfo.NoContext csenv ndeep m trace calledArgTy callerArg.Type ++ (fun () -> + let calledArgTy = AdjustCalledArgType csenv.InfoReader isConstraint calledArg callerArg + SolveTypSubsumesTypWithReport csenv ndeep m trace calledArgTy callerArg.Type ++ (fun () -> if calledArg.IsParamArray && isArray1DTy g calledArgTy && not (isArray1DTy g callerArg.Type) then @@ -1968,10 +1974,10 @@ and MustUnifyInsideUndo csenv ndeep trace ty1 ty2 = and ArgsMustSubsumeOrConvertInsideUndo (csenv:ConstraintSolverEnv) ndeep trace isConstraint calledArg (CallerArg(callerArgTy,m,_,_) as callerArg) = let calledArgTy = AdjustCalledArgType csenv.InfoReader isConstraint calledArg callerArg - SolveTypSubsumesTypWithReport ContextInfo.NoContext csenv ndeep m (WithTrace trace) calledArgTy callerArgTy + SolveTypSubsumesTypWithReport csenv ndeep m (WithTrace trace) calledArgTy callerArgTy and TypesMustSubsumeOrConvertInsideUndo (csenv:ConstraintSolverEnv) ndeep trace m calledArgTy callerArgTy = - SolveTypSubsumesTypWithReport ContextInfo.NoContext csenv ndeep m trace calledArgTy callerArgTy + SolveTypSubsumesTypWithReport csenv ndeep m trace calledArgTy callerArgTy and ArgsEquivInsideUndo (csenv:ConstraintSolverEnv) _trace isConstraint calledArg (CallerArg(callerArgTy,m,_,_) as callerArg) = let calledArgTy = AdjustCalledArgType csenv.InfoReader isConstraint calledArg callerArg @@ -2418,7 +2424,7 @@ let EliminateConstraintsForGeneralizedTypars csenv trace (generalizedTypars: Typ //------------------------------------------------------------------------- let AddCxTypeEqualsType contextInfo denv css m ty1 ty2 = - SolveTypEqualsTypWithReport contextInfo (MakeConstraintSolverEnv css m denv) 0 m NoTrace ty1 ty2 + SolveTypEqualsTypWithReport contextInfo (MakeConstraintSolverEnv contextInfo css m denv) 0 m NoTrace ty1 ty2 |> RaiseOperationResult let UndoIfFailed f = @@ -2435,72 +2441,72 @@ let UndoIfFailed f = ReportWarnings warns; true let AddCxTypeEqualsTypeUndoIfFailed denv css m ty1 ty2 = - UndoIfFailed (fun trace -> SolveTypEqualsTypKeepAbbrevs (MakeConstraintSolverEnv css m denv) 0 m (WithTrace(trace)) ty1 ty2) + UndoIfFailed (fun trace -> SolveTypEqualsTypKeepAbbrevs (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m (WithTrace(trace)) ty1 ty2) let AddCxTypeEqualsTypeMatchingOnlyUndoIfFailed denv css m ty1 ty2 = - let csenv = MakeConstraintSolverEnv css m denv + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv let csenv = { csenv with MatchingOnly = true } UndoIfFailed (fun trace -> SolveTypEqualsTypKeepAbbrevs csenv 0 m (WithTrace(trace)) ty1 ty2) let AddCxTypeMustSubsumeTypeUndoIfFailed denv css m ty1 ty2 = - UndoIfFailed (fun trace -> SolveTypSubsumesTypKeepAbbrevs (MakeConstraintSolverEnv css m denv) 0 m (WithTrace(trace)) ty1 ty2) + UndoIfFailed (fun trace -> SolveTypSubsumesTypKeepAbbrevs (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m (WithTrace(trace)) ty1 ty2) let AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed denv css m ty1 ty2 = - let csenv = MakeConstraintSolverEnv css m denv + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv let csenv = { csenv with MatchingOnly = true } UndoIfFailed (fun trace -> SolveTypSubsumesTypKeepAbbrevs csenv 0 m (WithTrace(trace)) ty1 ty2) let AddCxTypeMustSubsumeType contextInfo denv css m trace ty1 ty2 = - SolveTypSubsumesTypWithReport contextInfo (MakeConstraintSolverEnv css m denv) 0 m trace ty1 ty2 + SolveTypSubsumesTypWithReport (MakeConstraintSolverEnv contextInfo css m denv) 0 m trace ty1 ty2 |> RaiseOperationResult let AddCxMethodConstraint denv css m trace traitInfo = - TryD (fun () -> SolveMemberConstraint (MakeConstraintSolverEnv css m denv) false 0 m trace traitInfo ++ (fun _ -> CompleteD)) + TryD (fun () -> SolveMemberConstraint (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) false 0 m trace traitInfo ++ (fun _ -> CompleteD)) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult let AddCxTypeMustSupportNull denv css m trace ty = - TryD (fun () -> SolveTypSupportsNull (MakeConstraintSolverEnv css m denv) 0 m trace ty) + TryD (fun () -> SolveTypSupportsNull (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult let AddCxTypeMustSupportComparison denv css m trace ty = - TryD (fun () -> SolveTypeSupportsComparison (MakeConstraintSolverEnv css m denv) 0 m trace ty) + TryD (fun () -> SolveTypeSupportsComparison (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult let AddCxTypeMustSupportEquality denv css m trace ty = - TryD (fun () -> SolveTypSupportsEquality (MakeConstraintSolverEnv css m denv) 0 m trace ty) + TryD (fun () -> SolveTypSupportsEquality (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult let AddCxTypeMustSupportDefaultCtor denv css m trace ty = - TryD (fun () -> SolveTypRequiresDefaultConstructor (MakeConstraintSolverEnv css m denv) 0 m trace ty) + TryD (fun () -> SolveTypRequiresDefaultConstructor (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult let AddCxTypeIsReferenceType denv css m trace ty = - TryD (fun () -> SolveTypIsReferenceType (MakeConstraintSolverEnv css m denv) 0 m trace ty) + TryD (fun () -> SolveTypIsReferenceType (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult let AddCxTypeIsValueType denv css m trace ty = - TryD (fun () -> SolveTypIsNonNullableValueType (MakeConstraintSolverEnv css m denv) 0 m trace ty) + TryD (fun () -> SolveTypIsNonNullableValueType (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult let AddCxTypeIsUnmanaged denv css m trace ty = - TryD (fun () -> SolveTypIsUnmanaged (MakeConstraintSolverEnv css m denv) 0 m trace ty) + TryD (fun () -> SolveTypIsUnmanaged (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult let AddCxTypeIsEnum denv css m trace ty underlying = - TryD (fun () -> SolveTypIsEnum (MakeConstraintSolverEnv css m denv) 0 m trace ty underlying) + TryD (fun () -> SolveTypIsEnum (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty underlying) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult let AddCxTypeIsDelegate denv css m trace ty aty bty = - TryD (fun () -> SolveTypIsDelegate (MakeConstraintSolverEnv css m denv) 0 m trace ty aty bty) + TryD (fun () -> SolveTypIsDelegate (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty aty bty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult @@ -2509,7 +2515,7 @@ let CodegenWitnessThatTypSupportsTraitConstraint tcVal g amap m (traitInfo:Trait TcVal = tcVal ExtraCxs=HashMultiMap(10, HashIdentity.Structural) InfoReader=new InfoReader(g,amap) } - let csenv = MakeConstraintSolverEnv css m (DisplayEnv.Empty g) + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m (DisplayEnv.Empty g) SolveMemberConstraint csenv true 0 m NoTrace traitInfo ++ (fun _res -> let sln = match traitInfo.Solution with @@ -2587,7 +2593,7 @@ let ChooseTyparSolutionAndSolve css denv tp = let g = css.g let amap = css.amap let max,m = ChooseTyparSolutionAndRange g amap tp - let csenv = MakeConstraintSolverEnv css m denv + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv TryD (fun () -> SolveTyparEqualsTyp csenv 0 m NoTrace (mkTyparTy tp) max) (fun err -> ErrorD(ErrorFromApplyingDefault(g,denv,tp,max,err,m))) |> RaiseOperationResult @@ -2597,7 +2603,7 @@ let ChooseTyparSolutionAndSolve css denv tp = let CheckDeclaredTypars denv css m typars1 typars2 = TryD (fun () -> CollectThenUndo (fun trace -> - SolveTypEqualsTypEqns (MakeConstraintSolverEnv css m denv) 0 m (WithTrace(trace)) + SolveTypEqualsTypEqns (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m (WithTrace(trace)) (List.map mkTyparTy typars1) (List.map mkTyparTy typars2))) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) @@ -2615,7 +2621,7 @@ let IsApplicableMethApprox g amap m (minfo:MethInfo) availObjTy = TcVal = (fun _ -> failwith "should not be called") ExtraCxs=HashMultiMap(10, HashIdentity.Structural) InfoReader=new InfoReader(g,amap) } - let csenv = MakeConstraintSolverEnv css m (DisplayEnv.Empty g) + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m (DisplayEnv.Empty g) let minst = FreshenMethInfo m minfo match minfo.GetObjArgTypes(amap, m, minst) with | [reqdObjTy] -> diff --git a/src/fsharp/ConstraintSolver.fsi b/src/fsharp/ConstraintSolver.fsi index a0e404983e..63238ec1c4 100644 --- a/src/fsharp/ConstraintSolver.fsi +++ b/src/fsharp/ConstraintSolver.fsi @@ -60,13 +60,17 @@ type ContextInfo = | RecordFields /// The type equation comes from the verification of a tuple in record fields. | TupleInRecordFields +/// The type equation comes from a return in a computation expression. +| ReturnInComputationExpression +/// The type equation comes from a yield in a computation expression. +| YieldInComputationExpression /// The type equation comes from a runtime type test. | RuntimeTypeTest of bool /// The type equation comes from an downcast where a upcast could be used. | DowncastUsedInsteadOfUpcast of bool exception ConstraintSolverTupleDiffLengths of DisplayEnv * TType list * TType list * range * range -exception ConstraintSolverInfiniteTypes of DisplayEnv * TType * TType * range * range +exception ConstraintSolverInfiniteTypes of ContextInfo * DisplayEnv * TType * TType * range * range exception ConstraintSolverTypesNotInEqualityRelation of DisplayEnv * TType * TType * range * range exception ConstraintSolverTypesNotInSubsumptionRelation of DisplayEnv * TType * TType * range * range exception ConstraintSolverMissingConstraint of DisplayEnv * Typar * TyparConstraint * range * range @@ -92,7 +96,7 @@ type ConstraintSolverEnv val BakedInTraitConstraintNames : string list -val MakeConstraintSolverEnv : ConstraintSolverState -> range -> DisplayEnv -> ConstraintSolverEnv +val MakeConstraintSolverEnv : ContextInfo -> ConstraintSolverState -> range -> DisplayEnv -> ConstraintSolverEnv type Trace = Trace of (unit -> unit) list ref diff --git a/src/fsharp/FSComp.txt b/src/fsharp/FSComp.txt index b05aaca7ae..f9053080cf 100644 --- a/src/fsharp/FSComp.txt +++ b/src/fsharp/FSComp.txt @@ -17,6 +17,8 @@ missingElseBranch,"The 'if' expression is missing an 'else' branch. The 'then' b elseBranchHasWrongType,"All branches of an 'if' expression must return the same type. This expression was expected to have type '%s' but here has type '%s'." commaInsteadOfSemicolonInRecord,"A ';' is used to separate field values in records. Consider replacing ',' with ';'." buildUnexpectedTypeArgs,"The non-generic type '%s' does not expect any type arguments, but here is given %d type argument(s)" +returnUsedInsteadOfReturnBang,"Consider using 'return!' instead of 'return'." +yieldUsedInsteadOfYieldBang,"Consider using 'yield!' instead of 'yield'." 203,buildInvalidWarningNumber,"Invalid warning number '%s'" 204,buildInvalidVersionString,"Invalid version string '%s'" 205,buildInvalidVersionFile,"Invalid version file '%s'" diff --git a/src/fsharp/FSStrings.resx b/src/fsharp/FSStrings.resx index 74511b3354..f95cf777b4 100644 --- a/src/fsharp/FSStrings.resx +++ b/src/fsharp/FSStrings.resx @@ -124,7 +124,7 @@ The tuples have differing lengths of {0} and {1} - The resulting type would be infinite when unifying '{0}' and '{1}' + The types '{0}' and '{1}' cannot be unified. A type parameter is missing a constraint '{0}' diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs index ddcffab75a..b550ef3302 100755 --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -2153,7 +2153,7 @@ module GeneralizationHelpers = let CanonicalizePartialInferenceProblem (cenv,denv,m) tps = // Canonicalize constraints prior to generalization - let csenv = (MakeConstraintSolverEnv cenv.css m denv) + 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 @@ -2200,7 +2200,7 @@ module GeneralizationHelpers = generalizedTypars |> List.iter (SetTyparRigid cenv.g denv m) // Generalization removes constraints related to generalized type variables - let csenv = MakeConstraintSolverEnv cenv.css m denv + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext cenv.css m denv EliminateConstraintsForGeneralizedTypars csenv NoTrace generalizedTypars generalizedTypars @@ -3887,7 +3887,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 cenv.css m env.DisplayEnv) + let csenv = (MakeConstraintSolverEnv env.eContextInfo cenv.css m env.DisplayEnv) AddConstraint csenv 0 m NoTrace tp' (TyparConstraint.DefaultsTo(ridx,ty',m)) |> CommitOperationResult tpenv @@ -5092,7 +5092,7 @@ and TcPatterns warnOnUpper cenv env vFlags s argtys args = and solveTypAsError cenv denv m ty = let ty2 = NewErrorType () assert((destTyparTy cenv.g ty2).IsFromError) - SolveTypEqualsTypKeepAbbrevs (MakeConstraintSolverEnv cenv.css m denv) 0 m NoTrace ty ty2 |> ignore + SolveTypEqualsTypKeepAbbrevs (MakeConstraintSolverEnv ContextInfo.NoContext cenv.css m denv) 0 m NoTrace ty ty2 |> ignore and RecordNameAndTypeResolutions_IdeallyWithoutHavingOtherEffects cenv env tpenv expr = // This function is motivated by cases like @@ -7636,6 +7636,12 @@ and TcComputationExpression cenv env overallTy mWhole interpExpr builderTy tpenv let mBuilderVal = mBuilderVal.MakeSynthetic() SynExpr.Lambda (false,false,SynSimplePats.SimplePats ([mkSynSimplePatVar false (mkSynId mBuilderVal builderValName)],mBuilderVal), runExpr, mBuilderVal) + let env = + match comp with + | SynExpr.YieldOrReturn ((true,_),_,_) -> { env with eContextInfo = ContextInfo.YieldInComputationExpression } + | SynExpr.YieldOrReturn ((_,true),_,_) -> { env with eContextInfo = ContextInfo.ReturnInComputationExpression } + | _ -> env + let lambdaExpr ,tpenv= TcExpr cenv (builderTy --> overallTy) env tpenv lambdaExpr // beta-var-reduce to bind the builder using a 'let' binding let coreExpr = mkApps cenv.g ((lambdaExpr,tyOfExpr cenv.g lambdaExpr),[],[interpExpr],mBuilderVal) @@ -7648,7 +7654,7 @@ and TcComputationExpression cenv env overallTy mWhole interpExpr builderTy tpenv /// and helpers rather than to the builder methods (there is actually no builder for 'seq' in the library). /// These are later detected by state machine compilation. /// -/// Also "ienumerable extraction" is performaed on arguments to "for". +/// Also "ienumerable extraction" is performed on arguments to "for". and TcSequenceExpression cenv env tpenv comp overallTy m = let mkDelayedExpr (coreExpr:Expr) = @@ -8924,7 +8930,7 @@ and TcMethodApplication yield makeOneCalledMeth (minfo,pinfoOpt,false) ] let uniquelyResolved = - let csenv = MakeConstraintSolverEnv cenv.css mMethExpr denv + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext cenv.css mMethExpr denv let res = UnifyUniqueOverloading csenv callerArgCounts methodName ad preArgumentTypeCheckingCalledMethGroup returnTy match res with | ErrorResult _ -> afterTcOverloadResolution.OnOverloadResolutionFailure() @@ -9010,7 +9016,7 @@ and TcMethodApplication CalledMeth(cenv.infoReader,Some(env.NameEnv),checkingAttributeCall,FreshenMethInfo, mMethExpr,ad,minfo,minst,callerTyArgs,pinfoOpt,callerObjArgTys,callerArgs,usesParamArrayConversion,true,objTyOpt)) let callerArgCounts = (unnamedCurriedCallerArgs.Length, namedCurriedCallerArgs.Length) - let csenv = MakeConstraintSolverEnv cenv.css mMethExpr denv + 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. @@ -15637,7 +15643,7 @@ let ApplyDefaults cenv g denvAtEnd m mexpr extraAttribs = | 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 cenv.css m denvAtEnd + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext cenv.css m denvAtEnd TryD (fun () -> ConstraintSolver.SolveTyparEqualsTyp csenv 0 m NoTrace ty1 ty2) (fun e -> solveTypAsError cenv denvAtEnd m ty1 ErrorD(ErrorFromApplyingDefault(g,denvAtEnd,tp,ty2,e,m))) diff --git a/tests/fsharpqa/Source/Diagnostics/async/MissingBangForLoop01.fs b/tests/fsharpqa/Source/Diagnostics/async/MissingBangForLoop01.fs index bf56109e50..4a76753f58 100644 --- a/tests/fsharpqa/Source/Diagnostics/async/MissingBangForLoop01.fs +++ b/tests/fsharpqa/Source/Diagnostics/async/MissingBangForLoop01.fs @@ -1,7 +1,7 @@ // #Regression #Diagnostics #Async // Regression tests for FSHARP1.0:4394 // common mistake: forgetting the ! for a loop -//Type mismatch\. Expecting a. ''a' .but given a. 'Async<'a>' .The resulting type would be infinite when unifying ''a' and 'Async<'a>'$ +//Type mismatch\. Expecting a.+''a'.+but given a.+'Async<'a>'.*The types ''a' and 'Async<'a>' cannot be unified. let rec loop() = async { let x = 1 return loop() } diff --git a/tests/fsharpqa/Source/Diagnostics/async/MissingBangForLoop02.fs b/tests/fsharpqa/Source/Diagnostics/async/MissingBangForLoop02.fs index 73a3c6a278..ad5f28403e 100644 --- a/tests/fsharpqa/Source/Diagnostics/async/MissingBangForLoop02.fs +++ b/tests/fsharpqa/Source/Diagnostics/async/MissingBangForLoop02.fs @@ -2,6 +2,6 @@ // Regression tests for FSHARP1.0:4394 // common mistake: forgetting the ! for a loop // Note: Desugared form of MissingBangForLoop01.fs -//Type mismatch\. Expecting a. ''a' .but given a. 'Async<'a>' .The resulting type would be infinite when unifying ''a' and 'Async<'a>'$ +//Type mismatch\. Expecting a. ''a' .but given a. 'Async<'a>' .The types ''a' and 'Async<'a>' cannot be unified. let rec loop2() = async.Delay(fun () -> async.Return(loop2())) diff --git a/tests/fsharpqa/Source/Warnings/ReturnInsteadOfReturnBang.fs b/tests/fsharpqa/Source/Warnings/ReturnInsteadOfReturnBang.fs new file mode 100644 index 0000000000..1cb8bff1a9 --- /dev/null +++ b/tests/fsharpqa/Source/Warnings/ReturnInsteadOfReturnBang.fs @@ -0,0 +1,6 @@ +// #Warnings +//Type mismatch. Expecting a.+''a'.+but given a.+'Async<'a>'.+The types ''a' and 'Async<'a>' cannot be unified. Consider using 'return!' instead of 'return'.* + +let rec foo() = async { return foo() } + +exit 0 \ No newline at end of file diff --git a/tests/fsharpqa/Source/Warnings/YieldInsteadOfYieldBang.fs b/tests/fsharpqa/Source/Warnings/YieldInsteadOfYieldBang.fs new file mode 100644 index 0000000000..ce048df29c --- /dev/null +++ b/tests/fsharpqa/Source/Warnings/YieldInsteadOfYieldBang.fs @@ -0,0 +1,9 @@ +// #Warnings +//.Type mismatch. Expecting a.+''a'.+but given a.+''a list'.+The types ''a' and ''a list' cannot be unified. Consider using 'yield!' instead of 'yield'.* + +type Foo() = + member this.Yield(x) = [x] + +let rec f () = Foo() { yield f ()} + +exit 0 \ No newline at end of file diff --git a/tests/fsharpqa/Source/Warnings/env.lst b/tests/fsharpqa/Source/Warnings/env.lst index 5ec49c6ddb..89651c646a 100644 --- a/tests/fsharpqa/Source/Warnings/env.lst +++ b/tests/fsharpqa/Source/Warnings/env.lst @@ -1,5 +1,7 @@ SOURCE=WrongNumericLiteral.fs # WrongNumericLiteral.fs SOURCE=WarnIfMissingElseBranch.fs # WarnIfMissingElseBranch.fs + SOURCE=ReturnInsteadOfReturnBang.fs # ReturnInsteadOfReturnBang.fs + SOURCE=YieldInsteadOfYieldBang.fs # YieldInsteadOfYieldBang.fs SOURCE=CommaInRecCtor.fs # CommaInRecCtor.fs SOURCE=ValidCommaInRecCtor.fs # ValidCommaInRecCtor.fs SOURCE=ElseBranchHasWrongType.fs # ElseBranchHasWrongType.fs