Skip to content
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
14 changes: 11 additions & 3 deletions src/fsharp/CompileOps.fs
Original file line number Diff line number Diff line change
Expand Up @@ -200,7 +200,7 @@ let GetRangeOfError(err:PhasedError) =
| NonVirtualAugmentationOnNullValuedType(m)
| NonRigidTypar(_,_,_,_,_,m)
| ConstraintSolverTupleDiffLengths(_,_,_,m,_)
| ConstraintSolverInfiniteTypes(_,_,_,m,_)
| ConstraintSolverInfiniteTypes(_,_,_,_,m,_)
| ConstraintSolverMissingConstraint(_,_,_,m,_)
| ConstraintSolverTypesNotInEqualityRelation(_,_,_,m,_)
| ConstraintSolverError(_,m,_)
Expand Down Expand Up @@ -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) ->
Expand Down
68 changes: 37 additions & 31 deletions src/fsharp/ConstraintSolver.fs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -177,6 +181,7 @@ type ConstraintSolverState =
type ConstraintSolverEnv =
{
SolverState: ConstraintSolverState;
eContextInfo: ContextInfo
MatchingOnly : bool
m: range;
EquivEnv: TypeEquivEnv;
Expand All @@ -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;
Expand Down Expand Up @@ -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 () ->
Expand Down Expand Up @@ -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)
Expand All @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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 =
Expand All @@ -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

Expand All @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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)))
Expand All @@ -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] ->
Expand Down
8 changes: 6 additions & 2 deletions src/fsharp/ConstraintSolver.fsi
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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

Expand Down
2 changes: 2 additions & 0 deletions src/fsharp/FSComp.txt
Original file line number Diff line number Diff line change
Expand Up @@ -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'"
Expand Down
2 changes: 1 addition & 1 deletion src/fsharp/FSStrings.resx
Original file line number Diff line number Diff line change
Expand Up @@ -124,7 +124,7 @@
<value>The tuples have differing lengths of {0} and {1}</value>
</data>
<data name="ConstraintSolverInfiniteTypes" xml:space="preserve">
<value>The resulting type would be infinite when unifying '{0}' and '{1}'</value>
<value>The types '{0}' and '{1}' cannot be unified.</value>
</data>
<data name="ConstraintSolverMissingConstraint" xml:space="preserve">
<value>A type parameter is missing a constraint '{0}'</value>
Expand Down
Loading