diff --git a/src/fsharp/CompileOps.fs b/src/fsharp/CompileOps.fs index f7950c34dba6..695848b4b606 100644 --- a/src/fsharp/CompileOps.fs +++ b/src/fsharp/CompileOps.fs @@ -119,6 +119,7 @@ let GetRangeOfError(err:PhasedError) = | ErrorFromAddingTypeEquation(_,_,_,_,_,m) | ErrorFromApplyingDefault(_,_,_,_,_,m) | ErrorsFromAddingSubsumptionConstraint(_,_,_,_,_,m) + | ErrorsFromAddingSubsumptionConstraintWithDetails(_,_,_,_,_,_,m) | FunctionExpected(_,_,m) | BakedInMemberConstraintName(_,m) | StandardOperatorRedefinitionWarning(_,m) @@ -416,6 +417,9 @@ let SplitRelatedErrors(err:PhasedError) = | ErrorsFromAddingSubsumptionConstraint(g,denv,t1,t2,e,m) -> let e,related = SplitRelatedException e ErrorsFromAddingSubsumptionConstraint(g,denv,t1,t2,e.Exception,m)|>ToPhased, related + | ErrorsFromAddingSubsumptionConstraintWithDetails(g,denv,t1,t2,e,details,m) -> + let e,related = SplitRelatedException e + ErrorsFromAddingSubsumptionConstraintWithDetails(g,denv,t1,t2,e.Exception,details,m)|>ToPhased, related | ErrorFromAddingConstraint(x,e,m) -> let e,related = SplitRelatedException e ErrorFromAddingConstraint(x,e.Exception,m)|>ToPhased, related @@ -663,6 +667,14 @@ let OutputPhasedErrorR (os:System.Text.StringBuilder) (err:PhasedError) = os.Append(ErrorsFromAddingSubsumptionConstraintE().Format t2 t1 tpcs) |> ignore ) OutputExceptionR os e + | ErrorsFromAddingSubsumptionConstraintWithDetails(g,denv,t1,t2,e,details,_) -> + if not (typeEquiv g t1 t2) then ( + let t1,t2,tpcs = NicePrint.minimalStringsOfTwoTypes denv t1 t2 + if t1 <> (t2 + tpcs) then + os.Append(ErrorsFromAddingSubsumptionConstraintE().Format t2 t1 tpcs) |> ignore + ) + OutputExceptionR os e + os.Append(System.Environment.NewLine + details()) |> ignore | UpperCaseIdentifierInPattern(_) -> os.Append(UpperCaseIdentifierInPatternE().Format) |> ignore | NotUpperCaseConstructor(_) -> diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index 7cb5078e2913..d0e03d4d6a96 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -126,6 +126,7 @@ exception ConstraintSolverRelatedInformation of string option * range * exn exception ErrorFromApplyingDefault of TcGlobals * DisplayEnv * Tast.Typar * TType * exn * range exception ErrorFromAddingTypeEquation of TcGlobals * DisplayEnv * TType * TType * exn * range exception ErrorsFromAddingSubsumptionConstraint of TcGlobals * DisplayEnv * TType * TType * exn * range +exception ErrorsFromAddingSubsumptionConstraintWithDetails of TcGlobals * DisplayEnv * TType * TType * exn * (unit -> string) * range exception ErrorFromAddingConstraint of DisplayEnv * exn * range exception PossibleOverload of DisplayEnv * string * exn * range exception UnresolvedOverloading of DisplayEnv * exn list * string * range @@ -1912,6 +1913,13 @@ and private SolveTypSubsumesTypWithReport (csenv:ConstraintSolverEnv) ndeep m tr TryD (fun () -> SolveTypSubsumesTypKeepAbbrevs csenv ndeep m trace ty1 ty2) (fun res -> ErrorD (ErrorsFromAddingSubsumptionConstraint(csenv.g,csenv.DisplayEnv,ty1,ty2,res,m))) +and private SolveTypSubsumesTypWithSpecialReport (csenv:ConstraintSolverEnv) ndeep m trace ty1 ty2 = + TryD (fun () -> SolveTypSubsumesTypKeepAbbrevs csenv ndeep m trace ty1 ty2) + (fun res -> + match SolveTypSubsumesTypKeepAbbrevs csenv ndeep m trace ty2 ty1 with // test if we can cast other way around + | OkResult _ -> ErrorD (ErrorsFromAddingSubsumptionConstraintWithDetails(csenv.g,csenv.DisplayEnv,ty1,ty2,res,FSComp.SR.considerDownCast,m)) + | _ -> ErrorD (ErrorsFromAddingSubsumptionConstraint(csenv.g,csenv.DisplayEnv,ty1,ty2,res,m))) + and private SolveTypEqualsTypWithReport (csenv:ConstraintSolverEnv) ndeep m trace ty1 ty2 = TryD (fun () -> SolveTypEqualsTypKeepAbbrevs csenv ndeep m trace ty1 ty2) (fun res -> ErrorD (ErrorFromAddingTypeEquation(csenv.g,csenv.DisplayEnv,ty1,ty2,res,m))) @@ -2431,6 +2439,10 @@ let AddCxTypeMustSubsumeType denv css m trace ty1 ty2 = SolveTypSubsumesTypWithReport (MakeConstraintSolverEnv css m denv) 0 m trace ty1 ty2 |> RaiseOperationResult +let AddCxTypeMustSubsumeTypeSpecialReport denv css m trace ty1 ty2 = + SolveTypSubsumesTypWithSpecialReport (MakeConstraintSolverEnv 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)) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) diff --git a/src/fsharp/ConstraintSolver.fsi b/src/fsharp/ConstraintSolver.fsi index 7f648f99ca73..2c809eb6e9ca 100644 --- a/src/fsharp/ConstraintSolver.fsi +++ b/src/fsharp/ConstraintSolver.fsi @@ -57,6 +57,7 @@ exception ConstraintSolverRelatedInformation of string option * range exception ErrorFromApplyingDefault of TcGlobals * DisplayEnv * Typar * TType * exn * range exception ErrorFromAddingTypeEquation of TcGlobals * DisplayEnv * TType * TType * exn * range exception ErrorsFromAddingSubsumptionConstraint of TcGlobals * DisplayEnv * TType * TType * exn * range +exception ErrorsFromAddingSubsumptionConstraintWithDetails of TcGlobals * DisplayEnv * TType * TType * exn * (unit -> string) * range exception ErrorFromAddingConstraint of DisplayEnv * exn * range exception UnresolvedConversionOperator of DisplayEnv * TType * TType * range exception PossibleOverload of DisplayEnv * string * exn * range @@ -97,6 +98,7 @@ val AddCxTypeEqualsType : DisplayEnv -> ConstraintSolverSt val AddCxTypeEqualsTypeUndoIfFailed : DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> bool val AddCxTypeEqualsTypeMatchingOnlyUndoIfFailed : DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> bool val AddCxTypeMustSubsumeType : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> TType -> unit +val AddCxTypeMustSubsumeTypeSpecialReport : 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 diff --git a/src/fsharp/FSComp.txt b/src/fsharp/FSComp.txt index 096f76e140b6..de7ce94e3f59 100644 --- a/src/fsharp/FSComp.txt +++ b/src/fsharp/FSComp.txt @@ -14,6 +14,7 @@ undefinedNameRecordLabel,"The record label '%s' is not defined" undefinedNameTypeParameter,"The type parameter '%s' is not defined" undefinedNamePatternDiscriminator,"The pattern discriminator '%s' is not defined" buildUnexpectedTypeArgs,"The non-generic type '%s' does not expect any type arguments, but here is given %d type argument(s)" +considerDownCast,"Consider using the :> operator." 203,buildInvalidWarningNumber,"Invalid warning number '%s'" 204,buildInvalidVersionString,"Invalid version string '%s'" 205,buildInvalidVersionFile,"Invalid version file '%s'" diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs index 4d1cca379002..f6b67a024b27 100755 --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -2834,7 +2834,7 @@ let TcRuntimeTypeTest isCast cenv denv m tgty srcTy = if isSealedTy cenv.g tgty || isTyparTy cenv.g tgty || not (isInterfaceTy cenv.g srcTy) then - AddCxTypeMustSubsumeType denv cenv.css m NoTrace srcTy tgty + AddCxTypeMustSubsumeTypeSpecialReport denv cenv.css m NoTrace srcTy tgty if isErasedType cenv.g tgty then if isCast then