From 021d9f396b9111346271f829611340e46c6d82a1 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Sat, 7 May 2022 13:31:34 +0100 Subject: [PATCH 1/7] squash --- src/fsharp/CheckComputationExpressions.fs | 43 +- src/fsharp/CheckComputationExpressions.fsi | 7 +- src/fsharp/CheckDeclarations.fs | 5 +- src/fsharp/CheckExpressions.fs | 729 ++++++++++++------ src/fsharp/CheckExpressions.fsi | 27 +- src/fsharp/CompilerDiagnostics.fs | 3 + src/fsharp/ConstraintSolver.fs | 371 ++++++--- src/fsharp/ConstraintSolver.fsi | 15 +- src/fsharp/ErrorLogger.fs | 12 +- src/fsharp/ErrorLogger.fsi | 10 +- src/fsharp/FSComp.txt | 16 +- src/fsharp/FSharp.Core/prim-types.fsi | 4 + src/fsharp/IlxGen.fs | 3 + src/fsharp/InfoReader.fs | 591 +++++++------- src/fsharp/InfoReader.fsi | 44 +- src/fsharp/LanguageFeatures.fs | 6 + src/fsharp/LanguageFeatures.fsi | 2 + src/fsharp/MethodCalls.fs | 467 +++++++---- src/fsharp/MethodCalls.fsi | 103 ++- src/fsharp/NicePrint.fs | 21 +- src/fsharp/NicePrint.fsi | 4 +- src/fsharp/PostInferenceChecks.fs | 1 + src/fsharp/SyntaxTree.fs | 18 + src/fsharp/SyntaxTree.fsi | 16 + src/fsharp/SyntaxTreeOps.fs | 3 +- src/fsharp/TypeRelations.fs | 12 +- src/fsharp/TypedTree.fs | 16 + src/fsharp/TypedTreeOps.fs | 55 +- src/fsharp/TypedTreeOps.fsi | 11 + src/fsharp/TypedTreePickle.fs | 11 +- src/fsharp/fscmain.fs | 2 +- src/fsharp/infos.fs | 17 + src/fsharp/infos.fsi | 12 + src/fsharp/pars.fsy | 16 + src/fsharp/service/ItemKey.fs | 6 + src/fsharp/symbols/Symbols.fs | 1 + .../Diagnostics/async.fs | 4 +- .../ElseBranchHasWrongTypeTests.fs | 14 +- .../async/ReturnBangNonAsync_IfThenElse.fs | 2 +- ...erService.SurfaceArea.netstandard.expected | 22 + tests/fsharp/TypeProviderTests.fs | 6 +- tests/fsharp/core/access/test.fsx | 1 - tests/fsharp/tests.fs | 53 +- tests/fsharp/typecheck/sigs/neg20.bsl | 28 +- tests/fsharp/typecheck/sigs/neg20.fs | 18 +- tests/fsharp/typecheck/sigs/neg80.vsbsl | 2 +- .../fsharp/typecheck/sigs/version47/neg24.bsl | 4 +- .../fsharp/typecheck/sigs/version47/neg24.fs | 2 +- 48 files changed, 1942 insertions(+), 894 deletions(-) diff --git a/src/fsharp/CheckComputationExpressions.fs b/src/fsharp/CheckComputationExpressions.fs index 1ca65d4599..c9f1e3d691 100644 --- a/src/fsharp/CheckComputationExpressions.fs +++ b/src/fsharp/CheckComputationExpressions.fs @@ -213,8 +213,9 @@ let RecordNameAndTypeResolutions_IdeallyWithoutHavingOtherEffects cenv env tpenv with e -> ()) /// Used for all computation expressions except sequence expressions -let TcComputationExpression cenv env overallTy tpenv (mWhole, interpExpr: Expr, builderTy, comp: SynExpr) = - +let TcComputationExpression cenv env (overallTy: OverallTy) tpenv (mWhole, interpExpr: Expr, builderTy, comp: SynExpr) = + let overallTy = overallTy.Commit + //dprintfn "TcComputationExpression, comp = \n%A\n-------------------\n" comp let ad = env.eAccessRights @@ -1642,7 +1643,7 @@ let TcComputationExpression cenv env overallTy tpenv (mWhole, interpExpr: Expr, | SynExpr.YieldOrReturn ((_, true), _, _) -> { env with eContextInfo = ContextInfo.ReturnInComputationExpression } | _ -> env - let lambdaExpr, tpenv= TcExpr cenv (builderTy --> overallTy) env tpenv lambdaExpr + let lambdaExpr, tpenv= TcExpr cenv (MustEqual (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) @@ -1704,10 +1705,10 @@ let compileSeqExprMatchClauses (cenv: cenv) env inputExprMark (pat: Pattern, vsp /// These are later detected by state machine compilation. /// /// Also "ienumerable extraction" is performed on arguments to "for". -let TcSequenceExpression (cenv: cenv) env tpenv comp overallTy m = +let TcSequenceExpression (cenv: cenv) env tpenv comp (overallTy: OverallTy) m = let genEnumElemTy = NewInferenceType () - UnifyTypes cenv env m overallTy (mkSeqTy cenv.g genEnumElemTy) + UnifyTypes cenv env m overallTy.Commit (mkSeqTy cenv.g genEnumElemTy) // Allow subsumption at 'yield' if the element type is nominal prior to the analysis of the body of the sequence expression let flex = not (isTyparTy cenv.g genEnumElemTy) @@ -1765,7 +1766,7 @@ let TcSequenceExpression (cenv: cenv) env tpenv comp overallTy m = Some(tcSequenceExprBody env genOuterTy tpenv (elimFastIntegerForLoop (spBind, id, start, dir, finish, innerComp, m))) | SynExpr.While (spWhile, guardExpr, innerComp, _m) -> - let guardExpr, tpenv = TcExpr cenv cenv.g.bool_ty env tpenv guardExpr + let guardExpr, tpenv = TcExpr cenv (MustEqual cenv.g.bool_ty) env tpenv guardExpr let innerExpr, tpenv = tcSequenceExprBody env genOuterTy tpenv innerComp let guardExprMark = guardExpr.Range @@ -1782,7 +1783,7 @@ let TcSequenceExpression (cenv: cenv) env tpenv comp overallTy m = | SynExpr.TryFinally (innerComp, unwindExpr, mTryToLast, spTry, spFinally) -> let innerExpr, tpenv = tcSequenceExprBody env genOuterTy tpenv innerComp - let (unwindExpr: Expr), tpenv = TcExpr cenv cenv.g.unit_ty env tpenv unwindExpr + let unwindExpr, tpenv = TcExpr cenv (MustEqual cenv.g.unit_ty) env tpenv unwindExpr // We attach the debug points to the lambda expressions so we can fetch it out again in LowerComputedListOrArraySeqExpr let mTry = @@ -1823,7 +1824,7 @@ let TcSequenceExpression (cenv: cenv) env tpenv comp overallTy m = Some(Expr.Sequential(stmt1, innerExpr2, NormalSeq, sp, m), tpenv) | SynExpr.IfThenElse (_, _, guardExpr, _, thenComp, _, elseCompOpt, spIfToThen, _isRecovery, mIfToThen, mIfToEndOfElseBranch) -> - let guardExpr', tpenv = TcExpr cenv cenv.g.bool_ty env tpenv guardExpr + let guardExpr', tpenv = TcExpr cenv (MustEqual cenv.g.bool_ty) env tpenv guardExpr let thenExpr, tpenv = tcSequenceExprBody env genOuterTy tpenv thenComp let elseComp = (match elseCompOpt with Some c -> c | None -> SynExpr.ImplicitZero mIfToThen) let elseExpr, tpenv = tcSequenceExprBody env genOuterTy tpenv elseComp @@ -1832,7 +1833,7 @@ let TcSequenceExpression (cenv: cenv) env tpenv comp overallTy m = // 'let x = expr in expr' | SynExpr.LetOrUse (_, false (* not a 'use' binding *), _, _, _) -> TcLinearExprs - (fun ty envinner tpenv e -> tcSequenceExprBody envinner ty tpenv e) + (fun overallTy envinner tpenv e -> tcSequenceExprBody envinner overallTy.Commit tpenv e) cenv env overallTy tpenv true @@ -1846,7 +1847,7 @@ let TcSequenceExpression (cenv: cenv) env tpenv comp overallTy m = let inputExprTy = NewInferenceType () let pat', _, vspecs, envinner, tpenv = TcMatchPattern cenv bindPatTy env tpenv (pat, None) UnifyTypes cenv env m inputExprTy bindPatTy - let (inputExpr: Expr), tpenv = TcExpr cenv inputExprTy env tpenv rhsExpr + let inputExpr, tpenv = TcExpr cenv (MustEqual inputExprTy) env tpenv rhsExpr let innerExpr, tpenv = tcSequenceExprBody envinner genOuterTy tpenv innerComp let mBind = match spBind with @@ -1897,7 +1898,7 @@ let TcSequenceExpression (cenv: cenv) env tpenv comp overallTy m = | _ -> None - and tcSequenceExprBody env genOuterTy tpenv comp = + and tcSequenceExprBody env (genOuterTy: TType) tpenv comp = let res, tpenv = tcSequenceExprBodyAsSequenceOrStatement env genOuterTy tpenv comp match res with | Choice1Of2 expr -> @@ -1927,11 +1928,11 @@ let TcSequenceExpression (cenv: cenv) env tpenv comp overallTy m = let stmt, tpenv = TcStmtThatCantBeCtorBody cenv env tpenv comp Choice2Of2 stmt, tpenv - let coreExpr, tpenv = tcSequenceExprBody env overallTy tpenv comp + let coreExpr, tpenv = tcSequenceExprBody env overallTy.Commit tpenv comp let delayedExpr = mkDelayedExpr coreExpr.Range coreExpr delayedExpr, tpenv -let TcSequenceExpressionEntry (cenv: cenv) env overallTy tpenv (isArrayOrList, isNotNakedRefCell, comp) m = +let TcSequenceExpressionEntry (cenv: cenv) env (overallTy: OverallTy) tpenv (isArrayOrList, isNotNakedRefCell, comp) m = let implicitYieldEnabled = cenv.g.langVersion.SupportsFeature LanguageFeature.ImplicitYield let validateObjectSequenceOrRecordExpression = not implicitYieldEnabled if not isArrayOrList then @@ -1977,16 +1978,18 @@ let TcArrayOrListSequenceExpression (cenv: cenv) env overallTy tpenv (isArray, c TcExprUndelayed cenv overallTy env tpenv replacementExpr | _ -> - let genCollElemTy = NewInferenceType () + let genCollElemTy = NewInferenceType () - let genCollTy = (if isArray then mkArrayType else mkListTy) cenv.g genCollElemTy - - UnifyTypes cenv env m overallTy genCollTy + let genCollTy = (if isArray then mkArrayType else mkListTy) cenv.g genCollElemTy + // Propagating type directed conversion, e.g. for + // let x : seq = [ yield 1; if true then yield 2 ] + TcPropagatingExprLeafThenConvert cenv overallTy genCollTy env (* canAdhoc *) m (fun () -> + let exprty = mkSeqTy cenv.g genCollElemTy // Check the comprehension - let expr, tpenv = TcExpr cenv exprty env tpenv comp + let expr, tpenv = TcExpr cenv (MustEqual exprty) env tpenv comp let expr = mkCoerceIfNeeded cenv.g exprty (tyOfExpr cenv.g expr) expr @@ -1999,7 +2002,7 @@ let TcArrayOrListSequenceExpression (cenv: cenv) env overallTy tpenv (isArray, c // comprehension. But don't do this in FSharp.Core.dll since 'seq' may not yet be defined. mkCallSeq cenv.g m genCollElemTy expr - let expr = mkCoerceExpr(expr, exprty, expr.Range, overallTy) + let expr = mkCoerceExpr(expr, exprty, expr.Range, overallTy.Commit) let expr = if isArray then @@ -2007,4 +2010,4 @@ let TcArrayOrListSequenceExpression (cenv: cenv) env overallTy tpenv (isArray, c else mkCallSeqToList cenv.g m genCollElemTy expr - expr, tpenv + expr, tpenv) diff --git a/src/fsharp/CheckComputationExpressions.fsi b/src/fsharp/CheckComputationExpressions.fsi index a6c8a46d13..c5644c756d 100644 --- a/src/fsharp/CheckComputationExpressions.fsi +++ b/src/fsharp/CheckComputationExpressions.fsi @@ -3,13 +3,14 @@ module internal FSharp.Compiler.CheckComputationExpressions open FSharp.Compiler.CheckExpressions +open FSharp.Compiler.ConstraintSolver open FSharp.Compiler.Syntax open FSharp.Compiler.Text open FSharp.Compiler.TypedTree -val TcSequenceExpressionEntry: cenv:TcFileState -> env:TcEnv -> overallTy:TType -> tpenv:UnscopedTyparEnv -> isArrayOrList:bool * isNotNakedRefCell:bool ref * comp:SynExpr -> m:range -> Expr * UnscopedTyparEnv +val TcSequenceExpressionEntry: cenv:TcFileState -> env:TcEnv -> overallTy:OverallTy -> tpenv:UnscopedTyparEnv -> isArrayOrList:bool * isNotNakedRefCell:bool ref * comp:SynExpr -> m:range -> Expr * UnscopedTyparEnv -val TcArrayOrListSequenceExpression: cenv:TcFileState -> env:TcEnv -> overallTy:TType -> tpenv:UnscopedTyparEnv -> isArray:bool * comp:SynExpr -> m:range -> Expr * UnscopedTyparEnv +val TcArrayOrListSequenceExpression: cenv:TcFileState -> env:TcEnv -> overallTy:OverallTy -> tpenv:UnscopedTyparEnv -> isArray:bool * comp:SynExpr -> m:range -> Expr * UnscopedTyparEnv -val TcComputationExpression: cenv:TcFileState -> env:TcEnv -> overallTy:TType -> tpenv:UnscopedTyparEnv -> mWhole:range * interpExpr:Expr * builderTy:TType * comp:SynExpr -> Expr * UnscopedTyparEnv +val TcComputationExpression: cenv:TcFileState -> env:TcEnv -> overallTy:OverallTy -> tpenv:UnscopedTyparEnv -> mWhole:range * interpExpr:Expr * builderTy:TType * comp:SynExpr -> Expr * UnscopedTyparEnv diff --git a/src/fsharp/CheckDeclarations.fs b/src/fsharp/CheckDeclarations.fs index df6b0bf4c1..0a42266221 100644 --- a/src/fsharp/CheckDeclarations.fs +++ b/src/fsharp/CheckDeclarations.fs @@ -1874,7 +1874,7 @@ module MutRecBindingChecking = let ty = generalizedTyconRef tcref let ad = envNonRec.AccessRights match TryFindIntrinsicMethInfo cenv.infoReader bind.Var.Range ad nm ty, - TryFindPropInfo cenv.infoReader bind.Var.Range ad nm ty with + TryFindIntrinsicPropInfo cenv.infoReader bind.Var.Range ad nm ty with | [], [] -> () | _ -> errorR (Error(FSComp.SR.tcMemberAndLocalClassBindingHaveSameName nm, bind.Var.Range)) @@ -4120,7 +4120,8 @@ module EstablishTypeDefinitionCores = let rec accInAbbrevType ty acc = match stripTyparEqns ty with - | TType_anon (_,l) + | TType_anon (_,l) + | TType_erased_union (_, l) | TType_tuple (_, l) -> accInAbbrevTypes l acc | TType_ucase (UnionCaseRef(tc, _), tinst) | TType_app (tc, tinst) -> diff --git a/src/fsharp/CheckExpressions.fs b/src/fsharp/CheckExpressions.fs index 7566a18ae9..dba320ffd5 100644 --- a/src/fsharp/CheckExpressions.fs +++ b/src/fsharp/CheckExpressions.fs @@ -406,11 +406,13 @@ type TcFileState = isInternalTestSpanStackReferring: bool // forward call - TcSequenceExpressionEntry: TcFileState -> TcEnv -> TType -> UnscopedTyparEnv -> bool * bool ref * SynExpr -> range -> Expr * UnscopedTyparEnv + TcSequenceExpressionEntry: TcFileState -> TcEnv -> OverallTy -> UnscopedTyparEnv -> bool * bool ref * SynExpr -> range -> Expr * UnscopedTyparEnv + // forward call - TcArrayOrListSequenceExpression: TcFileState -> TcEnv -> TType -> UnscopedTyparEnv -> bool * SynExpr -> range -> Expr * UnscopedTyparEnv + TcArrayOrListSequenceExpression: TcFileState -> TcEnv -> OverallTy -> UnscopedTyparEnv -> bool * SynExpr -> range -> Expr * UnscopedTyparEnv + // forward call - TcComputationExpression: TcFileState -> TcEnv -> TType -> UnscopedTyparEnv -> range * Expr * TType * SynExpr -> Expr * UnscopedTyparEnv + TcComputationExpression: TcFileState -> TcEnv -> OverallTy -> UnscopedTyparEnv -> range * Expr * TType * SynExpr -> Expr * UnscopedTyparEnv } /// Create a new compilation environment @@ -453,6 +455,52 @@ let CopyAndFixupTypars m rigid tpsorig = let UnifyTypes cenv (env: TcEnv) m actualTy expectedTy = AddCxTypeEqualsType env.eContextInfo env.DisplayEnv cenv.css m (tryNormalizeMeasureInType cenv.g actualTy) (tryNormalizeMeasureInType cenv.g expectedTy) +// If the overall type admits subsumption or type directed conversion, and the original unify would have failed, +// then allow subsumption or type directed conversion. +// +// Any call to UnifyOverallType MUST have a matching call to TcAdjustExprForTypeDirectedConversions +// to actually build the expression for any conversion applied. +let UnifyOverallType cenv (env: TcEnv) m overallTy actualTy = + match overallTy with + | MustConvertTo(isMethodArg, reqdTy) when cenv.g.langVersion.SupportsFeature LanguageFeature.AdditionalTypeDirectedConversions -> + let actualTy = tryNormalizeMeasureInType cenv.g actualTy + let reqdTy = tryNormalizeMeasureInType cenv.g reqdTy + if AddCxTypeEqualsTypeUndoIfFailed env.DisplayEnv cenv.css m reqdTy actualTy then + () + else + // try adhoc type-directed conversions + let reqdTy2, usesTDC, eqn = AdjustRequiredTypeForTypeDirectedConversions cenv.infoReader env.eAccessRights isMethodArg false reqdTy actualTy m + match eqn with + | Some (ty1, ty2, msg) -> + UnifyTypes cenv env m ty1 ty2 + msg env.DisplayEnv + | None -> () + match usesTDC with + | TypeDirectedConversionUsed.Yes warn -> warning(warn env.DisplayEnv) + | TypeDirectedConversionUsed.No -> () + if AddCxTypeMustSubsumeTypeUndoIfFailed env.DisplayEnv cenv.css m reqdTy2 actualTy then + let reqdTyText, actualTyText, _cxs = NicePrint.minimalStringsOfTwoTypes env.DisplayEnv reqdTy actualTy + warning (Error(FSComp.SR.tcSubsumptionImplicitConversionUsed(actualTyText, reqdTyText), m)) + else + // report the error + UnifyTypes cenv env m reqdTy actualTy + | _ -> + UnifyTypes cenv env m overallTy.Commit actualTy + +let UnifyOverallTypeAndRecover cenv env m overallTy actualTy = + try + UnifyOverallType cenv env m overallTy actualTy + with e -> + errorRecovery e m + +// Calls UnifyTypes, but upon error only does the minimal error recovery +// so that IntelliSense information can continue to be collected. +let UnifyTypesAndRecover cenv env m expectedTy actualTy = + try + UnifyTypes cenv env m expectedTy actualTy + with e -> + errorRecovery e m + /// Make an environment suitable for a module or namespace. Does not create a new accumulator but uses one we already have/ let MakeInnerEnvWithAcc addOpenToNameEnv env nm mtypeAcc modKind = let path = env.ePath @ [nm] @@ -515,7 +563,6 @@ let LocateEnv ccu env enclosingNamespacePath = let env = { env with eNameResEnv = { env.NameEnv with eDisplayEnv = env.DisplayEnv.AddOpenPath (pathOfLid env.ePath) } } env - //------------------------------------------------------------------------- // Helpers for unification //------------------------------------------------------------------------- @@ -745,7 +792,7 @@ let rec TcSynRationalConst c = | SynRationalConst.Rational(p, q, _) -> DivRational (intToRational p) (intToRational q) /// Typecheck constant terms in expressions and patterns -let TcConst cenv ty m env c = +let TcConst cenv (overallTy: TType) m env c = let rec tcMeasure ms = match ms with | SynMeasure.One -> Measure.One @@ -767,7 +814,7 @@ let TcConst cenv ty m env c = | SynMeasure.Anon _ -> error(Error(FSComp.SR.tcUnexpectedMeasureAnon(), m)) | SynMeasure.Var(_, m) -> error(Error(FSComp.SR.tcNonZeroConstantCannotHaveGenericUnit(), m)) - let unif expected = UnifyTypes cenv env m ty expected + let unif expected = UnifyTypes cenv env m overallTy expected let unifyMeasureArg iszero tcr c = let measureTy = @@ -2907,7 +2954,7 @@ let TryFindIntrinsicOrExtensionMethInfo collectionSettings (cenv: cenv) (env: Tc AllMethInfosOfTypeInScope collectionSettings cenv.infoReader env.NameEnv (Some nm) ad IgnoreOverrides m ty let TryFindFSharpSignatureInstanceGetterProperty (cenv: cenv) (env: TcEnv) m nm ty (sigTys: TType list) = - TryFindPropInfo cenv.infoReader m env.AccessRights nm ty + TryFindIntrinsicPropInfo cenv.infoReader m env.AccessRights nm ty |> List.tryFind (fun propInfo -> not propInfo.IsStatic && propInfo.HasGetter && ( @@ -4256,8 +4303,12 @@ and TcTypeOrMeasure optKind cenv newOk checkCxs occ env (tpenv: UnscopedTyparEnv let item = Item.AnonRecdField(anonInfo, sortedCheckedArgTys, i, x.idRange) CallNameResolutionSink cenv.tcSink (x.idRange,env.NameEnv,item,emptyTyparInst,ItemOccurence.UseInType,env.eAccessRights)) TType_anon(anonInfo, sortedCheckedArgTys),tpenv + + | SynType.ErasedUnion(synCases, m) -> + checkLanguageFeatureError cenv.g.langVersion LanguageFeature.ErasedUnions m + TcErasedUnionTypeOr cenv env tpenv synCases m - | SynType.Fun(domainTy, resultTy, _) -> + | SynType.Fun(domainTy, resultTy, _) -> let domainTy', tpenv = TcTypeAndRecover cenv newOk checkCxs occ env tpenv domainTy let resultTy', tpenv = TcTypeAndRecover cenv newOk checkCxs occ env tpenv resultTy (domainTy' --> resultTy'), tpenv @@ -4345,6 +4396,59 @@ and TcTypeOrMeasure optKind cenv newOk checkCxs occ env (tpenv: UnscopedTyparEnv | SynType.Paren(innerType, _) -> TcTypeOrMeasure optKind cenv newOk checkCxs occ env (tpenv: UnscopedTyparEnv) innerType +and TcErasedUnionTypeOr (cenv: cenv) env (tpenv: UnscopedTyparEnv) synCases m = + let g = cenv.g + // Helper method for eliminating duplicate types from lists of types that form a union type, + // create a disjoint set of cases + // taking into account that a subtype is a "duplicate" of its supertype. + let rec addToCases (pt: TType) (list: ResizeArray) = + if not (ResizeArray.exists (isObjTy g) list) then + if isObjTy g pt then + list.Clear() + list.Add(pt) + elif isErasedUnionTy g pt then + let otherUnsortedCases = tryUnsortedErasedUnionTyCases g pt |> ValueOption.defaultValue [] + for otherCase in otherUnsortedCases + do addToCases otherCase list + else + let mutable shouldAdd = true + let mutable i = 0 + while i < list.Count && shouldAdd do + let t = list.[i] + if isSubTypeOf cenv.g cenv.amap m pt t then + shouldAdd <- false + elif isSuperTypeOf cenv.g cenv.amap m pt t then + list.RemoveAt(i) + i <- i - 1 // redo this index + i <- i + 1 + if shouldAdd then list.Add pt + + let createDisjointTypes synErasedUnionCases = + let unionTypeCases = ResizeArray() + do + synErasedUnionCases + |> List.map(fun (SynErasedUnionCase(typ=ty)) -> TcTypeAndRecover cenv NoNewTypars CheckCxs ItemOccurence.UseInType env tpenv ty |> fst) + |> List.iter (fun ty -> addToCases ty unionTypeCases) + ResizeArray.toList unionTypeCases + + let getCommonAncestorOfTys g amap tys = + let superTypes = tys |> List.map (AllPrimarySuperTypesOfType g amap m AllowMultiIntfInstantiations.No) + List.fold (ListSet.intersect (typeEquiv g)) (List.head superTypes) (List.tail superTypes) |> List.head + + // Sort into order for ordered equality + let sortedIndexedErasedUnionCases = + createDisjointTypes synCases + |> List.indexed + |> List.sortBy (snd >> stripTyEqnsAndMeasureEqns g >> string) + + // Map from sorted indexes to unsorted index + let sigma = List.map fst sortedIndexedErasedUnionCases |> List.toArray + let sortedErasedUnionCases = List.map snd sortedIndexedErasedUnionCases + let commonAncestorTy = getCommonAncestorOfTys g cenv.amap sortedErasedUnionCases + + let erasedUnionInfo = ErasedUnionInfo.Create(commonAncestorTy, sigma) + TType_erased_union(erasedUnionInfo, sortedErasedUnionCases), tpenv + and TcType cenv newOk checkCxs occ env (tpenv: UnscopedTyparEnv) ty = TcTypeOrMeasure (Some TyparKind.Type) cenv newOk checkCxs occ env tpenv ty @@ -4440,7 +4544,7 @@ and TcStaticConstantParameter cenv (env: TcEnv) tpenv kind (StripParenTypes v) i | SynType.StaticConstantExpr(e, _ ) -> // If an error occurs, don't try to recover, since the constant expression will be nothing like what we need - let te, tpenv' = TcExprNoRecover cenv kind env tpenv e + let te, tpenv' = TcExprNoRecover cenv (MustEqual kind) env tpenv e // Evaluate the constant expression using static attribute argument rules let te = EvalLiteralExprOrAttribArg g te @@ -5012,7 +5116,7 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty p let activePatType = apinfo.OverallType cenv.g m ty activePatResTys isStructRetTy let delayed = activePatArgsAsSynExprs |> List.map (fun arg -> DelayedApp(ExprAtomicFlag.NonAtomic, arg, unionRanges (rangeOfLid longId) arg.Range)) - let activePatExpr, tpenv = PropagateThenTcDelayed cenv activePatType env tpenv m vexp vexpty ExprAtomicFlag.NonAtomic delayed + let activePatExpr, tpenv = PropagateThenTcDelayed cenv (MustEqual activePatType) env tpenv m vexp vexpty ExprAtomicFlag.NonAtomic delayed if idx >= activePatResTys.Length then error(Error(FSComp.SR.tcInvalidIndexIntoActivePatternArray(), m)) let argty = List.item idx activePatResTys @@ -5275,31 +5379,27 @@ and RecordNameAndTypeResolutions_IdeallyWithoutHavingOtherEffects_Delayed cenv e | _ -> () dummyCheckedDelayed delayed -// Calls UnifyTypes, but upon error only does the minimal error recovery -// so that IntelliSense information can continue to be collected. -and UnifyTypesAndRecover cenv env m expectedTy actualTy = - try - UnifyTypes cenv env m expectedTy actualTy - with e -> - errorRecovery e m - and TcExprOfUnknownType cenv env tpenv expr = let exprty = NewInferenceType () - let expr', tpenv = TcExpr cenv exprty env tpenv expr + let expr', tpenv = TcExpr cenv (MustEqual exprty) env tpenv expr expr', exprty, tpenv -and TcExprFlex cenv flex compat ty (env: TcEnv) tpenv (e: SynExpr) = +and TcExprFlex cenv flex compat (desiredTy: TType) (env: TcEnv) tpenv (synExpr: SynExpr) = + // This is the old way of introducing flexibility via subtype constraints, still active + // for compat reasons. if flex then let argty = NewInferenceType () if compat then (destTyparTy cenv.g argty).SetIsCompatFlex(true) - AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css e.Range NoTrace ty argty - let e', tpenv = TcExpr cenv argty env tpenv e - let e' = mkCoerceIfNeeded cenv.g ty argty e' - e', tpenv + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css synExpr.Range NoTrace desiredTy argty + let expr2, tpenv = TcExprFlex2 cenv argty env false tpenv synExpr + let expr3 = mkCoerceIfNeeded cenv.g desiredTy argty expr2 + expr3, tpenv else - TcExpr cenv ty env tpenv e + TcExprFlex2 cenv desiredTy env false tpenv synExpr +and TcExprFlex2 cenv desiredTy env isMethodArg tpenv synExpr = + TcExpr cenv (MustConvertTo (isMethodArg, desiredTy)) env tpenv synExpr and TcExpr cenv ty (env: TcEnv) tpenv (expr: SynExpr) = // Start an error recovery handler @@ -5312,10 +5412,10 @@ and TcExpr cenv ty (env: TcEnv) tpenv (expr: SynExpr) = // Error recovery - return some rubbish expression, but replace/annotate // the type of the current expression with a type variable that indicates an error errorRecovery e m - solveTypAsError cenv env.DisplayEnv m ty - mkThrow m ty (mkOne cenv.g m), tpenv + solveTypAsError cenv env.DisplayEnv m ty.Commit + mkThrow m ty.Commit (mkOne cenv.g m), tpenv -and TcExprNoRecover cenv ty (env: TcEnv) tpenv (expr: SynExpr) = +and TcExprNoRecover cenv (ty: OverallTy) (env: TcEnv) tpenv (expr: SynExpr) = // Count our way through the expression shape that makes up an object constructor // See notes at definition of "ctor" re. object model constructors. @@ -5325,7 +5425,6 @@ and TcExprNoRecover cenv ty (env: TcEnv) tpenv (expr: SynExpr) = TcExprThen cenv ty env tpenv expr [] - // This recursive entry is only used from one callsite (DiscardAfterMissingQualificationAfterDot) // and has been added relatively late in F# 4.0 to preserve the structure of previous code. It pushes a 'delayed' parameter // through TcExprOfUnknownType, TcExpr and TcExprNoRecover @@ -5333,7 +5432,7 @@ and TcExprOfUnknownTypeThen cenv env tpenv expr delayed = let exprty = NewInferenceType () let expr', tpenv = try - TcExprThen cenv exprty env tpenv expr delayed + TcExprThen cenv (MustEqual exprty) env tpenv expr delayed with e -> let m = expr.Range errorRecovery e m @@ -5382,7 +5481,7 @@ and TryTcStmt cenv env tpenv synExpr = /// During checking of expressions of the form (x(y)).z(w1, w2) /// keep a stack of things on the right. This lets us recognize /// method applications and other item-based syntax. -and TcExprThen cenv overallTy env tpenv synExpr delayed = +and TcExprThen cenv (overallTy: OverallTy) env tpenv synExpr delayed = match synExpr with | LongOrSingleIdent (isOpt, longId, altNameRefCellOpt, mLongId) -> @@ -5425,7 +5524,7 @@ and TcExprThen cenv overallTy env tpenv synExpr delayed = let expr, exprty, tpenv = TcExprUndelayedNoType cenv env tpenv synExpr PropagateThenTcDelayed cenv overallTy env tpenv synExpr.Range (MakeApplicableExprNoFlex cenv expr) exprty ExprAtomicFlag.NonAtomic delayed -and TcExprs cenv env m tpenv flexes argTys args = +and TcExprsWithFlexes cenv env m tpenv flexes argTys args = if List.length args <> List.length argTys then error(Error(FSComp.SR.tcExpressionCountMisMatch((List.length argTys), (List.length args)), m)) (tpenv, List.zip3 flexes argTys args) ||> List.mapFold (fun tpenv (flex, ty, e) -> TcExprFlex cenv flex false ty env tpenv e) @@ -5443,16 +5542,101 @@ and CheckSuperInit cenv objTy m = and TcExprUndelayedNoType cenv env tpenv synExpr: Expr * TType * _ = let overallTy = NewInferenceType () - let expr, tpenv = TcExprUndelayed cenv overallTy env tpenv synExpr + let expr, tpenv = TcExprUndelayed cenv (MustEqual overallTy) env tpenv synExpr expr, overallTy, tpenv -and TcExprUndelayed cenv overallTy env tpenv (synExpr: SynExpr) = +/// Process a leaf construct where the actual type (or an approximation of it such as 'list<_>' +/// or 'array<_>') is already sufficiently pre-known, and the information in the overall type +/// can be eagerly propagated into the actual type (UnifyOverallType), including pre-calculating +/// any type-directed conversion. This must mean that types extracted when processing the expression are not +/// considered in determining any type-directed conversion. +/// +/// Used for: +/// - Array or List expressions (both computed and fixed-size), to propagate from the overall type into the array/list type +/// e.g. to infer element types, which may be relevant to processing each individual expression and the 'yield' +/// returns. +/// +/// - 'new ABC<_>(args)' expressions, to propagate from the overall type into the 'ABC<_>' type, e.g. to infer type parameters, +/// which may be relevant to checking the arguments. +/// +/// - object expressions '{ new ABC<_>(args) with ... }', to propagate from the overall type into the +/// object type, e.g. to infer type parameters, which may be relevant to checking the arguments and +/// methods of the object expression. +/// +/// - string literal expressions (though the propagation is not essential in this case) +/// +and TcPropagatingExprLeafThenConvert cenv overallTy actualTy (env: TcEnv) (* canAdhoc *) m (f: unit -> Expr * UnscopedTyparEnv) = + match overallTy with + | MustConvertTo _ when cenv.g.langVersion.SupportsFeature LanguageFeature.AdditionalTypeDirectedConversions -> + assert (cenv.g.langVersion.SupportsFeature LanguageFeature.AdditionalTypeDirectedConversions) + //if not canAdhoc then + // AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m NoTrace reqdTy actualTy + // Compute the conversion _before_ processing the construct. We know enough to process this conversion eagerly. + UnifyOverallType cenv env m overallTy actualTy + // Process the construct + let expr, tpenv = f () + // Build the conversion + let expr2 = TcAdjustExprForTypeDirectedConversions cenv overallTy actualTy env (* canAdhoc *) m expr + expr2, tpenv + | _ -> + UnifyTypes cenv env m overallTy.Commit actualTy + f () + +/// Process a leaf construct, for cases where we propogate the overall type eagerly in +/// some cases. Then apply additional type-directed conversions. +/// +/// However in some cases favour propagating characteristics of the overall type. +/// +/// 'isPropagating' indicates if propagation occurs +/// 'processExpr' does the actual processing of the construct. +/// +/// Used for +/// - tuple (exception is if overallTy is a tuple type, used to propagate structness from known type) +/// - anon record (exception is if overallTy is an anon record type, similarly) +/// - record (exception is (fun ty -> requiresCtor || haveCtor || isRecdTy cenv.g ty), similarly) +and TcPossiblyPropogatingExprLeafThenConvert isPropagating cenv (overallTy: OverallTy) (env: TcEnv) m processExpr = + match overallTy with + | MustConvertTo(_, reqdTy) when cenv.g.langVersion.SupportsFeature LanguageFeature.AdditionalTypeDirectedConversions && not (isPropagating reqdTy) -> + TcNonPropagatingExprLeafThenConvert cenv overallTy env m (fun () -> + let exprTy = NewInferenceType() + // Here 'processExpr' will do the unification with exprTy. + let expr, tpenv = processExpr exprTy + expr, exprTy, tpenv) + | _ -> + // Here 'processExpr' will do the unification with the overall type. + processExpr overallTy.Commit + +/// Process a leaf construct where the processing of the construct is initially independent +/// of the overall type. Determine and apply additional type-directed conversions after the processing +/// is complete, as the inferred type of the expression may enable a type-directed conversion. +/// +/// Used for: +/// - trait call +/// - LibraryOnlyUnionCaseFieldGet +/// - constants +and TcNonPropagatingExprLeafThenConvert cenv (overallTy: OverallTy) (env: TcEnv) m processExpr = + // Process the construct + let expr, exprTy, tpenv = processExpr () + // Now compute the conversion, based on the post-processing type + UnifyOverallType cenv env m overallTy exprTy + let expr2 = TcAdjustExprForTypeDirectedConversions cenv overallTy exprTy env (* true *) m expr + expr2, tpenv + +and TcAdjustExprForTypeDirectedConversions cenv (overallTy: OverallTy) actualTy (env: TcEnv) (* canAdhoc *) m expr = + match overallTy with + | MustConvertTo (_, reqdTy) when cenv.g.langVersion.SupportsFeature LanguageFeature.AdditionalTypeDirectedConversions -> + let tcVal = LightweightTcValForUsingInBuildMethodCall cenv.g + AdjustExprForTypeDirectedConversions tcVal cenv.g cenv.amap cenv.infoReader env.AccessRights reqdTy actualTy m expr + | _ -> + expr + +and TcExprUndelayed cenv (overallTy: OverallTy) env tpenv (synExpr: SynExpr) = match synExpr with | SynExpr.Paren (expr2, _, _, mWholeExprIncludingParentheses) -> // We invoke CallExprHasTypeSink for every construct which is atomic in the syntax, i.e. where a '.' immediately following the // construct is a dot-lookup for the result of the construct. - CallExprHasTypeSink cenv.tcSink (mWholeExprIncludingParentheses, env.NameEnv, overallTy, env.AccessRights) + CallExprHasTypeSink cenv.tcSink (mWholeExprIncludingParentheses, env.NameEnv, overallTy.Commit, env.AccessRights) let env = ShrinkContext env mWholeExprIncludingParentheses expr2.Range TcExpr cenv overallTy env tpenv expr2 @@ -5460,18 +5644,18 @@ and TcExprUndelayed cenv overallTy env tpenv (synExpr: SynExpr) = | SynExpr.TypeApp _ | SynExpr.Ident _ | SynExpr.LongIdent _ | SynExpr.App _ | SynExpr.DotGet _ -> error(Error(FSComp.SR.tcExprUndelayed(), synExpr.Range)) | SynExpr.Const (SynConst.String (s, _, m), _) -> - CallExprHasTypeSink cenv.tcSink (m, env.NameEnv, overallTy, env.AccessRights) + CallExprHasTypeSink cenv.tcSink (m, env.NameEnv, overallTy.Commit, env.AccessRights) TcConstStringExpr cenv overallTy env m tpenv s | SynExpr.InterpolatedString (parts, _, m) -> checkLanguageFeatureError cenv.g.langVersion LanguageFeature.StringInterpolation m - CallExprHasTypeSink cenv.tcSink (m, env.NameEnv, overallTy, env.AccessRights) + CallExprHasTypeSink cenv.tcSink (m, env.NameEnv, overallTy.Commit, env.AccessRights) TcInterpolatedStringExpr cenv overallTy env m tpenv parts | SynExpr.Const (synConst, m) -> - CallExprHasTypeSink cenv.tcSink (m, env.NameEnv, overallTy, env.AccessRights) + CallExprHasTypeSink cenv.tcSink (m, env.NameEnv, overallTy.Commit, env.AccessRights) TcConstExpr cenv overallTy env m tpenv synConst | SynExpr.Lambda _ -> @@ -5497,10 +5681,10 @@ and TcExprUndelayed cenv overallTy env tpenv (synExpr: SynExpr) = | SynExpr.MatchLambda (isExnMatch, mArg, clauses, spMatch, m) -> - let domainTy, resultTy = UnifyFunctionType None cenv env.DisplayEnv m overallTy + let domainTy, resultTy = UnifyFunctionType None cenv env.DisplayEnv m overallTy.Commit let idv1, idve1 = mkCompGenLocal mArg (cenv.synArgNameGenerator.New()) domainTy let envinner = ExitFamilyRegion env - let idv2, matchExpr, tpenv = TcAndPatternCompileMatchClauses m mArg (if isExnMatch then Throw else ThrowIncompleteMatchException) cenv None domainTy resultTy envinner tpenv clauses + let idv2, matchExpr, tpenv = TcAndPatternCompileMatchClauses m mArg (if isExnMatch then Throw else ThrowIncompleteMatchException) cenv None domainTy (MustConvertTo (false, resultTy)) envinner tpenv clauses let overallExpr = mkMultiLambda m [idv1] ((mkLet spMatch m idv2 idve1 matchExpr), resultTy) overallExpr, tpenv @@ -5513,14 +5697,15 @@ and TcExprUndelayed cenv overallTy env tpenv (synExpr: SynExpr) = // e: ty | SynExpr.Typed (synBodyExpr, synType, m) -> let tgtTy, tpenv = TcTypeAndRecover cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv synType - UnifyTypes cenv env m overallTy tgtTy - let expr, tpenv = TcExpr cenv overallTy env tpenv synBodyExpr - expr, tpenv + UnifyOverallType cenv env m overallTy tgtTy + let bodyExpr, tpenv = TcExpr cenv (MustConvertTo (false, tgtTy)) env tpenv synBodyExpr + let bodyExpr2 = TcAdjustExprForTypeDirectedConversions cenv overallTy tgtTy env (* true *) m bodyExpr + bodyExpr2, tpenv // e :? ty | SynExpr.TypeTest (synInnerExpr, tgtTy, m) -> let innerExpr, srcTy, tpenv = TcExprOfUnknownType cenv env tpenv synInnerExpr - UnifyTypes cenv env m overallTy cenv.g.bool_ty + UnifyTypes cenv env m overallTy.Commit cenv.g.bool_ty let tgtTy, tpenv = TcType cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv tgtTy TcRuntimeTypeTest (*isCast*)false (*isOperator*)true cenv env.DisplayEnv m tgtTy srcTy let expr = mkCallTypeTest cenv.g m tgtTy innerExpr @@ -5538,10 +5723,10 @@ and TcExprUndelayed cenv overallTy env tpenv (synExpr: SynExpr) = match synExpr with | SynExpr.Upcast (_, tgtTy, m) -> let tgtTy, tpenv = TcType cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv tgtTy - UnifyTypes cenv env m tgtTy overallTy + UnifyTypes cenv env m tgtTy overallTy.Commit tgtTy, tpenv | SynExpr.InferredUpcast _ -> - overallTy, tpenv + overallTy.Commit, tpenv | _ -> failwith "upcast" TcStaticUpcast cenv env.DisplayEnv m tgtTy srcTy let expr = mkCoerceExpr(innerExpr, tgtTy, m, srcTy) @@ -5553,9 +5738,9 @@ and TcExprUndelayed cenv overallTy env tpenv (synExpr: SynExpr) = match synExpr with | SynExpr.Downcast (_, tgtTy, m) -> let tgtTy, tpenv = TcType cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv tgtTy - UnifyTypes cenv env m tgtTy overallTy + UnifyTypes cenv env m tgtTy overallTy.Commit tgtTy, tpenv, true - | SynExpr.InferredDowncast _ -> overallTy, tpenv, false + | SynExpr.InferredDowncast _ -> overallTy.Commit, tpenv, false | _ -> failwith "downcast" TcRuntimeTypeTest (*isCast*)true isOperator cenv env.DisplayEnv m tgtTy srcTy @@ -5565,32 +5750,42 @@ and TcExprUndelayed cenv overallTy env tpenv (synExpr: SynExpr) = expr, tpenv | SynExpr.Null m -> - AddCxTypeMustSupportNull env.DisplayEnv cenv.css m NoTrace overallTy - mkNull m overallTy, tpenv + AddCxTypeMustSupportNull env.DisplayEnv cenv.css m NoTrace overallTy.Commit + mkNull m overallTy.Commit, tpenv | SynExpr.Lazy (synInnerExpr, m) -> let innerTy = NewInferenceType () - UnifyTypes cenv env m overallTy (mkLazyTy cenv.g innerTy) - let innerExpr, tpenv = TcExpr cenv innerTy env tpenv synInnerExpr + UnifyTypes cenv env m overallTy.Commit (mkLazyTy cenv.g innerTy) + let innerExpr, tpenv = TcExpr cenv (MustEqual innerTy) env tpenv synInnerExpr let expr = mkLazyDelayed cenv.g m innerTy (mkUnitDelayLambda cenv.g m innerExpr) expr, tpenv | SynExpr.Tuple (isExplicitStruct, args, _, m) -> - let tupInfo, argTys = UnifyTupleTypeAndInferCharacteristics env.eContextInfo cenv env.DisplayEnv m overallTy isExplicitStruct args - // No subsumption at tuple construction - let flexes = argTys |> List.map (fun _ -> false) - let args', tpenv = TcExprs cenv env m tpenv flexes argTys args - let expr = mkAnyTupled cenv.g m tupInfo args' argTys - expr, tpenv + TcPossiblyPropogatingExprLeafThenConvert (isAnyTupleTy cenv.g) cenv overallTy env m (fun overallTy -> + let tupInfo, argTys = UnifyTupleTypeAndInferCharacteristics env.eContextInfo cenv env.DisplayEnv m overallTy isExplicitStruct args + + let flexes = argTys |> List.map (fun _ -> false) + let args', tpenv = TcExprsWithFlexes cenv env m tpenv flexes argTys args + let expr = mkAnyTupled cenv.g m tupInfo args' argTys + expr, tpenv + ) | SynExpr.AnonRecd (isStruct, optOrigExpr, unsortedFieldExprs, mWholeExpr) -> - TcAnonRecdExpr cenv overallTy env tpenv (isStruct, optOrigExpr, unsortedFieldExprs, mWholeExpr) + TcPossiblyPropogatingExprLeafThenConvert (isAnonRecdTy cenv.g) cenv overallTy env mWholeExpr (fun overallTy -> + TcAnonRecdExpr cenv overallTy env tpenv (isStruct, optOrigExpr, unsortedFieldExprs, mWholeExpr) + ) | SynExpr.ArrayOrList (isArray, args, m) -> - CallExprHasTypeSink cenv.tcSink (m, env.NameEnv, overallTy, env.AccessRights) + CallExprHasTypeSink cenv.tcSink (m, env.NameEnv, overallTy.Commit, env.AccessRights) + let argty = NewInferenceType () + let actualTy = if isArray then mkArrayType cenv.g argty else mkListTy cenv.g argty - let argty = NewInferenceType () - UnifyTypes cenv env m overallTy (if isArray then mkArrayType cenv.g argty else mkListTy cenv.g argty) + // Propagating type directed conversion, e.g. for + // let x : seq = [ 1; 2 ] + // Consider also the case where there is no relation but an op_Implicit is enabled from List<_> to C + // let x : C = [ B(); B() ] + + TcPropagatingExprLeafThenConvert cenv overallTy actualTy env (* canAdhoc *) m (fun () -> // Always allow subsumption if a nominal type is known prior to type checking any arguments let flex = not (isTyparTy cenv.g argty) @@ -5608,30 +5803,65 @@ and TcExprUndelayed cenv overallTy env tpenv (synExpr: SynExpr) = if isArray then Expr.Op (TOp.Array, [argty], args', m) else List.foldBack (mkCons cenv.g argty) args' (mkNil cenv.g m argty) expr, tpenv + ) | SynExpr.New (superInit, synObjTy, arg, mNewExpr) -> - let objTy, tpenv = TcType cenv NewTyparsOK CheckCxs ItemOccurence.Use env tpenv synObjTy - UnifyTypes cenv env mNewExpr overallTy objTy + let objTy, tpenv = TcType cenv NewTyparsOK CheckCxs ItemOccurence.Use env tpenv synObjTy + + TcPropagatingExprLeafThenConvert cenv overallTy objTy env (* true *) mNewExpr (fun () -> TcNewExpr cenv env tpenv objTy (Some synObjTy.Range) superInit arg mNewExpr + ) + + | SynExpr.ObjExpr (synObjTy, argopt, binds, extraImpls, mNewExpr, m) -> + CallExprHasTypeSink cenv.tcSink (m, env.NameEnv, overallTy.Commit, env.eAccessRights) + + // Note, allowing canAdhoc = true would disable subtype-based propagation from overallTy into checking of structure + // + // For example + // let x : A seq = { new Collection<_> with ... the element type should be known in here! } + // + // So op_Implicit is effectively disabled for direct uses of object expressions + //let canAdhoc = false + + let mObjTy = synObjTy.Range + + let objTy, tpenv = TcType cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv synObjTy - | SynExpr.ObjExpr (objTy, argopt, binds, extraImpls, mNewExpr, m) -> - CallExprHasTypeSink cenv.tcSink (m, env.NameEnv, overallTy, env.eAccessRights) - TcObjectExpr cenv overallTy env tpenv (objTy, argopt, binds, extraImpls, mNewExpr, m) + // Work out the type of any interfaces to implement + let extraImpls, tpenv = + (tpenv, extraImpls) ||> List.mapFold (fun tpenv (SynInterfaceImpl(synIntfTy, overrides, m)) -> + let intfTy, tpenv = TcType cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv synIntfTy + if not (isInterfaceTy cenv.g intfTy) then + error(Error(FSComp.SR.tcExpectedInterfaceType(), m)) + if isErasedType cenv.g intfTy then + errorR(Error(FSComp.SR.tcCannotInheritFromErasedType(), m)) + (m, intfTy, overrides), tpenv) + + let realObjTy = if isObjTy cenv.g objTy && not (isNil extraImpls) then (p23 (List.head extraImpls)) else objTy + + TcPropagatingExprLeafThenConvert cenv overallTy realObjTy env (* canAdhoc *) m (fun () -> + TcObjectExpr cenv env tpenv (objTy, realObjTy, argopt, binds, extraImpls, mObjTy, mNewExpr, m) + ) | SynExpr.Record (inherits, optOrigExpr, flds, mWholeExpr) -> - CallExprHasTypeSink cenv.tcSink (mWholeExpr, env.NameEnv, overallTy, env.AccessRights) + + CallExprHasTypeSink cenv.tcSink (mWholeExpr, env.NameEnv, overallTy.Commit, env.AccessRights) + let requiresCtor = (GetCtorShapeCounter env = 1) // Get special expression forms for constructors + let haveCtor = Option.isSome inherits + TcPossiblyPropogatingExprLeafThenConvert (fun ty -> requiresCtor || haveCtor || isRecdTy cenv.g ty) cenv overallTy env mWholeExpr (fun overallTy -> TcRecdExpr cenv overallTy env tpenv (inherits, optOrigExpr, flds, mWholeExpr) + ) | SynExpr.While (spWhile, synGuardExpr, synBodyExpr, m) -> - UnifyTypes cenv env m overallTy cenv.g.unit_ty - let guardExpr, tpenv = TcExpr cenv cenv.g.bool_ty env tpenv synGuardExpr + UnifyTypes cenv env m overallTy.Commit cenv.g.unit_ty + let guardExpr, tpenv = TcExpr cenv (MustEqual cenv.g.bool_ty) env tpenv synGuardExpr let bodyExpr, tpenv = TcStmt cenv env tpenv synBodyExpr mkWhile cenv.g (spWhile, NoSpecialWhileLoopMarker, guardExpr, bodyExpr, m), tpenv | SynExpr.For (spBind, id, start, dir, finish, body, m) -> - UnifyTypes cenv env m overallTy cenv.g.unit_ty - let startExpr, tpenv = TcExpr cenv cenv.g.int_ty env tpenv start - let finishExpr, tpenv = TcExpr cenv cenv.g.int_ty env tpenv finish + UnifyTypes cenv env m overallTy.Commit cenv.g.unit_ty + let startExpr, tpenv = TcExpr cenv (MustEqual cenv.g.int_ty) env tpenv start + let finishExpr, tpenv = TcExpr cenv (MustEqual cenv.g.int_ty) env tpenv finish let idv, _ = mkLocal id.idRange id.idText cenv.g.int_ty let envinner = AddLocalVal cenv.g cenv.tcSink m idv env @@ -5652,7 +5882,7 @@ and TcExprUndelayed cenv overallTy env tpenv (synExpr: SynExpr) = cenv.TcSequenceExpressionEntry cenv env overallTy tpenv (isArrayOrList, isNotNakedRefCell, comp) m | SynExpr.ArrayOrListOfSeqExpr (isArray, comp, m) -> - CallExprHasTypeSink cenv.tcSink (m, env.NameEnv, overallTy, env.eAccessRights) + CallExprHasTypeSink cenv.tcSink (m, env.NameEnv, overallTy.Commit, env.eAccessRights) cenv.TcArrayOrListSequenceExpression cenv env overallTy tpenv (isArray, comp) m | SynExpr.LetOrUse _ -> @@ -5662,36 +5892,35 @@ and TcExprUndelayed cenv overallTy env tpenv (synExpr: SynExpr) = let bodyExpr, tpenv = TcExpr cenv overallTy env tpenv synBodyExpr // Compile the pattern twice, once as a List.filter with all succeeding targets returning "1", and once as a proper catch block. let filterClauses = synWithClauses |> List.map (function SynMatchClause(pat, optWhenExpr, _, m, _) -> SynMatchClause(pat, optWhenExpr, (SynExpr.Const (SynConst.Int32 1, m)), m, DebugPointForTarget.No)) - let checkedFilterClauses, tpenv = TcMatchClauses cenv cenv.g.exn_ty cenv.g.int_ty env tpenv filterClauses + let checkedFilterClauses, tpenv = TcMatchClauses cenv cenv.g.exn_ty (MustEqual cenv.g.int_ty) env tpenv filterClauses let checkedHandlerClauses, tpenv = TcMatchClauses cenv cenv.g.exn_ty overallTy env tpenv synWithClauses let v1, filterExpr = CompilePatternForMatchClauses cenv env mWithToLast mWithToLast true FailFilter None cenv.g.exn_ty cenv.g.int_ty checkedFilterClauses - let v2, handlerExpr = CompilePatternForMatchClauses cenv env mWithToLast mWithToLast true Rethrow None cenv.g.exn_ty overallTy checkedHandlerClauses - mkTryWith cenv.g (bodyExpr, v1, filterExpr, v2, handlerExpr, mTryToLast, overallTy, spTry, spWith), tpenv + let v2, handlerExpr = CompilePatternForMatchClauses cenv env mWithToLast mWithToLast true Rethrow None cenv.g.exn_ty overallTy.Commit checkedHandlerClauses + mkTryWith cenv.g (bodyExpr, v1, filterExpr, v2, handlerExpr, mTryToLast, overallTy.Commit, spTry, spWith), tpenv | SynExpr.TryFinally (synBodyExpr, synFinallyExpr, mTryToLast, spTry, spFinally) -> let bodyExpr, tpenv = TcExpr cenv overallTy env tpenv synBodyExpr let finallyExpr, tpenv = TcStmt cenv env tpenv synFinallyExpr - mkTryFinally cenv.g (bodyExpr, finallyExpr, mTryToLast, overallTy, spTry, spFinally), tpenv + mkTryFinally cenv.g (bodyExpr, finallyExpr, mTryToLast, overallTy.Commit, spTry, spFinally), tpenv | SynExpr.JoinIn (e1, mInToken, e2, mAll) -> errorR(Error(FSComp.SR.parsUnfinishedExpression("in"), mInToken)) let _, _, tpenv = suppressErrorReporting (fun () -> TcExprOfUnknownType cenv env tpenv e1) let _, _, tpenv = suppressErrorReporting (fun () -> TcExprOfUnknownType cenv env tpenv e2) - mkDefault(mAll, overallTy), tpenv + mkDefault(mAll, overallTy.Commit), tpenv | SynExpr.ArbitraryAfterError (_debugStr, m) -> //solveTypAsError cenv env.DisplayEnv m overallTy - mkDefault(m, overallTy), tpenv + mkDefault(m, overallTy.Commit), tpenv - // expr. (already reported as an error) | SynExpr.DiscardAfterMissingQualificationAfterDot (e1, m) -> let _, _, tpenv = suppressErrorReporting (fun () -> TcExprOfUnknownTypeThen cenv env tpenv e1 [DelayedDot]) - mkDefault(m, overallTy), tpenv + mkDefault(m, overallTy.Commit), tpenv | SynExpr.FromParseError (e1, m) -> //solveTypAsError cenv env.DisplayEnv m overallTy let _, tpenv = suppressErrorReporting (fun () -> TcExpr cenv overallTy env tpenv e1) - mkDefault(m, overallTy), tpenv + mkDefault(m, overallTy.Commit), tpenv | SynExpr.Sequential (sp, dir, synExpr1, synExpr2, m) -> if dir then @@ -5718,7 +5947,7 @@ and TcExprUndelayed cenv overallTy env tpenv (synExpr: SynExpr) = TcExpr cenv overallTy env tpenv otherExpr | SynExpr.Do (synInnerExpr, m) -> - UnifyTypes cenv env m overallTy cenv.g.unit_ty + UnifyTypes cenv env m overallTy.Commit cenv.g.unit_ty TcStmtThatCantBeCtorBody cenv env tpenv synInnerExpr | SynExpr.IfThenElse _ -> @@ -5773,6 +6002,7 @@ and TcExprUndelayed cenv overallTy env tpenv (synExpr: SynExpr) = TcLongIdentThen cenv overallTy env tpenv lidwd [ DelayedApp(ExprAtomicFlag.Atomic, e1, mStmt); MakeDelayedSet(e2, mStmt) ] | SynExpr.TraitCall (tps, memSpfn, arg, m) -> + TcNonPropagatingExprLeafThenConvert cenv overallTy env m (fun () -> let synTypes = tps |> List.map (fun tp -> SynType.Var(tp, m)) let traitInfo, tpenv = TcPseudoMemberSpec cenv NewTyparsOK env synTypes tpenv memSpfn m if BakedInTraitConstraintNames.Contains traitInfo.MemberName then @@ -5784,21 +6014,22 @@ and TcExprUndelayed cenv overallTy env tpenv (synExpr: SynExpr) = if not (isNil namedCallerArgs) then errorR(Error(FSComp.SR.tcNamedArgumentsCannotBeUsedInMemberTraits(), m)) // Subsumption at trait calls if arguments have nominal type prior to unification of any arguments or return type let flexes = argTys |> List.map (isTyparTy cenv.g >> not) - let args', tpenv = TcExprs cenv env m tpenv flexes argTys args + let args', tpenv = TcExprsWithFlexes cenv env m tpenv flexes argTys args AddCxMethodConstraint env.DisplayEnv cenv.css m NoTrace traitInfo - UnifyTypes cenv env m overallTy returnTy - Expr.Op (TOp.TraitCall traitInfo, [], args', m), tpenv + Expr.Op (TOp.TraitCall traitInfo, [], args', m), returnTy, tpenv + ) | SynExpr.LibraryOnlyUnionCaseFieldGet (e1, c, n, m) -> + TcNonPropagatingExprLeafThenConvert cenv overallTy env m (fun () -> let e1', ty1, tpenv = TcExprOfUnknownType cenv env tpenv e1 let mkf, ty2 = TcUnionCaseOrExnField cenv env ty1 m c n ((fun (a, b) n -> mkUnionCaseFieldGetUnproven cenv.g (e1', a, b, n, m)), (fun a n -> mkExnCaseFieldGet(e1', a, n, m))) - UnifyTypes cenv env m overallTy ty2 - mkf n, tpenv + mkf n, ty2, tpenv + ) | SynExpr.LibraryOnlyUnionCaseFieldSet (e1, c, n, e2, m) -> - UnifyTypes cenv env m overallTy cenv.g.unit_ty + UnifyTypes cenv env m overallTy.Commit cenv.g.unit_ty let e1', ty1, tpenv = TcExprOfUnknownType cenv env tpenv e1 let mkf, ty2 = TcUnionCaseOrExnField cenv env ty1 m c n ((fun (a, b) n e2' -> @@ -5807,7 +6038,7 @@ and TcExprUndelayed cenv overallTy env tpenv (synExpr: SynExpr) = (fun a n e2' -> if not (isExnFieldMutable a n) then errorR(Error(FSComp.SR.tcFieldIsNotMutable(), m)) mkExnCaseFieldSet(e1', a, n, e2', m))) - let e2', tpenv = TcExpr cenv ty2 env tpenv e2 + let e2', tpenv = TcExpr cenv (MustEqual ty2) env tpenv e2 mkf n e2', tpenv | SynExpr.LibraryOnlyILAssembly (s, tyargs, args, rtys, m) -> @@ -5816,18 +6047,18 @@ and TcExprUndelayed cenv overallTy env tpenv (synExpr: SynExpr) = let tyargs', tpenv = TcTypes cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv tyargs // No subsumption at uses of IL assembly code let flexes = argTys |> List.map (fun _ -> false) - let args', tpenv = TcExprs cenv env m tpenv flexes argTys args + let args', tpenv = TcExprsWithFlexes cenv env m tpenv flexes argTys args let rtys', tpenv = TcTypes cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv rtys let returnTy = match rtys' with | [] -> cenv.g.unit_ty | [ returnTy ] -> returnTy | _ -> error(InternalError("Only zero or one pushed items are permitted in IL assembly code", m)) - UnifyTypes cenv env m overallTy returnTy + UnifyTypes cenv env m overallTy.Commit returnTy mkAsmExpr (Array.toList s, tyargs', args', rtys', m), tpenv | SynExpr.Quote (oper, raw, ast, isFromQueryExpression, m) -> - CallExprHasTypeSink cenv.tcSink (m, env.NameEnv, overallTy, env.AccessRights) + CallExprHasTypeSink cenv.tcSink (m, env.NameEnv, overallTy.Commit, env.AccessRights) TcQuotationExpr cenv overallTy env tpenv (oper, raw, ast, isFromQueryExpression, m) | SynExpr.YieldOrReturn ((isTrueYield, _), _, m) @@ -5854,7 +6085,7 @@ and TcExprUndelayed cenv overallTy env tpenv (synExpr: SynExpr) = and TcIteratedLambdas cenv isFirst (env: TcEnv) overallTy takenNames tpenv e = match e with | SynExpr.Lambda (isMember, isSubsequent, spats, bodyExpr, _, m) when isMember || isFirst || isSubsequent -> - let domainTy, resultTy = UnifyFunctionType None cenv env.DisplayEnv m overallTy + let domainTy, resultTy = UnifyFunctionType None cenv env.DisplayEnv m overallTy.Commit let vs, (tpenv, names, takenNames) = TcSimplePats cenv isMember CheckCxs domainTy env (tpenv, Map.empty, takenNames) spats let envinner, _, vspecMap = MakeAndPublishSimpleValsForMergedScope cenv env m names let byrefs = vspecMap |> Map.map (fun _ v -> isByrefTy cenv.g v.Type, v) @@ -5873,7 +6104,7 @@ and TcIteratedLambdas cenv isFirst (env: TcEnv) overallTy takenNames tpenv e = { envinner with eLambdaArgInfos = rest } | [] -> envinner - let bodyExpr, tpenv = TcIteratedLambdas cenv false envinner resultTy takenNames tpenv bodyExpr + let bodyExpr, tpenv = TcIteratedLambdas cenv false envinner (MustConvertTo (false, resultTy)) takenNames tpenv bodyExpr // See bug 5758: Non-monotonicity in inference: need to ensure that parameters are never inferred to have byref type, instead it is always declared byrefs |> Map.iter (fun _ (orig, v) -> if not orig && isByrefTy cenv.g v.Type then errorR(Error(FSComp.SR.tcParameterInferredByref v.DisplayName, v.Range))) @@ -5883,10 +6114,8 @@ and TcIteratedLambdas cenv isFirst (env: TcEnv) overallTy takenNames tpenv e = | e -> // Dive into the expression to check for syntax errors and suppress them if they show. conditionallySuppressErrorReporting (not isFirst && synExprContainsError e) (fun () -> - //TcExprFlex cenv true true overallTy env tpenv e) TcExpr cenv overallTy env tpenv e) - // Check expr.[idx] // This is a little over complicated for my liking. Basically we want to interpret e1.[idx] as e1.Item(idx). // However it's not so simple as all that. First "Item" can have a different name according to an attribute in @@ -6110,10 +6339,10 @@ and TcNewExpr cenv env tpenv objTy mObjTyOpt superInit arg mWholeExprOrObjTy = if not (isAppTy cenv.g objTy) && not (isAnyTupleTy cenv.g objTy) then error(Error(FSComp.SR.tcNamedTypeRequired(if superInit then "inherit" else "new"), mWholeExprOrObjTy)) let item = ForceRaise (ResolveObjectConstructor cenv.nameResolver env.DisplayEnv mWholeExprOrObjTy ad objTy) - TcCtorCall false cenv env tpenv objTy objTy mObjTyOpt item superInit [arg] mWholeExprOrObjTy [] None + TcCtorCall false cenv env tpenv (MustEqual objTy) objTy mObjTyOpt item superInit [arg] mWholeExprOrObjTy [] None /// Check an 'inheritedTys declaration in an implicit or explicit class -and TcCtorCall isNaked cenv env tpenv overallTy objTy mObjTyOpt item superInit args mWholeCall delayed afterTcOverloadResolutionOpt = +and TcCtorCall isNaked cenv env tpenv (overallTy: OverallTy) objTy mObjTyOpt item superInit args mWholeCall delayed afterTcOverloadResolutionOpt = let ad = env.AccessRights let isSuperInit = (if superInit then CtorValUsedAsSuperInit else NormalValUse) let mItem = match mObjTyOpt with Some m -> m | None -> mWholeCall @@ -6145,14 +6374,13 @@ and TcCtorCall isNaked cenv env tpenv overallTy objTy mObjTyOpt item superInit a match mObjTyOpt with | Some mObjTy -> CallNameResolutionSink cenv.tcSink (mObjTy, env.NameEnv, item, emptyTyparInst, ItemOccurence.Use, env.AccessRights) | None -> () - TcNewDelegateThen cenv objTy env tpenv mItem mWholeCall ty arg ExprAtomicFlag.NonAtomic delayed + TcNewDelegateThen cenv (MustEqual objTy) env tpenv mItem mWholeCall ty arg ExprAtomicFlag.NonAtomic delayed | _ -> error(Error(FSComp.SR.tcSyntaxCanOnlyBeUsedToCreateObjectTypes(if superInit then "inherit" else "new"), mWholeCall)) - // Check a record construction expression -and TcRecordConstruction cenv overallTy env tpenv optOrigExprInfo objTy fldsList m = +and TcRecordConstruction cenv (overallTy: TType) env tpenv optOrigExprInfo objTy fldsList m = let tcref, tinst = destAppTy cenv.g objTy let tycon = tcref.Deref UnifyTypes cenv env m overallTy objTy @@ -6467,17 +6695,15 @@ and CheckSuperType cenv ty m = errorR(Error(FSComp.SR.tcCannotInheritFromErasedType(), m)) -and TcObjectExpr cenv overallTy env tpenv (synObjTy, argopt, binds, extraImpls, mNewExpr, mWholeExpr) = - let mObjTy = synObjTy.Range +and TcObjectExpr cenv env tpenv (objTy, realObjTy, argopt, binds, extraImpls, mObjTy, mNewExpr, mWholeExpr) = - let objTy, tpenv = TcType cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv synObjTy match tryTcrefOfAppTy cenv.g objTy with | ValueNone -> error(Error(FSComp.SR.tcNewMustBeUsedWithNamedType(), mNewExpr)) | ValueSome tcref -> let isRecordTy = tcref.IsRecordTycon if not isRecordTy && not (isInterfaceTy cenv.g objTy) && isSealedTy cenv.g objTy then errorR(Error(FSComp.SR.tcCannotCreateExtensionOfSealedType(), mNewExpr)) - CheckSuperType cenv objTy synObjTy.Range + CheckSuperType cenv objTy mObjTy // Add the object type to the ungeneralizable items let env = {env with eUngeneralizableItems = addFreeItemOfTy objTy env.eUngeneralizableItems } @@ -6501,34 +6727,21 @@ and TcObjectExpr cenv overallTy env tpenv (synObjTy, argopt, binds, extraImpls, | NormalizedBinding (_, _, _, _, [], _, _, _, SynPat.Named(id, _, _, _), NormalizedBindingRhs(_, _, rhsExpr), _, _) -> id.idText, rhsExpr | _ -> error(Error(FSComp.SR.tcOnlySimpleBindingsCanBeUsedInConstructionExpressions(), b.RangeOfBindingWithoutRhs))) - TcRecordConstruction cenv overallTy env tpenv None objTy fldsList mWholeExpr + TcRecordConstruction cenv objTy env tpenv None objTy fldsList mWholeExpr else let item = ForceRaise (ResolveObjectConstructor cenv.nameResolver env.DisplayEnv mObjTy ad objTy) if isFSharpObjModelTy cenv.g objTy && GetCtorShapeCounter env = 1 then error(Error(FSComp.SR.tcObjectsMustBeInitializedWithObjectExpression(), mNewExpr)) - // Work out the type of any interfaces to implement - let extraImpls, tpenv = - (tpenv, extraImpls) ||> List.mapFold (fun tpenv (SynInterfaceImpl(synIntfTy, overrides, m)) -> - let intfTy, tpenv = TcType cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv synIntfTy - if not (isInterfaceTy cenv.g intfTy) then - error(Error(FSComp.SR.tcExpectedInterfaceType(), m)) - if isErasedType cenv.g intfTy then - errorR(Error(FSComp.SR.tcCannotInheritFromErasedType(), m)) - (m, intfTy, overrides), tpenv) - - let realObjTy = if isObjTy cenv.g objTy && not (isNil extraImpls) then (p23 (List.head extraImpls)) else objTy - UnifyTypes cenv env mWholeExpr overallTy realObjTy - let ctorCall, baseIdOpt, tpenv = match item, argopt with | Item.CtorGroup(methodName, minfos), Some (arg, baseIdOpt) -> let meths = minfos |> List.map (fun minfo -> minfo, None) - let afterResolution = ForNewConstructors cenv.tcSink env synObjTy.Range methodName minfos + let afterResolution = ForNewConstructors cenv.tcSink env mObjTy methodName minfos let ad = env.AccessRights - let expr, tpenv = TcMethodApplicationThen cenv env objTy None tpenv None [] mWholeExpr mObjTy methodName ad PossiblyMutates false meths afterResolution CtorValUsedAsSuperInit [arg] ExprAtomicFlag.Atomic [] + let expr, tpenv = TcMethodApplicationThen cenv env (MustEqual objTy) None tpenv None [] mWholeExpr mObjTy methodName ad PossiblyMutates false meths afterResolution CtorValUsedAsSuperInit [arg] ExprAtomicFlag.Atomic [] // The 'base' value is always bound let baseIdOpt = (match baseIdOpt with None -> Some(ident("base", mObjTy)) | Some id -> Some id) expr, baseIdOpt, tpenv @@ -6550,6 +6763,7 @@ and TcObjectExpr cenv overallTy env tpenv (synObjTy, argopt, binds, extraImpls, let overridesAndVirts, tpenv = ComputeObjectExprOverrides cenv env tpenv impls + // 2. check usage conditions overridesAndVirts |> List.iter (fun (m, implty, dispatchSlots, dispatchSlotsKeyed, availPriorOverrides, overrides) -> let overrideSpecs = overrides |> List.map fst @@ -6557,7 +6771,7 @@ and TcObjectExpr cenv overallTy env tpenv (synObjTy, argopt, binds, extraImpls, DispatchSlotChecking.CheckDispatchSlotsAreImplemented (env.DisplayEnv, cenv.infoReader, m, env.NameEnv, cenv.tcSink, false, implty, dispatchSlots, availPriorOverrides, overrideSpecs) |> ignore) - // 6c. create the specs of overrides + // 3. create the specs of overrides let allTypeImpls = overridesAndVirts |> List.map (fun (m, implty, _, dispatchSlotsKeyed, _, overrides) -> let overrides' = @@ -6577,12 +6791,13 @@ and TcObjectExpr cenv overallTy env tpenv (synObjTy, argopt, binds, extraImpls, let overridden = match searchForOverride with | Some x -> x - | None -> error(Error(FSComp.SR.tcAtLeastOneOverrideIsInvalid(), synObjTy.Range)) + | None -> error(Error(FSComp.SR.tcAtLeastOneOverrideIsInvalid(), mObjTy)) yield TObjExprMethod(overridden.GetSlotSig(cenv.amap, m), bindingAttribs, mtps, [thisVal] :: methodVars, bindingBody, id.idRange) ] (implty, overrides')) let objTy', overrides' = allTypeImpls.Head + assert (typeEquiv cenv.g objTy objTy') let extraImpls = allTypeImpls.Tail // 7. Build the implementation @@ -6590,21 +6805,19 @@ and TcObjectExpr cenv overallTy env tpenv (synObjTy, argopt, binds, extraImpls, let expr = mkCoerceIfNeeded cenv.g realObjTy objTy' expr expr, tpenv - - //------------------------------------------------------------------------- // TcConstStringExpr //------------------------------------------------------------------------- /// Check a constant string expression. It might be a 'printf' format string -and TcConstStringExpr cenv overallTy env m tpenv s = +and TcConstStringExpr cenv (overallTy: OverallTy) env m tpenv s = - if (AddCxTypeEqualsTypeUndoIfFailed env.DisplayEnv cenv.css m overallTy cenv.g.string_ty) then + if (AddCxTypeEqualsTypeUndoIfFailed env.DisplayEnv cenv.css m overallTy.Commit cenv.g.string_ty) then mkString cenv.g m s, tpenv else TcFormatStringExpr cenv overallTy env m tpenv s -and TcFormatStringExpr cenv overallTy env m tpenv (fmtString: string) = +and TcFormatStringExpr cenv (overallTy: OverallTy) env m tpenv (fmtString: string) = let g = cenv.g let aty = NewInferenceType () let bty = NewInferenceType () @@ -6614,7 +6827,7 @@ and TcFormatStringExpr cenv overallTy env m tpenv (fmtString: string) = let formatTy = mkPrintfFormatTy g aty bty cty dty ety // This might qualify as a format string - check via a type directed rule - let ok = not (isObjTy g overallTy) && AddCxTypeMustSubsumeTypeUndoIfFailed env.DisplayEnv cenv.css m overallTy formatTy + let ok = not (isObjTy g overallTy.Commit) && AddCxTypeMustSubsumeTypeUndoIfFailed env.DisplayEnv cenv.css m overallTy.Commit formatTy if ok then // Parse the format string to work out the phantom types @@ -6637,11 +6850,12 @@ and TcFormatStringExpr cenv overallTy env m tpenv (fmtString: string) = fmtExpr, tpenv else - UnifyTypes cenv env m overallTy g.string_ty - mkString g m fmtString, tpenv + TcPropagatingExprLeafThenConvert cenv overallTy g.string_ty env (* true *) m (fun () -> + mkString g m fmtString, tpenv + ) /// Check an interpolated string expression -and TcInterpolatedStringExpr cenv overallTy env m tpenv (parts: SynInterpolatedStringPart list) = +and TcInterpolatedStringExpr cenv (overallTy: OverallTy) env m tpenv (parts: SynInterpolatedStringPart list) = let g = cenv.g let synFillExprs = @@ -6675,12 +6889,12 @@ and TcInterpolatedStringExpr cenv overallTy env m tpenv (parts: SynInterpolatedS let stringKind = // If this is an interpolated string then try to force the result to be a string - if (AddCxTypeEqualsTypeUndoIfFailed env.DisplayEnv cenv.css m overallTy g.string_ty) then + if (AddCxTypeEqualsTypeUndoIfFailed env.DisplayEnv cenv.css m overallTy.Commit g.string_ty) then // And if that succeeds, the result of printing is a string UnifyTypes cenv env m printerArgTy g.unit_ty UnifyTypes cenv env m printerResidueTy g.string_ty - UnifyTypes cenv env m printerResultTy overallTy + UnifyTypes cenv env m printerResultTy overallTy.Commit // And if that succeeds, the printerTy and printerResultTy must be the same (there are no curried arguments) UnifyTypes cenv env m printerTy printerResultTy @@ -6688,14 +6902,14 @@ and TcInterpolatedStringExpr cenv overallTy env m tpenv (parts: SynInterpolatedS Choice1Of2 (true, newFormatMethod) // ... or if that fails then may be a FormattableString by a type-directed rule.... - elif (not (isObjTy g overallTy) && - ((g.system_FormattableString_tcref.CanDeref && AddCxTypeMustSubsumeTypeUndoIfFailed env.DisplayEnv cenv.css m overallTy g.system_FormattableString_ty) - || (g.system_IFormattable_tcref.CanDeref && AddCxTypeMustSubsumeTypeUndoIfFailed env.DisplayEnv cenv.css m overallTy g.system_IFormattable_ty))) then + elif (not (isObjTy g overallTy.Commit) && + ((g.system_FormattableString_tcref.CanDeref && AddCxTypeMustSubsumeTypeUndoIfFailed env.DisplayEnv cenv.css m overallTy.Commit g.system_FormattableString_ty) + || (g.system_IFormattable_tcref.CanDeref && AddCxTypeMustSubsumeTypeUndoIfFailed env.DisplayEnv cenv.css m overallTy.Commit g.system_IFormattable_ty))) then // And if that succeeds, the result of printing is a string UnifyTypes cenv env m printerArgTy g.unit_ty UnifyTypes cenv env m printerResidueTy g.string_ty - UnifyTypes cenv env m printerResultTy overallTy + UnifyTypes cenv env m printerResultTy overallTy.Commit // Find the FormattableStringFactor.Create method in the .NET libraries let ad = env.eAccessRights @@ -6709,15 +6923,13 @@ and TcInterpolatedStringExpr cenv overallTy env m tpenv (parts: SynInterpolatedS | None -> languageFeatureNotSupportedInLibraryError cenv.g.langVersion LanguageFeature.StringInterpolation m // ... or if that fails then may be a PrintfFormat by a type-directed rule.... - elif not (isObjTy g overallTy) && AddCxTypeMustSubsumeTypeUndoIfFailed env.DisplayEnv cenv.css m overallTy formatTy then + elif not (isObjTy g overallTy.Commit) && AddCxTypeMustSubsumeTypeUndoIfFailed env.DisplayEnv cenv.css m overallTy.Commit formatTy then // And if that succeeds, the printerTy and printerResultTy must be the same (there are no curried arguments) UnifyTypes cenv env m printerTy printerResultTy Choice1Of2 (false, newFormatMethod) else - // this should fail and produce an error - UnifyTypes cenv env m overallTy g.string_ty Choice1Of2 (true, newFormatMethod) let isFormattableString = (match stringKind with Choice2Of2 _ -> true | _ -> false) @@ -6777,6 +6989,8 @@ and TcInterpolatedStringExpr cenv overallTy env m tpenv (parts: SynInterpolatedS UnifyTypes cenv env m printerTupleTy printerTupleTyRequired + // Type check the expressions filling the holes + if List.isEmpty synFillExprs then let str = mkString g m printfFormatString @@ -6787,7 +7001,7 @@ and TcInterpolatedStringExpr cenv overallTy env m tpenv (parts: SynInterpolatedS else // Type check the expressions filling the holes let flexes = argTys |> List.map (fun _ -> false) - let fillExprs, tpenv = TcExprs cenv env m tpenv flexes argTys synFillExprs + let fillExprs, tpenv = TcExprsWithFlexes cenv env m tpenv flexes argTys synFillExprs let fillExprsBoxed = (argTys, fillExprs) ||> List.map2 (mkCallBox g m) @@ -6802,8 +7016,10 @@ and TcInterpolatedStringExpr cenv overallTy env m tpenv (parts: SynInterpolatedS let fmtExpr = MakeMethInfoCall cenv.amap m newFormatMethod [] [mkString g m printfFormatString; argsExpr; percentATysExpr] if isString then - // Make the call to sprintf - mkCall_sprintf g m printerTy fmtExpr [], tpenv + TcPropagatingExprLeafThenConvert cenv overallTy g.string_ty env (* true *) m (fun () -> + // Make the call to sprintf + mkCall_sprintf g m printerTy fmtExpr [], tpenv + ) else fmtExpr, tpenv @@ -6812,7 +7028,7 @@ and TcInterpolatedStringExpr cenv overallTy env m tpenv (parts: SynInterpolatedS // Type check the expressions filling the holes let flexes = argTys |> List.map (fun _ -> false) - let fillExprs, tpenv = TcExprs cenv env m tpenv flexes argTys synFillExprs + let fillExprs, tpenv = TcExprsWithFlexes cenv env m tpenv flexes argTys synFillExprs let fillExprsBoxed = (argTys, fillExprs) ||> List.map2 (mkCallBox g m) @@ -6823,7 +7039,7 @@ and TcInterpolatedStringExpr cenv overallTy env m tpenv (parts: SynInterpolatedS let createExpr, _ = BuildPossiblyConditionalMethodCall cenv env NeverMutates m false createFormattableStringMethod NormalValUse [] [dotnetFormatStringExpr; argsExpr] [] let resultExpr = - if typeEquiv g overallTy g.system_IFormattable_ty then + if typeEquiv g overallTy.Commit g.system_IFormattable_ty then mkCoerceIfNeeded g g.system_IFormattable_ty g.system_FormattableString_ty createExpr else createExpr @@ -6834,16 +7050,18 @@ and TcInterpolatedStringExpr cenv overallTy env m tpenv (parts: SynInterpolatedS //------------------------------------------------------------------------- /// Check a constant expression. -and TcConstExpr cenv overallTy env m tpenv c = +and TcConstExpr cenv (overallTy: OverallTy) env m tpenv c = match c with - // NOTE: these aren't "really" constants | SynConst.Bytes (bytes, _, m) -> - UnifyTypes cenv env m overallTy (mkByteArrayTy cenv.g) + let actualTy = mkByteArrayTy cenv.g + TcPropagatingExprLeafThenConvert cenv overallTy actualTy env (* true *) m <| fun ()-> Expr.Op (TOp.Bytes bytes, [], [], m), tpenv | SynConst.UInt16s arr -> - UnifyTypes cenv env m overallTy (mkArrayType cenv.g cenv.g.uint16_ty); Expr.Op (TOp.UInt16s arr, [], [], m), tpenv + let actualTy = mkArrayType cenv.g cenv.g.uint16_ty + TcPropagatingExprLeafThenConvert cenv overallTy actualTy env (* true *) m <| fun () -> + Expr.Op (TOp.UInt16s arr, [], [], m), tpenv | SynConst.UserNum (s, suffix) -> let expr = @@ -6878,9 +7096,10 @@ and TcConstExpr cenv overallTy env m tpenv c = TcExpr cenv overallTy env tpenv expr | _ -> - let c' = TcConst cenv overallTy m env c - Expr.Const (c', m, overallTy), tpenv - + TcNonPropagatingExprLeafThenConvert cenv overallTy env m (fun () -> + let cTy = NewInferenceType() + let c' = TcConst cenv cTy m env c + Expr.Const (c', m, cTy), cTy, tpenv) //------------------------------------------------------------------------- // TcAssertExpr @@ -6895,8 +7114,7 @@ and TcAssertExpr cenv overallTy env (m: range) tpenv x = TcExpr cenv overallTy env tpenv callDiagnosticsExpr - -and TcRecdExpr cenv overallTy env tpenv (inherits, optOrigExpr, flds, mWholeExpr) = +and TcRecdExpr cenv (overallTy: TType) env tpenv (inherits, optOrigExpr, flds, mWholeExpr) = let requiresCtor = (GetCtorShapeCounter env = 1) // Get special expression forms for constructors let haveCtor = Option.isSome inherits @@ -6908,7 +7126,7 @@ and TcRecdExpr cenv overallTy env tpenv (inherits, optOrigExpr, flds, mWholeExpr match inherits with | Some (_, _, mInherits, _, _) -> error(Error(FSComp.SR.tcInvalidRecordConstruction(), mInherits)) | None -> - let olde, tpenv = TcExpr cenv overallTy env tpenv origExpr + let olde, tpenv = TcExpr cenv (MustEqual overallTy) env tpenv origExpr Some olde, tpenv let hasOrigExpr = optOrigExpr.IsSome @@ -6966,7 +7184,7 @@ and TcRecdExpr cenv overallTy env tpenv (inherits, optOrigExpr, flds, mWholeExpr match inherits, GetSuperTypeOfType cenv.g cenv.amap mWholeExpr overallTy with | Some (superTy, arg, m, _, _), Some realSuperTy -> // Constructor expression, with an explicit 'inheritedTys clause. Check the inherits clause. - let e, tpenv = TcExpr cenv realSuperTy env tpenv (SynExpr.New (true, superTy, arg, m)) + let e, tpenv = TcExpr cenv (MustEqual realSuperTy) env tpenv (SynExpr.New (true, superTy, arg, m)) Some e, tpenv | None, Some realSuperTy when requiresCtor -> // Constructor expression, No 'inherited' clause, hence look for a default constructor @@ -6989,7 +7207,7 @@ and TcRecdExpr cenv overallTy env tpenv (inherits, optOrigExpr, flds, mWholeExpr // Check '{| .... |}' -and TcAnonRecdExpr cenv overallTy env tpenv (isStruct, optOrigSynExpr, unsortedFieldIdsAndSynExprsGiven, mWholeExpr) = +and TcAnonRecdExpr cenv (overallTy: TType) env tpenv (isStruct, optOrigSynExpr, unsortedFieldIdsAndSynExprsGiven, mWholeExpr) = let unsortedFieldSynExprsGiven = List.map snd unsortedFieldIdsAndSynExprsGiven match optOrigSynExpr with @@ -7019,7 +7237,7 @@ and TcAnonRecdExpr cenv overallTy env tpenv (isStruct, optOrigSynExpr, unsortedF let flexes = unsortedFieldTys |> List.map (fun _ -> true) - let unsortedCheckedArgs, tpenv = TcExprs cenv env mWholeExpr tpenv flexes unsortedFieldTys unsortedFieldSynExprsGiven + let unsortedCheckedArgs, tpenv = TcExprsWithFlexes cenv env mWholeExpr tpenv flexes unsortedFieldTys unsortedFieldSynExprsGiven mkAnonRecd cenv.g mWholeExpr anonInfo unsortedFieldIds unsortedCheckedArgs unsortedFieldTys, tpenv @@ -7034,7 +7252,7 @@ and TcAnonRecdExpr cenv overallTy env tpenv (isStruct, optOrigSynExpr, unsortedF // Unlike in the case of record type copy-and-update {| a with X = 1 |} does not force a.X to exist or have had type 'int' let origExprTy = NewInferenceType() - let origExprChecked, tpenv = TcExpr cenv origExprTy env tpenv origExpr + let origExprChecked, tpenv = TcExpr cenv (MustEqual origExprTy) env tpenv origExpr let oldv, oldve = mkCompGenLocal mWholeExpr "inputRecord" origExprTy let mOrigExpr = origExpr.Range @@ -7104,7 +7322,7 @@ and TcAnonRecdExpr cenv overallTy env tpenv (isStruct, optOrigSynExpr, unsortedF // Check the expressions in unsorted order let unsortedFieldExprsGiven, tpenv = - TcExprs cenv env mWholeExpr tpenv flexes unsortedFieldTysGiven unsortedFieldSynExprsGiven + TcExprsWithFlexes cenv env mWholeExpr tpenv flexes unsortedFieldTysGiven unsortedFieldSynExprsGiven let unsortedFieldExprsGiven = unsortedFieldExprsGiven |> List.toArray @@ -7128,7 +7346,6 @@ and TcAnonRecdExpr cenv overallTy env tpenv (isStruct, optOrigSynExpr, unsortedF let expr = mkCompGenLet mOrigExpr oldv origExprChecked expr expr, tpenv - and TcForEachExpr cenv overallTy env tpenv (pat, enumSynExpr, bodySynExpr, mWholeExpr, spForLoop) = let tryGetOptimizeSpanMethodsAux g m ty isReadOnlySpan = match (if isReadOnlySpan then tryDestReadOnlySpanTy g m ty else tryDestSpanTy g m ty) with @@ -7149,7 +7366,7 @@ and TcForEachExpr cenv overallTy env tpenv (pat, enumSynExpr, bodySynExpr, mWhol else tryGetOptimizeSpanMethodsAux g m ty true - UnifyTypes cenv env mWholeExpr overallTy cenv.g.unit_ty + UnifyTypes cenv env mWholeExpr overallTy.Commit cenv.g.unit_ty let mPat = pat.Range //let mBodyExpr = bodySynExpr.Range @@ -7230,11 +7447,11 @@ and TcForEachExpr cenv overallTy env tpenv (pat, enumSynExpr, bodySynExpr, mWhol // Add the pattern match compilation let bodyExpr = let valsDefinedByMatching = ListSet.remove valEq elemVar vspecs - CompilePatternForMatch - cenv env enumSynExpr.Range pat.Range false IgnoreWithWarning (elemVar, [], None) + CompilePatternForMatch + cenv env enumSynExpr.Range pat.Range false IgnoreWithWarning (elemVar, [], None) [TClause(pat, None, TTarget(valsDefinedByMatching, bodyExpr, DebugPointForTarget.Yes, None), mForLoopStart)] - enumElemTy - overallTy + enumElemTy + overallTy.Commit // Apply the fixup to bind the elemVar if needed let bodyExpr = bodyExprFixup elemVar bodyExpr @@ -7279,13 +7496,13 @@ and TcQuotationExpr cenv overallTy env tpenv (_oper, raw, ast, isFromQueryExpres let astTy = NewInferenceType () // Assert the overall type for the domain of the quotation template - UnifyTypes cenv env m overallTy (if raw then mkRawQuotedExprTy cenv.g else mkQuotedExprTy cenv.g astTy) + UnifyTypes cenv env m overallTy.Commit (if raw then mkRawQuotedExprTy cenv.g else mkQuotedExprTy cenv.g astTy) // Check the expression - let expr, tpenv = TcExpr cenv astTy env tpenv ast + let expr, tpenv = TcExpr cenv (MustEqual astTy) env tpenv ast // Wrap the expression - let expr = Expr.Quote (expr, ref None, isFromQueryExpression, m, overallTy) + let expr = Expr.Quote (expr, ref None, isFromQueryExpression, m, overallTy.Commit) // Coerce it if needed let expr = if raw then mkCoerceExpr(expr, (mkRawQuotedExprTy cenv.g), m, (tyOfExpr cenv.g expr)) else expr @@ -7302,7 +7519,7 @@ and TcQuotationExpr cenv overallTy env tpenv (_oper, raw, ast, isFromQueryExpres /// /// We propagate information from the expected overall type 'overallTy'. The use /// of function application syntax unambiguously implies that 'overallTy' is a function type. -and Propagate cenv overallTy env tpenv (expr: ApplicableExpr) exprty delayed = +and Propagate cenv (overallTy: OverallTy) (env: TcEnv) tpenv (expr: ApplicableExpr) exprty delayed = let rec propagate isAddrOf delayedList mExpr exprty = match delayedList with @@ -7317,13 +7534,14 @@ and Propagate cenv overallTy env tpenv (expr: ApplicableExpr) exprty delayed = mkByrefTyWithInference cenv.g (destByrefTy cenv.g exprty) (NewByRefKindInferenceType cenv.g mExpr) elif isByrefTy cenv.g exprty then // Implicit dereference on byref on return - if isByrefTy cenv.g overallTy then + if isByrefTy cenv.g overallTy.Commit then errorR(Error(FSComp.SR.tcByrefReturnImplicitlyDereferenced(), mExpr)) destByrefTy cenv.g exprty else exprty - UnifyTypesAndRecover cenv env mExpr overallTy exprty + // at the end of the application chain allow coercion introduction + UnifyOverallTypeAndRecover cenv env mExpr overallTy exprty | DelayedDot :: _ | DelayedSet _ :: _ @@ -7358,26 +7576,26 @@ and Propagate cenv overallTy env tpenv (expr: ApplicableExpr) exprty delayed = if IsIndexerType cenv.g cenv.amap expr.Type then match expr.Expr with | Expr.Val (d, _, _) -> - error (NotAFunctionButIndexer(denv, overallTy, Some d.DisplayName, mExpr, mArg)) + error (NotAFunctionButIndexer(denv, overallTy.Commit, Some d.DisplayName, mExpr, mArg)) | _ -> - error (NotAFunctionButIndexer(denv, overallTy, None, mExpr, mArg)) + error (NotAFunctionButIndexer(denv, overallTy.Commit, None, mExpr, mArg)) else - error (NotAFunction(denv, overallTy, mExpr, mArg)) + error (NotAFunction(denv, overallTy.Commit, mExpr, mArg)) | _ -> // 'delayed' is about to be dropped on the floor, first do rudimentary checking to get name resolutions in its body RecordNameAndTypeResolutions_IdeallyWithoutHavingOtherEffects_Delayed cenv env tpenv delayed - error (NotAFunction(denv, overallTy, mExpr, mArg)) + error (NotAFunction(denv, overallTy.Commit, mExpr, mArg)) propagate false delayed expr.Range exprty -and PropagateThenTcDelayed cenv overallTy env tpenv mExpr expr exprty (atomicFlag: ExprAtomicFlag) delayed = +and PropagateThenTcDelayed cenv (overallTy: OverallTy) env tpenv mExpr expr exprty (atomicFlag: ExprAtomicFlag) delayed = Propagate cenv overallTy env tpenv expr exprty delayed TcDelayed cenv overallTy env tpenv mExpr expr exprty atomicFlag delayed /// Typecheck "expr ... " constructs where "..." is a sequence of applications, /// type applications and dot-notation projections. -and TcDelayed cenv overallTy env tpenv mExpr expr exprty (atomicFlag: ExprAtomicFlag) delayed = +and TcDelayed cenv (overallTy: OverallTy) env tpenv mExpr expr exprty (atomicFlag: ExprAtomicFlag) delayed = // OK, we've typechecked the thing on the left of the delayed lookup chain. // We can now record for posterity the type of this expression and the location of the expression. @@ -7387,8 +7605,11 @@ and TcDelayed cenv overallTy env tpenv mExpr expr exprty (atomicFlag: ExprAtomic match delayed with | [] | DelayedDot :: _ -> - UnifyTypes cenv env mExpr overallTy exprty - expr.Expr, tpenv + // at the end of the application chain allow coercion introduction + UnifyOverallType cenv env mExpr overallTy exprty + let expr2 = TcAdjustExprForTypeDirectedConversions cenv overallTy exprty env (* true *) mExpr expr.Expr + expr2, tpenv + // Expr.M (args) where x.M is a .NET method or index property // expr.M(args) where x.M is a .NET method or index property // expr.M where x.M is a .NET method or index property @@ -7402,7 +7623,7 @@ and TcDelayed cenv overallTy env tpenv mExpr expr exprty (atomicFlag: ExprAtomic error(Error(FSComp.SR.tcUnexpectedTypeArguments(), mTypeArgs)) | DelayedSet (synExpr2, mStmt) :: otherDelayed -> if not (isNil otherDelayed) then error(Error(FSComp.SR.tcInvalidAssignment(), mExpr)) - UnifyTypes cenv env mExpr overallTy cenv.g.unit_ty + UnifyTypes cenv env mExpr overallTy.Commit cenv.g.unit_ty let expr = expr.Expr let _wrap, exprAddress, _readonly, _writeonly = mkExprAddrOfExpr cenv.g true false DefinitelyMutates expr None mExpr let vty = tyOfExpr cenv.g expr @@ -7469,7 +7690,7 @@ and TcNameOfExpr cenv env tpenv (synArg: SynExpr) = | Item.CtorGroup _ | Item.FakeInterfaceCtor _ -> false | _ -> true) -> - let overallTy = match overallTyOpt with None -> NewInferenceType() | Some t -> t + let overallTy = match overallTyOpt with None -> MustEqual (NewInferenceType()) | Some t -> t let _, _ = TcItemThen cenv overallTy env tpenv res delayed true | _ -> @@ -7524,9 +7745,9 @@ and TcNameOfExpr cenv env tpenv (synArg: SynExpr) = check overallTyOpt resultOpt expr delayed // expr : type" allowed with no subsequent qualifications - | SynExpr.Typed (synBodyExpr, synType, _m) when delayed.IsEmpty && overallTyOpt.IsNone -> - let tgtTy, _tpenv = TcTypeAndRecover cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv synType - check (Some tgtTy) resultOpt synBodyExpr delayed + | SynExpr.Typed (synBodyExpr, synType, _) when delayed.IsEmpty && overallTyOpt.IsNone -> + let tgtTy, _tpenv = TcTypeAndRecover cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv synType + check (Some (MustEqual tgtTy)) resultOpt synBodyExpr delayed | _ -> error (Error(FSComp.SR.expressionHasNoName(), m)) @@ -7542,7 +7763,7 @@ and TcNameOfExprResult cenv (lastIdent: Ident) m = // TcFunctionApplicationThen: Typecheck "expr x" + projections //------------------------------------------------------------------------- -and TcFunctionApplicationThen cenv overallTy env tpenv mExprAndArg expr exprty (synArg: SynExpr) atomicFlag delayed = +and TcFunctionApplicationThen cenv (overallTy: OverallTy) env tpenv mExprAndArg expr exprty (synArg: SynExpr) atomicFlag delayed = let denv = env.DisplayEnv let mArg = synArg.Range let mFunExpr = expr.Range @@ -7568,7 +7789,7 @@ and TcFunctionApplicationThen cenv overallTy env tpenv mExprAndArg expr exprty ( | _ -> false) | _ -> () - let arg, tpenv = TcExpr cenv domainTy env tpenv synArg + let arg, tpenv = TcExprFlex2 cenv domainTy env false tpenv synArg let exprAndArg, resultTy = buildApp cenv expr resultTy arg mExprAndArg TcDelayed cenv overallTy env tpenv mExprAndArg exprAndArg resultTy atomicFlag delayed @@ -7579,7 +7800,7 @@ and TcFunctionApplicationThen cenv overallTy env tpenv mExprAndArg expr exprty ( let bodyOfCompExpr, tpenv = cenv.TcComputationExpression cenv env overallTy tpenv (mFunExpr, expr.Expr, exprty, comp) TcDelayed cenv overallTy env tpenv mExprAndArg (MakeApplicableExprNoFlex cenv bodyOfCompExpr) (tyOfExpr cenv.g bodyOfCompExpr) ExprAtomicFlag.NonAtomic delayed | _ -> - error (NotAFunction(denv, overallTy, mFunExpr, mArg)) + error (NotAFunction(denv, overallTy.Commit, mFunExpr, mArg)) //------------------------------------------------------------------------- // TcLongIdentThen: Typecheck "A.B.C.E.F ... " constructs @@ -7601,7 +7822,7 @@ and GetLongIdentTypeNameInfo delayed = | _ -> TypeNameResolutionInfo.Default -and TcLongIdentThen cenv overallTy env tpenv (LongIdentWithDots(longId, _)) delayed = +and TcLongIdentThen cenv (overallTy: OverallTy) env tpenv (LongIdentWithDots(longId, _)) delayed = let ad = env.eAccessRights let typeNameResInfo = GetLongIdentTypeNameInfo delayed @@ -7614,7 +7835,7 @@ and TcLongIdentThen cenv overallTy env tpenv (LongIdentWithDots(longId, _)) dela // Typecheck "item+projections" //------------------------------------------------------------------------- *) // mItem is the textual range covered by the long identifiers that make up the item -and TcItemThen cenv overallTy env tpenv (tinstEnclosing, item, mItem, rest, afterResolution) delayed = +and TcItemThen cenv (overallTy: OverallTy) env tpenv (tinstEnclosing, item, mItem, rest, afterResolution) delayed = let g = cenv.g let delayed = delayRest rest mItem delayed let ad = env.eAccessRights @@ -7639,6 +7860,7 @@ and TcItemThen cenv overallTy env tpenv (tinstEnclosing, item, mItem, rest, afte | _ -> ApplyUnionCaseOrExnTypes mItem cenv env ucaseAppTy item let numArgTys = List.length argTys + // Subsumption at data constructions if argument type is nominal prior to equations for any arguments or return types let flexes = argTys |> List.map (isTyparTy g >> not) @@ -7655,7 +7877,7 @@ and TcItemThen cenv overallTy env tpenv (tinstEnclosing, item, mItem, rest, afte | DelayedApp (atomicFlag, (FittedArgs args as origArg), mExprAndArg) :: otherDelayed -> // assert the overall result type if possible if isNil otherDelayed then - UnifyTypes cenv env mExprAndArg overallTy ucaseAppTy + UnifyOverallType cenv env mExprAndArg overallTy ucaseAppTy let numArgs = List.length args UnionCaseOrExnCheck env numArgTys numArgs mExprAndArg @@ -7729,7 +7951,7 @@ and TcItemThen cenv overallTy env tpenv (tinstEnclosing, item, mItem, rest, afte assert (Seq.forall (box >> ((<>) null) ) fittedArgs) List.ofArray fittedArgs - let args', tpenv = TcExprs cenv env mExprAndArg tpenv flexes argTys args + let args', tpenv = TcExprsWithFlexes cenv env mExprAndArg tpenv flexes argTys args PropagateThenTcDelayed cenv overallTy env tpenv mExprAndArg (MakeApplicableExprNoFlex cenv (mkConstrApp mExprAndArg args')) ucaseAppTy atomicFlag otherDelayed | DelayedTypeApp (_x, mTypeArgs, _mExprAndTypeArgs) :: _delayed' -> @@ -7998,9 +8220,9 @@ and TcItemThen cenv overallTy env tpenv (tinstEnclosing, item, mItem, rest, afte let delayed1, delayed2 = let pred = (function DelayedApp (_, arg, _) -> isSimpleArgument arg | _ -> false) List.takeWhile pred delayed, List.skipWhile pred delayed - let intermediateTy = if isNil delayed2 then overallTy else NewInferenceType () + let intermediateTy = if isNil delayed2 then overallTy.Commit else NewInferenceType () - let resultExpr, tpenv = TcDelayed cenv intermediateTy env tpenv mItem (MakeApplicableExprNoFlex cenv expr) (tyOfExpr g expr) ExprAtomicFlag.NonAtomic delayed1 + let resultExpr, tpenv = TcDelayed cenv (MustEqual intermediateTy) env tpenv mItem (MakeApplicableExprNoFlex cenv expr) (tyOfExpr g expr) ExprAtomicFlag.NonAtomic delayed1 // Add the constraint after the application arguments have been checked to allow annotations to kick in on rigid type parameters AddCxMethodConstraint env.DisplayEnv cenv.css mItem NoTrace traitInfo @@ -8030,7 +8252,7 @@ and TcItemThen cenv overallTy env tpenv (tinstEnclosing, item, mItem, rest, afte // Mutable value set: 'v <- e' | DelayedSet(e2, mStmt) :: otherDelayed -> if not (isNil otherDelayed) then error(Error(FSComp.SR.tcInvalidAssignment(), mStmt)) - UnifyTypes cenv env mStmt overallTy g.unit_ty + UnifyTypes cenv env mStmt overallTy.Commit g.unit_ty vref.Deref.SetHasBeenReferenced() CheckValAccessible mItem env.AccessRights vref CheckValAttributes g vref mItem |> CommitOperationResult @@ -8101,7 +8323,7 @@ and TcItemThen cenv overallTy env tpenv (tinstEnclosing, item, mItem, rest, afte | DelayedSet(e2, mStmt) :: otherDelayed -> if not (isNil otherDelayed) then error(Error(FSComp.SR.tcInvalidAssignment(), mStmt)) // Static Property Set (possibly indexer) - UnifyTypes cenv env mStmt overallTy g.unit_ty + UnifyTypes cenv env mStmt overallTy.Commit g.unit_ty let meths = pinfos |> SettersOfPropInfos if meths.IsEmpty then let meths = pinfos |> GettersOfPropInfos @@ -8131,7 +8353,7 @@ and TcItemThen cenv overallTy env tpenv (tinstEnclosing, item, mItem, rest, afte let exprty = finfo.FieldType(cenv.amap, mItem) match delayed with | DelayedSet(e2, mStmt) :: _delayed' -> - UnifyTypes cenv env mStmt overallTy g.unit_ty + UnifyTypes cenv env mStmt overallTy.Commit g.unit_ty // Always allow subsumption on assignment to fields let e2', tpenv = TcExprFlex cenv true false exprty env tpenv e2 let expr = BuildILStaticFieldSet mStmt finfo e2' @@ -8168,7 +8390,7 @@ and TcItemThen cenv overallTy env tpenv (tinstEnclosing, item, mItem, rest, afte // Set static F# field CheckRecdFieldMutation mItem env.DisplayEnv rfinfo - UnifyTypes cenv env mStmt overallTy g.unit_ty + UnifyTypes cenv env mStmt overallTy.Commit g.unit_ty let fieldTy = rfinfo.FieldType // Always allow subsumption on assignment to fields let e2', tpenv = TcExprFlex cenv true false fieldTy env tpenv e2 @@ -8284,7 +8506,7 @@ and TcLookupThen cenv overallTy env tpenv mObjExpr objExpr objExprTy longId dela | DelayedSet(e2, mStmt) :: otherDelayed -> if not (isNil otherDelayed) then error(Error(FSComp.SR.tcInvalidAssignment(), mStmt)) // Instance property setter - UnifyTypes cenv env mStmt overallTy cenv.g.unit_ty + UnifyTypes cenv env mStmt overallTy.Commit cenv.g.unit_ty let meths = SettersOfPropInfos pinfos if meths.IsEmpty then let meths = pinfos |> GettersOfPropInfos @@ -8317,7 +8539,7 @@ and TcLookupThen cenv overallTy env tpenv mObjExpr objExpr objExprTy longId dela // Mutable value set: 'v <- e' if not (isNil otherDelayed) then error(Error(FSComp.SR.tcInvalidAssignment(), mItem)) CheckRecdFieldMutation mItem env.DisplayEnv rfinfo - UnifyTypes cenv env mStmt overallTy cenv.g.unit_ty + UnifyTypes cenv env mStmt overallTy.Commit cenv.g.unit_ty // Always allow subsumption on assignment to fields let e2', tpenv = TcExprFlex cenv true false fieldTy env tpenv e2 BuildRecdFieldSet cenv.g mStmt objExpr rfinfo e2', tpenv @@ -8348,7 +8570,7 @@ and TcLookupThen cenv overallTy env tpenv mObjExpr objExpr objExprTy longId dela match delayed with // Set instance IL field | DelayedSet(e2, mStmt) :: _delayed' -> - UnifyTypes cenv env mStmt overallTy cenv.g.unit_ty + UnifyTypes cenv env mStmt overallTy.Commit cenv.g.unit_ty // Always allow subsumption on assignment to fields let e2', tpenv = TcExprFlex cenv true false exprty env tpenv e2 let expr = BuildILFieldSet cenv.g mStmt objExpr finfo e2' @@ -8417,8 +8639,9 @@ and TcEventValueThen cenv overallTy env tpenv mItem mExprAndItem objDetails (ein and TcMethodApplicationThen cenv env - overallTy // The type of the overall expression including "delayed". The method "application" may actually be a use of a member as - // a first-class function value, when this would be a function type. + // The type of the overall expression including "delayed". The method "application" may actually be a use of a member as + // a first-class function value, when this would be a function type. + (overallTy: OverallTy) objTyOpt // methodType tpenv callerTyArgs // The return type of the overall expression including "delayed" @@ -8442,7 +8665,7 @@ and TcMethodApplicationThen // Work out if we know anything about the return type of the overall expression. If there are any delayed // lookups then we don't know anything. - let exprTy = if isNil delayed then overallTy else NewInferenceType () + let exprTy = if isNil delayed then overallTy else MustEqual (NewInferenceType ()) // Call the helper below to do the real checking let (expr, attributeAssignedNamedItems, delayed), tpenv = @@ -8481,7 +8704,7 @@ and TcMethodApplication mMethExpr // range of the entire method expression mItem methodName - (objTyOpt: TType option) + (objTyOpt: TType option) ad mut isProp @@ -8489,7 +8712,7 @@ and TcMethodApplication afterResolution isSuperInit curriedCallerArgs - exprTy + (exprTy: OverallTy) delayed = @@ -8507,7 +8730,7 @@ and TcMethodApplication let curriedCallerArgs, exprTy, delayed = match calledMeths with | [calledMeth] when not isProp && calledMeth.NumArgs.Length > 1 -> - [], NewInferenceType (), [ for x in curriedCallerArgs -> DelayedApp(ExprAtomicFlag.NonAtomic, x, x.Range) ] @ delayed + [], MustEqual (NewInferenceType ()), [ for x in curriedCallerArgs -> DelayedApp(ExprAtomicFlag.NonAtomic, x, x.Range) ] @ delayed | _ when not isProp && calledMeths |> List.exists (fun calledMeth -> calledMeth.NumArgs.Length > 1) -> // This condition should only apply when multiple conflicting curried extension members are brought into scope error(Error(FSComp.SR.tcOverloadsCannotHaveCurriedArguments(), mMethExpr)) @@ -8581,9 +8804,9 @@ and TcMethodApplication curriedCalledArgs.Head |> List.forall isSimpleFormalArg) -> // The call lambda has function type - let exprTy = mkFunTy (NewInferenceType ()) exprTy + let exprTy = mkFunTy (NewInferenceType ()) exprTy.Commit - (None, Some unnamedCurriedCallerArgs.Head.Head, exprTy) + (None, Some unnamedCurriedCallerArgs.Head.Head, MustEqual exprTy) | _ -> let unnamedCurriedCallerArgs = unnamedCurriedCallerArgs |> List.mapSquared MakeUnnamedCallerArgInfo @@ -8640,10 +8863,10 @@ and TcMethodApplication // method will take. Optional and out args are _not_ included, which means they will be resolved // to their default values (for optionals) and be part of the return tuple (for out args). | None, [calledMeth] -> - let curriedArgTys, returnTy = UnifyMatchingSimpleArgumentTypes exprTy calledMeth + let curriedArgTys, returnTy = UnifyMatchingSimpleArgumentTypes exprTy.Commit calledMeth let unnamedCurriedCallerArgs = curriedArgTys |> List.mapSquared (fun ty -> CallerArg(ty, mMethExpr, false, dummyExpr)) let namedCurriedCallerArgs = unnamedCurriedCallerArgs |> List.map (fun _ -> []) - unnamedCurriedCallerArgs, namedCurriedCallerArgs, returnTy + unnamedCurriedCallerArgs, namedCurriedCallerArgs, MustEqual returnTy // "type directed" rule for first-class uses of ambiguous methods. // By context we know a type for the input argument. If it's a tuple @@ -8651,7 +8874,7 @@ and TcMethodApplication // type we assume the number of arguments is just "1". | None, _ -> - let domainTy, returnTy = UnifyFunctionType None cenv denv mMethExpr exprTy + let domainTy, returnTy = UnifyFunctionType None cenv denv mMethExpr exprTy.Commit let argTys = if isUnitTy cenv.g domainTy then [] else tryDestRefTupleTy cenv.g domainTy // Only apply this rule if a candidate method exists with this number of arguments let argTys = @@ -8661,7 +8884,7 @@ and TcMethodApplication [domainTy] let unnamedCurriedCallerArgs = [argTys |> List.map (fun ty -> CallerArg(ty, mMethExpr, false, dummyExpr)) ] let namedCurriedCallerArgs = unnamedCurriedCallerArgs |> List.map (fun _ -> []) - unnamedCurriedCallerArgs, namedCurriedCallerArgs, returnTy + unnamedCurriedCallerArgs, namedCurriedCallerArgs, MustEqual returnTy | Some (unnamedCurriedCallerArgs, namedCurriedCallerArgs), _ -> let unnamedCurriedCallerArgs = unnamedCurriedCallerArgs |> List.mapSquared (fun (argExpr, argTy, mArg) -> CallerArg(argTy, mArg, false, argExpr)) @@ -8710,9 +8933,10 @@ and TcMethodApplication // method will take. Optional and out args are _not_ included, which means they will be resolved // to their default values (for optionals) and be part of the return tuple (for out args). | [calledMeth] -> - UnifyMatchingSimpleArgumentTypes exprTy calledMeth + let curriedArgTys, returnTy = UnifyMatchingSimpleArgumentTypes exprTy.Commit calledMeth + curriedArgTys, MustEqual returnTy | _ -> - let domainTy, returnTy = UnifyFunctionType None cenv denv mMethExpr exprTy + let domainTy, returnTy = UnifyFunctionType None cenv denv mMethExpr exprTy.Commit let argTys = if isUnitTy cenv.g domainTy then [] else tryDestRefTupleTy cenv.g domainTy // Only apply this rule if a candidate method exists with this number of arguments let argTys = @@ -8720,7 +8944,7 @@ and TcMethodApplication argTys else [domainTy] - [argTys], returnTy + [argTys], MustEqual returnTy let lambdaVarsAndExprs = curriedArgTys |> List.mapiSquared (fun i j ty -> mkCompGenLocal mMethExpr ("arg"+string i+string j) ty) let unnamedCurriedCallerArgs = lambdaVarsAndExprs |> List.mapSquared (fun (_, e) -> CallerArg(tyOfExpr cenv.g e, e.Range, false, e)) @@ -8738,7 +8962,7 @@ and TcMethodApplication let lambdaPropagationInfo = if preArgumentTypeCheckingCalledMethGroup.Length > 1 then [| for meth in preArgumentTypeCheckingCalledMethGroup do - match ExamineMethodForLambdaPropagation meth with + match ExamineMethodForLambdaPropagation meth ad with | Some (unnamedInfo, namedInfo) -> let calledObjArgTys = meth.CalledObjArgTys mMethExpr if (calledObjArgTys, callerObjArgTys) ||> Seq.forall2 (fun calledTy callerTy -> AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed denv cenv.css mMethExpr calledTy callerTy) then @@ -8824,7 +9048,6 @@ and TcMethodApplication | AfterResolution.RecordResolution(_, _, _, onFailure), None -> onFailure() - // Raise the errors from the constraint solving RaiseOperationResult errors match result with @@ -8873,7 +9096,8 @@ and TcMethodApplication /// STEP 5. Build the argument list. Adjust for optional arguments, byref arguments and coercions. let objArgPreBinder, objArgs, allArgsPreBinders, allArgs, allArgsCoerced, optArgPreBinder, paramArrayPreBinders, outArgExprs, outArgTmpBinds = - AdjustCallerArgs TcFieldInit env.eCallerMemberName cenv.infoReader ad finalCalledMeth objArgs lambdaVars mItem mMethExpr + let tcVal = LightweightTcValForUsingInBuildMethodCall cenv.g + AdjustCallerArgs tcVal TcFieldInit env.eCallerMemberName cenv.infoReader ad finalCalledMeth objArgs lambdaVars mItem mMethExpr // Record the resolution of the named argument for the Language Service allArgs |> List.iter (fun assignedArg -> @@ -8891,13 +9115,13 @@ and TcMethodApplication BuildPossiblyConditionalMethodCall cenv env mut mMethExpr isProp finalCalledMethInfo isSuperInit finalCalledMethInst objArgs allArgsCoerced // Handle byref returns - let callExpr1 = + let callExpr1, exprty = // byref-typed returns get implicitly dereferenced let vty = tyOfExpr cenv.g callExpr0 if isByrefTy cenv.g vty then - mkDerefAddrExpr mMethExpr callExpr0 mMethExpr vty + mkDerefAddrExpr mMethExpr callExpr0 mMethExpr vty, destByrefTy cenv.g vty else - callExpr0 + callExpr0, exprty // Bind "out" parameters as part of the result tuple let callExpr2, exprty = @@ -8913,9 +9137,12 @@ and TcMethodApplication let expr = mkLetsBind mMethExpr outArgTmpBinds expr expr, tyOfExpr cenv.g expr + // Subsumption or conversion to return type + let callExpr2b = TcAdjustExprForTypeDirectedConversions cenv returnTy exprty env mMethExpr callExpr2 + // Handle post-hoc property assignments let setterExprPrebinders, callExpr3 = - let expr = callExpr2 + let expr = callExpr2b if isCheckingAttributeCall then [], expr elif isNil finalAssignedItemSetters then @@ -8952,7 +9179,7 @@ and TcMethodApplication | Some synArgExpr -> match lambdaVars with | Some [lambdaVars] -> - let argExpr, tpenv = TcExpr cenv (mkRefTupledVarsTy cenv.g lambdaVars) env tpenv synArgExpr + let argExpr, tpenv = TcExpr cenv (MustEqual (mkRefTupledVarsTy cenv.g lambdaVars)) env tpenv synArgExpr mkApps cenv.g ((expr, tyOfExpr cenv.g expr), [], [argExpr], mMethExpr), tpenv | _ -> error(InternalError("unreachable - expected some lambda vars for a tuple mismatch", mItem)) @@ -8980,7 +9207,8 @@ and TcSetterArgExpr cenv env denv objExpr ad (AssignedItemSetter(id, setter, Cal | AssignedPropSetter (pinfo, pminfo, pminst) -> MethInfoChecks cenv.g cenv.amap true None [objExpr] ad m pminfo let calledArgTy = List.head (List.head (pminfo.GetParamTypes(cenv.amap, m, pminst))) - let argExprPrebinder, argExpr = AdjustCallerArgExprForCoercions cenv.g cenv.amap cenv.infoReader ad false calledArgTy ReflectedArgInfo.None callerArgTy m argExpr + let tcVal = LightweightTcValForUsingInBuildMethodCall cenv.g + let argExprPrebinder, argExpr = MethodCalls.AdjustCallerArgExpr tcVal cenv.g cenv.amap cenv.infoReader ad false calledArgTy ReflectedArgInfo.None callerArgTy m argExpr let mut = (if isStructTy cenv.g (tyOfExpr cenv.g objExpr) then DefinitelyMutates else PossiblyMutates) let action = BuildPossiblyConditionalMethodCall cenv env mut m true pminfo NormalValUse pminst [objExpr] [argExpr] |> fst argExprPrebinder, action, Item.Property (pinfo.PropertyName, [pinfo]) @@ -8989,7 +9217,8 @@ and TcSetterArgExpr cenv env denv objExpr ad (AssignedItemSetter(id, setter, Cal // Get or set instance IL field ILFieldInstanceChecks cenv.g cenv.amap ad m finfo let calledArgTy = finfo.FieldType (cenv.amap, m) - let argExprPrebinder, argExpr = AdjustCallerArgExprForCoercions cenv.g cenv.amap cenv.infoReader ad false calledArgTy ReflectedArgInfo.None callerArgTy m argExpr + let tcVal = LightweightTcValForUsingInBuildMethodCall cenv.g + let argExprPrebinder, argExpr = MethodCalls.AdjustCallerArgExpr tcVal cenv.g cenv.amap cenv.infoReader ad false calledArgTy ReflectedArgInfo.None callerArgTy m argExpr let action = BuildILFieldSet cenv.g m objExpr finfo argExpr argExprPrebinder, action, Item.ILField finfo @@ -8997,7 +9226,8 @@ and TcSetterArgExpr cenv env denv objExpr ad (AssignedItemSetter(id, setter, Cal RecdFieldInstanceChecks cenv.g cenv.amap ad m rfinfo let calledArgTy = rfinfo.FieldType CheckRecdFieldMutation m denv rfinfo - let argExprPrebinder, argExpr = AdjustCallerArgExprForCoercions cenv.g cenv.amap cenv.infoReader ad false calledArgTy ReflectedArgInfo.None callerArgTy m argExpr + let tcVal = LightweightTcValForUsingInBuildMethodCall cenv.g + let argExprPrebinder, argExpr = MethodCalls.AdjustCallerArgExpr tcVal cenv.g cenv.amap cenv.infoReader ad false calledArgTy ReflectedArgInfo.None callerArgTy m argExpr let action = BuildRecdFieldSet cenv.g m objExpr rfinfo argExpr argExprPrebinder, action, Item.RecdField rfinfo @@ -9069,7 +9299,7 @@ and TcMethodArg cenv env (lambdaPropagationInfo, tpenv) (lambdaPropagationInfoFo | _ -> () loop argTy 0 - let e', tpenv = TcExpr cenv argTy env tpenv argExpr + let e', tpenv = TcExprFlex2 cenv argTy env true tpenv argExpr // After we have checked, propagate the info from argument into the overloads that receive it. // @@ -9088,9 +9318,9 @@ and TcMethodArg cenv env (lambdaPropagationInfo, tpenv) (lambdaPropagationInfoFo CallerArg(argTy, mArg, isOpt, e'), (lambdaPropagationInfo, tpenv) /// Typecheck "new Delegate(fun x y z -> ...)" constructs -and TcNewDelegateThen cenv overallTy env tpenv mDelTy mExprAndArg delegateTy arg atomicFlag delayed = +and TcNewDelegateThen cenv (overallTy: OverallTy) env tpenv mDelTy mExprAndArg delegateTy arg atomicFlag delayed = let ad = env.eAccessRights - UnifyTypes cenv env mExprAndArg overallTy delegateTy + UnifyTypes cenv env mExprAndArg overallTy.Commit delegateTy let (SigOfFunctionForDelegate(invokeMethInfo, delArgTys, _, fty)) = GetSigOfFunctionForDelegate cenv.infoReader delegateTy mDelTy ad // We pass isInstance = true here because we're checking the rights to access the "Invoke" method MethInfoChecks cenv.g cenv.amap true None [] env.eAccessRights mExprAndArg invokeMethInfo @@ -9153,10 +9383,10 @@ and TcLinearExprs bodyChecker cenv env overallTy tpenv isCompExpr expr cont = let envinner = ShrinkContext envinner m body.Range // tailcall TcLinearExprs bodyChecker cenv envinner overallTy tpenv isCompExpr body (fun (x, tpenv) -> - cont (fst (mkf (x, overallTy)), tpenv)) + cont (fst (mkf (x, overallTy.Commit)), tpenv)) | SynExpr.IfThenElse (_, _, synBoolExpr, _, synThenExpr, _, synElseExprOpt, spIfToThen, isRecovery, mIfToThen, m) when not isCompExpr -> - let boolExpr, tpenv = TcExprThatCantBeCtorBody cenv cenv.g.bool_ty env tpenv synBoolExpr + let boolExpr, tpenv = TcExprThatCantBeCtorBody cenv (MustEqual cenv.g.bool_ty) env tpenv synBoolExpr let thenExpr, tpenv = let env = match env.eContextInfo with @@ -9167,7 +9397,7 @@ and TcLinearExprs bodyChecker cenv env overallTy tpenv isCompExpr expr cont = | _ -> { env with eContextInfo = ContextInfo.IfExpression synThenExpr.Range } if not isRecovery && Option.isNone synElseExprOpt then - UnifyTypes cenv env m cenv.g.unit_ty overallTy + UnifyTypes cenv env m cenv.g.unit_ty overallTy.Commit TcExprThatCanBeCtorBody cenv overallTy env tpenv synThenExpr @@ -9175,14 +9405,14 @@ and TcLinearExprs bodyChecker cenv env overallTy tpenv isCompExpr expr cont = | None -> let elseExpr = mkUnit cenv.g mIfToThen let spElse = DebugPointForTarget.No // the fake 'unit' value gets exactly the same range as spIfToThen - let overallExpr = primMkCond spIfToThen DebugPointForTarget.Yes spElse m overallTy boolExpr thenExpr elseExpr + let overallExpr = primMkCond spIfToThen DebugPointForTarget.Yes spElse m overallTy.Commit boolExpr thenExpr elseExpr cont (overallExpr, tpenv) | Some synElseExpr -> let env = { env with eContextInfo = ContextInfo.ElseBranchResult synElseExpr.Range } // tailcall TcLinearExprs bodyChecker cenv env overallTy tpenv isCompExpr synElseExpr (fun (elseExpr, tpenv) -> - let resExpr = primMkCond spIfToThen DebugPointForTarget.Yes DebugPointForTarget.Yes m overallTy boolExpr thenExpr elseExpr + let resExpr = primMkCond spIfToThen DebugPointForTarget.Yes DebugPointForTarget.Yes m overallTy.Commit boolExpr thenExpr elseExpr cont (resExpr, tpenv)) | _ -> @@ -9191,7 +9421,7 @@ and TcLinearExprs bodyChecker cenv env overallTy tpenv isCompExpr expr cont = /// Typecheck and compile pattern-matching constructs and TcAndPatternCompileMatchClauses mExpr matchm actionOnFailure cenv inputExprOpt inputTy resultTy env tpenv synClauses = let clauses, tpenv = TcMatchClauses cenv inputTy resultTy env tpenv synClauses - let matchVal, expr = CompilePatternForMatchClauses cenv env mExpr matchm true actionOnFailure inputExprOpt inputTy resultTy clauses + let matchVal, expr = CompilePatternForMatchClauses cenv env mExpr matchm true actionOnFailure inputExprOpt inputTy resultTy.Commit clauses matchVal, expr, tpenv and TcMatchPattern cenv inputTy env tpenv (pat: SynPat, optWhenExpr: SynExpr option) = @@ -9202,17 +9432,17 @@ and TcMatchPattern cenv inputTy env tpenv (pat: SynPat, optWhenExpr: SynExpr opt match optWhenExpr with | Some whenExpr -> let guardEnv = { envinner with eContextInfo = ContextInfo.PatternMatchGuard whenExpr.Range } - let whenExpr', tpenv = TcExpr cenv cenv.g.bool_ty guardEnv tpenv whenExpr + let whenExpr', tpenv = TcExpr cenv (MustEqual cenv.g.bool_ty) guardEnv tpenv whenExpr Some whenExpr', tpenv | None -> None, tpenv patf' (TcPatPhase2Input (values, true)), optWhenExpr', NameMap.range vspecMap, envinner, tpenv -and TcMatchClauses cenv inputTy resultTy env tpenv clauses = +and TcMatchClauses cenv inputTy (resultTy: OverallTy) env tpenv clauses = let mutable first = true let isFirst() = if first then first <- false; true else false List.mapFold (fun clause -> TcMatchClause cenv inputTy resultTy env (isFirst()) clause) tpenv clauses -and TcMatchClause cenv inputTy resultTy env isFirst tpenv (SynMatchClause(pat, optWhenExpr, e, patm, spTgt)) = +and TcMatchClause cenv inputTy (resultTy: OverallTy) env isFirst tpenv (SynMatchClause(pat, optWhenExpr, e, patm, spTgt)) = let pat', optWhenExpr', vspecs, envinner, tpenv = TcMatchPattern cenv inputTy env tpenv (pat, optWhenExpr) let resultEnv = if isFirst then envinner else { envinner with eContextInfo = ContextInfo.FollowingPatternMatchClause e.Range } let e', tpenv = TcExprThatCanBeCtorBody cenv resultTy resultEnv tpenv e @@ -9501,8 +9731,8 @@ and TcNormalizedBinding declKind (cenv: cenv) env tpenv overallTy safeThisValOpt let (PartialValReprInfo(argInfos, _)) = partialValReprInfo let envinner = { envinner with eLambdaArgInfos = argInfos } - if isCtor then TcExprThatIsCtorBody (safeThisValOpt, safeInitInfo) cenv overallExprTy envinner tpenv rhsExpr - else TcExprThatCantBeCtorBody cenv overallExprTy envinner tpenv rhsExpr) + if isCtor then TcExprThatIsCtorBody (safeThisValOpt, safeInitInfo) cenv (MustEqual overallExprTy) envinner tpenv rhsExpr + else TcExprThatCantBeCtorBody cenv (MustConvertTo (false, overallExprTy)) envinner tpenv rhsExpr) if bkind = SynBindingKind.StandaloneExpression && not cenv.isScript then UnifyUnitType cenv env mBinding overallPatTy rhsExprChecked |> ignore @@ -9543,7 +9773,7 @@ and TcNormalizedBinding declKind (cenv: cenv) env tpenv overallTy safeThisValOpt and TcLiteral cenv overallTy env tpenv (attrs, synLiteralValExpr) = let hasLiteralAttr = HasFSharpAttribute cenv.g cenv.g.attrib_LiteralAttribute attrs if hasLiteralAttr then - let literalValExpr, _ = TcExpr cenv overallTy env tpenv synLiteralValExpr + let literalValExpr, _ = TcExpr cenv (MustEqual overallTy) env tpenv synLiteralValExpr match EvalLiteralExprOrAttribArg cenv.g literalValExpr with | Expr.Const (c, _, ty) -> if c = Const.Zero && isStructTy cenv.g ty then @@ -9692,7 +9922,7 @@ and TcAttributeEx canFail cenv (env: TcEnv) attrTgt attrEx (synAttr: SynAttribut let meths = minfos |> List.map (fun minfo -> minfo, None) let afterResolution = ForNewConstructors cenv.tcSink env tyid.idRange methodName minfos let (expr, attributeAssignedNamedItems, _), _ = - TcMethodApplication true cenv env tpenv None [] mAttr mAttr methodName None ad PossiblyMutates false meths afterResolution NormalValUse [arg] (NewInferenceType ()) [] + TcMethodApplication true cenv env tpenv None [] mAttr mAttr methodName None ad PossiblyMutates false meths afterResolution NormalValUse [arg] (MustEqual ty) [] UnifyTypes cenv env mAttr ty (tyOfExpr cenv.g expr) @@ -10027,12 +10257,7 @@ and ApplyAbstractSlotInference (cenv: cenv) (envinner: TcEnv) (bindingTy, m, syn match dispatchSlotsArityMatch with | meths when methInfosEquivByNameAndSig meths -> meths | [] -> - let details = - slots - |> Seq.map (NicePrint.stringOfMethInfo cenv.infoReader m envinner.DisplayEnv) - |> Seq.map (sprintf "%s %s" Environment.NewLine) - |> String.concat "" - + let details = NicePrint.multiLineStringOfMethInfos cenv.infoReader m envinner.DisplayEnv slots errorR(Error(FSComp.SR.tcOverrideArityMismatch details, memberId.idRange)) [] | _ -> [] // check that method to override is sealed is located at CheckOverridesAreAllUsedOnce (typrelns.fs) diff --git a/src/fsharp/CheckExpressions.fsi b/src/fsharp/CheckExpressions.fsi index 1b29c65a55..bef3163d4c 100644 --- a/src/fsharp/CheckExpressions.fsi +++ b/src/fsharp/CheckExpressions.fsi @@ -227,11 +227,11 @@ type TcFileState = isInternalTestSpanStackReferring: bool // forward call - TcSequenceExpressionEntry: TcFileState -> TcEnv -> TType -> UnscopedTyparEnv -> bool * bool ref * SynExpr -> range -> Expr * UnscopedTyparEnv + TcSequenceExpressionEntry: TcFileState -> TcEnv -> OverallTy -> UnscopedTyparEnv -> bool * bool ref * SynExpr -> range -> Expr * UnscopedTyparEnv // forward call - TcArrayOrListSequenceExpression: TcFileState -> TcEnv -> TType -> UnscopedTyparEnv -> bool * SynExpr -> range -> Expr * UnscopedTyparEnv + TcArrayOrListSequenceExpression: TcFileState -> TcEnv -> OverallTy -> UnscopedTyparEnv -> bool * SynExpr -> range -> Expr * UnscopedTyparEnv // forward call - TcComputationExpression: TcFileState -> TcEnv -> TType -> UnscopedTyparEnv -> range * Expr * TType * SynExpr -> Expr * UnscopedTyparEnv + TcComputationExpression: TcFileState -> TcEnv -> OverallTy -> UnscopedTyparEnv -> range * Expr * TType * SynExpr -> Expr * UnscopedTyparEnv } static member Create: g: TcGlobals * @@ -246,11 +246,11 @@ type TcFileState = tcVal: TcValF * isInternalTestSpanStackReferring: bool * // forward call to CheckComputationExpressions.fs - tcSequenceExpressionEntry: (TcFileState -> TcEnv -> TType -> UnscopedTyparEnv -> bool * bool ref * SynExpr -> range -> Expr * UnscopedTyparEnv) * + tcSequenceExpressionEntry: (TcFileState -> TcEnv -> OverallTy -> UnscopedTyparEnv -> bool * bool ref * SynExpr -> range -> Expr * UnscopedTyparEnv) * // forward call to CheckComputationExpressions.fs - tcArrayOrListSequenceExpression: (TcFileState -> TcEnv -> TType -> UnscopedTyparEnv -> bool * SynExpr -> range -> Expr * UnscopedTyparEnv) * + tcArrayOrListSequenceExpression: (TcFileState -> TcEnv -> OverallTy -> UnscopedTyparEnv -> bool * SynExpr -> range -> Expr * UnscopedTyparEnv) * // forward call to CheckComputationExpressions.fs - tcComputationExpression: (TcFileState -> TcEnv -> TType -> UnscopedTyparEnv -> range * Expr * TType * SynExpr -> Expr * UnscopedTyparEnv) + tcComputationExpression: (TcFileState -> TcEnv -> OverallTy -> UnscopedTyparEnv -> range * Expr * TType * SynExpr -> Expr * UnscopedTyparEnv) -> TcFileState /// Represents information about the module or type in which a member or value is declared. @@ -652,28 +652,33 @@ val TcAttributesCanFail: cenv:TcFileState -> env:TcEnv -> attrTgt:AttributeTarge val TcAttributesWithPossibleTargets: canFail: bool -> cenv: TcFileState -> env: TcEnv -> attrTgt: AttributeTargets -> synAttribs: SynAttribute list -> (AttributeTargets * Attrib) list * bool /// Check a constant value, e.g. a literal -val TcConst: cenv: TcFileState -> ty: TType -> m: range -> env: TcEnv -> c: SynConst -> Const +val TcConst: cenv: TcFileState -> overallTy: TType -> m: range -> env: TcEnv -> c: SynConst -> Const /// Check a syntactic expression and convert it to a typed tree expression -val TcExpr: cenv:TcFileState -> ty:TType -> env:TcEnv -> tpenv:UnscopedTyparEnv -> expr:SynExpr -> Expr * UnscopedTyparEnv +val TcExpr: cenv:TcFileState -> ty:OverallTy -> env:TcEnv -> tpenv:UnscopedTyparEnv -> expr:SynExpr -> Expr * UnscopedTyparEnv /// Check a syntactic expression and convert it to a typed tree expression val TcExprOfUnknownType: cenv:TcFileState -> env:TcEnv -> tpenv:UnscopedTyparEnv -> expr:SynExpr -> Expr * TType * UnscopedTyparEnv /// Check a syntactic expression and convert it to a typed tree expression. Possibly allow for subsumption flexibility /// and insert a coercion if necessary. -val TcExprFlex: cenv:TcFileState -> flex:bool -> compat:bool -> ty:TType -> env:TcEnv -> tpenv:UnscopedTyparEnv -> e:SynExpr -> Expr * UnscopedTyparEnv +val TcExprFlex: cenv:TcFileState -> flex:bool -> compat:bool -> desiredTy:TType -> env:TcEnv -> tpenv:UnscopedTyparEnv -> synExpr:SynExpr -> Expr * UnscopedTyparEnv + +/// Process a leaf construct where the actual type of that construct is already pre-known, +/// and the overall type can be eagerly propagated into the actual type, including pre-calculating +/// any type-directed conversion. +val TcPropagatingExprLeafThenConvert: cenv:TcFileState -> overallTy: OverallTy -> actualTy: TType -> env: TcEnv -> m: range -> f: (unit -> Expr * UnscopedTyparEnv) -> Expr * UnscopedTyparEnv /// Check a syntactic statement and convert it to a typed tree expression. val TcStmtThatCantBeCtorBody: cenv:TcFileState -> env:TcEnv -> tpenv:UnscopedTyparEnv -> expr:SynExpr -> Expr * UnscopedTyparEnv /// Check a syntactic expression and convert it to a typed tree expression -val TcExprUndelayed: cenv:TcFileState -> overallTy:TType -> env:TcEnv -> tpenv:UnscopedTyparEnv -> synExpr:SynExpr -> Expr * UnscopedTyparEnv +val TcExprUndelayed: cenv:TcFileState -> overallTy:OverallTy -> env:TcEnv -> tpenv:UnscopedTyparEnv -> synExpr:SynExpr -> Expr * UnscopedTyparEnv /// Check a linear expression (e.g. a sequence of 'let') in a tail-recursive way /// and convert it to a typed tree expression, using the bodyChecker to check the parts /// that are not linear. -val TcLinearExprs: bodyChecker:(TType -> TcEnv -> UnscopedTyparEnv -> SynExpr -> Expr * UnscopedTyparEnv) -> cenv:TcFileState -> env:TcEnv -> overallTy:TType -> tpenv:UnscopedTyparEnv -> isCompExpr:bool -> expr:SynExpr -> cont:(Expr * UnscopedTyparEnv -> Expr * UnscopedTyparEnv) -> Expr * UnscopedTyparEnv +val TcLinearExprs: bodyChecker:(OverallTy -> TcEnv -> UnscopedTyparEnv -> SynExpr -> Expr * UnscopedTyparEnv) -> cenv:TcFileState -> env:TcEnv -> overallTy:OverallTy -> tpenv:UnscopedTyparEnv -> isCompExpr:bool -> expr:SynExpr -> cont:(Expr * UnscopedTyparEnv -> Expr * UnscopedTyparEnv) -> Expr * UnscopedTyparEnv /// Try to check a syntactic statement and indicate if it's type is not unit without emitting a warning val TryTcStmt: cenv:TcFileState -> env:TcEnv -> tpenv:UnscopedTyparEnv -> synExpr:SynExpr -> bool * Expr * UnscopedTyparEnv diff --git a/src/fsharp/CompilerDiagnostics.fs b/src/fsharp/CompilerDiagnostics.fs index 2006048da0..8ce2fe9e14 100644 --- a/src/fsharp/CompilerDiagnostics.fs +++ b/src/fsharp/CompilerDiagnostics.fs @@ -375,6 +375,9 @@ let warningOn err level specificWarnOn = | 1182 -> false // chkUnusedValue - off by default | 3180 -> false // abImplicitHeapAllocation - off by default | 3517 -> false // optFailedToInlineSuggestedValue - off by default + | 3388 -> false // tcSubsumptionImplicitConversionUsed - off by default + | 3389 -> false // tcBuiltInImplicitConversionUsed - off by default + | 3390 -> false // tcImplicitConversionUsedForMethodArg - off by default | _ -> level >= GetWarningLevel err let SplitRelatedDiagnostics(err: PhasedDiagnostic) : PhasedDiagnostic * PhasedDiagnostic list = diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index ba4f4469f9..d709cd5110 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -207,6 +207,19 @@ type OverloadResolutionFailure = * candidates: OverloadInformation list // methodNames may be different (with operators?), this is refactored from original logic to assemble overload failure message * cx: TraitConstraintInfo option +type OverallTy = + /// Each branch of the expression must have the type indicated + | MustEqual of TType + + /// Each branch of the expression must convert to the type indicated + | MustConvertTo of isMethodArg: bool * ty: TType + + /// Represents a point where no subsumption/widening is possible + member x.Commit = + match x with + | MustEqual ty -> ty + | MustConvertTo (_, ty) -> ty + exception ConstraintSolverTupleDiffLengths of displayEnv: DisplayEnv * TType list * TType list * range * range exception ConstraintSolverInfiniteTypes of displayEnv: DisplayEnv * contextInfo: ContextInfo * TType * TType * range * range @@ -474,7 +487,7 @@ let FilterEachThenUndo f meths = trace.Undo() match CheckNoErrorsAndGetWarnings res with | None -> None - | Some warns -> Some (calledMeth, warns, trace)) + | Some (warns, res) -> Some (calledMeth, warns, trace, res)) let ShowAccessDomain ad = match ad with @@ -726,6 +739,7 @@ let rec SimplifyMeasuresInType g resultFirst (generalizable, generalized as para | TType_ucase(_, l) | TType_app (_, l) | TType_anon (_,l) + | TType_erased_union (_,l) | TType_tuple (_, l) -> SimplifyMeasuresInTypes g param l | TType_fun (d, r) -> if resultFirst then SimplifyMeasuresInTypes g param [r;d] else SimplifyMeasuresInTypes g param [d;r] @@ -764,6 +778,7 @@ let rec GetMeasureVarGcdInType v ty = | TType_ucase(_, l) | TType_app (_, l) | TType_anon (_,l) + | TType_erased_union (_,l) | TType_tuple (_, l) -> GetMeasureVarGcdInTypes v l | TType_fun (d, r) -> GcdRational (GetMeasureVarGcdInType v d) (GetMeasureVarGcdInType v r) @@ -980,7 +995,7 @@ and SolveAnonInfoEqualsAnonInfo (csenv: ConstraintSolverEnv) m2 (anonInfo1: Anon ErrorD (ConstraintSolverError(message, csenv.m,m2)) else ResultD ()) - + /// Add the constraint "ty1 = ty2" to the constraint problem. /// Propagate all effects of adding this constraint, e.g. to solve type variables and SolveTypeEqualsType (csenv: ConstraintSolverEnv) ndeep m2 (trace: OptionalTrace) (cxsln:(TraitConstraintInfo * TraitConstraintSln) option) ty1 ty2 = @@ -1033,10 +1048,12 @@ and SolveTypeEqualsType (csenv: ConstraintSolverEnv) ndeep m2 (trace: OptionalTr if not (typarsAEquiv g aenv tps1 tps2) then localAbortD else SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty1 rty2 - | TType_ucase (uc1, l1), TType_ucase (uc2, l2) when g.unionCaseRefEq uc1 uc2 -> SolveTypeEqualsTypeEqns csenv ndeep m2 trace None l1 l2 + | TType_ucase (uc1, l1), TType_ucase (uc2, l2) when g.unionCaseRefEq uc1 uc2 -> + SolveTypeEqualsTypeEqns csenv ndeep m2 trace None l1 l2 + | TType_erased_union (_, cases1), TType_erased_union (_, cases2) -> + SolveTypeEqualsTypeEqns csenv ndeep m2 trace None cases1 cases2 | _ -> localAbortD - and SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace ty1 ty2 = SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 trace None ty1 ty2 and private SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 trace cxsln ty1 ty2 = @@ -1134,6 +1151,22 @@ and SolveTypeSubsumesType (csenv: ConstraintSolverEnv) ndeep m2 (trace: Optional | TType_ucase (uc1, l1), TType_ucase (uc2, l2) when g.unionCaseRefEq uc1 uc2 -> SolveTypeEqualsTypeEqns csenv ndeep m2 trace cxsln l1 l2 + // (int|string) :> sty1 if + // int :> sty1 AND + // string :> sty1 + | _, TType_erased_union (_, cases2) -> + cases2 |> IterateD (fun ty2 -> SolveTypeSubsumesType csenv ndeep m2 trace cxsln sty1 ty2) + + // sty2 :> (IComparable|ICloneable) if + // sty2 :> IComparable OR + // sty2 :> ICloneable OR + // when sty2 is not an erased union type + | TType_erased_union (_, cases1), _ -> + match cases1 |> List.tryFind (fun ty1 -> TypeFeasiblySubsumesType ndeep g amap csenv.m ty1 CanCoerce sty2) with + | Some ty1 -> + SolveTypeSubsumesType csenv ndeep m2 trace cxsln ty1 sty2 + | None -> + ErrorD (ConstraintSolverError(FSComp.SR.csErasedUnionTypeNotContained(NicePrint.minimalStringOfType denv sty2, NicePrint.minimalStringOfType denv sty1), csenv.m, m2)) | _ -> // By now we know the type is not a variable type @@ -1563,7 +1596,7 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload let methOverloadResult, errors = trace.CollectThenUndoOrCommit (fun (a, _) -> Option.isSome a) - (fun trace -> ResolveOverloading csenv (WithTrace trace) nm ndeep (Some traitInfo) CallerArgs.Empty AccessibleFromEverywhere calledMethGroup false (Some rty)) + (fun trace -> ResolveOverloading csenv (WithTrace trace) nm ndeep (Some traitInfo) CallerArgs.Empty AccessibleFromEverywhere calledMethGroup false (Some (MustEqual rty))) match anonRecdPropSearch, recdPropSearch, methOverloadResult with | Some (anonInfo, tinst, i), None, None -> @@ -2238,11 +2271,12 @@ and CanMemberSigsMatchUpToCheck (csenv: ConstraintSolverEnv) permitOptArgs // are we allowed to supply optional and/or "param" arguments? alwaysCheckReturn // always check the return type? - unifyTypes // used to equate the formal method instantiation with the actual method instantiation for a generic method, and the return types - subsumeTypes // used to compare the "obj" type - (subsumeArg: CalledArg -> CallerArg<_> -> OperationResult) // used to compare the arguments for compatibility - reqdRetTyOpt - (calledMeth: CalledMeth<_>): ImperativeOperationResult = + (unifyTypes: TType -> TType -> OperationResult) // used to equate the formal method instantiation with the actual method instantiation for a generic method, and the return types + (subsumeTypes: TType -> TType -> OperationResult) // used to compare the "obj" type + (subsumeOrConvertTypes: TType -> TType -> OperationResult) // used to convert the "return" for MustConvertTo + (subsumeOrConvertArg: CalledArg -> CallerArg<_> -> OperationResult) // used to convert the arguments + (reqdRetTyOpt: OverallTy option) + (calledMeth: CalledMeth<_>): OperationResult = trackErrors { let g = csenv.g let amap = csenv.amap @@ -2260,41 +2294,60 @@ and CanMemberSigsMatchUpToCheck if minst.Length <> uminst.Length then return! ErrorD(Error(FSComp.SR.csTypeInstantiationLengthMismatch(), m)) else - do! Iterate2D unifyTypes minst uminst - if not (permitOptArgs || isNil unnamedCalledOptArgs) then - return! ErrorD(Error(FSComp.SR.csOptionalArgumentNotPermittedHere(), m)) - else - let calledObjArgTys = calledMeth.CalledObjArgTys(m) + let! usesTDC1 = MapCombineTDC2D unifyTypes minst uminst + let! usesTDC2 = + trackErrors { + if not (permitOptArgs || isNil unnamedCalledOptArgs) then + return! ErrorD(Error(FSComp.SR.csOptionalArgumentNotPermittedHere(), m)) + else + let calledObjArgTys = calledMeth.CalledObjArgTys(m) - // Check all the argument types. + // Check all the argument types. - if calledObjArgTys.Length <> callerObjArgTys.Length then - if calledObjArgTys.Length <> 0 then - return! ErrorD(Error (FSComp.SR.csMemberIsNotStatic(minfo.LogicalName), m)) + if calledObjArgTys.Length <> callerObjArgTys.Length then + if calledObjArgTys.Length <> 0 then + return! ErrorD(Error (FSComp.SR.csMemberIsNotStatic(minfo.LogicalName), m)) + else + return! ErrorD(Error (FSComp.SR.csMemberIsNotInstance(minfo.LogicalName), m)) + else + return! MapCombineTDC2D subsumeTypes calledObjArgTys callerObjArgTys + } + + let! usesTDC3 = + calledMeth.ArgSets |> MapCombineTDCD (fun argSet -> trackErrors { + if argSet.UnnamedCalledArgs.Length <> argSet.UnnamedCallerArgs.Length then + return! ErrorD(Error(FSComp.SR.csArgumentLengthMismatch(), m)) else - return! ErrorD(Error (FSComp.SR.csMemberIsNotInstance(minfo.LogicalName), m)) - else - do! Iterate2D subsumeTypes calledObjArgTys callerObjArgTys - for argSet in calledMeth.ArgSets do - if argSet.UnnamedCalledArgs.Length <> argSet.UnnamedCallerArgs.Length then - return! ErrorD(Error(FSComp.SR.csArgumentLengthMismatch(), m)) - else - do! Iterate2D subsumeArg argSet.UnnamedCalledArgs argSet.UnnamedCallerArgs - match calledMeth.ParamArrayCalledArgOpt with - | Some calledArg -> - if isArray1DTy g calledArg.CalledArgumentType then - let paramArrayElemTy = destArrayTy g calledArg.CalledArgumentType - let reflArgInfo = calledArg.ReflArgInfo // propagate the reflected-arg info to each param array argument - match calledMeth.ParamArrayCallerArgs with - | Some args -> - for callerArg in args do - do! subsumeArg (CalledArg((0, 0), false, NotOptional, NoCallerInfo, false, false, None, reflArgInfo, paramArrayElemTy)) callerArg - | _ -> () - | _ -> () - for argSet in calledMeth.ArgSets do - for arg in argSet.AssignedNamedArgs do - do! subsumeArg arg.CalledArg arg.CallerArg - for AssignedItemSetter(_, item, caller) in assignedItemSetters do + return! MapCombineTDC2D subsumeOrConvertArg argSet.UnnamedCalledArgs argSet.UnnamedCallerArgs + }) + + let! usesTDC4 = + match calledMeth.ParamArrayCalledArgOpt with + | Some calledArg -> + if isArray1DTy g calledArg.CalledArgumentType then + let paramArrayElemTy = destArrayTy g calledArg.CalledArgumentType + let reflArgInfo = calledArg.ReflArgInfo // propagate the reflected-arg info to each param array argument + match calledMeth.ParamArrayCallerArgs with + | Some args -> + args |> MapCombineTDCD (fun callerArg -> + subsumeOrConvertArg (CalledArg((0, 0), false, NotOptional, NoCallerInfo, false, false, None, reflArgInfo, paramArrayElemTy)) callerArg + ) + + + | _ -> ResultD TypeDirectedConversionUsed.No + else + ResultD TypeDirectedConversionUsed.No + | _ -> ResultD TypeDirectedConversionUsed.No + + let! usesTDC5 = + calledMeth.ArgSets |> MapCombineTDCD (fun argSet -> + argSet.AssignedNamedArgs |> MapCombineTDCD (fun arg -> + subsumeOrConvertArg arg.CalledArg arg.CallerArg + ) + ) + + let! usesTDC6 = + assignedItemSetters |> MapCombineTDCD (fun (AssignedItemSetter(_, item, caller)) -> let name, calledArgTy = match item with | AssignedPropSetter(_, pminfo, pminst) -> @@ -2310,17 +2363,26 @@ and CanMemberSigsMatchUpToCheck let calledArgTy = rfinfo.FieldType rfinfo.Name, calledArgTy - do! subsumeArg (CalledArg((-1, 0), false, NotOptional, NoCallerInfo, false, false, Some (mkSynId m name), ReflectedArgInfo.None, calledArgTy)) caller - // - Always take the return type into account for + subsumeOrConvertArg (CalledArg((-1, 0), false, NotOptional, NoCallerInfo, false, false, Some (mkSynId m name), ReflectedArgInfo.None, calledArgTy)) caller + ) + + // - Always take the return type into account for resolving overloading of // -- op_Explicit, op_Implicit // -- methods using tupling of unfilled out args // - Never take into account return type information for constructors - match reqdRetTyOpt with - | Some _ when (minfo.IsConstructor || not alwaysCheckReturn && isNil unnamedCalledOutArgs) -> () - | Some reqdRetTy -> - let methodRetTy = calledMeth.CalledReturnTypeAfterOutArgTupling - return! unifyTypes reqdRetTy methodRetTy - | _ -> () + let! usesTDC7 = + match reqdRetTyOpt with + | Some _ when ( (* minfo.IsConstructor || *) not alwaysCheckReturn && isNil unnamedCalledOutArgs) -> + ResultD TypeDirectedConversionUsed.No + | Some (MustConvertTo(_, reqdTy)) when g.langVersion.SupportsFeature LanguageFeature.AdditionalTypeDirectedConversions -> + let methodRetTy = calledMeth.CalledReturnTypeAfterOutArgTupling + subsumeOrConvertTypes reqdTy methodRetTy + | Some reqdRetTy -> + let methodRetTy = calledMeth.CalledReturnTypeAfterOutArgTupling + unifyTypes reqdRetTy.Commit methodRetTy + | _ -> + ResultD TypeDirectedConversionUsed.No + return Array.reduce TypeDirectedConversionUsed.Combine [| usesTDC1; usesTDC2; usesTDC3; usesTDC4; usesTDC5; usesTDC6; usesTDC7 |] } // Assert a subtype constraint, and wrap an ErrorsFromAddingSubsumptionConstraint error around any failure @@ -2344,7 +2406,7 @@ and private SolveTypeSubsumesTypeWithWrappedContextualReport (csenv: ConstraintS | _ -> ErrorD (wrapper (ErrorsFromAddingSubsumptionConstraint(csenv.g, csenv.DisplayEnv, ty1, ty2, res, csenv.eContextInfo, m)))) and private SolveTypeSubsumesTypeWithReport (csenv: ConstraintSolverEnv) ndeep m trace cxsln ty1 ty2 = - SolveTypeSubsumesTypeWithWrappedContextualReport csenv ndeep m trace cxsln ty1 ty2 id + SolveTypeSubsumesTypeWithWrappedContextualReport csenv ndeep m trace cxsln ty1 ty2 id // ty1: actual // ty2: expected @@ -2355,6 +2417,7 @@ and private SolveTypeEqualsTypeWithReport (csenv: ConstraintSolverEnv) ndeep m and ArgsMustSubsumeOrConvert (csenv: ConstraintSolverEnv) + ad ndeep trace cxsln @@ -2365,29 +2428,95 @@ and ArgsMustSubsumeOrConvert let g = csenv.g let m = callerArg.Range - let calledArgTy = AdjustCalledArgType csenv.InfoReader isConstraint enforceNullableOptionalsKnownTypes calledArg callerArg + let calledArgTy, usesTDC, eqn = AdjustCalledArgType csenv.InfoReader ad isConstraint enforceNullableOptionalsKnownTypes calledArg callerArg + match eqn with + | Some (ty1, ty2, msg) -> + do! SolveTypeEqualsTypeWithReport csenv ndeep m trace cxsln ty1 ty2 + msg csenv.DisplayEnv + | None -> () + match usesTDC with + | TypeDirectedConversionUsed.Yes warn -> do! WarnD(warn csenv.DisplayEnv) + | TypeDirectedConversionUsed.No -> () do! SolveTypeSubsumesTypeWithReport csenv ndeep m trace cxsln calledArgTy callerArg.CallerArgumentType if calledArg.IsParamArray && isArray1DTy g calledArgTy && not (isArray1DTy g callerArg.CallerArgumentType) then return! ErrorD(Error(FSComp.SR.csMethodExpectsParams(), m)) - else () + else + return usesTDC } -and MustUnify csenv ndeep trace cxsln ty1 ty2 = - SolveTypeEqualsTypeWithReport csenv ndeep csenv.m trace cxsln ty1 ty2 +// This is a slight variation on ArgsMustSubsumeOrConvert that adds contextual error report to the +// subsumption check. The two could likely be combines. +and ArgsMustSubsumeOrConvertWithContextualReport + (csenv: ConstraintSolverEnv) + ad + ndeep + trace + cxsln + isConstraint + calledMeth + calledArg + (callerArg: CallerArg) = + trackErrors { + let callerArgTy = callerArg.CallerArgumentType + let m = callerArg.Range + let calledArgTy, usesTDC, eqn = AdjustCalledArgType csenv.InfoReader ad isConstraint true calledArg callerArg + match eqn with + | Some (ty1, ty2, msg) -> + do! SolveTypeEqualsType csenv ndeep m trace cxsln ty1 ty2 + msg csenv.DisplayEnv + | None -> () + match usesTDC with + | TypeDirectedConversionUsed.Yes warn -> do! WarnD(warn csenv.DisplayEnv) + | TypeDirectedConversionUsed.No -> () + do! SolveTypeSubsumesTypeWithWrappedContextualReport csenv ndeep m trace cxsln calledArgTy callerArgTy (fun e -> ArgDoesNotMatchError(e :?> _, calledMeth, calledArg, callerArg)) + return usesTDC + } -and MustUnifyInsideUndo csenv ndeep trace cxsln ty1 ty2 = - SolveTypeEqualsTypeWithReport csenv ndeep csenv.m (WithTrace trace) cxsln ty1 ty2 +and TypesEquiv csenv ndeep trace cxsln ty1 ty2 = + trackErrors { + do! SolveTypeEqualsTypeWithReport csenv ndeep csenv.m trace cxsln ty1 ty2 + return TypeDirectedConversionUsed.No + } -and ArgsMustSubsumeOrConvertInsideUndo (csenv: ConstraintSolverEnv) ndeep trace cxsln isConstraint calledMeth calledArg (CallerArg(callerArgTy, m, _, _) as callerArg) = - let calledArgTy = AdjustCalledArgType csenv.InfoReader isConstraint true calledArg callerArg - SolveTypeSubsumesTypeWithWrappedContextualReport csenv ndeep m (WithTrace trace) cxsln calledArgTy callerArgTy (fun e -> ArgDoesNotMatchError(e :?> _, calledMeth, calledArg, callerArg)) +and TypesMustSubsume (csenv: ConstraintSolverEnv) ndeep trace cxsln m calledArgTy callerArgTy = + trackErrors { + do! SolveTypeSubsumesTypeWithReport csenv ndeep m trace cxsln calledArgTy callerArgTy + return TypeDirectedConversionUsed.No + } -and TypesMustSubsumeOrConvertInsideUndo (csenv: ConstraintSolverEnv) ndeep trace cxsln m calledArgTy callerArgTy = - SolveTypeSubsumesTypeWithReport csenv ndeep m trace cxsln calledArgTy callerArgTy +and ReturnTypesMustSubsumeOrConvert (csenv: ConstraintSolverEnv) ad ndeep trace cxsln isConstraint m reqdTy actualTy = + trackErrors { + let reqdTy, usesTDC, eqn = AdjustRequiredTypeForTypeDirectedConversions csenv.InfoReader ad false isConstraint reqdTy actualTy m + match eqn with + | Some (ty1, ty2, msg) -> + do! SolveTypeEqualsType csenv ndeep m trace cxsln ty1 ty2 + msg csenv.DisplayEnv + | None -> () + match usesTDC with + | TypeDirectedConversionUsed.Yes warn -> do! WarnD(warn csenv.DisplayEnv) + | TypeDirectedConversionUsed.No -> () + do! SolveTypeSubsumesTypeWithReport csenv ndeep m trace cxsln reqdTy actualTy + return usesTDC + } -and ArgsEquivInsideUndo (csenv: ConstraintSolverEnv) isConstraint calledArg (CallerArg(callerArgTy, m, _, _) as callerArg) = - let calledArgTy = AdjustCalledArgType csenv.InfoReader isConstraint true calledArg callerArg - if typeEquiv csenv.g calledArgTy callerArgTy then CompleteD else ErrorD(Error(FSComp.SR.csArgumentTypesDoNotMatch(), m)) +and ArgsEquivOrConvert (csenv: ConstraintSolverEnv) ad ndeep trace cxsln isConstraint calledArg (callerArg: CallerArg<_>) = + trackErrors { + let callerArgTy = callerArg.CallerArgumentType + let m = callerArg.Range + let calledArgTy, usesTDC, eqn = AdjustCalledArgType csenv.InfoReader ad isConstraint true calledArg callerArg + match eqn with + | Some (ty1, ty2, msg) -> + do! SolveTypeEqualsType csenv ndeep m trace cxsln ty1 ty2 + msg csenv.DisplayEnv + | None -> () + match usesTDC with + | TypeDirectedConversionUsed.Yes warn -> do! WarnD(warn csenv.DisplayEnv) + | TypeDirectedConversionUsed.No -> () + if not (typeEquiv csenv.g calledArgTy callerArgTy) then + return! ErrorD(Error(FSComp.SR.csArgumentTypesDoNotMatch(), m)) + else + return usesTDC + } and ReportNoCandidatesError (csenv: ConstraintSolverEnv) (nUnnamedCallerArgs, nNamedCallerArgs) methodName ad (calledMethGroup: CalledMeth<_> list) isSequential = @@ -2523,7 +2652,8 @@ and ResolveOverloading ad // The access domain of the caller, e.g. a module, type etc. calledMethGroup // The set of methods being called permitOptArgs // Can we supply optional arguments? - reqdRetTyOpt // The expected return type, if known + (reqdRetTyOpt: OverallTy option) // The expected return type, if known + : CalledMeth option * OperationResult = let g = csenv.g let infoReader = csenv.InfoReader @@ -2554,35 +2684,41 @@ and ResolveOverloading // Exact match rule. // // See what candidates we have based on current inferred type information - // and _exact_ matches of argument types. - match candidates |> FilterEachThenUndo (fun newTrace calledMeth -> + // and exact matches of argument types. + let exactMatchCandidates = + candidates |> FilterEachThenUndo (fun newTrace calledMeth -> let cxsln = Option.map (fun traitInfo -> (traitInfo, MemberConstraintSolutionOfMethInfo csenv.SolverState m calledMeth.Method calledMeth.CalledTyArgs)) cx CanMemberSigsMatchUpToCheck csenv permitOptArgs alwaysCheckReturn - (MustUnifyInsideUndo csenv ndeep newTrace cxsln) - (TypesMustSubsumeOrConvertInsideUndo csenv ndeep (WithTrace newTrace) cxsln m) - (ArgsEquivInsideUndo csenv cx.IsSome) + (TypesEquiv csenv ndeep (WithTrace newTrace) cxsln) // instantiations equivalent + (TypesMustSubsume csenv ndeep (WithTrace newTrace) cxsln m) // obj can subsume + (ReturnTypesMustSubsumeOrConvert csenv ad ndeep (WithTrace newTrace) cxsln cx.IsSome m) // return can subsume or convert + (ArgsEquivOrConvert csenv ad ndeep (WithTrace newTrace) cxsln cx.IsSome) // args exact reqdRetTyOpt - calledMeth) with - | [(calledMeth, warns, _)] -> - Some calledMeth, OkResult (warns, ()), NoTrace // Can't re-play the trace since ArgsEquivInsideUndo was used + calledMeth) + + match exactMatchCandidates with + | [(calledMeth, warns, _, _usesTDC)] -> + Some calledMeth, OkResult (warns, ()), NoTrace | _ -> // Now determine the applicable methods. // Subsumption on arguments is allowed. - let applicable = candidates |> FilterEachThenUndo (fun newTrace candidate -> - let cxsln = Option.map (fun traitInfo -> (traitInfo, MemberConstraintSolutionOfMethInfo csenv.SolverState m candidate.Method candidate.CalledTyArgs)) cx - CanMemberSigsMatchUpToCheck - csenv - permitOptArgs - alwaysCheckReturn - (MustUnifyInsideUndo csenv ndeep newTrace cxsln) - (TypesMustSubsumeOrConvertInsideUndo csenv ndeep (WithTrace newTrace) cxsln m) - (ArgsMustSubsumeOrConvertInsideUndo csenv ndeep newTrace cxsln cx.IsSome candidate) - reqdRetTyOpt - candidate) + let applicable = + candidates |> FilterEachThenUndo (fun newTrace candidate -> + let cxsln = Option.map (fun traitInfo -> (traitInfo, MemberConstraintSolutionOfMethInfo csenv.SolverState m candidate.Method candidate.CalledTyArgs)) cx + CanMemberSigsMatchUpToCheck + csenv + permitOptArgs + alwaysCheckReturn + (TypesEquiv csenv ndeep (WithTrace newTrace) cxsln) // instantiations equivalent + (TypesMustSubsume csenv ndeep (WithTrace newTrace) cxsln m) // obj can subsume + (ReturnTypesMustSubsumeOrConvert csenv ad ndeep (WithTrace newTrace) cxsln cx.IsSome m) // return can subsume or convert + (ArgsMustSubsumeOrConvertWithContextualReport csenv ad ndeep (WithTrace newTrace) cxsln cx.IsSome candidate) // args can subsume + reqdRetTyOpt + candidate) let failOverloading overloadResolutionFailure = // Try to extract information to give better error for ambiguous op_Explicit and op_Implicit @@ -2597,7 +2733,7 @@ and ResolveOverloading match convOpData with | Some (fromTy, toTy) -> - UnresolvedConversionOperator (denv, fromTy, toTy, m) + UnresolvedConversionOperator (denv, fromTy, toTy.Commit, m) | None -> // Otherwise pass the overload resolution failure for error printing in CompileOps UnresolvedOverloading (denv, callerArgs, overloadResolutionFailure, m) @@ -2614,9 +2750,10 @@ and ResolveOverloading csenv permitOptArgs alwaysCheckReturn - (MustUnifyInsideUndo csenv ndeep newTrace cxsln) - (TypesMustSubsumeOrConvertInsideUndo csenv ndeep (WithTrace newTrace) cxsln m) - (ArgsMustSubsumeOrConvertInsideUndo csenv ndeep newTrace cxsln cx.IsSome calledMeth) + (TypesEquiv csenv ndeep (WithTrace newTrace) cxsln) + (TypesMustSubsume csenv ndeep (WithTrace newTrace) cxsln m) + (ReturnTypesMustSubsumeOrConvert csenv ad ndeep (WithTrace newTrace) cxsln cx.IsSome m) + (ArgsMustSubsumeOrConvertWithContextualReport csenv ad ndeep (WithTrace newTrace) cxsln cx.IsSome calledMeth) reqdRetTyOpt calledMeth) with | OkResult _ -> None @@ -2625,7 +2762,7 @@ and ResolveOverloading None, ErrorD (failOverloading (NoOverloadsFound (methodName, errors, cx))), NoTrace - | [(calledMeth, warns, t)] -> + | [(calledMeth, warns, t, _usesTDC)] -> Some calledMeth, OkResult (warns, ()), WithTrace t | applicableMeths -> @@ -2675,9 +2812,14 @@ and ResolveOverloading 0 /// Check whether one overload is better than another - let better (candidate: CalledMeth<_>, candidateWarnings, _) (other: CalledMeth<_>, otherWarnings, _) = + let better (candidate: CalledMeth<_>, candidateWarnings, _, usesTDC1) (other: CalledMeth<_>, otherWarnings, _, usesTDC2) = let candidateWarnCount = List.length candidateWarnings let otherWarnCount = List.length otherWarnings + + // Prefer methods that don't use type-directed conversion + let c = compare (match usesTDC1 with TypeDirectedConversionUsed.No -> 1 | _ -> 0) (match usesTDC2 with TypeDirectedConversionUsed.No -> 1 | _ -> 0) + if c <> 0 then c else + // Prefer methods that don't give "this code is less generic" warnings // Note: Relies on 'compare' respecting true > false let c = compare (candidateWarnCount = 0) (otherWarnCount = 0) @@ -2779,7 +2921,6 @@ and ResolveOverloading if c <> 0 then c else 0 - let bestMethods = let indexedApplicableMeths = applicableMeths |> List.indexed @@ -2793,7 +2934,7 @@ and ResolveOverloading else None) match bestMethods with - | [(calledMeth, warns, t)] -> Some calledMeth, OkResult (warns, ()), WithTrace t + | [(calledMeth, warns, t, _usesTDC)] -> Some calledMeth, OkResult (warns, ()), WithTrace t | bestMethods -> let methods = let getMethodSlotsAndErrors methodSlot errors = @@ -2809,8 +2950,8 @@ and ResolveOverloading | [] -> match applicableMeths with | [] -> for methodSlot in candidates do yield getMethodSlotsAndErrors methodSlot [] - | m -> for methodSlot, errors, _ in m do yield getMethodSlotsAndErrors methodSlot errors - | m -> for methodSlot, errors, _ in m do yield getMethodSlotsAndErrors methodSlot errors ] + | m -> for methodSlot, errors, _, _ in m do yield getMethodSlotsAndErrors methodSlot errors + | m -> for methodSlot, errors, _, _ in m do yield getMethodSlotsAndErrors methodSlot errors ] let methods = List.concat methods @@ -2833,17 +2974,18 @@ and ResolveOverloading let cxsln = Option.map (fun traitInfo -> (traitInfo, MemberConstraintSolutionOfMethInfo csenv.SolverState m calledMeth.Method calledMeth.CalledTyArgs)) cx match calledMethTrace with | NoTrace -> - return! - // No trace available for CanMemberSigsMatchUpToCheck with ArgsMustSubsumeOrConvert + let! _usesTDC = CanMemberSigsMatchUpToCheck csenv permitOptArgs true - (MustUnify csenv ndeep trace cxsln) - (TypesMustSubsumeOrConvertInsideUndo csenv ndeep trace cxsln m)// REVIEW: this should not be an "InsideUndo" operation - (ArgsMustSubsumeOrConvert csenv ndeep trace cxsln cx.IsSome true) + (TypesEquiv csenv ndeep trace cxsln) // instantiations equal + (TypesMustSubsume csenv ndeep trace cxsln m) // obj can subsume + (ReturnTypesMustSubsumeOrConvert csenv ad ndeep trace cxsln cx.IsSome m) // return can subsume or convert + (ArgsMustSubsumeOrConvert csenv ad ndeep trace cxsln cx.IsSome true) // args can subsume or convert reqdRetTyOpt calledMeth + return () | WithTrace calledMethTrc -> // Re-play existing trace @@ -2852,13 +2994,19 @@ and ResolveOverloading // Unify return type match reqdRetTyOpt with | None -> () - | Some _ when calledMeth.Method.IsConstructor -> () - | Some reqdRetTy -> + | Some reqdRetTy -> let actualRetTy = calledMeth.CalledReturnTypeAfterOutArgTupling - if isByrefTy g reqdRetTy then + if isByrefTy g reqdRetTy.Commit then return! ErrorD(Error(FSComp.SR.tcByrefReturnImplicitlyDereferenced(), m)) else - return! MustUnify csenv ndeep trace cxsln reqdRetTy actualRetTy + match reqdRetTy with + | MustConvertTo(isMethodArg, reqdRetTy) when g.langVersion.SupportsFeature LanguageFeature.AdditionalTypeDirectedConversions -> + let! _usesTDC = ReturnTypesMustSubsumeOrConvert csenv ad ndeep trace cxsln isMethodArg m reqdRetTy actualRetTy + return () + | _ -> + let! _usesTDC = TypesEquiv csenv ndeep trace cxsln reqdRetTy.Commit actualRetTy + return () + } | None -> @@ -2886,15 +3034,16 @@ let UnifyUniqueOverloading let ndeep = 0 match calledMethGroup, candidates with | _, [calledMeth] -> trackErrors { - do! + let! _usesTDC = // Only one candidate found - we thus know the types we expect of arguments CanMemberSigsMatchUpToCheck csenv true // permitOptArgs true // always check return type - (MustUnify csenv ndeep NoTrace None) - (TypesMustSubsumeOrConvertInsideUndo csenv ndeep NoTrace None m) - (ArgsMustSubsumeOrConvert csenv ndeep NoTrace None false false) // UnifyUniqueOverloading is not called in case of trait call - pass isConstraint=false + (TypesEquiv csenv ndeep NoTrace None) + (TypesMustSubsume csenv ndeep NoTrace None m) + (ReturnTypesMustSubsumeOrConvert csenv ad ndeep NoTrace None false m) + (ArgsMustSubsumeOrConvert csenv ad ndeep NoTrace None false false) (Some reqdRetTy) calledMeth return true @@ -2946,7 +3095,7 @@ let UndoIfFailed f = // Don't report warnings if we failed trace.Undo() false - | Some warns -> + | Some (warns, _) -> // Report warnings if we succeeded ReportWarnings warns true @@ -2957,9 +3106,9 @@ let UndoIfFailedOrWarnings f = try f trace |> CheckNoErrorsAndGetWarnings - with e -> None + with _ -> None match res with - | Some [] -> + | Some ([], _)-> true | _ -> trace.Undo() diff --git a/src/fsharp/ConstraintSolver.fsi b/src/fsharp/ConstraintSolver.fsi index 086168c272..fb0d76a2b4 100644 --- a/src/fsharp/ConstraintSolver.fsi +++ b/src/fsharp/ConstraintSolver.fsi @@ -106,6 +106,17 @@ type OverloadResolutionFailure = * candidates: OverloadInformation list // methodNames may be different (with operators?), this is refactored from original logic to assemble overload failure message * cx: TraitConstraintInfo option +/// Represents known information prior to checking an expression or pattern, e.g. it's expected type +type OverallTy = + /// Each branch of the expression must have the type indicated + | MustEqual of TType + + /// Each branch of the expression must convert to the type indicated + | MustConvertTo of isMethodArg: bool * ty: TType + + /// Represents a point where no subsumption/widening is possible + member Commit: TType + exception ConstraintSolverTupleDiffLengths of displayEnv: DisplayEnv * TType list * TType list * range * range exception ConstraintSolverInfiniteTypes of displayEnv: DisplayEnv * contextInfo: ContextInfo * TType * TType * range * range exception ConstraintSolverTypesNotInEqualityRelation of displayEnv: DisplayEnv * TType * TType * range * range * ContextInfo @@ -141,9 +152,9 @@ type OptionalTrace = val SimplifyMeasuresInTypeScheme: TcGlobals -> bool -> Typars -> TType -> TyparConstraint list -> Typars -val ResolveOverloadingForCall: DisplayEnv -> ConstraintSolverState -> range -> methodName: string -> ndeep: int -> cx: TraitConstraintInfo option -> callerArgs: CallerArgs -> AccessorDomain -> calledMethGroup: CalledMeth list -> permitOptArgs: bool -> reqdRetTyOpt: TType option -> CalledMeth option * OperationResult +val ResolveOverloadingForCall: DisplayEnv -> ConstraintSolverState -> range -> methodName: string -> ndeep: int -> cx: TraitConstraintInfo option -> callerArgs: CallerArgs -> AccessorDomain -> calledMethGroup: CalledMeth list -> permitOptArgs: bool -> reqdRetTyOpt: OverallTy option -> CalledMeth option * OperationResult -val UnifyUniqueOverloading: DisplayEnv -> ConstraintSolverState -> range -> int * int -> string -> AccessorDomain -> CalledMeth list -> TType -> OperationResult +val UnifyUniqueOverloading: DisplayEnv -> ConstraintSolverState -> range -> int * int -> string -> AccessorDomain -> CalledMeth list -> OverallTy -> OperationResult /// Remove the global constraints where these type variables appear in the support of the constraint val EliminateConstraintsForGeneralizedTypars: DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> Typars -> unit diff --git a/src/fsharp/ErrorLogger.fs b/src/fsharp/ErrorLogger.fs index cb786b8d39..ed4469d7fc 100644 --- a/src/fsharp/ErrorLogger.fs +++ b/src/fsharp/ErrorLogger.fs @@ -543,9 +543,9 @@ let ResultD x = OkResult([], x) let CheckNoErrorsAndGetWarnings res = match res with - | OkResult (warns, _) -> Some warns + | OkResult (warns, res2) -> Some (warns, res2) | ErrorResult _ -> None - + /// The bind in the monad. Stop on first error. Accumulate warnings and continue. let (++) res f = match res with @@ -616,7 +616,13 @@ let TryD f g = let rec RepeatWhileD nDeep body = body nDeep ++ (fun x -> if x then RepeatWhileD (nDeep+1) body else CompleteD) -let AtLeastOneD f l = MapD f l ++ (fun res -> ResultD (List.exists id res)) +let inline AtLeastOneD f l = MapD f l ++ (fun res -> ResultD (List.exists id res)) + +let inline AtLeastOne2D f xs ys = List.zip xs ys |> AtLeastOneD (fun (x,y) -> f x y) + +let inline MapReduceD mapper zero reducer l = MapD mapper l ++ (fun res -> ResultD (match res with [] -> zero | _ -> List.reduce reducer res)) + +let inline MapReduce2D mapper zero reducer xs ys = List.zip xs ys |> MapReduceD (fun (x,y) -> mapper x y) zero reducer [] module OperationResult = diff --git a/src/fsharp/ErrorLogger.fsi b/src/fsharp/ErrorLogger.fsi index d5fbb9d46e..cdecdafdc6 100644 --- a/src/fsharp/ErrorLogger.fsi +++ b/src/fsharp/ErrorLogger.fsi @@ -256,7 +256,7 @@ val CompleteD: OperationResult val ResultD: x:'a -> OperationResult<'a> -val CheckNoErrorsAndGetWarnings: res:OperationResult<'a> -> exn list option +val CheckNoErrorsAndGetWarnings: res:OperationResult<'a> -> (exn list * 'a) option val ( ++ ): res:OperationResult<'a> -> f:('a -> OperationResult<'b>) -> OperationResult<'b> @@ -302,7 +302,13 @@ val TryD: f:(unit -> OperationResult<'a>) -> g:(exn -> OperationResult<'a>) -> O val RepeatWhileD: nDeep:int -> body:(int -> OperationResult) -> OperationResult -val AtLeastOneD: f:('a -> OperationResult) -> l:'a list -> OperationResult +val inline AtLeastOneD: f:('a -> OperationResult) -> l:'a list -> OperationResult + +val inline AtLeastOne2D: f:('a -> 'b -> OperationResult) -> xs:'a list -> ys:'b list -> OperationResult + +val inline MapReduceD: mapper:('a -> OperationResult<'b>) -> zero: 'b -> reducer: ('b -> 'b -> 'b) -> l:'a list -> OperationResult<'b> + +val inline MapReduce2D: mapper:('a -> 'b -> OperationResult<'c>) -> zero: 'c -> reducer: ('c -> 'c -> 'c) -> xs:'a list -> ys:'b list -> OperationResult<'c> module OperationResult = val inline ignore: res:OperationResult<'a> -> OperationResult diff --git a/src/fsharp/FSComp.txt b/src/fsharp/FSComp.txt index 5b45a4451f..408a7bcb89 100644 --- a/src/fsharp/FSComp.txt +++ b/src/fsharp/FSComp.txt @@ -18,12 +18,12 @@ undefinedNameTypeParameter,"The type parameter %s is not defined." undefinedNamePatternDiscriminator,"The pattern discriminator '%s' is not defined." replaceWithSuggestion,"Replace with '%s'" addIndexerDot,"Add . for indexer access." -listElementHasWrongType,"All elements of a list must be of the same type as the first element, which here is '%s'. This element has type '%s'." -arrayElementHasWrongType,"All elements of an array must be of the same type as the first element, which here is '%s'. This element has type '%s'." +listElementHasWrongType,"All elements of a list must be implicitly convertible to the type of the first element, which here is '%s'. This element has type '%s'." +arrayElementHasWrongType,"All elements of an array must be implicitly convertible to the type of the first element, which here is '%s'. This element has type '%s'." missingElseBranch,"This 'if' expression is missing an 'else' branch. Because 'if' is an expression, and not a statement, add an 'else' branch which also returns a value of type '%s'." ifExpression,"The 'if' expression needs to have type '%s' to satisfy context type requirements. It currently has type '%s'." -elseBranchHasWrongType,"All branches of an 'if' expression must return values of the same type as the first branch, which here is '%s'. This branch returns a value of type '%s'." -followingPatternMatchClauseHasWrongType,"All branches of a pattern match expression must return values of the same type as the first branch, which here is '%s'. This branch returns a value of type '%s'." +elseBranchHasWrongType,"All branches of an 'if' expression must return values implicitly convertible to the type of the first branch, which here is '%s'. This branch returns a value of type '%s'." +followingPatternMatchClauseHasWrongType,"All branches of a pattern match expression must return values implicitly convertible to the type of the first branch, which here is '%s'. This branch returns a value of type '%s'." patternMatchGuardIsNotBool,"A pattern match guard must be of type 'bool', but this 'when' expression is of type '%s'." commaInsteadOfSemicolonInRecord,"A ';' is used to separate field values in records. Consider replacing ',' with ';'." derefInsteadOfNot,"The '!' operator is used to dereference a ref cell. Consider using 'not expr' here." @@ -324,6 +324,7 @@ csTypeIsNotEnumType,"The type '%s' is not a CLI enum type" csTypeHasNonStandardDelegateType,"The type '%s' has a non-standard delegate type" csTypeIsNotDelegateType,"The type '%s' is not a CLI delegate type" csTypeParameterCannotBeNullable,"This type parameter cannot be instantiated to 'Nullable'. This is a restriction imposed in order to ensure the meaning of 'null' in some CLI languages is not confusing when used in conjunction with 'Nullable' values." +csErasedUnionTypeNotContained,"The erased union type '%s' is not compatible with the erased union type '%s'" csGenericConstructRequiresStructType,"A generic construct requires that the type '%s' is a CLI or F# struct type" csGenericConstructRequiresUnmanagedType,"A generic construct requires that the type '%s' is an unmanaged type" csTypeNotCompatibleBecauseOfPrintf,"The type '%s' is not compatible with any of the types %s, arising from the use of a printf-style format string" @@ -1529,6 +1530,8 @@ featureNullableOptionalInterop,"nullable optional interop" featureDefaultInterfaceMemberConsumption,"default interface member consumption" featureStringInterpolation,"string interpolation" featureWitnessPassing,"witness passing for trait constraints in F# quotations" +featureErasedUnions,"erased unions" +featureAdditionalImplicitConversions,"additional type-directed conversions" featureStructActivePattern,"struct representation for active patterns" 3353,fsiInvalidDirective,"Invalid directive '#%s %s'" 3360,typrelInterfaceWithConcreteAndVariable,"'%s' cannot implement the interface '%s' with the two instantiations '%s' and '%s' because they may unify." @@ -1556,6 +1559,11 @@ forFormatInvalidForInterpolated4,"Interpolated strings used as type IFormattable 3384,scriptSdkNotDeterminedUnexpected,"The .NET SDK for this script could not be determined. If the script is in a directory using a 'global.json' then ensure the relevant .NET SDK is installed. Unexpected error '%s'." 3384,scriptSdkNotDeterminedNoHost,"The .NET SDK for this script could not be determined. dotnet.exe could not be found ensure a .NET SDK is installed." 3385,tcInvalidStructReturn,"The use of '[]' on values, functions and methods is only allowed on partial active pattern definitions" +3387,tcAmbiguousImplicitConversion,"This expression has type '%s' and is only made compatible with type '%s' through an ambiguous implicit conversion. Consider using an explicit call to 'op_Implicit'. The applicable implicit conversions are:%s" +3388,tcSubsumptionImplicitConversionUsed,"This expression implicitly converts type '%s' to type '%s'. See https://aka.ms/fsharp-implicit-convs." +3389,tcBuiltInImplicitConversionUsed,"This expression uses a built-in implicit conversion to convert type '%s' to type '%s'. See https://aka.ms/fsharp-implicit-convs." +3390,tcImplicitConversionUsedForMethodArg,"This expression uses the implicit conversion '%s' to convert type '%s' to type '%s'." +3391,tcImplicitConversionUsedForNonMethodArg,"This expression uses the implicit conversion '%s' to convert type '%s' to type '%s'. See https://aka.ms/fsharp-implicit-convs. This warning may be disabled using '#nowarn \"3391\"." #3501 "This construct is not supported by your version of the F# compiler" CompilerMessage(ExperimentalAttributeMessages.NotSupportedYet, 3501, IsError=true) 3390,xmlDocBadlyFormed,"This XML comment is invalid: '%s'" 3390,xmlDocMissingParameterName,"This XML comment is invalid: missing 'name' attribute for parameter or parameter reference" diff --git a/src/fsharp/FSharp.Core/prim-types.fsi b/src/fsharp/FSharp.Core/prim-types.fsi index baa9a5127b..917abe5829 100644 --- a/src/fsharp/FSharp.Core/prim-types.fsi +++ b/src/fsharp/FSharp.Core/prim-types.fsi @@ -2410,6 +2410,8 @@ namespace Microsoft.FSharp.Core /// /// The input value /// + /// The F# compiler ignored this method when determining possible type-directed conversions. Instead, use Some or None explicitly. + /// /// An option representing the value. /// static member op_Implicit : value:'T -> 'T option @@ -2485,6 +2487,8 @@ namespace Microsoft.FSharp.Core /// /// The input value /// + /// The F# compiler ignored this method when determining possible type-directed conversions. Instead, use Some or None explicitly. + /// /// A voption representing the value. /// static member op_Implicit: value: 'T -> 'T voption diff --git a/src/fsharp/IlxGen.fs b/src/fsharp/IlxGen.fs index 0e6ba2aac8..7df0f5d9ba 100644 --- a/src/fsharp/IlxGen.fs +++ b/src/fsharp/IlxGen.fs @@ -547,6 +547,9 @@ and GenTypeAux amap m (tyenv: TypeReprEnv) voidOK ptrsOK ty = | TType_ucase (ucref, args) -> let cuspec, idx = GenUnionCaseSpec amap m tyenv ucref args EraseUnions.GetILTypeForAlternative cuspec idx + + | TType_erased_union (erasedUnionInfo, _) -> + GenTypeArgAux amap m tyenv erasedUnionInfo.CommonAncestorTy | TType_forall (tps, tau) -> let tps = DropErasedTypars tps diff --git a/src/fsharp/InfoReader.fs b/src/fsharp/InfoReader.fs index b015ad466e..dbd8ec3ba0 100644 --- a/src/fsharp/InfoReader.fs +++ b/src/fsharp/InfoReader.fs @@ -122,7 +122,7 @@ type PropertyCollector(g, amap, m, ty, optFilter, ad) = | _ -> props.[pinfo] <- pinfo - member x.Collect(membInfo: ValMemberInfo, vref: ValRef) = + member _.Collect(membInfo: ValMemberInfo, vref: ValRef) = match membInfo.MemberFlags.MemberKind with | SynMemberKind.PropertyGet -> let pinfo = FSProp(g, ty, Some vref, None) @@ -135,7 +135,7 @@ type PropertyCollector(g, amap, m, ty, optFilter, ad) = | _ -> () - member x.Close() = [ for KeyValue(_, pinfo) in props -> pinfo ] + member _.Close() = [ for KeyValue(_, pinfo) in props -> pinfo ] let rec GetImmediateIntrinsicPropInfosOfTypeAux (optFilter, ad) g amap m origTy metadataTy = @@ -252,6 +252,44 @@ type HierarchyItem = | EventItem of EventInfo list | ILFieldItem of ILFieldInfo list +//------------------------------------------------------------------------- +// Collecting methods and properties taking into account hiding rules in the hierarchy + + +/// Indicates if we prefer overrides or abstract slots. +type FindMemberFlag = + /// Prefer items toward the top of the hierarchy, which we do if the items are virtual + /// but not when resolving base calls. + | IgnoreOverrides + /// Get overrides instead of abstract slots when measuring whether a class/interface implements all its required slots. + | PreferOverrides + +/// The input list is sorted from most-derived to least-derived type, so any System.Object methods +/// are at the end of the list. Return a filtered list where prior/subsequent members matching by name and +/// that are in the same equivalence class have been removed. We keep a name-indexed table to +/// be more efficient when we check to see if we've already seen a particular named method. +type private IndexedList<'T>(itemLists: 'T list list, itemsByName: NameMultiMap<'T>) = + + /// Get the item sets + member _.Items = itemLists + + /// Get the items with a particular name + member _.ItemsWithName(nm) = NameMultiMap.find nm itemsByName + + /// Add new items, extracting the names using the given function. + member _.AddItems(items, nmf) = IndexedList<'T>(items :: itemLists, List.foldBack (fun x acc -> NameMultiMap.add (nmf x) x acc) items itemsByName ) + + /// Get an empty set of items + static member Empty = IndexedList<'T>([], NameMultiMap.empty) + + /// Filter a set of new items to add according to the content of the list. Only keep an item + /// if it passes 'keepTest' for all matching items already in the list. + member x.FilterNewItems keepTest nmf itemsToAdd = + // Have we already seen an item with the same name and that is in the same equivalence class? + // If so, ignore this one. Note we can check against the original incoming 'ilist' because we are assuming that + // none the elements of 'itemsToAdd' are equivalent. + itemsToAdd |> List.filter (fun item -> List.forall (keepTest item) (x.ItemsWithName(nmf item))) + /// An InfoReader is an object to help us read and cache infos. /// We create one of these for each file we typecheck. type InfoReader(g: TcGlobals, amap: Import.ImportMap) as this = @@ -434,6 +472,145 @@ type InfoReader(g: TcGlobals, amap: Import.ImportMap) as this = ||> List.fold (fun acc ty -> GetImmediateIntrinsicOverrideMethodSetsOfType optFilter m interfaceTys ty acc) |> FilterMostSpecificMethInfoSets g amap m + /// Add all the items to the IndexedList, preferring the ones in the super-types. This is used to hide methods + /// in super classes and/or hide overrides of methods in subclasses. + /// + /// Assume no items in 'items' are equivalent according to 'equivTest'. This is valid because each step in a + /// .NET class hierarchy introduces a consistent set of methods, none of which hide each other within the + /// given set. This is an important optimization because it means we don't have filter for equivalence between the + /// large overload sets introduced by methods like System.WriteLine. + /// + /// Assume items can be given names by 'nmf', where two items with different names are + /// not equivalent. + + static let FilterItemsInSubTypesBasedOnItemsInSuperTypes nmf keepTest itemLists = + let rec loop itemLists = + match itemLists with + | [] -> IndexedList.Empty + | items :: itemsInSuperTypes -> + let ilist = loop itemsInSuperTypes + let itemsToAdd = ilist.FilterNewItems keepTest nmf items + ilist.AddItems(itemsToAdd, nmf) + (loop itemLists).Items + + /// Add all the items to the IndexedList, preferring the ones in the sub-types. + static let FilterItemsInSuperTypesBasedOnItemsInSubTypes nmf keepTest itemLists = + let rec loop itemLists (indexedItemsInSubTypes: IndexedList<_>) = + match itemLists with + | [] -> List.rev indexedItemsInSubTypes.Items + | items :: itemsInSuperTypes -> + let itemsToAdd = items |> List.filter (fun item -> keepTest item (indexedItemsInSubTypes.ItemsWithName(nmf item))) + let ilist = indexedItemsInSubTypes.AddItems(itemsToAdd, nmf) + loop itemsInSuperTypes ilist + + loop itemLists IndexedList.Empty + + static let ExcludeItemsInSuperTypesBasedOnEquivTestWithItemsInSubTypes nmf equivTest itemLists = + FilterItemsInSuperTypesBasedOnItemsInSubTypes nmf (fun item1 items -> not (items |> List.exists (fun item2 -> equivTest item1 item2))) itemLists + + /// Filter the overrides of methods or properties, either keeping the overrides or keeping the dispatch slots. + static let FilterOverrides findFlag (isVirt:'a->bool, isNewSlot, isDefiniteOverride, isFinal, equivSigs, nmf:'a->string) items = + let equivVirts x y = isVirt x && isVirt y && equivSigs x y + + match findFlag with + | PreferOverrides -> + items + // For each F#-declared override, get rid of any equivalent abstract member in the same type + // This is because F# abstract members with default overrides give rise to two members with the + // same logical signature in the same type, e.g. + // type ClassType1() = + // abstract VirtualMethod1: string -> int + // default x.VirtualMethod1(s) = 3 + + |> List.map (fun items -> + let definiteOverrides = items |> List.filter isDefiniteOverride + items |> List.filter (fun item -> (isDefiniteOverride item || not (List.exists (equivVirts item) definiteOverrides)))) + + // only keep virtuals that are not signature-equivalent to virtuals in subtypes + |> ExcludeItemsInSuperTypesBasedOnEquivTestWithItemsInSubTypes nmf equivVirts + | IgnoreOverrides -> + let equivNewSlots x y = isNewSlot x && isNewSlot y && equivSigs x y + items + // Remove any F#-declared overrides. These may occur in the same type as the abstract member (unlike with .NET metadata) + // Include any 'newslot' declared methods. + |> List.map (List.filter (fun x -> not (isDefiniteOverride x))) + + // Remove any virtuals that are signature-equivalent to virtuals in subtypes, except for newslots + // That is, keep if it's + /// (a) not virtual + // (b) is a new slot or + // (c) not equivalent + // We keep virtual finals around for error detection later on + |> FilterItemsInSubTypesBasedOnItemsInSuperTypes nmf (fun newItem priorItem -> + (isVirt newItem && isFinal newItem) || not (isVirt newItem) || isNewSlot newItem || not (equivVirts newItem priorItem) ) + + // Remove any abstract slots in supertypes that are (a) hidden by another newslot and (b) implemented + // We leave unimplemented ones around to give errors, e.g. for + // [] + // type PA() = + // abstract M : int -> unit + // + // [] + // type PB<'a>() = + // inherit PA() + // abstract M : 'a -> unit + // + // [] + // type PC() = + // inherit PB() + // // Here, PA.M and PB.M have the same signature, so PA.M is unimplementable. + // // REVIEW: in future we may give a friendly error at this point + // + // type PD() = + // inherit PC() + // override this.M(x: int) = () + + |> FilterItemsInSuperTypesBasedOnItemsInSubTypes nmf (fun item1 superTypeItems -> + not (isNewSlot item1 && + superTypeItems |> List.exists (equivNewSlots item1) && + superTypeItems |> List.exists (fun item2 -> isDefiniteOverride item1 && equivVirts item1 item2))) + + + /// Filter the overrides of methods, either keeping the overrides or keeping the dispatch slots. + static let FilterOverridesOfMethInfos findFlag g amap m minfos = + minfos + |> FilterOverrides findFlag + ((fun (minfo: MethInfo) -> minfo.IsVirtual), + (fun minfo -> minfo.IsNewSlot), + (fun minfo -> minfo.IsDefiniteFSharpOverride), + (fun minfo -> minfo.IsFinal), + MethInfosEquivByNameAndSig EraseNone true g amap m, + (fun minfo -> minfo.LogicalName)) + + /// Filter the overrides of properties, either keeping the overrides or keeping the dispatch slots. + static let FilterOverridesOfPropInfos findFlag g amap m props = + props + |> FilterOverrides findFlag + ((fun (pinfo: PropInfo) -> pinfo.IsVirtualProperty), + (fun pinfo -> pinfo.IsNewSlot), + (fun pinfo -> pinfo.IsDefiniteFSharpOverride), + (fun _ -> false), + PropInfosEquivByNameAndSig EraseNone g amap m, + (fun pinfo -> pinfo.PropertyName)) + + /// Exclude methods from super types which have the same signature as a method in a more specific type. + static let ExcludeHiddenOfMethInfosImpl g amap m (minfos: MethInfo list list) = + minfos + |> ExcludeItemsInSuperTypesBasedOnEquivTestWithItemsInSubTypes + (fun minfo -> minfo.LogicalName) + (fun m1 m2 -> + // only hide those truly from super classes + not (tyconRefEq g m1.DeclaringTyconRef m2.DeclaringTyconRef) && + MethInfosEquivByNameAndPartialSig EraseNone true g amap m m1 m2) + + |> List.concat + + /// Exclude properties from super types which have the same name as a property in a more specific type. + static let ExcludeHiddenOfPropInfosImpl g amap m pinfos = + pinfos + |> ExcludeItemsInSuperTypesBasedOnEquivTestWithItemsInSubTypes (fun (pinfo: PropInfo) -> pinfo.PropertyName) (PropInfosEquivByNameAndPartialSig EraseNone g amap m) + |> List.concat + /// Make a cache for function 'f' keyed by type (plus some additional 'flags') that only /// caches computations for monomorphic types. @@ -450,34 +627,48 @@ type InfoReader(g: TcGlobals, amap: Import.ImportMap) as this = keyComparer= { new System.Collections.Generic.IEqualityComparer<_> with - member x.Equals((flags1, _, typ1), (flags2, _, typ2)) = + member _.Equals((flags1, _, typ1), (flags2, _, typ2)) = // Ignoring the ranges - that's OK. flagsEq.Equals(flags1, flags2) && match stripTyEqns g typ1, stripTyEqns g typ2 with | TType_app(tcref1, []), TType_app(tcref2, []) -> tyconRefEq g tcref1 tcref2 | _ -> false - member x.GetHashCode((flags, _, ty)) = + member _.GetHashCode((flags, _, ty)) = // Ignoring the ranges - that's OK. flagsEq.GetHashCode flags + (match stripTyEqns g ty with | TType_app(tcref, []) -> hash tcref.LogicalName | _ -> 0) }) + let FindImplicitConversionsUncached (ad, m, ty) = + if isTyparTy g ty then + [] + // F# ignores the op_Implicit conversions defined on the 'Option' and 'ValueOption' types + elif isOptionTy g ty || isValueOptionTy g ty then + [] + else + this.TryFindIntrinsicMethInfo m ad "op_Implicit" ty + let hashFlags0 = - { new System.Collections.Generic.IEqualityComparer<_> with - member x.GetHashCode((filter: string option, ad: AccessorDomain, _allowMultiIntfInst1)) = hash filter + AccessorDomain.CustomGetHashCode ad - member x.Equals((filter1, ad1, allowMultiIntfInst1), (filter2, ad2, allowMultiIntfInst2)) = + { new System.Collections.Generic.IEqualityComparer with + member _.GetHashCode((filter: string option, ad: AccessorDomain, _allowMultiIntfInst1)) = hash filter + AccessorDomain.CustomGetHashCode ad + member _.Equals((filter1, ad1, allowMultiIntfInst1), (filter2, ad2, allowMultiIntfInst2)) = (filter1 = filter2) && AccessorDomain.CustomEquals(g, ad1, ad2) && allowMultiIntfInst1 = allowMultiIntfInst2 } let hashFlags1 = - { new System.Collections.Generic.IEqualityComparer<_> with - member x.GetHashCode((filter: string option, ad: AccessorDomain)) = hash filter + AccessorDomain.CustomGetHashCode ad - member x.Equals((filter1, ad1), (filter2, ad2)) = (filter1 = filter2) && AccessorDomain.CustomEquals(g, ad1, ad2) } + { new System.Collections.Generic.IEqualityComparer with + member _.GetHashCode((filter: string option, ad: AccessorDomain)) = hash filter + AccessorDomain.CustomGetHashCode ad + member _.Equals((filter1, ad1), (filter2, ad2)) = (filter1 = filter2) && AccessorDomain.CustomEquals(g, ad1, ad2) } let hashFlags2 = - { new System.Collections.Generic.IEqualityComparer<_> with - member x.GetHashCode((nm: string, ad: AccessorDomain)) = hash nm + AccessorDomain.CustomGetHashCode ad - member x.Equals((nm1, ad1), (nm2, ad2)) = (nm1 = nm2) && AccessorDomain.CustomEquals(g, ad1, ad2) } + { new System.Collections.Generic.IEqualityComparer with + member _.GetHashCode((nm: string, ad: AccessorDomain)) = hash nm + AccessorDomain.CustomGetHashCode ad + member _.Equals((nm1, ad1), (nm2, ad2)) = (nm1 = nm2) && AccessorDomain.CustomEquals(g, ad1, ad2) } + + let hashFlags3 = + { new System.Collections.Generic.IEqualityComparer with + member _.GetHashCode((ad: AccessorDomain)) = AccessorDomain.CustomGetHashCode ad + member _.Equals((ad1), (ad2)) = AccessorDomain.CustomEquals(g, ad1, ad2) } let methodInfoCache = MakeInfoCache GetIntrinsicMethodSetsUncached hashFlags0 let propertyInfoCache = MakeInfoCache GetIntrinsicPropertySetsUncached hashFlags0 @@ -489,6 +680,7 @@ type InfoReader(g: TcGlobals, amap: Import.ImportMap) as this = let entireTypeHierarchyCache = MakeInfoCache GetEntireTypeHierarchyUncached HashIdentity.Structural let primaryTypeHierarchyCache = MakeInfoCache GetPrimaryTypeHierarchyUncached HashIdentity.Structural + let implicitConversionCache = MakeInfoCache FindImplicitConversionsUncached hashFlags3 // Runtime feature support @@ -503,33 +695,34 @@ type InfoReader(g: TcGlobals, amap: Import.ImportMap) as this = let isRuntimeFeatureDefaultImplementationsOfInterfacesSupported = lazy isRuntimeFeatureSupported this "DefaultImplementationsOfInterfaces" - member x.g = g - member x.amap = amap + member _.g = g + member _.amap = amap /// Read the raw method sets of a type, including inherited ones. Cache the result for monomorphic types - member x.GetRawIntrinsicMethodSetsOfType (optFilter, ad, allowMultiIntfInst, m, ty) = + member _.GetRawIntrinsicMethodSetsOfType (optFilter, ad, allowMultiIntfInst, m, ty) = methodInfoCache.Apply(((optFilter, ad, allowMultiIntfInst), m, ty)) /// Read the raw property sets of a type, including inherited ones. Cache the result for monomorphic types - member x.GetRawIntrinsicPropertySetsOfType (optFilter, ad, allowMultiIntfInst, m, ty) = + member _.GetRawIntrinsicPropertySetsOfType (optFilter, ad, allowMultiIntfInst, m, ty) = propertyInfoCache.Apply(((optFilter, ad, allowMultiIntfInst), m, ty)) /// Read the record or class fields of a type, including inherited ones. Cache the result for monomorphic types. - member x.GetRecordOrClassFieldsOfType (optFilter, ad, m, ty) = + member _.GetRecordOrClassFieldsOfType (optFilter, ad, m, ty) = recdOrClassFieldInfoCache.Apply(((optFilter, ad), m, ty)) /// Read the IL fields of a type, including inherited ones. Cache the result for monomorphic types. - member x.GetILFieldInfosOfType (optFilter, ad, m, ty) = + member _.GetILFieldInfosOfType (optFilter, ad, m, ty) = ilFieldInfoCache.Apply(((optFilter, ad), m, ty)) - member x.GetImmediateIntrinsicEventsOfType (optFilter, ad, m, ty) = ComputeImmediateIntrinsicEventsOfType (optFilter, ad) m ty + member _.GetImmediateIntrinsicEventsOfType (optFilter, ad, m, ty) = + ComputeImmediateIntrinsicEventsOfType (optFilter, ad) m ty /// Read the events of a type, including inherited ones. Cache the result for monomorphic types. - member x.GetEventInfosOfType (optFilter, ad, m, ty) = + member _.GetEventInfosOfType (optFilter, ad, m, ty) = eventInfoCache.Apply(((optFilter, ad), m, ty)) /// Try and find a record or class field for a type. - member x.TryFindRecdOrClassFieldInfoOfType (nm, m, ty) = + member _.TryFindRecdOrClassFieldInfoOfType (nm, m, ty) = match recdOrClassFieldInfoCache.Apply((Some nm, AccessibleFromSomewhere), m, ty) with | [] -> ValueNone | [single] -> ValueSome single @@ -545,28 +738,110 @@ type InfoReader(g: TcGlobals, amap: Import.ImportMap) as this = | _ -> failwith "unexpected multiple fields with same name" // Because it should have been already reported as duplicate fields /// Try and find an item with the given name in a type. - member x.TryFindNamedItemOfType (nm, ad, m, ty) = + member _.TryFindNamedItemOfType (nm, ad, m, ty) = namedItemsCache.Apply(((nm, ad), m, ty)) /// Read the raw method sets of a type that are the most specific overrides. Cache the result for monomorphic types - member x.GetIntrinsicMostSpecificOverrideMethodSetsOfType (optFilter, ad, allowMultiIntfInst, m, ty) = + member _.GetIntrinsicMostSpecificOverrideMethodSetsOfType (optFilter, ad, allowMultiIntfInst, m, ty) = mostSpecificOverrideMethodInfoCache.Apply(((optFilter, ad, allowMultiIntfInst), m, ty)) /// Get the super-types of a type, including interface types. - member x.GetEntireTypeHierarchy (allowMultiIntfInst, m, ty) = + member _.GetEntireTypeHierarchy (allowMultiIntfInst, m, ty) = entireTypeHierarchyCache.Apply((allowMultiIntfInst, m, ty)) /// Get the super-types of a type, excluding interface types. - member x.GetPrimaryTypeHierarchy (allowMultiIntfInst, m, ty) = + member _.GetPrimaryTypeHierarchy (allowMultiIntfInst, m, ty) = primaryTypeHierarchyCache.Apply((allowMultiIntfInst, m, ty)) /// Check if the given language feature is supported by the runtime. - member x.IsLanguageFeatureRuntimeSupported langFeature = + member _.IsLanguageFeatureRuntimeSupported langFeature = match langFeature with // Both default and static interface method consumption features are tied to the runtime support of DIMs. | LanguageFeature.DefaultInterfaceMemberConsumption -> isRuntimeFeatureDefaultImplementationsOfInterfacesSupported.Value | _ -> true + /// Get the declared constructors of any F# type + member infoReader.GetIntrinsicConstructorInfosOfTypeAux m origTy metadataTy = + protectAssemblyExploration [] (fun () -> + let g = infoReader.g + let amap = infoReader.amap + match metadataOfTy g metadataTy with + #if !NO_EXTENSIONTYPING + | ProvidedTypeMetadata info -> + let st = info.ProvidedType + [ for ci in st.PApplyArray((fun st -> st.GetConstructors()), "GetConstructors", m) do + yield ProvidedMeth(amap, ci.Coerce(m), None, m) ] + #endif + | ILTypeMetadata _ -> + let tinfo = ILTypeInfo.FromType g origTy + tinfo.RawMetadata.Methods.FindByName ".ctor" + |> List.filter (fun md -> md.IsConstructor) + |> List.map (fun mdef -> MethInfo.CreateILMeth (amap, m, origTy, mdef)) + + | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> + // Tuple types also support constructors. In this case convert to the .NET Tuple type that carries metadata and try again + // Function types also support constructors. In this case convert to the FSharpFunc type that carries metadata and try again + if isAnyTupleTy g metadataTy || isFunTy g metadataTy then + let betterMetadataTy = convertToTypeWithMetadataIfPossible g metadataTy + infoReader.GetIntrinsicConstructorInfosOfTypeAux m origTy betterMetadataTy + else + match tryTcrefOfAppTy g metadataTy with + | ValueNone -> [] + | ValueSome tcref -> + tcref.MembersOfFSharpTyconByName + |> NameMultiMap.find ".ctor" + |> List.choose(fun vref -> + match vref.MemberInfo with + | Some membInfo when (membInfo.MemberFlags.MemberKind = SynMemberKind.Constructor) -> Some vref + | _ -> None) + |> List.map (fun x -> FSMeth(g, origTy, x, None)) + ) + + static member ExcludeHiddenOfMethInfos g amap m minfos = + ExcludeHiddenOfMethInfosImpl g amap m minfos + + static member ExcludeHiddenOfPropInfos g amap m pinfos = + ExcludeHiddenOfPropInfosImpl g amap m pinfos + + /// Get the sets of intrinsic methods in the hierarchy (not including extension methods) + member infoReader.GetIntrinsicMethInfoSetsOfType optFilter ad allowMultiIntfInst findFlag m ty = + infoReader.GetRawIntrinsicMethodSetsOfType(optFilter, ad, allowMultiIntfInst, m, ty) + |> FilterOverridesOfMethInfos findFlag infoReader.g infoReader.amap m + + /// Get the sets intrinsic properties in the hierarchy (not including extension properties) + member infoReader.GetIntrinsicPropInfoSetsOfType optFilter ad allowMultiIntfInst findFlag m ty = + infoReader.GetRawIntrinsicPropertySetsOfType(optFilter, ad, allowMultiIntfInst, m, ty) + |> FilterOverridesOfPropInfos findFlag infoReader.g infoReader.amap m + + /// Get the flattened list of intrinsic methods in the hierarchy + member infoReader.GetIntrinsicMethInfosOfType optFilter ad allowMultiIntfInst findFlag m ty = + infoReader.GetIntrinsicMethInfoSetsOfType optFilter ad allowMultiIntfInst findFlag m ty |> List.concat + + /// Get the flattened list of intrinsic properties in the hierarchy + member infoReader.GetIntrinsicPropInfosOfType optFilter ad allowMultiIntfInst findFlag m ty = + infoReader.GetIntrinsicPropInfoSetsOfType optFilter ad allowMultiIntfInst findFlag m ty |> List.concat + + member infoReader.TryFindIntrinsicNamedItemOfType (nm, ad) findFlag m ty = + match infoReader.TryFindNamedItemOfType(nm, ad, m, ty) with + | Some item -> + match item with + | PropertyItem psets -> Some(PropertyItem (psets |> FilterOverridesOfPropInfos findFlag infoReader.g infoReader.amap m)) + | MethodItem msets -> Some(MethodItem (msets |> FilterOverridesOfMethInfos findFlag infoReader.g infoReader.amap m)) + | _ -> Some(item) + | None -> None + + /// Try to detect the existence of a method on a type. + member infoReader.TryFindIntrinsicMethInfo m ad nm ty = + infoReader.GetIntrinsicMethInfosOfType (Some nm) ad AllowMultiIntfInstantiations.Yes IgnoreOverrides m ty + + /// Try to find a particular named property on a type. Only used to ensure that local 'let' definitions and property names + /// are distinct, a somewhat adhoc check in tc.fs. + member infoReader.TryFindIntrinsicPropInfo m ad nm ty = + infoReader.GetIntrinsicPropInfosOfType (Some nm) ad AllowMultiIntfInstantiations.Yes IgnoreOverrides m ty + + member _.FindImplicitConversions m ad ty = + implicitConversionCache.Apply((ad, m, ty)) + let private tryLanguageFeatureRuntimeErrorAux (infoReader: InfoReader) langFeature m error = if not (infoReader.IsLanguageFeatureRuntimeSupported langFeature) then let featureStr = infoReader.g.langVersion.GetFeatureString langFeature @@ -584,263 +859,35 @@ let checkLanguageFeatureRuntimeErrorRecover infoReader langFeature m = let tryLanguageFeatureRuntimeErrorRecover infoReader langFeature m = tryLanguageFeatureRuntimeErrorAux infoReader langFeature m errorR -/// Get the declared constructors of any F# type -let rec GetIntrinsicConstructorInfosOfTypeAux (infoReader: InfoReader) m origTy metadataTy = - protectAssemblyExploration [] (fun () -> - let g = infoReader.g - let amap = infoReader.amap - match metadataOfTy g metadataTy with -#if !NO_EXTENSIONTYPING - | ProvidedTypeMetadata info -> - let st = info.ProvidedType - [ for ci in st.PApplyArray((fun st -> st.GetConstructors()), "GetConstructors", m) do - yield ProvidedMeth(amap, ci.Coerce(m), None, m) ] -#endif - | ILTypeMetadata _ -> - let tinfo = ILTypeInfo.FromType g origTy - tinfo.RawMetadata.Methods.FindByName ".ctor" - |> List.filter (fun md -> md.IsConstructor) - |> List.map (fun mdef -> MethInfo.CreateILMeth (amap, m, origTy, mdef)) - - | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> - // Tuple types also support constructors. In this case convert to the .NET Tuple type that carries metadata and try again - // Function types also support constructors. In this case convert to the FSharpFunc type that carries metadata and try again - if isAnyTupleTy g metadataTy || isFunTy g metadataTy then - let betterMetadataTy = convertToTypeWithMetadataIfPossible g metadataTy - GetIntrinsicConstructorInfosOfTypeAux infoReader m origTy betterMetadataTy - else - match tryTcrefOfAppTy g metadataTy with - | ValueNone -> [] - | ValueSome tcref -> - tcref.MembersOfFSharpTyconByName - |> NameMultiMap.find ".ctor" - |> List.choose(fun vref -> - match vref.MemberInfo with - | Some membInfo when (membInfo.MemberFlags.MemberKind = SynMemberKind.Constructor) -> Some vref - | _ -> None) - |> List.map (fun x -> FSMeth(g, origTy, x, None)) - ) - -let GetIntrinsicConstructorInfosOfType infoReader m ty = - GetIntrinsicConstructorInfosOfTypeAux infoReader m ty ty - -//------------------------------------------------------------------------- -// Collecting methods and properties taking into account hiding rules in the hierarchy - - -/// Indicates if we prefer overrides or abstract slots. -type FindMemberFlag = - /// Prefer items toward the top of the hierarchy, which we do if the items are virtual - /// but not when resolving base calls. - | IgnoreOverrides - /// Get overrides instead of abstract slots when measuring whether a class/interface implements all its required slots. - | PreferOverrides - -/// The input list is sorted from most-derived to least-derived type, so any System.Object methods -/// are at the end of the list. Return a filtered list where prior/subsequent members matching by name and -/// that are in the same equivalence class have been removed. We keep a name-indexed table to -/// be more efficient when we check to see if we've already seen a particular named method. -type private IndexedList<'T>(itemLists: 'T list list, itemsByName: NameMultiMap<'T>) = - - /// Get the item sets - member x.Items = itemLists - - /// Get the items with a particular name - member x.ItemsWithName(nm) = NameMultiMap.find nm itemsByName - - /// Add new items, extracting the names using the given function. - member x.AddItems(items, nmf) = IndexedList<'T>(items :: itemLists, List.foldBack (fun x acc -> NameMultiMap.add (nmf x) x acc) items itemsByName ) - - /// Get an empty set of items - static member Empty = IndexedList<'T>([], NameMultiMap.empty) - - /// Filter a set of new items to add according to the content of the list. Only keep an item - /// if it passes 'keepTest' for all matching items already in the list. - member x.FilterNewItems keepTest nmf itemsToAdd = - // Have we already seen an item with the same name and that is in the same equivalence class? - // If so, ignore this one. Note we can check against the original incoming 'ilist' because we are assuming that - // none the elements of 'itemsToAdd' are equivalent. - itemsToAdd |> List.filter (fun item -> List.forall (keepTest item) (x.ItemsWithName(nmf item))) - -/// Add all the items to the IndexedList, preferring the ones in the super-types. This is used to hide methods -/// in super classes and/or hide overrides of methods in subclasses. -/// -/// Assume no items in 'items' are equivalent according to 'equivTest'. This is valid because each step in a -/// .NET class hierarchy introduces a consistent set of methods, none of which hide each other within the -/// given set. This is an important optimization because it means we don't have filter for equivalence between the -/// large overload sets introduced by methods like System.WriteLine. -/// -/// Assume items can be given names by 'nmf', where two items with different names are -/// not equivalent. - -let private FilterItemsInSubTypesBasedOnItemsInSuperTypes nmf keepTest itemLists = - let rec loop itemLists = - match itemLists with - | [] -> IndexedList.Empty - | items :: itemsInSuperTypes -> - let ilist = loop itemsInSuperTypes - let itemsToAdd = ilist.FilterNewItems keepTest nmf items - ilist.AddItems(itemsToAdd, nmf) - (loop itemLists).Items - -/// Add all the items to the IndexedList, preferring the ones in the sub-types. -let private FilterItemsInSuperTypesBasedOnItemsInSubTypes nmf keepTest itemLists = - let rec loop itemLists (indexedItemsInSubTypes: IndexedList<_>) = - match itemLists with - | [] -> List.rev indexedItemsInSubTypes.Items - | items :: itemsInSuperTypes -> - let itemsToAdd = items |> List.filter (fun item -> keepTest item (indexedItemsInSubTypes.ItemsWithName(nmf item))) - let ilist = indexedItemsInSubTypes.AddItems(itemsToAdd, nmf) - loop itemsInSuperTypes ilist - - loop itemLists IndexedList.Empty - -let private ExcludeItemsInSuperTypesBasedOnEquivTestWithItemsInSubTypes nmf equivTest itemLists = - FilterItemsInSuperTypesBasedOnItemsInSubTypes nmf (fun item1 items -> not (items |> List.exists (fun item2 -> equivTest item1 item2))) itemLists - -/// Filter the overrides of methods or properties, either keeping the overrides or keeping the dispatch slots. -let private FilterOverrides findFlag (isVirt:'a->bool, isNewSlot, isDefiniteOverride, isFinal, equivSigs, nmf:'a->string) items = - let equivVirts x y = isVirt x && isVirt y && equivSigs x y - - match findFlag with - | PreferOverrides -> - items - // For each F#-declared override, get rid of any equivalent abstract member in the same type - // This is because F# abstract members with default overrides give rise to two members with the - // same logical signature in the same type, e.g. - // type ClassType1() = - // abstract VirtualMethod1: string -> int - // default x.VirtualMethod1(s) = 3 - - |> List.map (fun items -> - let definiteOverrides = items |> List.filter isDefiniteOverride - items |> List.filter (fun item -> (isDefiniteOverride item || not (List.exists (equivVirts item) definiteOverrides)))) - - // only keep virtuals that are not signature-equivalent to virtuals in subtypes - |> ExcludeItemsInSuperTypesBasedOnEquivTestWithItemsInSubTypes nmf equivVirts - | IgnoreOverrides -> - let equivNewSlots x y = isNewSlot x && isNewSlot y && equivSigs x y - items - // Remove any F#-declared overrides. These may occur in the same type as the abstract member (unlike with .NET metadata) - // Include any 'newslot' declared methods. - |> List.map (List.filter (fun x -> not (isDefiniteOverride x))) - - // Remove any virtuals that are signature-equivalent to virtuals in subtypes, except for newslots - // That is, keep if it's - /// (a) not virtual - // (b) is a new slot or - // (c) not equivalent - // We keep virtual finals around for error detection later on - |> FilterItemsInSubTypesBasedOnItemsInSuperTypes nmf (fun newItem priorItem -> - (isVirt newItem && isFinal newItem) || not (isVirt newItem) || isNewSlot newItem || not (equivVirts newItem priorItem) ) - - // Remove any abstract slots in supertypes that are (a) hidden by another newslot and (b) implemented - // We leave unimplemented ones around to give errors, e.g. for - // [] - // type PA() = - // abstract M : int -> unit - // - // [] - // type PB<'a>() = - // inherit PA() - // abstract M : 'a -> unit - // - // [] - // type PC() = - // inherit PB() - // // Here, PA.M and PB.M have the same signature, so PA.M is unimplementable. - // // REVIEW: in future we may give a friendly error at this point - // - // type PD() = - // inherit PC() - // override this.M(x: int) = () - - |> FilterItemsInSuperTypesBasedOnItemsInSubTypes nmf (fun item1 superTypeItems -> - not (isNewSlot item1 && - superTypeItems |> List.exists (equivNewSlots item1) && - superTypeItems |> List.exists (fun item2 -> isDefiniteOverride item1 && equivVirts item1 item2))) +let GetIntrinsicConstructorInfosOfType (infoReader: InfoReader) m ty = + infoReader.GetIntrinsicConstructorInfosOfTypeAux m ty ty - -/// Filter the overrides of methods, either keeping the overrides or keeping the dispatch slots. -let private FilterOverridesOfMethInfos findFlag g amap m minfos = - minfos - |> FilterOverrides findFlag - ((fun (minfo: MethInfo) -> minfo.IsVirtual), - (fun minfo -> minfo.IsNewSlot), - (fun minfo -> minfo.IsDefiniteFSharpOverride), - (fun minfo -> minfo.IsFinal), - MethInfosEquivByNameAndSig EraseNone true g amap m, - (fun minfo -> minfo.LogicalName)) - -/// Filter the overrides of properties, either keeping the overrides or keeping the dispatch slots. -let private FilterOverridesOfPropInfos findFlag g amap m props = - props - |> FilterOverrides findFlag - ((fun (pinfo: PropInfo) -> pinfo.IsVirtualProperty), - (fun pinfo -> pinfo.IsNewSlot), - (fun pinfo -> pinfo.IsDefiniteFSharpOverride), - (fun _ -> false), - PropInfosEquivByNameAndSig EraseNone g amap m, - (fun pinfo -> pinfo.PropertyName)) - -/// Exclude methods from super types which have the same signature as a method in a more specific type. let ExcludeHiddenOfMethInfos g amap m (minfos: MethInfo list list) = - minfos - |> ExcludeItemsInSuperTypesBasedOnEquivTestWithItemsInSubTypes - (fun minfo -> minfo.LogicalName) - (fun m1 m2 -> - // only hide those truly from super classes - not (tyconRefEq g m1.DeclaringTyconRef m2.DeclaringTyconRef) && - MethInfosEquivByNameAndPartialSig EraseNone true g amap m m1 m2) - - |> List.concat + InfoReader.ExcludeHiddenOfMethInfos g amap m minfos -/// Exclude properties from super types which have the same name as a property in a more specific type. let ExcludeHiddenOfPropInfos g amap m pinfos = - pinfos - |> ExcludeItemsInSuperTypesBasedOnEquivTestWithItemsInSubTypes (fun (pinfo: PropInfo) -> pinfo.PropertyName) (PropInfosEquivByNameAndPartialSig EraseNone g amap m) - |> List.concat + InfoReader.ExcludeHiddenOfPropInfos g amap m pinfos -/// Get the sets of intrinsic methods in the hierarchy (not including extension methods) let GetIntrinsicMethInfoSetsOfType (infoReader:InfoReader) optFilter ad allowMultiIntfInst findFlag m ty = - infoReader.GetRawIntrinsicMethodSetsOfType(optFilter, ad, allowMultiIntfInst, m, ty) - |> FilterOverridesOfMethInfos findFlag infoReader.g infoReader.amap m + infoReader.GetIntrinsicMethInfoSetsOfType optFilter ad allowMultiIntfInst findFlag m ty -/// Get the sets intrinsic properties in the hierarchy (not including extension properties) let GetIntrinsicPropInfoSetsOfType (infoReader:InfoReader) optFilter ad allowMultiIntfInst findFlag m ty = - infoReader.GetRawIntrinsicPropertySetsOfType(optFilter, ad, allowMultiIntfInst, m, ty) - |> FilterOverridesOfPropInfos findFlag infoReader.g infoReader.amap m + infoReader.GetIntrinsicPropInfoSetsOfType optFilter ad allowMultiIntfInst findFlag m ty -/// Get the flattened list of intrinsic methods in the hierarchy -let GetIntrinsicMethInfosOfType infoReader optFilter ad allowMultiIntfInst findFlag m ty = - GetIntrinsicMethInfoSetsOfType infoReader optFilter ad allowMultiIntfInst findFlag m ty |> List.concat +let GetIntrinsicMethInfosOfType (infoReader: InfoReader) optFilter ad allowMultiIntfInst findFlag m ty = + infoReader.GetIntrinsicMethInfosOfType optFilter ad allowMultiIntfInst findFlag m ty -/// Get the flattened list of intrinsic properties in the hierarchy -let GetIntrinsicPropInfosOfType infoReader optFilter ad allowMultiIntfInst findFlag m ty = - GetIntrinsicPropInfoSetsOfType infoReader optFilter ad allowMultiIntfInst findFlag m ty |> List.concat +let GetIntrinsicPropInfosOfType (infoReader: InfoReader) optFilter ad allowMultiIntfInst findFlag m ty = + infoReader.GetIntrinsicPropInfosOfType optFilter ad allowMultiIntfInst findFlag m ty -/// Perform type-directed name resolution of a particular named member in an F# type let TryFindIntrinsicNamedItemOfType (infoReader: InfoReader) (nm, ad) findFlag m ty = - match infoReader.TryFindNamedItemOfType(nm, ad, m, ty) with - | Some item -> - match item with - | PropertyItem psets -> Some(PropertyItem (psets |> FilterOverridesOfPropInfos findFlag infoReader.g infoReader.amap m)) - | MethodItem msets -> Some(MethodItem (msets |> FilterOverridesOfMethInfos findFlag infoReader.g infoReader.amap m)) - | _ -> Some(item) - | None -> None - -/// Try to detect the existence of a method on a type. -/// Used for -/// -- getting the GetEnumerator, get_Current, MoveNext methods for enumerable types -/// -- getting the Dispose method when resolving the 'use' construct -/// -- getting the various methods used to desugar the computation expression syntax -let TryFindIntrinsicMethInfo infoReader m ad nm ty = - GetIntrinsicMethInfosOfType infoReader (Some nm) ad AllowMultiIntfInstantiations.Yes IgnoreOverrides m ty - -/// Try to find a particular named property on a type. Only used to ensure that local 'let' definitions and property names -/// are distinct, a somewhat adhoc check in tc.fs. -let TryFindPropInfo infoReader m ad nm ty = - GetIntrinsicPropInfosOfType infoReader (Some nm) ad AllowMultiIntfInstantiations.Yes IgnoreOverrides m ty + infoReader.TryFindIntrinsicNamedItemOfType (nm, ad) findFlag m ty + +let TryFindIntrinsicMethInfo (infoReader: InfoReader) m ad nm ty = + infoReader.TryFindIntrinsicMethInfo m ad nm ty + +let TryFindIntrinsicPropInfo (infoReader: InfoReader) m ad nm ty = + infoReader.TryFindIntrinsicPropInfo m ad nm ty /// Get a set of most specific override methods. let GetIntrinisicMostSpecificOverrideMethInfoSetsOfType (infoReader: InfoReader) m ty = diff --git a/src/fsharp/InfoReader.fsi b/src/fsharp/InfoReader.fsi index d8606880ce..3247ed7ac9 100644 --- a/src/fsharp/InfoReader.fsi +++ b/src/fsharp/InfoReader.fsi @@ -52,6 +52,15 @@ type HierarchyItem = | EventItem of EventInfo list | ILFieldItem of ILFieldInfo list +/// Indicates if we prefer overrides or abstract slots. +type FindMemberFlag = + /// Prefer items toward the top of the hierarchy, which we do if the items are virtual + /// but not when resolving base calls. + | IgnoreOverrides + + /// Get overrides instead of abstract slots when measuring whether a class/interface implements all its required slots. + | PreferOverrides + /// An InfoReader is an object to help us read and cache infos. /// We create one of these for each file we typecheck. type InfoReader = @@ -86,6 +95,30 @@ type InfoReader = member amap: ImportMap member g: TcGlobals + /// Exclude methods from super types which have the same signature as a method in a more specific type. + static member ExcludeHiddenOfMethInfos: g:TcGlobals -> amap:ImportMap -> m:range -> minfos:MethInfo list list -> MethInfo list + + /// Exclude properties from super types which have the same name as a property in a more specific type. + static member ExcludeHiddenOfPropInfos: g:TcGlobals -> amap:ImportMap -> m:range -> pinfos:PropInfo list list -> PropInfo list + + /// Get the sets of intrinsic methods in the hierarchy (not including extension methods) + member GetIntrinsicMethInfoSetsOfType: optFilter:string option -> ad:AccessorDomain -> allowMultiIntfInst:AllowMultiIntfInstantiations -> findFlag:FindMemberFlag -> m:range -> ty:TType -> MethInfo list list + + /// Get the sets intrinsic properties in the hierarchy (not including extension properties) + member GetIntrinsicPropInfoSetsOfType: optFilter:string option -> ad:AccessorDomain -> allowMultiIntfInst:AllowMultiIntfInstantiations -> findFlag:FindMemberFlag -> m:range -> ty:TType -> PropInfo list list + + /// Get the flattened list of intrinsic methods in the hierarchy + member GetIntrinsicMethInfosOfType: optFilter:string option -> ad:AccessorDomain -> allowMultiIntfInst:AllowMultiIntfInstantiations -> findFlag:FindMemberFlag -> m:range -> ty:TType -> MethInfo list + + /// Get the flattened list of intrinsic properties in the hierarchy + member GetIntrinsicPropInfosOfType: optFilter:string option -> ad:AccessorDomain -> allowMultiIntfInst:AllowMultiIntfInstantiations -> findFlag:FindMemberFlag -> m:range -> ty:TType -> PropInfo list + + /// Perform type-directed name resolution of a particular named member in an F# type + member TryFindIntrinsicNamedItemOfType: nm:string * ad:AccessorDomain -> findFlag:FindMemberFlag -> m:range -> ty:TType -> HierarchyItem option + + /// Find the op_Implicit for a type + member FindImplicitConversions: m: range -> ad: AccessorDomain -> ty: TType -> MethInfo list + val checkLanguageFeatureRuntimeError: infoReader:InfoReader -> langFeature:Features.LanguageFeature -> m:range -> unit val checkLanguageFeatureRuntimeErrorRecover: infoReader:InfoReader -> langFeature:Features.LanguageFeature -> m:range -> unit @@ -95,15 +128,6 @@ val tryLanguageFeatureRuntimeErrorRecover: infoReader:InfoReader -> langFeature: /// Get the declared constructors of any F# type val GetIntrinsicConstructorInfosOfType: infoReader:InfoReader -> m:range -> ty:TType -> MethInfo list -/// Indicates if we prefer overrides or abstract slots. -type FindMemberFlag = - /// Prefer items toward the top of the hierarchy, which we do if the items are virtual - /// but not when resolving base calls. - | IgnoreOverrides - - /// Get overrides instead of abstract slots when measuring whether a class/interface implements all its required slots. - | PreferOverrides - /// Exclude methods from super types which have the same signature as a method in a more specific type. val ExcludeHiddenOfMethInfos: g:TcGlobals -> amap:ImportMap -> m:range -> minfos:MethInfo list list -> MethInfo list @@ -130,7 +154,7 @@ val TryFindIntrinsicMethInfo: infoReader:InfoReader -> m:range -> ad:AccessorDom /// Try to find a particular named property on a type. Only used to ensure that local 'let' definitions and property names /// are distinct, a somewhat adhoc check in tc.fs. -val TryFindPropInfo: infoReader:InfoReader -> m:range -> ad:AccessorDomain -> nm:string -> ty:TType -> PropInfo list +val TryFindIntrinsicPropInfo: infoReader:InfoReader -> m:range -> ad:AccessorDomain -> nm:string -> ty:TType -> PropInfo list /// Get a set of most specific override methods. val GetIntrinisicMostSpecificOverrideMethInfoSetsOfType: infoReader:InfoReader -> m:range -> ty:TType -> NameMultiMap diff --git a/src/fsharp/LanguageFeatures.fs b/src/fsharp/LanguageFeatures.fs index 85ef41d4ea..4a667e0d4e 100644 --- a/src/fsharp/LanguageFeatures.fs +++ b/src/fsharp/LanguageFeatures.fs @@ -31,6 +31,8 @@ type LanguageFeature = | NullableOptionalInterop | DefaultInterfaceMemberConsumption | WitnessPassing + | ErasedUnions + | AdditionalTypeDirectedConversions | InterfacesWithMultipleGenericInstantiation | StringInterpolation | OverloadsForCustomOperations @@ -78,6 +80,8 @@ type LanguageVersion (specifiedVersionAsString) = LanguageFeature.StringInterpolation, languageVersion50 // F# preview + LanguageFeature.ErasedUnions, previewVersion + LanguageFeature.AdditionalTypeDirectedConversions, previewVersion LanguageFeature.OverloadsForCustomOperations, previewVersion LanguageFeature.ExpandedMeasurables, previewVersion LanguageFeature.FromEndSlicing, previewVersion @@ -157,6 +161,8 @@ type LanguageVersion (specifiedVersionAsString) = | LanguageFeature.NullableOptionalInterop -> FSComp.SR.featureNullableOptionalInterop() | LanguageFeature.DefaultInterfaceMemberConsumption -> FSComp.SR.featureDefaultInterfaceMemberConsumption() | LanguageFeature.WitnessPassing -> FSComp.SR.featureWitnessPassing() + | LanguageFeature.ErasedUnions -> FSComp.SR.featureErasedUnions() + | LanguageFeature.AdditionalTypeDirectedConversions -> FSComp.SR.featureAdditionalImplicitConversions() | LanguageFeature.InterfacesWithMultipleGenericInstantiation -> FSComp.SR.featureInterfacesWithMultipleGenericInstantiation() | LanguageFeature.StringInterpolation -> FSComp.SR.featureStringInterpolation() | LanguageFeature.OverloadsForCustomOperations -> FSComp.SR.featureOverloadsForCustomOperations() diff --git a/src/fsharp/LanguageFeatures.fsi b/src/fsharp/LanguageFeatures.fsi index b7ee7c18f7..85657eb74e 100644 --- a/src/fsharp/LanguageFeatures.fsi +++ b/src/fsharp/LanguageFeatures.fsi @@ -21,6 +21,8 @@ type LanguageFeature = | NullableOptionalInterop | DefaultInterfaceMemberConsumption | WitnessPassing + | ErasedUnions + | AdditionalTypeDirectedConversions | InterfacesWithMultipleGenericInstantiation | StringInterpolation | OverloadsForCustomOperations diff --git a/src/fsharp/MethodCalls.fs b/src/fsharp/MethodCalls.fs index e1a50ab621..7507dcc279 100644 --- a/src/fsharp/MethodCalls.fs +++ b/src/fsharp/MethodCalls.fs @@ -137,64 +137,204 @@ type CallerArgs<'T> = // Callsite conversions //------------------------------------------------------------------------- -// If the called method argument is a delegate type, and the caller is known to be a function type, then the caller may provide a function -// If the called method argument is an Expression type, and the caller is known to be a function type, then the caller may provide a T -// If the called method argument is an [] Quotations.Expr, and the caller is not known to be a quoted expression type, then the caller may provide a T -let AdjustCalledArgTypeForLinqExpressionsAndAutoQuote (infoReader: InfoReader) callerArgTy (calledArg: CalledArg) m = +let AdjustDelegateTy (infoReader: InfoReader) actualTy reqdTy m = let g = infoReader.g - let calledArgTy = calledArg.CalledArgumentType + let (SigOfFunctionForDelegate(_, delArgTys, _, fty)) = GetSigOfFunctionForDelegate infoReader reqdTy m AccessibleFromSomewhere + let delArgTys = if isNil delArgTys then [g.unit_ty] else delArgTys + if (fst (stripFunTy g actualTy)).Length = delArgTys.Length then + fty + else + reqdTy - let adjustDelegateTy calledTy = - let (SigOfFunctionForDelegate(_, delArgTys, _, fty)) = GetSigOfFunctionForDelegate infoReader calledTy m AccessibleFromSomewhere - let delArgTys = if isNil delArgTys then [g.unit_ty] else delArgTys - if (fst (stripFunTy g callerArgTy)).Length = delArgTys.Length then - fty - else - calledArgTy - if isDelegateTy g calledArgTy && isFunTy g callerArgTy then - adjustDelegateTy calledArgTy +// Adhoc based on op_Implicit +// +// NOTE: +// no generic method op_Implicit as yet +// +// Search for an adhoc conversion based on op_Implicit, optionally returing a new equational type constraint to +// eliminate articifical constrained type variables. +// +// Allow adhoc for X --> Y where there is an op_Implicit from X to Y, and there is +// no feasible subtype relationship between X and Y. +// +// Also allow adhoc for X --> ? where the ? is a type inference variable constrained +// by a coercion constraint to Y for which there is an op_Implicit from X to Y, and there is +// no feasible subtype relationship between X and Y. +// +// Implicit conversions are only activated if the types precisely match based on known type information +// at the point of resolution. For example +// let f (x: 'T) : Nullable<'T> = x +// is enough, whereas +// let f (x: 'T) : Nullable<_> = x +// let f x : Nullable<'T> = x +// are not enough to activate. + +let TryFindRelevantImplicitConversion (infoReader: InfoReader) ad reqdTy actualTy m = + let g = infoReader.g + let amap = infoReader.amap + if g.langVersion.SupportsFeature LanguageFeature.AdditionalTypeDirectedConversions then + + // shortcut + if typeEquiv g reqdTy actualTy then None else + let reqdTy2 = + if isTyparTy g reqdTy then + let tp = destTyparTy g reqdTy + match tp.Constraints |> List.choose (function TyparConstraint.CoercesTo (c, _) -> Some c | _ -> None) with + | [reqdTy2] when tp.Rigidity = TyparRigidity.Flexible -> reqdTy2 + | _ -> reqdTy + else reqdTy + + // Implicit conversions only activate if a precise implicit conversion exists and: + // 1. no feasible subtype relationship between X and Y (an approximation), OR + // 2. T --> some-type-containing-precisely-T + // Note that even for (2) implicit conversions are still only activated if the + // types *precisely* and *completely* match based on *known* type information at the point of resolution. + + if not (isTyparTy g reqdTy2) && + (not (TypeFeasiblySubsumesType 0 g amap m reqdTy2 CanCoerce actualTy) || + isTyparTy g actualTy && (let ftyvs = freeInType CollectAll reqdTy2 in ftyvs.FreeTypars.Contains(destTyparTy g actualTy))) then - elif isLinqExpressionTy g calledArgTy && isFunTy g callerArgTy then - let calledArgTyNoExpr = destLinqExpressionTy g calledArgTy - if isDelegateTy g calledArgTyNoExpr then - adjustDelegateTy calledArgTyNoExpr + let implicits = + infoReader.FindImplicitConversions m ad actualTy @ + infoReader.FindImplicitConversions m ad reqdTy2 + + let implicits = + implicits |> List.filter (fun minfo -> + not minfo.IsInstance && + minfo.FormalMethodTyparInst.IsEmpty && + (match minfo.GetParamTypes(amap, m, []) with + | [[a]] -> typeEquiv g a actualTy + | _ -> false) && + (let rty = minfo.GetFSharpReturnTy(amap, m, []) + typeEquiv g rty reqdTy2) + ) + + match implicits with + | [minfo] -> + Some (minfo, (reqdTy, reqdTy2, ignore)) + | minfo :: _ -> + Some (minfo, (reqdTy, reqdTy2, fun denv -> + let reqdTy2Text, actualTyText, _cxs = NicePrint.minimalStringsOfTwoTypes denv reqdTy2 actualTy + let implicitsText = NicePrint.multiLineStringOfMethInfos infoReader m denv implicits + errorR(Error(FSComp.SR.tcAmbiguousImplicitConversion(actualTyText, reqdTy2Text, implicitsText), m)))) + | _ -> None else - calledArgTy + None + else + None + +[] +type TypeDirectedConversion = + | BuiltIn + | Implicit of MethInfo + +[] +type TypeDirectedConversionUsed = + | Yes of (DisplayEnv -> exn) + | No + static member Combine a b = + match a with + | Yes _ -> a + | No -> b - elif calledArg.ReflArgInfo.AutoQuote && isQuotedExprTy g calledArgTy && not (isQuotedExprTy g callerArgTy) then - destQuotedExprTy g calledArgTy +let MapCombineTDCD mapper xs = + MapReduceD mapper TypeDirectedConversionUsed.No TypeDirectedConversionUsed.Combine xs - else calledArgTy +let MapCombineTDC2D mapper xs ys = + MapReduce2D mapper TypeDirectedConversionUsed.No TypeDirectedConversionUsed.Combine xs ys + +let rec AdjustRequiredTypeForTypeDirectedConversions (infoReader: InfoReader) ad isMethodArg isConstraint (reqdTy: TType) actualTy m = + let g = infoReader.g + + let warn info denv = + let reqdTyText, actualTyText, _cxs = NicePrint.minimalStringsOfTwoTypes denv reqdTy actualTy + match info with + | TypeDirectedConversion.BuiltIn -> + Error(FSComp.SR.tcBuiltInImplicitConversionUsed(actualTyText, reqdTyText), m) + | TypeDirectedConversion.Implicit convMeth -> + let methText = NicePrint.stringOfMethInfo infoReader m denv convMeth + if isMethodArg then + Error(FSComp.SR.tcImplicitConversionUsedForMethodArg(methText, actualTyText, reqdTyText), m) + else + Error(FSComp.SR.tcImplicitConversionUsedForNonMethodArg(methText, actualTyText, reqdTyText), m) + + if isConstraint then + reqdTy, TypeDirectedConversionUsed.No, None + else + + // Delegate --> function + if isDelegateTy g reqdTy && isFunTy g actualTy then + AdjustDelegateTy infoReader actualTy reqdTy m, TypeDirectedConversionUsed.No, None + + // (T -> U) --> Expression U> LINQ-style quotation + elif isLinqExpressionTy g reqdTy && isDelegateTy g (destLinqExpressionTy g reqdTy) && isFunTy g actualTy then + let delegateTy = destLinqExpressionTy g reqdTy + AdjustRequiredTypeForTypeDirectedConversions infoReader ad isMethodArg isConstraint delegateTy actualTy m + + // Adhoc int32 --> int64 + elif g.langVersion.SupportsFeature LanguageFeature.AdditionalTypeDirectedConversions && typeEquiv g g.int64_ty reqdTy && typeEquiv g g.int32_ty actualTy then + g.int32_ty, TypeDirectedConversionUsed.Yes(warn TypeDirectedConversion.BuiltIn), None + + // Adhoc int32 --> nativeint + elif g.langVersion.SupportsFeature LanguageFeature.AdditionalTypeDirectedConversions && typeEquiv g g.nativeint_ty reqdTy && typeEquiv g g.int32_ty actualTy then + g.int32_ty, TypeDirectedConversionUsed.Yes(warn TypeDirectedConversion.BuiltIn), None + + // Adhoc int32 --> float64 + elif g.langVersion.SupportsFeature LanguageFeature.AdditionalTypeDirectedConversions && typeEquiv g g.float_ty reqdTy && typeEquiv g g.int32_ty actualTy then + g.int32_ty, TypeDirectedConversionUsed.Yes(warn TypeDirectedConversion.BuiltIn), None + + // Adhoc based on op_Implicit, perhaps returing a new equational type constraint to + // eliminate articifical constrained type variables. + elif g.langVersion.SupportsFeature LanguageFeature.AdditionalTypeDirectedConversions then + match TryFindRelevantImplicitConversion infoReader ad reqdTy actualTy m with + | Some (minfo, eqn) -> actualTy, TypeDirectedConversionUsed.Yes(warn (TypeDirectedConversion.Implicit minfo)), Some eqn + | None -> reqdTy, TypeDirectedConversionUsed.No, None + + else reqdTy, TypeDirectedConversionUsed.No, None + +// If the called method argument is a delegate type, and the caller is known to be a function type, then the caller may provide a function +// If the called method argument is an Expression type, and the caller is known to be a function type, then the caller may provide a T +// If the called method argument is an [] Quotations.Expr, and the caller is not known to be a quoted expression type, then the caller may provide a T +let AdjustCalledArgTypeForTypeDirectedConversionsAndAutoQuote (infoReader: InfoReader) ad (callerArgTy: TType) calledArgTy (calledArg: CalledArg) m = + let g = infoReader.g + + if calledArg.ReflArgInfo.AutoQuote && isQuotedExprTy g calledArgTy && not (isQuotedExprTy g callerArgTy) then + destQuotedExprTy g calledArgTy, TypeDirectedConversionUsed.No, None + else + AdjustRequiredTypeForTypeDirectedConversions infoReader ad true false calledArgTy callerArgTy m /// Adjust the called argument type to take into account whether the caller's argument is CSharpMethod(?arg=Some(3)) or CSharpMethod(arg=1) -let AdjustCalledArgTypeForOptionals (g: TcGlobals) enforceNullableOptionalsKnownTypes (calledArg: CalledArg) calledArgTy (callerArg: CallerArg<_>) = +let AdjustCalledArgTypeForOptionals (infoReader: InfoReader) ad enforceNullableOptionalsKnownTypes (calledArg: CalledArg) calledArgTy (callerArg: CallerArg<_>) = + let g = infoReader.g + let m = callerArg.Range + let callerArgTy = callerArg.CallerArgumentType if callerArg.IsExplicitOptional then match calledArg.OptArgInfo with // CSharpMethod(?x = arg), optional C#-style argument, may have nullable type | CallerSide _ -> if g.langVersion.SupportsFeature LanguageFeature.NullableOptionalInterop then if isNullableTy g calledArgTy then - mkOptionTy g (destNullableTy g calledArgTy) + mkOptionTy g (destNullableTy g calledArgTy), TypeDirectedConversionUsed.No, None else - mkOptionTy g calledArgTy + mkOptionTy g calledArgTy, TypeDirectedConversionUsed.No, None else - calledArgTy + calledArgTy, TypeDirectedConversionUsed.No, None // FSharpMethod(?x = arg), optional F#-style argument | CalleeSide -> // In this case, the called argument will already have option type - calledArgTy + calledArgTy, TypeDirectedConversionUsed.No, None | NotOptional -> // This condition represents an error but the error is raised in later processing - calledArgTy + AdjustCalledArgTypeForTypeDirectedConversionsAndAutoQuote infoReader ad callerArgTy calledArgTy calledArg m else match calledArg.OptArgInfo with // CSharpMethod(x = arg), non-optional C#-style argument, may have type Nullable. | NotOptional when not (g.langVersion.SupportsFeature LanguageFeature.NullableOptionalInterop) -> - calledArgTy + AdjustCalledArgTypeForTypeDirectedConversionsAndAutoQuote infoReader ad callerArgTy calledArgTy calledArg m // The arg should have type ty. However for backwards compat, we also allow arg to have type Nullable | NotOptional @@ -202,35 +342,41 @@ let AdjustCalledArgTypeForOptionals (g: TcGlobals) enforceNullableOptionalsKnown | CallerSide _ -> if isNullableTy g calledArgTy && g.langVersion.SupportsFeature LanguageFeature.NullableOptionalInterop then // If inference has worked out it's a nullable then use this - if isNullableTy g callerArg.CallerArgumentType then - calledArgTy + if isNullableTy g callerArgTy then + calledArgTy, TypeDirectedConversionUsed.No, None + // If inference has worked out it's a struct (e.g. an int) then use this - elif isStructTy g callerArg.CallerArgumentType then - destNullableTy g calledArgTy + elif isStructTy g callerArgTy then + let calledArgTy2 = destNullableTy g calledArgTy + AdjustRequiredTypeForTypeDirectedConversions infoReader ad true false calledArgTy2 callerArgTy m + // If neither and we are at the end of overload resolution then use the Nullable elif enforceNullableOptionalsKnownTypes then - calledArgTy + calledArgTy, TypeDirectedConversionUsed.No, None + // If at the beginning of inference then use a type variable. else match calledArg.OptArgInfo with // If inference has not solved the kind of Nullable on the called arg and is not optional then use this. | NotOptional when isTyparTy g (destNullableTy g calledArgTy) -> - calledArgTy + calledArgTy, TypeDirectedConversionUsed.No, None | _ -> let compgenId = mkSynId range0 unassignedTyparName - mkTyparTy (Construct.NewTypar (TyparKind.Type, TyparRigidity.Flexible, SynTypar(compgenId, TyparStaticReq.None, true), false, TyparDynamicReq.No, [], false, false)) + let tp = mkTyparTy (Construct.NewTypar (TyparKind.Type, TyparRigidity.Flexible, SynTypar(compgenId, TyparStaticReq.None, true), false, TyparDynamicReq.No, [], false, false)) + tp, TypeDirectedConversionUsed.No, None else - calledArgTy + AdjustCalledArgTypeForTypeDirectedConversionsAndAutoQuote infoReader ad callerArgTy calledArgTy calledArg m // FSharpMethod(x = arg), optional F#-style argument, should have option type | CalleeSide -> - if isOptionTy g calledArgTy then - destOptionTy g calledArgTy - else - calledArgTy + let calledArgTy2 = + if isOptionTy g calledArgTy then + destOptionTy g calledArgTy + else + calledArgTy + AdjustCalledArgTypeForTypeDirectedConversionsAndAutoQuote infoReader ad callerArgTy calledArgTy2 calledArg m -// F# supports three adhoc conversions at method callsites (note C# supports more, though ones -// such as implicit conversions interact badly with type inference). +// F# supports adhoc conversions at some specific points // // 1. The use of "(fun x y -> ...)" when a delegate it expected. This is not part of // the ":>" coercion relationship or inference constraint problem as @@ -247,15 +393,16 @@ let AdjustCalledArgTypeForOptionals (g: TcGlobals) enforceNullableOptionalsKnown // and record the presence of the syntax "&e" in the pre-inferred actual type for the method argument. // The function AdjustCalledArgType detects this and refuses to apply the default byref-to-ref transformation. // +// 4. Other type directed conversions in 'AdjustRequiredTypeForTypeDirectedConversions' +// // The function AdjustCalledArgType also adjusts for optional arguments. -let AdjustCalledArgType (infoReader: InfoReader) isConstraint enforceNullableOptionalsKnownTypes (calledArg: CalledArg) (callerArg: CallerArg<_>) = +let AdjustCalledArgType (infoReader: InfoReader) ad isConstraint enforceNullableOptionalsKnownTypes (calledArg: CalledArg) (callerArg: CallerArg<_>) = let g = infoReader.g - let m = callerArg.Range // #424218 - when overload resolution is part of constraint solving - do not perform type-directed conversions let calledArgTy = calledArg.CalledArgumentType let callerArgTy = callerArg.CallerArgumentType if isConstraint then - calledArgTy + calledArgTy, TypeDirectedConversionUsed.No, None else // If the called method argument is an inref type, then the caller may provide a byref or value @@ -266,20 +413,18 @@ let AdjustCalledArgType (infoReader: InfoReader) isConstraint enforceNullableOpt else destByrefTy g calledArgTy #else - calledArgTy + calledArgTy, TypeDirectedConversionUsed.No, None #endif // If the called method argument is a (non inref) byref type, then the caller may provide a byref or ref. elif isByrefTy g calledArgTy then if isByrefTy g callerArgTy then - calledArgTy + calledArgTy, TypeDirectedConversionUsed.No, None else - mkRefCellTy g (destByrefTy g calledArgTy) + mkRefCellTy g (destByrefTy g calledArgTy), TypeDirectedConversionUsed.No, None else - let calledArgTy2 = AdjustCalledArgTypeForLinqExpressionsAndAutoQuote infoReader callerArgTy calledArg m - let calledArgTy3 = AdjustCalledArgTypeForOptionals g enforceNullableOptionalsKnownTypes calledArg calledArgTy2 callerArg - calledArgTy3 + AdjustCalledArgTypeForOptionals infoReader ad enforceNullableOptionalsKnownTypes calledArg calledArgTy callerArg //------------------------------------------------------------------------- // CalledMeth @@ -356,7 +501,7 @@ type CalledMeth<'T> tyargsOpt : TType option) = let g = infoReader.g - let methodRetTy = minfo.GetFSharpReturnTy(infoReader.amap, m, calledTyArgs) + let methodRetTy = if minfo.IsConstructor then minfo.ApparentEnclosingType else minfo.GetFSharpReturnTy(infoReader.amap, m, calledTyArgs) let fullCurriedCalledArgs = MakeCalledArgs infoReader.amap m minfo calledTyArgs do assert (fullCurriedCalledArgs.Length = fullCurriedCalledArgs.Length) @@ -427,7 +572,7 @@ type CalledMeth<'T> [] let assignedNamedProps, unassignedNamedItems = - let returnedObjTy = if minfo.IsConstructor then minfo.ApparentEnclosingType else methodRetTy + let returnedObjTy = methodRetTy unassignedNamedItems |> List.splitChoose (fun (CallerNamedArg(id, e) as arg) -> let nm = id.idText let pinfos = GetIntrinsicPropInfoSetsOfType infoReader (Some nm) ad AllowMultiIntfInstantiations.Yes IgnoreOverrides id.idRange returnedObjTy @@ -508,8 +653,7 @@ type CalledMeth<'T> /// The return type after implicit deference of byref returns is taken into account member x.CalledReturnTypeAfterByrefDeref = - let retTy = methodRetTy - if isByrefTy g retTy then destByrefTy g retTy else retTy + if isByrefTy g methodRetTy then destByrefTy g methodRetTy else methodRetTy /// Return type after tupling of out args is taken into account member x.CalledReturnTypeAfterOutArgTupling = @@ -630,7 +774,7 @@ let InferLambdaArgsForLambdaPropagation origRhsExpr = | _ -> 0 loop origRhsExpr -let ExamineArgumentForLambdaPropagation (infoReader: InfoReader) (arg: AssignedCalledArg) = +let ExamineArgumentForLambdaPropagation (infoReader: InfoReader) ad (arg: AssignedCalledArg) = let g = infoReader.g // Find the explicit lambda arguments of the caller. Ignore parentheses. @@ -638,7 +782,7 @@ let ExamineArgumentForLambdaPropagation (infoReader: InfoReader) (arg: AssignedC let countOfCallerLambdaArg = InferLambdaArgsForLambdaPropagation argExpr // Adjust for Expression<_>, Func<_, _>, ... - let adjustedCalledArgTy = AdjustCalledArgType infoReader false false arg.CalledArg arg.CallerArg + let adjustedCalledArgTy, _, _ = AdjustCalledArgType infoReader ad false false arg.CalledArg arg.CallerArg if countOfCallerLambdaArg > 0 then // Decompose the explicit function type of the target let calledLambdaArgTys, _calledLambdaRetTy = stripFunTy g adjustedCalledArgTy @@ -656,9 +800,9 @@ let ExamineArgumentForLambdaPropagation (infoReader: InfoReader) (arg: AssignedC CalledArgMatchesType(adjustedCalledArgTy) -let ExamineMethodForLambdaPropagation (x: CalledMeth) = - let unnamedInfo = x.AssignedUnnamedArgs |> List.mapSquared (ExamineArgumentForLambdaPropagation x.infoReader) - let namedInfo = x.AssignedNamedArgs |> List.mapSquared (fun arg -> (arg.NamedArgIdOpt.Value, ExamineArgumentForLambdaPropagation x.infoReader arg)) +let ExamineMethodForLambdaPropagation (x: CalledMeth) ad = + let unnamedInfo = x.AssignedUnnamedArgs |> List.mapSquared (ExamineArgumentForLambdaPropagation x.infoReader ad) + let namedInfo = x.AssignedNamedArgs |> List.mapSquared (fun arg -> (arg.NamedArgIdOpt.Value, ExamineArgumentForLambdaPropagation x.infoReader ad arg)) if unnamedInfo |> List.existsSquared (function CallerLambdaHasArgTypes _ -> true | _ -> false) || namedInfo |> List.existsSquared (function _, CallerLambdaHasArgTypes _ -> true | _ -> false) then Some (unnamedInfo, namedInfo) @@ -958,6 +1102,56 @@ let BuildMethodCall tcVal g amap isMutable m isProp minfo valUseFlags minst objA errorR(Error(FSComp.SR.tcDefaultStructConstructorCall(), m)) mkDefault (m, ty), ty) +let ILFieldStaticChecks g amap infoReader ad m (finfo : ILFieldInfo) = + CheckILFieldInfoAccessible g amap m ad finfo + if not finfo.IsStatic then error (Error (FSComp.SR.tcFieldIsNotStatic(finfo.FieldName), m)) + + // Static IL interfaces fields are not supported in lower F# versions. + if isInterfaceTy g finfo.ApparentEnclosingType then + checkLanguageFeatureRuntimeErrorRecover infoReader LanguageFeature.DefaultInterfaceMemberConsumption m + checkLanguageFeatureErrorRecover g.langVersion LanguageFeature.DefaultInterfaceMemberConsumption m + + CheckILFieldAttributes g finfo m + +let ILFieldInstanceChecks g amap ad m (finfo : ILFieldInfo) = + if finfo.IsStatic then error (Error (FSComp.SR.tcStaticFieldUsedWhenInstanceFieldExpected(), m)) + CheckILFieldInfoAccessible g amap m ad finfo + CheckILFieldAttributes g finfo m + +let MethInfoChecks g amap isInstance tyargsOpt objArgs ad m (minfo: MethInfo) = + if minfo.IsInstance <> isInstance then + if isInstance then + error (Error (FSComp.SR.csMethodIsNotAnInstanceMethod(minfo.LogicalName), m)) + else + error (Error (FSComp.SR.csMethodIsNotAStaticMethod(minfo.LogicalName), m)) + + // keep the original accessibility domain to determine type accessibility + let adOriginal = ad + // Eliminate the 'protected' portion of the accessibility domain for instance accesses + let ad = + match objArgs, ad with + | [objArg], AccessibleFrom(paths, Some tcref) -> + let objArgTy = tyOfExpr g objArg + let ty = generalizedTyconRef tcref + // We get to keep our rights if the type we're in subsumes the object argument type + if TypeFeasiblySubsumesType 0 g amap m ty CanCoerce objArgTy then + ad + // We get to keep our rights if this is a base call + elif IsBaseCall objArgs then + ad + else + AccessibleFrom(paths, None) + | _ -> ad + + if not (IsTypeAndMethInfoAccessible amap m adOriginal ad minfo) then + error (Error (FSComp.SR.tcMethodNotAccessible(minfo.LogicalName), m)) + + if isAnyTupleTy g minfo.ApparentEnclosingType && not minfo.IsExtensionMember && + (minfo.LogicalName.StartsWithOrdinal("get_Item") || minfo.LogicalName.StartsWithOrdinal("get_Rest")) then + warning (Error (FSComp.SR.tcTupleMemberNotNormallyUsed(), m)) + + CheckMethInfoAttributes g m tyargsOpt minfo |> CommitOperationResult + //------------------------------------------------------------------------- // Adjust caller arguments as part of building a method call //------------------------------------------------------------------------- @@ -1013,7 +1207,40 @@ let CoerceFromFSharpFuncToDelegate g amap infoReader ad callerArgTy m callerArgE BuildNewDelegateExpr (None, g, amap, delegateTy, invokeMethInfo, delArgTys, callerArgExpr, callerArgTy, m) // Handle adhoc argument conversions -let AdjustCallerArgExprForCoercions (g: TcGlobals) amap infoReader ad isOutArg calledArgTy (reflArgInfo: ReflectedArgInfo) callerArgTy m callerArgExpr = +let rec AdjustExprForTypeDirectedConversions tcVal (g: TcGlobals) amap infoReader ad reqdTy actualTy m expr = + if isDelegateTy g reqdTy && isFunTy g actualTy then + CoerceFromFSharpFuncToDelegate g amap infoReader ad actualTy m expr reqdTy + + elif isLinqExpressionTy g reqdTy && isDelegateTy g (destLinqExpressionTy g reqdTy) && isFunTy g actualTy then + let delegateTy = destLinqExpressionTy g reqdTy + let expr2 = AdjustExprForTypeDirectedConversions tcVal g amap infoReader ad delegateTy actualTy m expr + mkCallQuoteToLinqLambdaExpression g m delegateTy (Expr.Quote (expr2, ref None, false, m, mkQuotedExprTy g delegateTy)) + + // Adhoc int32 --> int64 + elif g.langVersion.SupportsFeature LanguageFeature.AdditionalTypeDirectedConversions && typeEquiv g g.int64_ty reqdTy && typeEquiv g g.int32_ty actualTy then + mkCallToInt64Operator g m actualTy expr + + // Adhoc int32 --> nativeint + elif g.langVersion.SupportsFeature LanguageFeature.AdditionalTypeDirectedConversions && typeEquiv g g.nativeint_ty reqdTy && typeEquiv g g.int32_ty actualTy then + mkCallToIntPtrOperator g m actualTy expr + + // Adhoc int32 --> float64 + elif g.langVersion.SupportsFeature LanguageFeature.AdditionalTypeDirectedConversions && typeEquiv g g.float_ty reqdTy && typeEquiv g g.int32_ty actualTy then + mkCallToDoubleOperator g m actualTy expr + + else + match TryFindRelevantImplicitConversion infoReader ad reqdTy actualTy m with + | Some (minfo, _) -> + MethInfoChecks g amap false None [] ad m minfo + let callExpr, _ = BuildMethodCall tcVal g amap Mutates.NeverMutates m false minfo ValUseFlag.NormalValUse [] [] [expr] + assert (let resTy = tyOfExpr g callExpr in typeEquiv g reqdTy resTy) + callExpr + | None -> mkCoerceIfNeeded g reqdTy actualTy expr + // TODO: consider Nullable + + +// Handle adhoc argument conversions +let AdjustCallerArgExpr tcVal (g: TcGlobals) amap infoReader ad isOutArg calledArgTy (reflArgInfo: ReflectedArgInfo) callerArgTy m callerArgExpr = if isByrefTy g calledArgTy && isRefCellTy g callerArgTy then None, Expr.Op (TOp.RefAddrGet false, [destRefCellTy g callerArgTy], [callerArgExpr], m) @@ -1023,14 +1250,6 @@ let AdjustCallerArgExprForCoercions (g: TcGlobals) amap infoReader ad isOutArg c Some wrap, callerArgExprAddress #endif - elif isDelegateTy g calledArgTy && isFunTy g callerArgTy then - None, CoerceFromFSharpFuncToDelegate g amap infoReader ad callerArgTy m callerArgExpr calledArgTy - - elif isLinqExpressionTy g calledArgTy && isDelegateTy g (destLinqExpressionTy g calledArgTy) && isFunTy g callerArgTy then - let delegateTy = destLinqExpressionTy g calledArgTy - let expr = CoerceFromFSharpFuncToDelegate g amap infoReader ad callerArgTy m callerArgExpr delegateTy - None, mkCallQuoteToLinqLambdaExpression g m delegateTy (Expr.Quote (expr, ref None, false, m, mkQuotedExprTy g delegateTy)) - // auto conversions to quotations (to match auto conversions to LINQ expressions) elif reflArgInfo.AutoQuote && isQuotedExprTy g calledArgTy && not (isQuotedExprTy g callerArgTy) then match reflArgInfo with @@ -1044,9 +1263,9 @@ let AdjustCallerArgExprForCoercions (g: TcGlobals) amap infoReader ad isOutArg c elif isOutArg then None, callerArgExpr - // Note: not all these casts are reported in quotations else - None, mkCoerceIfNeeded g calledArgTy callerArgTy callerArgExpr + let callerArgExpr2 = AdjustExprForTypeDirectedConversions tcVal g amap infoReader ad calledArgTy callerArgTy m callerArgExpr + None, callerArgExpr2 /// Some of the code below must allocate temporary variables or bind other variables to particular values. /// As usual we represent variable allocators by expr -> expr functions @@ -1165,11 +1384,14 @@ let MakeNullableExprIfNeeded (infoReader: InfoReader) calledArgTy callerArgTy ca MakeMethInfoCall amap m minfo [] [callerArgExprCoerced] // Adjust all the optional arguments, filling in values for defaults, -let AdjustCallerArgForOptional tcFieldInit eCallerMemberName (infoReader: InfoReader) (assignedArg: AssignedCalledArg<_>) = +let AdjustCallerArgForOptional tcVal tcFieldInit eCallerMemberName (infoReader: InfoReader) ad (assignedArg: AssignedCalledArg<_>) = let g = infoReader.g + let amap = infoReader.amap let callerArg = assignedArg.CallerArg let (CallerArg(callerArgTy, m, isOptCallerArg, callerArgExpr)) = callerArg let calledArg = assignedArg.CalledArg + let isOutArg = calledArg.IsOutArg + let reflArgInfo = calledArg.ReflArgInfo let calledArgTy = calledArg.CalledArgumentType match calledArg.OptArgInfo with | NotOptional when not (g.langVersion.SupportsFeature LanguageFeature.NullableOptionalInterop) -> @@ -1193,7 +1415,12 @@ let AdjustCallerArgForOptional tcFieldInit eCallerMemberName (infoReader: InfoRe // T --> Nullable widening at callsites if isOptCallerArg then errorR(Error(FSComp.SR.tcFormalArgumentIsNotOptional(), m)) if isNullableTy g calledArgTy then - MakeNullableExprIfNeeded infoReader calledArgTy callerArgTy callerArgExpr m + if isNullableTy g callerArgTy then + callerArgExpr + else + let calledNonOptTy = destNullableTy g calledArgTy + let _, callerArgExpr2 = AdjustCallerArgExpr tcVal g amap infoReader ad isOutArg calledNonOptTy reflArgInfo callerArgTy m callerArgExpr + MakeNullableExprIfNeeded infoReader calledArgTy callerArgTy callerArgExpr2 m else failwith "unreachable" // see case above @@ -1216,24 +1443,30 @@ let AdjustCallerArgForOptional tcFieldInit eCallerMemberName (infoReader: InfoRe callerArgExpr else if isNullableTy g calledArgTy then - // CSharpMethod(x=b) when 'x' has nullable type - // CSharpMethod(x=b) when both 'x' and 'b' have nullable type --> CSharpMethod(x=b) - // CSharpMethod(x=b) when 'x' has nullable type and 'b' does not --> CSharpMethod(x=Nullable(b)) - MakeNullableExprIfNeeded infoReader calledArgTy callerArgTy callerArgExpr m + if isNullableTy g callerArgTy then + // CSharpMethod(x=b) when 'x' has nullable type + // CSharpMethod(x=b) when both 'x' and 'b' have nullable type --> CSharpMethod(x=b) + callerArgExpr + else + // CSharpMethod(x=b) when 'x' has nullable type and 'b' does not --> CSharpMethod(x=Nullable(b)) + let calledNonOptTy = destNullableTy g calledArgTy + let _, callerArgExpr2 = AdjustCallerArgExpr tcVal g amap infoReader ad isOutArg calledNonOptTy reflArgInfo callerArgTy m callerArgExpr + MakeNullableExprIfNeeded infoReader calledArgTy callerArgTy callerArgExpr2 m else // CSharpMethod(x=b) --> CSharpMethod(?x=b) - callerArgExpr + let _, callerArgExpr2 = AdjustCallerArgExpr tcVal g amap infoReader ad isOutArg calledArgTy reflArgInfo callerArgTy m callerArgExpr + callerArgExpr2 | CalleeSide -> if isOptCallerArg then - // CSharpMethod(?x=b) --> CSharpMethod(?x=b) + // FSharpMethod(?x=b) --> FSharpMethod(?x=b) callerArgExpr else - // CSharpMethod(x=b) when CSharpMethod(A) --> CSharpMethod(?x=Some(b :> A)) + // FSharpMethod(x=b) when FSharpMethod(A) --> FSharpMethod(?x=Some(b :> A)) if isOptionTy g calledArgTy then let calledNonOptTy = destOptionTy g calledArgTy - let callerArgExprCoerced = mkCoerceIfNeeded g calledNonOptTy callerArgTy callerArgExpr - mkSome g calledNonOptTy callerArgExprCoerced m + let _, callerArgExpr2 = AdjustCallerArgExpr tcVal g amap infoReader ad isOutArg calledNonOptTy reflArgInfo callerArgTy m callerArgExpr + mkSome g calledNonOptTy callerArgExpr2 m else assert false callerArgExpr // defensive code - this case is unreachable @@ -1260,7 +1493,7 @@ let AdjustCallerArgForOptional tcFieldInit eCallerMemberName (infoReader: InfoRe // - VB also allows you to pass intrinsic values as optional values to parameters // typed as Object. What we do in this case is we box the intrinsic value." // -let AdjustCallerArgsForOptionals tcFieldInit eCallerMemberName (infoReader: InfoReader) (calledMeth: CalledMeth<_>) mItem mMethExpr = +let AdjustCallerArgsForOptionals tcVal tcFieldInit eCallerMemberName (infoReader: InfoReader) ad (calledMeth: CalledMeth<_>) mItem mMethExpr = let g = infoReader.g let assignedNamedArgs = calledMeth.ArgSets |> List.collect (fun argSet -> argSet.AssignedNamedArgs) @@ -1277,8 +1510,8 @@ let AdjustCallerArgsForOptionals tcFieldInit eCallerMemberName (infoReader: Info let preBinder2, arg = GetDefaultExpressionForOptionalArg tcFieldInit g calledArg eCallerMemberName mItem mMethExpr arg, (preBinder >> preBinder2)) - let adjustedNormalUnnamedArgs = List.map (AdjustCallerArgForOptional tcFieldInit eCallerMemberName infoReader) unnamedArgs - let adjustedAssignedNamedArgs = List.map (AdjustCallerArgForOptional tcFieldInit eCallerMemberName infoReader) assignedNamedArgs + let adjustedNormalUnnamedArgs = List.map (AdjustCallerArgForOptional tcVal tcFieldInit eCallerMemberName infoReader ad) unnamedArgs + let adjustedAssignedNamedArgs = List.map (AdjustCallerArgForOptional tcVal tcFieldInit eCallerMemberName infoReader ad) assignedNamedArgs optArgs, optArgPreBinder, adjustedNormalUnnamedArgs, adjustedAssignedNamedArgs @@ -1295,7 +1528,7 @@ let AdjustOutCallerArgs g (calledMeth: CalledMeth<_>) mMethExpr = |> List.unzip3 /// Adjust any '[]' arguments, converting to an array -let AdjustParamArrayCallerArgs g amap infoReader ad (calledMeth: CalledMeth<_>) mMethExpr = +let AdjustParamArrayCallerArgs tcVal g amap infoReader ad (calledMeth: CalledMeth<_>) mMethExpr = let argSets = calledMeth.ArgSets let paramArrayCallerArgs = argSets |> List.collect (fun argSet -> argSet.ParamArrayCallerArgs) @@ -1311,7 +1544,7 @@ let AdjustParamArrayCallerArgs g amap infoReader ad (calledMeth: CalledMeth<_>) paramArrayCallerArgs |> List.map (fun callerArg -> let (CallerArg(callerArgTy, m, isOutArg, callerArgExpr)) = callerArg - AdjustCallerArgExprForCoercions g amap infoReader ad isOutArg paramArrayCalledArgElementType paramArrayCalledArg.ReflArgInfo callerArgTy m callerArgExpr) + AdjustCallerArgExpr tcVal g amap infoReader ad isOutArg paramArrayCalledArgElementType paramArrayCalledArg.ReflArgInfo callerArgTy m callerArgExpr) |> List.unzip let paramArrayExpr = Expr.Op (TOp.Array, [paramArrayCalledArgElementType], paramArrayExprs, mMethExpr) @@ -1326,7 +1559,7 @@ let AdjustParamArrayCallerArgs g amap infoReader ad (calledMeth: CalledMeth<_>) /// Build the argument list for a method call. Adjust for param array, optional arguments, byref arguments and coercions. /// For example, if you pass an F# reference cell to a byref then we must get the address of the /// contents of the ref. Likewise lots of adjustments are made for optional arguments etc. -let AdjustCallerArgs tcFieldInit eCallerMemberName (infoReader: InfoReader) ad (calledMeth: CalledMeth<_>) objArgs lambdaVars mItem mMethExpr = +let AdjustCallerArgs tcVal tcFieldInit eCallerMemberName (infoReader: InfoReader) ad (calledMeth: CalledMeth<_>) objArgs lambdaVars mItem mMethExpr = let g = infoReader.g let amap = infoReader.amap let calledMethInfo = calledMeth.Method @@ -1345,10 +1578,10 @@ let AdjustCallerArgs tcFieldInit eCallerMemberName (infoReader: InfoReader) ad ( // Handle param array and optional arguments let paramArrayPreBinders, paramArrayArgs = - AdjustParamArrayCallerArgs g amap infoReader ad calledMeth mMethExpr + AdjustParamArrayCallerArgs tcVal g amap infoReader ad calledMeth mMethExpr let optArgs, optArgPreBinder, adjustedNormalUnnamedArgs, adjustedFinalAssignedNamedArgs = - AdjustCallerArgsForOptionals tcFieldInit eCallerMemberName infoReader calledMeth mItem mMethExpr + AdjustCallerArgsForOptionals tcVal tcFieldInit eCallerMemberName infoReader ad calledMeth mItem mMethExpr let outArgs, outArgExprs, outArgTmpBinds = AdjustOutCallerArgs g calledMeth mMethExpr @@ -1371,7 +1604,7 @@ let AdjustCallerArgs tcFieldInit eCallerMemberName (infoReader: InfoReader) ad ( let calledArgTy = assignedArg.CalledArg.CalledArgumentType let (CallerArg(callerArgTy, m, _, e)) = assignedArg.CallerArg - AdjustCallerArgExprForCoercions g amap infoReader ad isOutArg calledArgTy reflArgInfo callerArgTy m e) + AdjustCallerArgExpr tcVal g amap infoReader ad isOutArg calledArgTy reflArgInfo callerArgTy m e) |> List.unzip objArgPreBinder, objArgs, allArgsPreBinders, allArgs, allArgsCoerced, optArgPreBinder, paramArrayPreBinders, outArgExprs, outArgTmpBinds @@ -1748,56 +1981,6 @@ let RecdFieldInstanceChecks g amap ad m (rfinfo: RecdFieldInfo) = CheckRecdFieldInfoAttributes g rfinfo m |> CommitOperationResult CheckRecdFieldInfoAccessible amap m ad rfinfo -let ILFieldStaticChecks g amap infoReader ad m (finfo : ILFieldInfo) = - CheckILFieldInfoAccessible g amap m ad finfo - if not finfo.IsStatic then error (Error (FSComp.SR.tcFieldIsNotStatic(finfo.FieldName), m)) - - // Static IL interfaces fields are not supported in lower F# versions. - if isInterfaceTy g finfo.ApparentEnclosingType then - checkLanguageFeatureRuntimeErrorRecover infoReader LanguageFeature.DefaultInterfaceMemberConsumption m - checkLanguageFeatureErrorRecover g.langVersion LanguageFeature.DefaultInterfaceMemberConsumption m - - CheckILFieldAttributes g finfo m - -let ILFieldInstanceChecks g amap ad m (finfo : ILFieldInfo) = - if finfo.IsStatic then error (Error (FSComp.SR.tcStaticFieldUsedWhenInstanceFieldExpected(), m)) - CheckILFieldInfoAccessible g amap m ad finfo - CheckILFieldAttributes g finfo m - -let MethInfoChecks g amap isInstance tyargsOpt objArgs ad m (minfo: MethInfo) = - if minfo.IsInstance <> isInstance then - if isInstance then - error (Error (FSComp.SR.csMethodIsNotAnInstanceMethod(minfo.LogicalName), m)) - else - error (Error (FSComp.SR.csMethodIsNotAStaticMethod(minfo.LogicalName), m)) - - // keep the original accessibility domain to determine type accessibility - let adOriginal = ad - // Eliminate the 'protected' portion of the accessibility domain for instance accesses - let ad = - match objArgs, ad with - | [objArg], AccessibleFrom(paths, Some tcref) -> - let objArgTy = tyOfExpr g objArg - let ty = generalizedTyconRef tcref - // We get to keep our rights if the type we're in subsumes the object argument type - if TypeFeasiblySubsumesType 0 g amap m ty CanCoerce objArgTy then - ad - // We get to keep our rights if this is a base call - elif IsBaseCall objArgs then - ad - else - AccessibleFrom(paths, None) - | _ -> ad - - if not (IsTypeAndMethInfoAccessible amap m adOriginal ad minfo) then - error (Error (FSComp.SR.tcMethodNotAccessible(minfo.LogicalName), m)) - - if isAnyTupleTy g minfo.ApparentEnclosingType && not minfo.IsExtensionMember && - (minfo.LogicalName.StartsWithOrdinal("get_Item") || minfo.LogicalName.StartsWithOrdinal("get_Rest")) then - warning (Error (FSComp.SR.tcTupleMemberNotNormallyUsed(), m)) - - CheckMethInfoAttributes g m tyargsOpt minfo |> CommitOperationResult - exception FieldNotMutable of DisplayEnv * RecdFieldRef * range let CheckRecdFieldMutation m denv (rfinfo: RecdFieldInfo) = diff --git a/src/fsharp/MethodCalls.fsi b/src/fsharp/MethodCalls.fsi index 968ab70084..1624d0d966 100644 --- a/src/fsharp/MethodCalls.fsi +++ b/src/fsharp/MethodCalls.fsi @@ -5,6 +5,7 @@ module internal FSharp.Compiler.MethodCalls open FSharp.Compiler open FSharp.Compiler.AccessibilityLogic +open FSharp.Compiler.ErrorLogger open FSharp.Compiler.Import open FSharp.Compiler.InfoReader open FSharp.Compiler.Infos @@ -13,6 +14,7 @@ open FSharp.Compiler.Syntax open FSharp.Compiler.Text open FSharp.Compiler.TcGlobals open FSharp.Compiler.TypedTree +open FSharp.Compiler.TypedTreeOps #if !NO_EXTENSIONTYPING open FSharp.Compiler.ExtensionTyping @@ -79,8 +81,11 @@ type AssignedItemSetter<'T> = type CallerNamedArg<'T> = | CallerNamedArg of Ident * CallerArg<'T> + member CallerArg: CallerArg<'T> + member Ident: Ident + member Name: string /// Represents the list of unnamed / named arguments at method call site @@ -90,13 +95,51 @@ type CallerNamedArg<'T> = type CallerArgs<'T> = { Unnamed: CallerArg<'T> list list Named: CallerNamedArg<'T> list list } + member ArgumentNamesAndTypes: (string option * TType) list + member CallerArgCounts: int * int + member CurriedCallerArgs: (CallerArg<'T> list * CallerNamedArg<'T> list) list + static member Empty: CallerArgs<'T> -/// F# supports some adhoc conversions at method callsites -val AdjustCalledArgType: infoReader:InfoReader -> isConstraint:bool -> enforceNullableOptionalsKnownTypes:bool -> calledArg:CalledArg -> callerArg:CallerArg<'a> -> TType +/// Indicates whether a type directed conversion (e.g. int32 to int64, or op_Implicit) +/// has been used in F# code +[] +type TypeDirectedConversionUsed = + | Yes of (DisplayEnv -> exn) + | No + static member Combine: TypeDirectedConversionUsed -> TypeDirectedConversionUsed -> TypeDirectedConversionUsed + +/// Performs a set of constraint solver operations returning TypeDirectedConversionUsed and +/// combines their results. +val MapCombineTDCD: mapper:('a -> OperationResult) -> xs:'a list -> OperationResult + +/// Performs a set of constraint solver operations returning TypeDirectedConversionUsed and +/// combines their results. +val MapCombineTDC2D: mapper:('a -> 'b -> OperationResult) -> xs:'a list -> ys:'b list -> OperationResult + +/// F# supports some adhoc conversions to make expression fit known overall type +val AdjustRequiredTypeForTypeDirectedConversions: + infoReader:InfoReader -> + ad: AccessorDomain -> + isMethodArg: bool -> + isConstraint: bool -> + reqdTy: TType -> + actualTy:TType -> + m: range + -> TType * TypeDirectedConversionUsed * (TType * TType * (DisplayEnv -> unit)) option + +/// F# supports some adhoc conversions to make expression fit known overall type +val AdjustCalledArgType: + infoReader:InfoReader -> + ad: AccessorDomain -> + isConstraint:bool -> + enforceNullableOptionalsKnownTypes:bool -> + calledArg:CalledArg -> + callerArg:CallerArg<'a> + -> TType * TypeDirectedConversionUsed * (TType * TType * (DisplayEnv -> unit)) option type CalledMethArgSet<'T> = { /// The called arguments corresponding to "unnamed" arguments @@ -141,13 +184,21 @@ type CalledMeth<'T> = allowParamArgs:bool * allowOutAndOptArgs:bool * tyargsOpt:TType option -> CalledMeth<'T> + static member GetMethod: x:CalledMeth<'T> -> MethInfo + member CalledObjArgTys: m:range -> TType list + member GetParamArrayElementType: unit -> TType + member HasCorrectObjArgs: m:range -> bool + member IsAccessible: m:range * ad:AccessorDomain -> bool + member IsCandidate: m:range * ad:AccessorDomain -> bool + member AllCalledArgs: CalledArg list list + member AllUnnamedCalledArgs: CalledArg list /// The argument analysis for each set of curried arguments @@ -155,8 +206,11 @@ type CalledMeth<'T> = /// Named setters member AssignedItemSetters: AssignedItemSetter<'T> list + member AssignedNamedArgs: AssignedCalledArg<'T> list list + member AssignedUnnamedArgs: AssignedCalledArg<'T> list list + member AssignsAllNamedArgs: bool /// The property related to the method we're attempting to call, if any @@ -182,21 +236,34 @@ type CalledMeth<'T> = /// The formal instantiation of the method we're attempting to call member CallerTyArgs: TType list + member HasCorrectArity: bool + member HasCorrectGenericArity: bool + member HasOptArgs: bool + member HasOutArgs: bool /// The method we're attempting to call member Method: MethInfo + member NumArgSets: int + member NumAssignedProps: int + member NumCalledTyArgs: int + member NumCallerTyArgs: int + member ParamArrayCalledArgOpt: CalledArg option + member ParamArrayCallerArgs: CallerArg<'T> list option + member TotalNumAssignedNamedArgs: int + member TotalNumUnnamedCalledArgs: int + member TotalNumUnnamedCallerArgs: int /// Unassigned args @@ -207,8 +274,11 @@ type CalledMeth<'T> = /// Unnamed called out args: return these as part of the return tuple member UnnamedCalledOutArgs: CalledArg list + member UsesParamArrayConversion: bool + member amap: ImportMap + member infoReader: InfoReader val NamesOfCalledArgs: calledArgs:CalledArg list -> Ident list @@ -219,7 +289,7 @@ type ArgumentAnalysis = | CallerLambdaHasArgTypes of TType list | CalledArgMatchesType of TType -val ExamineMethodForLambdaPropagation: x:CalledMeth -> (ArgumentAnalysis list list * (Ident * ArgumentAnalysis) list list) option +val ExamineMethodForLambdaPropagation: x:CalledMeth -> ad:AccessorDomain -> (ArgumentAnalysis list list * (Ident * ArgumentAnalysis) list list) option /// Is this a 'base' call val IsBaseCall: objArgs:Expr list -> bool @@ -260,12 +330,37 @@ val BuildNewDelegateExpr: eventInfoOpt:EventInfo option * g:TcGlobals * amap:Imp val CoerceFromFSharpFuncToDelegate: g:TcGlobals -> amap:ImportMap -> infoReader:InfoReader -> ad:AccessorDomain -> callerArgTy:TType -> m:range -> callerArgExpr:Expr -> delegateTy:TType -> Expr -val AdjustCallerArgExprForCoercions: g:TcGlobals -> amap:ImportMap -> infoReader:InfoReader -> ad:AccessorDomain -> isOutArg:bool -> calledArgTy:TType -> reflArgInfo:ReflectedArgInfo -> callerArgTy:TType -> m:range -> callerArgExpr:Expr -> 'a option * Expr +val AdjustExprForTypeDirectedConversions: + tcVal:(ValRef -> ValUseFlag -> TType list -> range -> Expr * TType) -> + g: TcGlobals -> + amap:ImportMap -> + infoReader:InfoReader -> + ad:AccessorDomain -> + reqdTy:TType -> + actualTy:TType -> + m:range -> + expr:Expr + -> Expr + +val AdjustCallerArgExpr: + tcVal:(ValRef -> ValUseFlag -> TType list -> range -> Expr * TType) -> + g:TcGlobals -> + amap:ImportMap -> + infoReader:InfoReader -> + ad:AccessorDomain -> + isOutArg:bool -> + calledArgTy:TType -> + reflArgInfo:ReflectedArgInfo -> + callerArgTy:TType -> + m:range -> + callerArgExpr:Expr -> + 'a option * Expr /// Build the argument list for a method call. Adjust for param array, optional arguments, byref arguments and coercions. /// For example, if you pass an F# reference cell to a byref then we must get the address of the /// contents of the ref. Likewise lots of adjustments are made for optional arguments etc. val AdjustCallerArgs: + tcVal:(ValRef -> ValUseFlag -> TType list -> range -> Expr * TType) -> tcFieldInit:(range -> AbstractIL.IL.ILFieldInit -> Const) -> eCallerMemberName:string option -> infoReader:InfoReader -> diff --git a/src/fsharp/NicePrint.fs b/src/fsharp/NicePrint.fs index fb4127adb3..0df983273c 100755 --- a/src/fsharp/NicePrint.fs +++ b/src/fsharp/NicePrint.fs @@ -799,6 +799,17 @@ module private PrintTypes = layoutTyparRefWithInfo denv env r | TType_measure unt -> layoutMeasure denv unt + + | TType_erased_union (unionInfo, types) -> + let sigma = unionInfo.UnsortedCaseSourceIndices + + let unsortedTyps = + types + |> List.indexed + |> List.sortBy (fun (sortedIdx, _) -> sigma.[sortedIdx]) + |> List.map snd + + bracketL (layoutTypesWithInfoAndPrec denv env 2 (wordL (tagPunctuation "|")) unsortedTyps) /// Layout a list of types, separated with the given separator, either '*' or ',' and private layoutTypesWithInfoAndPrec denv env prec sep typl = @@ -2213,7 +2224,15 @@ let prettyLayoutOfMethInfoFreeStyle infoReader m denv typarInst minfo = InfoMemb let prettyLayoutOfPropInfoFreeStyle g amap m denv d = InfoMemberPrinting.prettyLayoutOfPropInfoFreeStyle g amap m denv d /// Convert a MethInfo to a string -let stringOfMethInfo infoReader m denv d = bufs (fun buf -> InfoMemberPrinting.formatMethInfoToBufferFreeStyle infoReader m denv buf d) +let stringOfMethInfo infoReader m denv minfo = + bufs (fun buf -> InfoMemberPrinting.formatMethInfoToBufferFreeStyle infoReader m denv buf minfo) + +/// Convert MethInfos to lines separated by newline including a newline as the first character +let multiLineStringOfMethInfos infoReader m denv minfos = + minfos + |> List.map (stringOfMethInfo infoReader m denv) + |> List.map (sprintf "%s %s" System.Environment.NewLine) + |> String.concat "" /// Convert a ParamData to a string let stringOfParamData denv paramData = bufs (fun buf -> InfoMemberPrinting.formatParamDataToBuffer denv buf paramData) diff --git a/src/fsharp/NicePrint.fsi b/src/fsharp/NicePrint.fsi index 54dbc524c0..303770e5a2 100644 --- a/src/fsharp/NicePrint.fsi +++ b/src/fsharp/NicePrint.fsi @@ -57,7 +57,9 @@ val prettyLayoutOfMethInfoFreeStyle: infoReader:InfoReader -> m:range -> denv:Di val prettyLayoutOfPropInfoFreeStyle: g:TcGlobals -> amap:ImportMap -> m:range -> denv:DisplayEnv -> d:PropInfo -> Layout -val stringOfMethInfo: infoReader:InfoReader -> m:range -> denv:DisplayEnv -> d:MethInfo -> string +val stringOfMethInfo: infoReader:InfoReader -> m:range -> denv:DisplayEnv -> minfo:MethInfo -> string + +val multiLineStringOfMethInfos: infoReader:InfoReader -> m:range -> denv:DisplayEnv -> minfos:MethInfo list -> string val stringOfParamData: denv:DisplayEnv -> paramData:ParamData -> string diff --git a/src/fsharp/PostInferenceChecks.fs b/src/fsharp/PostInferenceChecks.fs index e230643baa..fcbe263bc8 100644 --- a/src/fsharp/PostInferenceChecks.fs +++ b/src/fsharp/PostInferenceChecks.fs @@ -387,6 +387,7 @@ let rec CheckTypeDeep (cenv: cenv) (visitTy, visitTyconRefOpt, visitAppTyOpt, vi CheckTypesDeep cenv f g env tys | TType_ucase (_, tinst) -> CheckTypesDeep cenv f g env tinst + | TType_erased_union (_, tys) -> CheckTypesDeep cenv f g env tys | TType_tuple (_, tys) -> CheckTypesDeep cenv f g env tys | TType_fun (s, t) -> CheckTypeDeep cenv f g env true s; CheckTypeDeep cenv f g env true t | TType_var tp -> diff --git a/src/fsharp/SyntaxTree.fs b/src/fsharp/SyntaxTree.fs index 23d46cd3d0..cf31b2b15f 100644 --- a/src/fsharp/SyntaxTree.fs +++ b/src/fsharp/SyntaxTree.fs @@ -371,6 +371,11 @@ type SynType = isStruct: bool * fields:(Ident * SynType) list * range: range + + /// Erased union type definition, type X = (A | B) + | ErasedUnion of + erasedUnionCases: SynErasedUnionCase list * + range: range/// | Array of rank: int * @@ -431,6 +436,7 @@ type SynType = | SynType.Tuple (range=m) | SynType.Array (range=m) | SynType.AnonRecd (range=m) + | SynType.ErasedUnion (range=m) | SynType.Fun (range=m) | SynType.Var (range=m) | SynType.Anon (range=m) @@ -1384,6 +1390,18 @@ type SynUnionCase = match this with | SynUnionCase (range=m) -> m +[] +type SynErasedUnionCase = + + | SynErasedUnionCase of + typ: SynType * + xmlDoc: PreXmlDoc * + range: range + + member this.Range = + match this with + | SynErasedUnionCase (range=m) -> m + [] type SynUnionCaseKind = diff --git a/src/fsharp/SyntaxTree.fsi b/src/fsharp/SyntaxTree.fsi index 035f3d9b42..cee1a60790 100644 --- a/src/fsharp/SyntaxTree.fsi +++ b/src/fsharp/SyntaxTree.fsi @@ -465,6 +465,11 @@ type SynType = fields:(Ident * SynType) list * range: range + /// Erased union type definition, type X = (A | B) + | ErasedUnion of + erasedUnionCases: SynErasedUnionCase list * + range: range/// + /// F# syntax: type[] | Array of rank: int * @@ -1546,6 +1551,17 @@ type SynUnionCase = /// Gets the syntax range of this construct member Range: range +[] +type SynErasedUnionCase = + + /// The untyped, unchecked syntax tree for one case in a union definition. + | SynErasedUnionCase of + typ: SynType * + xmlDoc: PreXmlDoc * + range: range + + member Range: range + /// Represents the syntax tree for the right-hand-side of union definition, excluding members, /// in either a signature or implementation. [] diff --git a/src/fsharp/SyntaxTreeOps.fs b/src/fsharp/SyntaxTreeOps.fs index 5c1f0ce6ba..9ada0d8105 100644 --- a/src/fsharp/SyntaxTreeOps.fs +++ b/src/fsharp/SyntaxTreeOps.fs @@ -565,7 +565,8 @@ let mkSynBindingRhs staticOptimizations rhsExpr mRhs retInfo = let rhsExpr = List.foldBack (fun (c, e1) e2 -> SynExpr.LibraryOnlyStaticOptimization (c, e1, e2, mRhs)) staticOptimizations rhsExpr let rhsExpr, retTyOpt = match retInfo with - | Some (SynReturnInfo((ty, SynArgInfo(rAttribs, _, _)), tym)) -> SynExpr.Typed (rhsExpr, ty, rhsExpr.Range), Some(SynBindingReturnInfo(ty, tym, rAttribs) ) + | Some (SynReturnInfo((ty, SynArgInfo(rAttribs, _, _)), tym)) -> + SynExpr.Typed (rhsExpr, ty, rhsExpr.Range), Some(SynBindingReturnInfo(ty, tym, rAttribs) ) | None -> rhsExpr, None rhsExpr, retTyOpt diff --git a/src/fsharp/TypeRelations.fs b/src/fsharp/TypeRelations.fs index b52dfac4dd..23d154a236 100755 --- a/src/fsharp/TypeRelations.fs +++ b/src/fsharp/TypeRelations.fs @@ -6,6 +6,7 @@ module internal FSharp.Compiler.TypeRelations open Internal.Utilities.Collections open Internal.Utilities.Library +open Internal.Utilities.Library.Extras open FSharp.Compiler.ErrorLogger open FSharp.Compiler.Infos open FSharp.Compiler.TcGlobals @@ -78,6 +79,9 @@ let rec TypesFeasiblyEquivalent stripMeasures ndeep g amap m ty1 ty2 = | TType_fun (d1, r1), TType_fun (d2, r2) -> (TypesFeasiblyEquivalent stripMeasures ndeep g amap m) d1 d2 && (TypesFeasiblyEquivalent stripMeasures ndeep g amap m) r1 r2 + + | TType_erased_union (_, l1), TType_erased_union (_, l2) -> + List.lengthsEqAndForall2 (TypesFeasiblyEquivalent stripMeasures ndeep g amap m) l1 l2 | TType_measure _, TType_measure _ -> true @@ -94,6 +98,7 @@ let TypesFeasiblyEquivStripMeasures g amap m ty1 ty2 = TypesFeasiblyEquivalent true 0 g amap m ty1 ty2 /// The feasible coercion relation. Part of the language spec. +/// Test whether ty2 :> ty1, for erased union (A|B :> A) let rec TypeFeasiblySubsumesType ndeep g amap m ty1 canCoerce ty2 = if ndeep > 100 then error(InternalError("recursive class hierarchy (detected in TypeFeasiblySubsumesType), ty1 = " + (DebugPrint.showType ty1), m)) let ty1 = stripTyEqns g ty1 @@ -107,7 +112,12 @@ let rec TypeFeasiblySubsumesType ndeep g amap m ty1 canCoerce ty2 = | TType_tuple _, TType_tuple _ | TType_anon _, TType_anon _ | TType_fun _, TType_fun _ -> TypesFeasiblyEquiv ndeep g amap m ty1 ty2 - + | TType_erased_union (_, l1), TType_erased_union (_, l2) -> + ListSet.isSupersetOf (fun x1 x2 -> TypeFeasiblySubsumesType ndeep g amap m x1 canCoerce x2) l1 l2 + | _, TType_erased_union (_, l2) -> + List.forall (TypeFeasiblySubsumesType ndeep g amap m ty1 canCoerce) l2 + | TType_erased_union (_, l1), _ -> + List.exists (fun x1 -> TypeFeasiblySubsumesType ndeep g amap m x1 canCoerce ty2) l1 | TType_measure _, TType_measure _ -> true diff --git a/src/fsharp/TypedTree.fs b/src/fsharp/TypedTree.fs index 800d4b361e..7ab916fea4 100644 --- a/src/fsharp/TypedTree.fs +++ b/src/fsharp/TypedTree.fs @@ -3970,6 +3970,9 @@ type TType = /// Indicates the type is a variable type, whether declared, generalized or an inference type parameter | TType_var of typar: Typar + + /// Indicates the type is a union type, containing common ancestor type and the disjoint cases + | TType_erased_union of unionInfo: ErasedUnionInfo * choices: TTypes /// Indicates the type is a unit-of-measure expression being used as an argument to a type or member | TType_measure of measure: Measure @@ -3988,6 +3991,7 @@ type TType = | TType_ucase (_uc, _tinst) -> let (TILObjectReprData(scope, _nesting, _definition)) = _uc.Tycon.ILTyconInfo scope.QualifiedName + | TType_erased_union _ -> "" [] member x.DebugText = x.ToString() @@ -4013,6 +4017,7 @@ type TType = | None -> tp.DisplayName | Some _ -> tp.DisplayName + " (solved)" | TType_measure ms -> ms.ToString() + | TType_erased_union (_, l) -> "( " + String.concat " | " (List.map string l) + " )" type TypeInst = TType list @@ -4070,6 +4075,17 @@ type AnonRecdTypeInfo = member x.IsLinked = (match x.SortedIds with null -> true | _ -> false) +[] +type ErasedUnionInfo = + { /// Common ancestor type for all cases in this union, used for ILgen + CommonAncestorTy: TType + + /// Indices representing order of cases they were defined in + UnsortedCaseSourceIndices: int [] } + static member Create(commonAncestorTy: TType, unsortedCaseSourceIndices: int[]) = + { CommonAncestorTy = commonAncestorTy + UnsortedCaseSourceIndices = unsortedCaseSourceIndices } + [] type TupInfo = /// Some constant, e.g. true or false for tupInfo diff --git a/src/fsharp/TypedTreeOps.fs b/src/fsharp/TypedTreeOps.fs index 76e5572590..1f9e03e2cb 100644 --- a/src/fsharp/TypedTreeOps.fs +++ b/src/fsharp/TypedTreeOps.fs @@ -188,6 +188,12 @@ let rec remapTypeAux (tyenv: Remap) (ty: TType) = match tyenv.tyconRefRemap.TryFind tcref with | Some tcref' -> TType_ucase (UnionCaseRef(tcref', n), remapTypesAux tyenv tinst) | None -> TType_ucase (UnionCaseRef(tcref, n), remapTypesAux tyenv tinst) + + // Remap single disjoint? + | TType_erased_union (_, l) as ty -> + match l with + | [singleCase] -> singleCase + | _ -> ty | TType_anon (anonInfo, l) as ty -> let tupInfo' = remapTupInfoAux tyenv anonInfo.TupInfo @@ -777,6 +783,7 @@ let rec stripTyEqnsAndErase eraseFuncAndTuple (g: TcGlobals) ty = ty | TType_fun(a, b) when eraseFuncAndTuple -> TType_app(g.fastFunc_tcr, [ a; b]) | TType_tuple(tupInfo, l) when eraseFuncAndTuple -> mkCompiledTupleTy g (evalTupInfoIsStruct tupInfo) l + | TType_erased_union(unionInfo, _) -> stripTyEqnsAndErase eraseFuncAndTuple g unionInfo.CommonAncestorTy | ty -> ty let stripTyEqnsAndMeasureEqns g ty = @@ -816,12 +823,11 @@ let isReprHiddenTy g ty = ty |> stripTyEqns g |> (function TType_app(tcref, _) - let isFSharpObjModelTy g ty = ty |> stripTyEqns g |> (function TType_app(tcref, _) -> tcref.IsFSharpObjectModelTycon | _ -> false) let isRecdTy g ty = ty |> stripTyEqns g |> (function TType_app(tcref, _) -> tcref.IsRecordTycon | _ -> false) let isFSharpStructOrEnumTy g ty = ty |> stripTyEqns g |> (function TType_app(tcref, _) -> tcref.IsFSharpStructOrEnumTycon | _ -> false) +let isErasedUnionTy g ty = ty |> stripTyEqns g |> (function TType_erased_union _ -> true | _ -> false) let isFSharpEnumTy g ty = ty |> stripTyEqns g |> (function TType_app(tcref, _) -> tcref.IsFSharpEnumTycon | _ -> false) let isTyparTy g ty = ty |> stripTyEqns g |> (function TType_var _ -> true | _ -> false) let isAnyParTy g ty = ty |> stripTyEqns g |> (function TType_var _ -> true | TType_measure unt -> isUnitParMeasure g unt | _ -> false) let isMeasureTy g ty = ty |> stripTyEqns g |> (function TType_measure _ -> true | _ -> false) - - let isProvenUnionCaseTy ty = match ty with TType_ucase _ -> true | _ -> false let mkAppTy tcref tyargs = TType_app(tcref, tyargs) @@ -842,6 +848,20 @@ let (|AppTy|_|) g ty = ty |> stripTyEqns g |> (function TType_app(tcref, tinst) let (|RefTupleTy|_|) g ty = ty |> stripTyEqns g |> (function TType_tuple(tupInfo, tys) when not (evalTupInfoIsStruct tupInfo) -> Some tys | _ -> None) let (|FunTy|_|) g ty = ty |> stripTyEqns g |> (function TType_fun(dty, rty) -> Some (dty, rty) | _ -> None) +let tryUnsortedErasedUnionTyCases g ty = + let ty = ty |> stripTyEqns g + match ty with + | TType_erased_union (unionInfo, tys) -> + let sigma = unionInfo.UnsortedCaseSourceIndices + let unsortedTyps = + tys + |> List.indexed + |> List.sortBy (fun (sortedIdx, _) -> sigma.[sortedIdx]) + |> List.map snd + + ValueSome (unsortedTyps) + | _ -> ValueNone + let tryNiceEntityRefOfTy ty = let ty = stripTyparEqnsAux false ty match ty with @@ -984,6 +1004,7 @@ and tcrefAEquiv g aenv tc1 tc2 = tyconRefEq g tc1 tc2 || (match aenv.EquivTycons.TryFind tc1 with Some v -> tyconRefEq g v tc2 | None -> false) +/// Test ty1 = ty2 and typeAEquivAux erasureFlag g aenv ty1 ty2 = let ty1 = stripTyEqnsWrtErasure erasureFlag g ty1 let ty2 = stripTyEqnsWrtErasure erasureFlag g ty2 @@ -1013,7 +1034,9 @@ and typeAEquivAux erasureFlag g aenv ty1 ty2 = | TType_measure m1, TType_measure m2 -> match erasureFlag with | EraseNone -> measureAEquiv g aenv m1 m2 - | _ -> true + | _ -> true + | TType_erased_union (_, l1), TType_erased_union (_, l2) -> + ListSet.equals (typeAEquivAux erasureFlag g aenv) l1 l2 | _ -> false @@ -1078,7 +1101,7 @@ let rec getErasedTypes g ty = getErasedTypes g rty | TType_var tp -> if tp.IsErased then [ty] else [] - | TType_app (_, b) | TType_ucase(_, b) | TType_anon (_, b) | TType_tuple (_, b) -> + | TType_app (_, b) | TType_ucase(_, b) | TType_anon (_, b) | TType_tuple (_, b) | TType_erased_union (_, b) -> List.foldBack (fun ty tys -> getErasedTypes g ty @ tys) b [] | TType_fun (dty, rty) -> getErasedTypes g dty @ getErasedTypes g rty @@ -1826,7 +1849,8 @@ let isRefTy g ty = isReprHiddenTy g ty || isFSharpObjModelRefTy g ty || isUnitTy g ty || - (isAnonRecdTy g ty && not (isStructAnonRecdTy g ty)) + (isAnonRecdTy g ty && not (isStructAnonRecdTy g ty)) || + isErasedUnionTy g ty ) let isForallFunctionTy g ty = @@ -2134,6 +2158,8 @@ and accFreeInType opts ty acc = match stripTyparEqns ty with | TType_tuple (tupInfo, l) -> accFreeInTypes opts l (accFreeInTupInfo opts tupInfo acc) | TType_anon (anonInfo, l) -> accFreeInTypes opts l (accFreeInTupInfo opts anonInfo.TupInfo acc) + // SWOOORUP TODO: No idea whatsoever + | TType_erased_union (_, l) -> accFreeInTypes opts l acc | TType_app (tc, tinst) -> let acc = accFreeTycon opts tc acc match tinst with @@ -2237,7 +2263,10 @@ and accFreeInTypeLeftToRight g cxFlag thruFlag acc ty = | TType_app (_, tinst) -> accFreeInTypesLeftToRight g cxFlag thruFlag acc tinst | TType_ucase (_, tinst) -> - accFreeInTypesLeftToRight g cxFlag thruFlag acc tinst + accFreeInTypesLeftToRight g cxFlag thruFlag acc tinst + // SWOORUP TODO: No idea wtf this is + | TType_erased_union (_, tinst) -> + accFreeInTypesLeftToRight g cxFlag thruFlag acc tinst | TType_fun (d, r) -> let dacc = accFreeInTypeLeftToRight g cxFlag thruFlag acc d accFreeInTypeLeftToRight g cxFlag thruFlag dacc r @@ -2674,7 +2703,8 @@ module SimplifyTypes = | TType_forall (_, body) -> foldTypeButNotConstraints f z body | TType_app (_, tys) | TType_ucase (_, tys) - | TType_anon (_, tys) + | TType_anon (_, tys) + | TType_erased_union (_, tys) // fold to up | TType_tuple (_, tys) -> List.fold (foldTypeButNotConstraints f) z tys | TType_fun (s, t) -> foldTypeButNotConstraints f (foldTypeButNotConstraints f z s) t | TType_var _ -> z @@ -3280,6 +3310,11 @@ let mkNullableTy (g: TcGlobals) ty = TType_app (g.system_Nullable_tcref, [ty]) let mkListTy (g: TcGlobals) ty = TType_app (g.list_tcr_nice, [ty]) +let isValueOptionTy (g: TcGlobals) ty = + match tryTcrefOfAppTy g ty with + | ValueNone -> false + | ValueSome tcref -> tyconRefEq g g.valueoption_tcr_canon tcref + let isOptionTy (g: TcGlobals) ty = match tryTcrefOfAppTy g ty with | ValueNone -> false @@ -3527,6 +3562,7 @@ module DebugPrint = auxTyparsL env tcL prefix tinst | TType_anon (anonInfo, tys) -> braceBarL (sepListL (wordL (tagText ";")) (List.map2 (fun nm ty -> wordL (tagField nm) --- auxTypeAtomL env ty) (Array.toList anonInfo.SortedNames) tys)) | TType_tuple (_tupInfo, tys) -> sepListL (wordL (tagText "*")) (List.map (auxTypeAtomL env) tys) |> wrap + | TType_erased_union (_, tys) -> leftL (tagText "(") ^^ sepListL (wordL (tagText "|")) (List.map (auxTypeAtomL env) tys) ^^ rightL (tagText ")") | TType_fun (f, x) -> ((auxTypeAtomL env f ^^ wordL (tagText "->")) --- auxTypeL env x) |> wrap | TType_var typar -> auxTyparWrapL env isAtomic typar | TType_measure unt -> @@ -8185,6 +8221,7 @@ let rec typeEnc g (gtpsType, gtpsMethod) ty = typarEnc g (gtpsType, gtpsMethod) typar | TType_measure _ -> "?" + | TType_erased_union _ -> failwith "unreachable" // always erased by stripTyEqnsAndMeasureEqns and tyargsEnc g (gtpsType, gtpsMethod) args = match args with @@ -8518,7 +8555,9 @@ let isSealedTy g ty = if (isFSharpInterfaceTy g ty || isFSharpClassTy g ty) then let tcref = tcrefOfAppTy g ty TryFindFSharpBoolAttribute g g.attrib_SealedAttribute tcref.Attribs = Some true - else + elif (isErasedUnionTy g ty) then + false + else // All other F# types, array, byref, tuple types are sealed true diff --git a/src/fsharp/TypedTreeOps.fsi b/src/fsharp/TypedTreeOps.fsi index 402208b2be..8dc0a626fd 100755 --- a/src/fsharp/TypedTreeOps.fsi +++ b/src/fsharp/TypedTreeOps.fsi @@ -621,6 +621,8 @@ val isAnonRecdTy: TcGlobals -> TType -> bool val isUnionTy: TcGlobals -> TType -> bool +val isErasedUnionTy: TcGlobals -> TType -> bool + val isReprHiddenTy: TcGlobals -> TType -> bool val isFSharpObjModelTy: TcGlobals -> TType -> bool @@ -1427,6 +1429,9 @@ val mkVoidPtrTy: TcGlobals -> TType /// Build a single-dimensional array type val mkArrayType: TcGlobals -> TType -> TType +/// Determine if a type is a value option type +val isValueOptionTy: TcGlobals -> TType -> bool + /// Determine if a type is an option type val isOptionTy: TcGlobals -> TType -> bool @@ -2254,6 +2259,12 @@ val AdjustPossibleSubsumptionExpr: TcGlobals -> Expr -> Exprs -> (Expr * Exprs) val NormalizeAndAdjustPossibleSubsumptionExprs: TcGlobals -> Expr -> Expr +//------------------------------------------------------------------------- +// Erased union helper +//------------------------------------------------------------------------- + +val tryUnsortedErasedUnionTyCases : TcGlobals -> TType -> TTypes ValueOption + //------------------------------------------------------------------------- // XmlDoc signatures, used by both VS mode and XML-help emit //------------------------------------------------------------------------- diff --git a/src/fsharp/TypedTreePickle.fs b/src/fsharp/TypedTreePickle.fs index a2a51c0047..c44e185af7 100644 --- a/src/fsharp/TypedTreePickle.fs +++ b/src/fsharp/TypedTreePickle.fs @@ -1704,6 +1704,10 @@ let u_tyar_spec st = let u_tyar_specs = (u_list u_tyar_spec) +let u_erasedUnionInfo st = + let (commonAncestor, unsortedIndices) = u_tup2 u_ty (u_array u_int) st + ErasedUnionInfo.Create(commonAncestor, unsortedIndices) + let _ = fill_p_ty2 (fun isStructThisArgPos ty st -> let ty = stripTyparEqns ty @@ -1740,7 +1744,11 @@ let _ = fill_p_ty2 (fun isStructThisArgPos ty st -> | TType_anon (anonInfo, l) -> p_byte 9 st p_anonInfo anonInfo st - p_tys l st) + p_tys l st + | TType_erased_union (unionInfo, l) -> + p_byte 10 st + p_tup2 p_ty (p_array p_int) (unionInfo.CommonAncestorTy, unionInfo.UnsortedCaseSourceIndices) st + p_tys l st) let _ = fill_u_ty (fun st -> let tag = u_byte st @@ -1755,6 +1763,7 @@ let _ = fill_u_ty (fun st -> | 7 -> let uc = u_ucref st in let tinst = u_tys st in TType_ucase (uc, tinst) | 8 -> let l = u_tys st in TType_tuple (tupInfoStruct, l) | 9 -> let anonInfo = u_anonInfo st in let l = u_tys st in TType_anon (anonInfo, l) + | 10-> let erasedUnionInfo = u_erasedUnionInfo st in let l = u_tys st in TType_erased_union (erasedUnionInfo, l) | _ -> ufailwith st "u_typ") diff --git a/src/fsharp/fscmain.fs b/src/fsharp/fscmain.fs index 5bce29fd22..947839cd5f 100644 --- a/src/fsharp/fscmain.fs +++ b/src/fsharp/fscmain.fs @@ -18,7 +18,7 @@ open FSharp.Compiler.Text [] do () - + [] let main(argv) = diff --git a/src/fsharp/infos.fs b/src/fsharp/infos.fs index fb0b58e527..dae2a76147 100755 --- a/src/fsharp/infos.fs +++ b/src/fsharp/infos.fs @@ -275,6 +275,9 @@ let SearchEntireHierarchyOfType f g amap m ty = | None -> if f ty then Some ty else None | Some _ -> acc) g amap m ty None + +let AllPrimarySuperTypesOfType g amap m allowMultiIntfInst ty = + FoldPrimaryHierarchyOfType (ListSet.insert (typeEquiv g)) g amap m allowMultiIntfInst ty [] /// Get all super types of the type, including the type itself let AllSuperTypesOfType g amap m allowMultiIntfInst ty = @@ -298,6 +301,20 @@ let HasHeadType g tcref ty2 = match tryTcrefOfAppTy g ty2 with | ValueSome tcref2 -> tyconRefEq g tcref tcref2 | ValueNone -> false + +let isSubTypeOf g amap m typeToSearchFrom typeToLookFor = + ExistsInEntireHierarchyOfType (typeEquiv g typeToLookFor) g amap m AllowMultiIntfInstantiations.Yes typeToSearchFrom + +let isSuperTypeOf g amap m typeToSearchFrom typeToLookFor = + isSubTypeOf g amap m typeToLookFor typeToSearchFrom + +let getCommonAncestorOfTys g amap tys m = + let superTypes = List.map (AllPrimarySuperTypesOfType g amap m AllowMultiIntfInstantiations.No) tys + List.fold (ListSet.intersect (typeEquiv g)) (List.head superTypes) (List.tail superTypes) |> List.head + +/// choose if a type exists somewhere in the hierarchy which has the same head type as the given type (note, the given type need not have a head type at all) +let ChooseSameHeadTypeInHierarchy g amap m typeToSearchFrom typeToLookFor = + SearchEntireHierarchyOfType (HaveSameHeadType g typeToLookFor) g amap m typeToSearchFrom /// Check if a type exists somewhere in the hierarchy which has the same head type as the given type (note, the given type need not have a head type at all) let ExistsSameHeadTypeInHierarchy g amap m typeToSearchFrom typeToLookFor = diff --git a/src/fsharp/infos.fsi b/src/fsharp/infos.fsi index 5b0c29f11a..a0a3ed7b25 100644 --- a/src/fsharp/infos.fsi +++ b/src/fsharp/infos.fsi @@ -62,6 +62,9 @@ val SearchEntireHierarchyOfType: f:(TType -> bool) -> g:TcGlobals -> amap:Import /// Get all super types of the type, including the type itself val AllSuperTypesOfType: g:TcGlobals -> amap:ImportMap -> m:range -> allowMultiIntfInst:AllowMultiIntfInstantiations -> ty:TType -> TType list +/// Get all super types of the type, including the type itself +val AllPrimarySuperTypesOfType: g:TcGlobals -> amap:ImportMap -> m:range -> allowMultiIntfInst:AllowMultiIntfInstantiations -> ty:TType -> TType list + /// Get all interfaces of a type, including the type itself if it is an interface val AllInterfacesOfType: g:TcGlobals -> amap:ImportMap -> m:range -> allowMultiIntfInst:AllowMultiIntfInstantiations -> ty:TType -> TType list @@ -77,6 +80,15 @@ val ExistsSameHeadTypeInHierarchy: g:TcGlobals -> amap:ImportMap -> m:range -> t /// Check if a type exists somewhere in the hierarchy which has the given head type. val ExistsHeadTypeInEntireHierarchy: g:TcGlobals -> amap:ImportMap -> m:range -> typeToSearchFrom:TType -> tcrefToLookFor:TyconRef -> bool +/// Check if one (nominal) type is a subtype of another +val isSubTypeOf: g: TcGlobals -> amap: ImportMap -> m: range -> typeToSearchFrom: TType -> typeToLookFor: TType -> bool + +/// Check if one (nominal) type is a supertype of another +val isSuperTypeOf: g: TcGlobals -> amap: ImportMap -> m: range -> typeToSearchFrom: TType -> typeToLookFor: TType -> bool + +/// Get the common ancestor of a set of nominal types +val getCommonAncestorOfTys: g: TcGlobals -> amap: ImportMap -> tys: TTypes -> m: range -> TType + /// Read an Abstract IL type from metadata and convert to an F# type. val ImportILTypeFromMetadata: amap:ImportMap -> m:range -> scoref:ILScopeRef -> tinst:TType list -> minst:TType list -> ilty:ILType -> TType diff --git a/src/fsharp/pars.fsy b/src/fsharp/pars.fsy index d1519188df..0d39c94316 100644 --- a/src/fsharp/pars.fsy +++ b/src/fsharp/pars.fsy @@ -5097,6 +5097,7 @@ atomTypeOrAnonRecdType: | (SynField([], false, Some id, ty, false, _xmldoc, None, _m)) -> Some (id, ty) | _ -> reportParseErrorAt (rhs parseState 1) (FSComp.SR.parsInvalidAnonRecdType()); None) SynType.AnonRecd (isStruct, flds2, rhs parseState 1) } + | erasedUnionType { SynType.ErasedUnion ($1, (rhs parseState 1, $1 |> List.map(fun (SynErasedUnionCase(range = m)) -> m)) ||> List.fold unionRanges) } /* Any tokens in this grammar must be added to the lex filter rule 'peekAdjacentTypars' */ /* See the F# specification "Lexical analysis of type applications and type parameter definitions" */ @@ -5170,6 +5171,21 @@ atomType: { if not $3 then reportParseErrorAt (rhs parseState 2) (FSComp.SR.parsExpectedNameAfterToken()) $1 } +/* The core of an erased union type definition */ +erasedUnionType: + /* Note the next three rules are required to disambiguate this from type x = y */ + /* Attributes can only appear on a single constructor if you've used a | */ + | LPAREN attrErasedUnionCaseDecl barAndgrabXmlDoc attrErasedUnionCaseDecls rparen + { ($2 (grabXmlDoc(parseState, 1))) :: $4 $3 } + +attrErasedUnionCaseDecls: + | attrErasedUnionCaseDecl barAndgrabXmlDoc attrErasedUnionCaseDecls { (fun xmlDoc -> $1 xmlDoc :: $3 $2) } + | attrErasedUnionCaseDecl { (fun xmlDoc -> [ $1 xmlDoc ]) } + +/* The core of an anon union case definition */ +attrErasedUnionCaseDecl: + | typ { let mDecl = rhs parseState 3 in (fun xmlDoc -> SynErasedUnionCase ($1, xmlDoc, mDecl)) } + typeArgsNoHpaDeprecated: | typeArgsActual { let mLessThan, mGreaterThan, parsedOk, args, commas, mAll = $1 diff --git a/src/fsharp/service/ItemKey.fs b/src/fsharp/service/ItemKey.fs index ebeafff9ff..c483dbb388 100644 --- a/src/fsharp/service/ItemKey.fs +++ b/src/fsharp/service/ItemKey.fs @@ -40,6 +40,9 @@ module ItemKeyTags = [] let typeUnionCase = "#U#" + + [] + let typeErasedUnionCase = "#G#" [] let typeMeasureVar = "#p#" @@ -242,6 +245,9 @@ and [] ItemKeyStoreBuilder() = writeString ItemKeyTags.typeUnionCase writeEntityRef tcref writeString nm + | TType_erased_union (_, tinst) -> + writeString ItemKeyTags.typeErasedUnionCase + tinst |> List.iter (writeType false) and writeMeasure isStandalone (ms: Measure) = match ms with diff --git a/src/fsharp/symbols/Symbols.fs b/src/fsharp/symbols/Symbols.fs index fdf67fb311..329efbc37e 100644 --- a/src/fsharp/symbols/Symbols.fs +++ b/src/fsharp/symbols/Symbols.fs @@ -2433,6 +2433,7 @@ type FSharpType(cenv, ty:TType) = | TType_fun (dty, rty) -> 10500 + hashType dty + hashType rty | TType_measure _ -> 10600 | TType_anon (_,l1) -> 10800 + List.sumBy hashType l1 + | TType_erased_union (_,l1) -> 10900 + List.sumBy hashType l1 hashType ty member _.Format(context: FSharpDisplayContext) = diff --git a/tests/FSharp.Compiler.ComponentTests/Diagnostics/async.fs b/tests/FSharp.Compiler.ComponentTests/Diagnostics/async.fs index 2c52972d2c..d868564e98 100644 --- a/tests/FSharp.Compiler.ComponentTests/Diagnostics/async.fs +++ b/tests/FSharp.Compiler.ComponentTests/Diagnostics/async.fs @@ -35,7 +35,7 @@ module async = |> ignore // This test was automatically generated (moved from FSharpQA suite - Diagnostics/async) - //All branches of an 'if' expression must return values of the same type as the first branch + //All branches of an 'if' expression must return values implicitly convertible to the type of the first branch [] let ``async - ReturnBangNonAsync_IfThenElse.fs - --warnaserror+ --test:ErrorRanges --flaterrors`` compilation = compilation @@ -44,7 +44,7 @@ module async = |> compile |> shouldFail |> withErrorCode 0001 - |> withDiagnosticMessageMatches "All branches of an 'if' expression must return values of the same type as the first branch" + |> withDiagnosticMessageMatches "All branches of an 'if' expression must return values implicitly convertible to the type of the first branch" |> ignore // This test was automatically generated (moved from FSharpQA suite - Diagnostics/async) diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/ElseBranchHasWrongTypeTests.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/ElseBranchHasWrongTypeTests.fs index 439ada429c..250fc8f674 100644 --- a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/ElseBranchHasWrongTypeTests.fs +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/ElseBranchHasWrongTypeTests.fs @@ -18,7 +18,7 @@ let y = |> typecheck |> shouldFail |> withSingleDiagnostic (Error 1, Line 5, Col 10, Line 5, Col 13, - "All branches of an 'if' expression must return values of the same type as the first branch, which here is 'string'. This branch returns a value of type 'int'.") + "All branches of an 'if' expression must return values implicitly convertible to the type of the first branch, which here is 'string'. This branch returns a value of type 'int'.") [] let ``Else branch is a function that returns int while if branch is string``() = @@ -32,7 +32,7 @@ let y = |> typecheck |> shouldFail |> withSingleDiagnostic (Error 1, Line 6, Col 10, Line 6, Col 14, - "All branches of an 'if' expression must return values of the same type as the first branch, which here is 'string'. This branch returns a value of type 'int'.") + "All branches of an 'if' expression must return values implicitly convertible to the type of the first branch, which here is 'string'. This branch returns a value of type 'int'.") [] @@ -50,7 +50,7 @@ let y = |> typecheck |> shouldFail |> withSingleDiagnostic (Error 1, Line 9, Col 10, Line 9, Col 13, - "All branches of an 'if' expression must return values of the same type as the first branch, which here is 'string'. This branch returns a value of type 'int'.") + "All branches of an 'if' expression must return values implicitly convertible to the type of the first branch, which here is 'string'. This branch returns a value of type 'int'.") [] @@ -70,7 +70,7 @@ let y = |> typecheck |> shouldFail |> withSingleDiagnostic (Error 1, Line 11, Col 10, Line 11, Col 13, - "All branches of an 'if' expression must return values of the same type as the first branch, which here is 'string'. This branch returns a value of type 'int'.") + "All branches of an 'if' expression must return values implicitly convertible to the type of the first branch, which here is 'string'. This branch returns a value of type 'int'.") [] @@ -151,7 +151,7 @@ let y : bool = |> shouldFail |> withDiagnostics [ (Error 1, Line 4, Col 19, Line 4, Col 22, "The 'if' expression needs to have type 'bool' to satisfy context type requirements. It currently has type 'string'.") - (Error 1, Line 5, Col 10, Line 5, Col 13, "All branches of an 'if' expression must return values of the same type as the first branch, which here is 'bool'. This branch returns a value of type 'string'.")] + (Error 1, Line 5, Col 10, Line 5, Col 13, "All branches of an 'if' expression must return values implicitly convertible to the type of the first branch, which here is 'bool'. This branch returns a value of type 'string'.")] [] @@ -166,6 +166,6 @@ else |> typecheck |> shouldFail |> withDiagnostics [ - (Error 1, Line 5, Col 19, Line 5, Col 22, "All branches of an 'if' expression must return values of the same type as the first branch, which here is 'bool'. This branch returns a value of type 'string'.") - (Error 1, Line 6, Col 10, Line 6, Col 13, "All branches of an 'if' expression must return values of the same type as the first branch, which here is 'bool'. This branch returns a value of type 'string'.") + (Error 1, Line 5, Col 19, Line 5, Col 22, "All branches of an 'if' expression must return values implicitly convertible to the type of the first branch, which here is 'bool'. This branch returns a value of type 'string'.") + (Error 1, Line 6, Col 10, Line 6, Col 13, "All branches of an 'if' expression must return values implicitly convertible to the type of the first branch, which here is 'bool'. This branch returns a value of type 'string'.") (Warning 20, Line 3, Col 1, Line 6, Col 13, "The result of this expression has type 'bool' and is implicitly ignored. Consider using 'ignore' to discard this value explicitly, e.g. 'expr |> ignore', or 'let' to bind the result to a name, e.g. 'let result = expr'.")] diff --git a/tests/FSharp.Compiler.ComponentTests/resources/tests/Diagnostics/async/ReturnBangNonAsync_IfThenElse.fs b/tests/FSharp.Compiler.ComponentTests/resources/tests/Diagnostics/async/ReturnBangNonAsync_IfThenElse.fs index 74f2176d4c..ecc1175241 100644 --- a/tests/FSharp.Compiler.ComponentTests/resources/tests/Diagnostics/async/ReturnBangNonAsync_IfThenElse.fs +++ b/tests/FSharp.Compiler.ComponentTests/resources/tests/Diagnostics/async/ReturnBangNonAsync_IfThenElse.fs @@ -1,6 +1,6 @@ // #Regression #Diagnostics #Async // Regression tests for FSHARP1.0:4394 -//All branches of an 'if' expression must return values of the same type as the first branch +//All branches of an 'if' expression must return values implicitly convertible to the type of the first branch async { if true then return () else diff --git a/tests/FSharp.Compiler.Service.Tests/FSharp.CompilerService.SurfaceArea.netstandard.expected b/tests/FSharp.Compiler.Service.Tests/FSharp.CompilerService.SurfaceArea.netstandard.expected index 9d49174ce6..26b23a43fe 100644 --- a/tests/FSharp.Compiler.Service.Tests/FSharp.CompilerService.SurfaceArea.netstandard.expected +++ b/tests/FSharp.Compiler.Service.Tests/FSharp.CompilerService.SurfaceArea.netstandard.expected @@ -6045,6 +6045,19 @@ FSharp.Compiler.Syntax.SynEnumCase: Int32 get_Tag() FSharp.Compiler.Syntax.SynEnumCase: Microsoft.FSharp.Collections.FSharpList`1[FSharp.Compiler.Syntax.SynAttributeList] attributes FSharp.Compiler.Syntax.SynEnumCase: Microsoft.FSharp.Collections.FSharpList`1[FSharp.Compiler.Syntax.SynAttributeList] get_attributes() FSharp.Compiler.Syntax.SynEnumCase: System.String ToString() +FSharp.Compiler.Syntax.SynErasedUnionCase +FSharp.Compiler.Syntax.SynErasedUnionCase: FSharp.Compiler.Xml.PreXmlDoc get_xmlDoc() +FSharp.Compiler.Syntax.SynErasedUnionCase: FSharp.Compiler.Xml.PreXmlDoc xmlDoc +FSharp.Compiler.Syntax.SynErasedUnionCase: FSharp.Compiler.Syntax.SynErasedUnionCase NewSynErasedUnionCase(FSharp.Compiler.Syntax.SynType, FSharp.Compiler.Xml.PreXmlDoc, FSharp.Compiler.Text.Range) +FSharp.Compiler.Syntax.SynErasedUnionCase: FSharp.Compiler.Syntax.SynType get_typ() +FSharp.Compiler.Syntax.SynErasedUnionCase: FSharp.Compiler.Syntax.SynType typ +FSharp.Compiler.Syntax.SynErasedUnionCase: FSharp.Compiler.Text.Range Range +FSharp.Compiler.Syntax.SynErasedUnionCase: FSharp.Compiler.Text.Range get_Range() +FSharp.Compiler.Syntax.SynErasedUnionCase: FSharp.Compiler.Text.Range get_range() +FSharp.Compiler.Syntax.SynErasedUnionCase: FSharp.Compiler.Text.Range range +FSharp.Compiler.Syntax.SynErasedUnionCase: Int32 Tag +FSharp.Compiler.Syntax.SynErasedUnionCase: Int32 get_Tag() +FSharp.Compiler.Syntax.SynErasedUnionCase: System.String ToString() FSharp.Compiler.Syntax.SynExceptionDefn FSharp.Compiler.Syntax.SynExceptionDefn: FSharp.Compiler.Syntax.SynExceptionDefn NewSynExceptionDefn(FSharp.Compiler.Syntax.SynExceptionDefnRepr, Microsoft.FSharp.Collections.FSharpList`1[FSharp.Compiler.Syntax.SynMemberDefn], FSharp.Compiler.Text.Range) FSharp.Compiler.Syntax.SynExceptionDefn: FSharp.Compiler.Syntax.SynExceptionDefnRepr exnRepr @@ -8148,6 +8161,10 @@ FSharp.Compiler.Syntax.SynType+Array: FSharp.Compiler.Text.Range get_range() FSharp.Compiler.Syntax.SynType+Array: FSharp.Compiler.Text.Range range FSharp.Compiler.Syntax.SynType+Array: Int32 get_rank() FSharp.Compiler.Syntax.SynType+Array: Int32 rank +FSharp.Compiler.Syntax.SynType+ErasedUnion: FSharp.Compiler.Text.Range get_range() +FSharp.Compiler.Syntax.SynType+ErasedUnion: FSharp.Compiler.Text.Range range +FSharp.Compiler.Syntax.SynType+ErasedUnion: Microsoft.FSharp.Collections.FSharpList`1[FSharp.Compiler.Syntax.SynErasedUnionCase] erasedUnionCases +FSharp.Compiler.Syntax.SynType+ErasedUnion: Microsoft.FSharp.Collections.FSharpList`1[FSharp.Compiler.Syntax.SynErasedUnionCase] get_erasedUnionCases() FSharp.Compiler.Syntax.SynType+Fun: FSharp.Compiler.Syntax.SynType argType FSharp.Compiler.Syntax.SynType+Fun: FSharp.Compiler.Syntax.SynType get_argType() FSharp.Compiler.Syntax.SynType+Fun: FSharp.Compiler.Syntax.SynType get_returnType() @@ -8208,6 +8225,7 @@ FSharp.Compiler.Syntax.SynType+Tags: Int32 Anon FSharp.Compiler.Syntax.SynType+Tags: Int32 AnonRecd FSharp.Compiler.Syntax.SynType+Tags: Int32 App FSharp.Compiler.Syntax.SynType+Tags: Int32 Array +FSharp.Compiler.Syntax.SynType+Tags: Int32 ErasedUnion FSharp.Compiler.Syntax.SynType+Tags: Int32 Fun FSharp.Compiler.Syntax.SynType+Tags: Int32 HashConstraint FSharp.Compiler.Syntax.SynType+Tags: Int32 LongIdent @@ -8241,6 +8259,7 @@ FSharp.Compiler.Syntax.SynType: Boolean IsAnon FSharp.Compiler.Syntax.SynType: Boolean IsAnonRecd FSharp.Compiler.Syntax.SynType: Boolean IsApp FSharp.Compiler.Syntax.SynType: Boolean IsArray +FSharp.Compiler.Syntax.SynType: Boolean IsErasedUnion FSharp.Compiler.Syntax.SynType: Boolean IsFun FSharp.Compiler.Syntax.SynType: Boolean IsHashConstraint FSharp.Compiler.Syntax.SynType: Boolean IsLongIdent @@ -8258,6 +8277,7 @@ FSharp.Compiler.Syntax.SynType: Boolean get_IsAnon() FSharp.Compiler.Syntax.SynType: Boolean get_IsAnonRecd() FSharp.Compiler.Syntax.SynType: Boolean get_IsApp() FSharp.Compiler.Syntax.SynType: Boolean get_IsArray() +FSharp.Compiler.Syntax.SynType: Boolean get_IsErasedUnion() FSharp.Compiler.Syntax.SynType: Boolean get_IsFun() FSharp.Compiler.Syntax.SynType: Boolean get_IsHashConstraint() FSharp.Compiler.Syntax.SynType: Boolean get_IsLongIdent() @@ -8275,6 +8295,7 @@ FSharp.Compiler.Syntax.SynType: FSharp.Compiler.Syntax.SynType NewAnon(FSharp.Co FSharp.Compiler.Syntax.SynType: FSharp.Compiler.Syntax.SynType NewAnonRecd(Boolean, Microsoft.FSharp.Collections.FSharpList`1[System.Tuple`2[FSharp.Compiler.Syntax.Ident,FSharp.Compiler.Syntax.SynType]], FSharp.Compiler.Text.Range) FSharp.Compiler.Syntax.SynType: FSharp.Compiler.Syntax.SynType NewApp(FSharp.Compiler.Syntax.SynType, Microsoft.FSharp.Core.FSharpOption`1[FSharp.Compiler.Text.Range], Microsoft.FSharp.Collections.FSharpList`1[FSharp.Compiler.Syntax.SynType], Microsoft.FSharp.Collections.FSharpList`1[FSharp.Compiler.Text.Range], Microsoft.FSharp.Core.FSharpOption`1[FSharp.Compiler.Text.Range], Boolean, FSharp.Compiler.Text.Range) FSharp.Compiler.Syntax.SynType: FSharp.Compiler.Syntax.SynType NewArray(Int32, FSharp.Compiler.Syntax.SynType, FSharp.Compiler.Text.Range) +FSharp.Compiler.Syntax.SynType: FSharp.Compiler.Syntax.SynType NewErasedUnion(Microsoft.FSharp.Collections.FSharpList`1[FSharp.Compiler.Syntax.SynErasedUnionCase], FSharp.Compiler.Text.Range) FSharp.Compiler.Syntax.SynType: FSharp.Compiler.Syntax.SynType NewFun(FSharp.Compiler.Syntax.SynType, FSharp.Compiler.Syntax.SynType, FSharp.Compiler.Text.Range) FSharp.Compiler.Syntax.SynType: FSharp.Compiler.Syntax.SynType NewHashConstraint(FSharp.Compiler.Syntax.SynType, FSharp.Compiler.Text.Range) FSharp.Compiler.Syntax.SynType: FSharp.Compiler.Syntax.SynType NewLongIdent(FSharp.Compiler.Syntax.LongIdentWithDots) @@ -8292,6 +8313,7 @@ FSharp.Compiler.Syntax.SynType: FSharp.Compiler.Syntax.SynType+Anon FSharp.Compiler.Syntax.SynType: FSharp.Compiler.Syntax.SynType+AnonRecd FSharp.Compiler.Syntax.SynType: FSharp.Compiler.Syntax.SynType+App FSharp.Compiler.Syntax.SynType: FSharp.Compiler.Syntax.SynType+Array +FSharp.Compiler.Syntax.SynType: FSharp.Compiler.Syntax.SynType+ErasedUnion FSharp.Compiler.Syntax.SynType: FSharp.Compiler.Syntax.SynType+Fun FSharp.Compiler.Syntax.SynType: FSharp.Compiler.Syntax.SynType+HashConstraint FSharp.Compiler.Syntax.SynType: FSharp.Compiler.Syntax.SynType+LongIdent diff --git a/tests/fsharp/TypeProviderTests.fs b/tests/fsharp/TypeProviderTests.fs index cfc83d5f7f..76561ffdaa 100644 --- a/tests/fsharp/TypeProviderTests.fs +++ b/tests/fsharp/TypeProviderTests.fs @@ -227,7 +227,7 @@ let ``negative type provider tests`` (name:string) = rm cfg "provider.dll" - fsc cfg "--out:provider.dll -a" ["provider.fsx"] + fsc cfg "--out:provider.dll -g --optimize- -a" ["provider.fsx"] fsc cfg "--out:provider_providerAttributeErrorConsume.dll -a" ["providerAttributeError.fsx"] @@ -235,11 +235,11 @@ let ``negative type provider tests`` (name:string) = rm cfg "helloWorldProvider.dll" - fsc cfg "--out:helloWorldProvider.dll -a" [".." ++ "helloWorld" ++ "provider.fsx"] + fsc cfg "--out:helloWorldProvider.dll -g --optimize- -a" [".." ++ "helloWorld" ++ "provider.fsx"] rm cfg "MostBasicProvider.dll" - fsc cfg "--out:MostBasicProvider.dll -a" ["MostBasicProvider.fsx"] + fsc cfg "--out:MostBasicProvider.dll -g --optimize- -a" ["MostBasicProvider.fsx"] let preprocess name pref = let dirp = (dir |> Commands.pathAddBackslash) diff --git a/tests/fsharp/core/access/test.fsx b/tests/fsharp/core/access/test.fsx index 26034dc99e..3d7e7f1624 100644 --- a/tests/fsharp/core/access/test.fsx +++ b/tests/fsharp/core/access/test.fsx @@ -267,7 +267,6 @@ module RestrictedRecordsAndUnionsUsingPrivateAndInternalTypes = (*--------------------*) - #if TESTS_AS_APP let RUN() = !failures #else diff --git a/tests/fsharp/tests.fs b/tests/fsharp/tests.fs index 1fb5f52225..8220b30fb2 100644 --- a/tests/fsharp/tests.fs +++ b/tests/fsharp/tests.fs @@ -67,6 +67,31 @@ module CoreTests = [] let ``array-FSI_BASIC`` () = singleTestBuildAndRun "core/array" FSI_BASIC + [] + let ``auto-widen-version-5_0``() = + let cfg = testConfig "core/auto-widen/5.0" + singleVersionedNegTest cfg "5.0" "test" + + [] + let ``auto-widen-version-FSC_BASIC_OPT_MINUS-preview``() = + singleTestBuildAndRunVersion "core/auto-widen/preview" FSC_BASIC_OPT_MINUS "preview" + + [] + let ``auto-widen-version-FSC_BASIC-preview``() = + singleTestBuildAndRunVersion "core/auto-widen/preview" FSC_BASIC "preview" + + [] + let ``auto-widen-version-preview-warns-on``() = + let cfg = testConfig "core/auto-widen/preview" + let cfg = { cfg with fsc_flags = cfg.fsc_flags + " --warnon:3388 --warnon:3389 --warnon:3390 --warnaserror+ --define:NEGATIVE" } + singleVersionedNegTest cfg "preview" "test" + + [] + let ``auto-widen-version-preview-default-warns``() = + let cfg = testConfig "core/auto-widen/preview-default-warns" + let cfg = { cfg with fsc_flags = cfg.fsc_flags + " --warnaserror+ --define:NEGATIVE" } + singleVersionedNegTest cfg "preview" "test" + [] let ``comprehensions-FSC_BASIC_OPT_MINUS`` () = singleTestBuildAndRun "core/comprehensions" FSC_BASIC_OPT_MINUS @@ -1009,35 +1034,35 @@ module CoreTests = | diffs -> Assert.Fail (sprintf "'%s' and '%s' differ; %A" diffFileErr expectedFileErr diffs) [] - let ``printing-1 --langversion:4.7`` () = + let ``printing-1 --langversion:4_7`` () = printing "--langversion:4.7" "z.output.test.default.stdout.47.txt" "z.output.test.default.stdout.47.bsl" "z.output.test.default.stderr.txt" "z.output.test.default.stderr.bsl" [] - let ``printing-1 --langversion:5.0`` () = + let ``printing-1 --langversion:5_0`` () = printing "--langversion:5.0" "z.output.test.default.stdout.50.txt" "z.output.test.default.stdout.50.bsl" "z.output.test.default.stderr.txt" "z.output.test.default.stderr.bsl" [] - let ``printing-2 --langversion:4.7`` () = + let ``printing-2 --langversion:4_7`` () = printing "--langversion:4.7 --use:preludePrintSize1000.fsx" "z.output.test.1000.stdout.47.txt" "z.output.test.1000.stdout.47.bsl" "z.output.test.1000.stderr.txt" "z.output.test.1000.stderr.bsl" [] - let ``printing-2 --langversion:5.0`` () = + let ``printing-2 --langversion:5_0`` () = printing "--langversion:5.0 --use:preludePrintSize1000.fsx" "z.output.test.1000.stdout.50.txt" "z.output.test.1000.stdout.50.bsl" "z.output.test.1000.stderr.txt" "z.output.test.1000.stderr.bsl" [] - let ``printing-3 --langversion:4.7`` () = + let ``printing-3 --langversion:4_7`` () = printing "--langversion:4.7 --use:preludePrintSize200.fsx" "z.output.test.200.stdout.47.txt" "z.output.test.200.stdout.47.bsl" "z.output.test.200.stderr.txt" "z.output.test.200.stderr.bsl" [] - let ``printing-3 --langversion:5.0`` () = + let ``printing-3 --langversion:5_0`` () = printing "--langversion:5.0 --use:preludePrintSize200.fsx" "z.output.test.200.stdout.50.txt" "z.output.test.200.stdout.50.bsl" "z.output.test.200.stderr.txt" "z.output.test.200.stderr.bsl" [] - let ``printing-4 --langversion:4.7`` () = + let ``printing-4 --langversion:4_7`` () = printing "--langversion:4.7 --use:preludeShowDeclarationValuesFalse.fsx" "z.output.test.off.stdout.47.txt" "z.output.test.off.stdout.47.bsl" "z.output.test.off.stderr.txt" "z.output.test.off.stderr.bsl" [] - let ``printing-4 --langversion:5.0`` () = + let ``printing-4 --langversion:5_0`` () = printing "--langversion:5.0 --use:preludeShowDeclarationValuesFalse.fsx" "z.output.test.off.stdout.50.txt" "z.output.test.off.stdout.50.bsl" "z.output.test.off.stderr.txt" "z.output.test.off.stderr.bsl" [] @@ -2611,6 +2636,11 @@ module TypecheckTests = [] let ``type check neg20`` () = singleNegTest (testConfig "typecheck/sigs") "neg20" + [] + let ``type check neg20 version 5_0`` () = + let cfg = testConfig "typecheck/sigs/version50" + singleVersionedNegTest cfg "5.0" "neg20" + [] let ``type check neg21`` () = singleNegTest (testConfig "typecheck/sigs") "neg21" @@ -2632,6 +2662,13 @@ module TypecheckTests = let cfg = testConfig "typecheck/sigs/version47" // For some reason this warning is off by default in the test framework but in this case we are testing for it let cfg = { cfg with fsc_flags = cfg.fsc_flags.Replace("--nowarn:20", "") } + singleVersionedNegTest cfg "4.7" "neg24" + + [] + let ``type check neg24 version preview`` () = + let cfg = testConfig "typecheck/sigs" + // For some reason this warning is off by default in the test framework but in this case we are testing for it + let cfg = { cfg with fsc_flags = cfg.fsc_flags.Replace("--nowarn:20", "") } singleVersionedNegTest cfg "preview" "neg24" [] diff --git a/tests/fsharp/typecheck/sigs/neg20.bsl b/tests/fsharp/typecheck/sigs/neg20.bsl index 75d06ce133..810220f059 100644 --- a/tests/fsharp/typecheck/sigs/neg20.bsl +++ b/tests/fsharp/typecheck/sigs/neg20.bsl @@ -69,17 +69,17 @@ neg20.fs(53,38,53,39): typecheck error FS0001: This expression was expected to h but here has type 'int' -neg20.fs(60,26,60,33): typecheck error FS0001: All elements of a list must be of the same type as the first element, which here is 'B'. This element has type 'A'. +neg20.fs(60,26,60,33): typecheck error FS0001: All elements of a list must be implicitly convertible to the type of the first element, which here is 'B'. This element has type 'A'. -neg20.fs(61,27,61,35): typecheck error FS0001: All elements of a list must be of the same type as the first element, which here is 'B1'. This element has type 'B2'. +neg20.fs(61,27,61,35): typecheck error FS0001: All elements of a list must be implicitly convertible to the type of the first element, which here is 'B1'. This element has type 'B2'. -neg20.fs(62,26,62,33): typecheck error FS0001: All elements of a list must be of the same type as the first element, which here is 'C'. This element has type 'B'. +neg20.fs(62,26,62,33): typecheck error FS0001: All elements of a list must be implicitly convertible to the type of the first element, which here is 'C'. This element has type 'B'. -neg20.fs(66,25,66,32): typecheck error FS0001: All elements of a list must be of the same type as the first element, which here is 'A'. This element has type 'B'. +neg20.fs(66,25,66,32): typecheck error FS0001: All elements of a list must be implicitly convertible to the type of the first element, which here is 'A'. This element has type 'B'. -neg20.fs(67,27,67,34): typecheck error FS0001: All elements of a list must be of the same type as the first element, which here is 'B'. This element has type 'C'. +neg20.fs(67,27,67,34): typecheck error FS0001: All elements of a list must be implicitly convertible to the type of the first element, which here is 'B'. This element has type 'C'. -neg20.fs(70,31,70,38): typecheck error FS0001: All elements of a list must be of the same type as the first element, which here is 'B'. This element has type 'C'. +neg20.fs(70,31,70,38): typecheck error FS0001: All elements of a list must be implicitly convertible to the type of the first element, which here is 'B'. This element has type 'C'. neg20.fs(71,34,71,42): typecheck error FS0001: Type mismatch. Expecting a 'A list' @@ -110,9 +110,9 @@ but given a 'B list' The type 'A' does not match the type 'B' -neg20.fs(83,47,83,54): typecheck error FS0001: All branches of an 'if' expression must return values of the same type as the first branch, which here is 'B'. This branch returns a value of type 'C'. +neg20.fs(83,47,83,54): typecheck error FS0001: All branches of an 'if' expression must return values implicitly convertible to the type of the first branch, which here is 'B'. This branch returns a value of type 'C'. -neg20.fs(87,54,87,61): typecheck error FS0001: All branches of a pattern match expression must return values of the same type as the first branch, which here is 'B'. This branch returns a value of type 'C'. +neg20.fs(87,54,87,61): typecheck error FS0001: All branches of a pattern match expression must return values implicitly convertible to the type of the first branch, which here is 'B'. This branch returns a value of type 'C'. neg20.fs(92,19,92,26): typecheck error FS0001: This expression was expected to have type 'A' @@ -129,7 +129,7 @@ neg20.fs(97,26,97,33): typecheck error FS0001: This expression was expected to h but here has type 'B' -neg20.fs(99,26,99,33): typecheck error FS0001: All elements of a list must be of the same type as the first element, which here is 'B'. This element has type 'A'. +neg20.fs(99,26,99,33): typecheck error FS0001: All elements of a list must be implicitly convertible to the type of the first element, which here is 'B'. This element has type 'A'. neg20.fs(108,12,108,16): typecheck error FS0001: Type mismatch. Expecting a 'B * B -> 'a' @@ -415,3 +415,13 @@ neg20.fs(428,19,428,38): typecheck error FS1133: No constructors are available f neg20.fs(430,22,430,41): typecheck error FS1133: No constructors are available for the type 'OverloadedClassName<'a,'b>' neg20.fs(444,39,444,41): typecheck error FS0039: The type 'OverloadedClassName' does not define the field, constructor or member 'S2'. + +neg20.fs(447,27,447,28): typecheck error FS0001: This expression was expected to have type + 'int option' +but here has type + 'int' + +neg20.fs(448,30,448,33): typecheck error FS0001: This expression was expected to have type + 'string option' +but here has type + 'string' diff --git a/tests/fsharp/typecheck/sigs/neg20.fs b/tests/fsharp/typecheck/sigs/neg20.fs index 5d465aeea9..4b0a08e003 100644 --- a/tests/fsharp/typecheck/sigs/neg20.fs +++ b/tests/fsharp/typecheck/sigs/neg20.fs @@ -49,7 +49,7 @@ module BiGenericFunctionTests = module NoSubsumptionOnApplication = - (fun (x:A) -> 1) (new B()) // no: subsumption comes from de-condensation, not application! + (fun (x:A) -> 1) (new B()) // now permitted (fun (x:System.ValueType) -> 1) 1 // coercion on application! @@ -73,7 +73,7 @@ module NoSubsumptionForLists = // Q: how about on sequence expressions? let controls2 = [ yield (new B()) yield (new C()) ] - StaticClass2.DisplayControls controls2 // bang + StaticClass2.DisplayControls controls2 // Q: how about on sequence expressions? let controls3 = [ yield! [new B()] @@ -81,14 +81,14 @@ module NoSubsumptionForLists = StaticClass2.DisplayControls controls3 // bang let controls4 = if true then new B() else new C() - StaticClass2.DisplayControls [controls4] // bang + StaticClass2.DisplayControls [controls4] // allowed - // Q: how about on matches? Not covered. Decision: disallow + // Q: how about on matches? allowed let controls5 = match 1 with 1 -> new B() | _ -> new C() - StaticClass2.DisplayControls [controls5] // bang + StaticClass2.DisplayControls [controls5] // allowed - // Q. subsumption on 'let v = expr'? Not covered. Disallow + // Q. subsumption on 'let v = expr'? Allowed let x76 : A = new B() module NoSubsumptionForLists2 = @@ -126,7 +126,7 @@ module BiGenericMethodsInGenericClassTests = let str = "" C.M3("a",obj) // this is not permitted since 'b is inferred to be "string". Fair enough - C.M3(obj,"a") + C.M3(obj,"a") // now permitted C.OM3("a",obj) // this is not permitted since 'b is inferred to be "string". Fair enough @@ -443,3 +443,7 @@ module OverloadedTypeNamesIncludingNonGenericTypeNoConstructors = let t3 = 3 |> OverloadedClassName.S // NO ERROR EXPECTED let t4 = 3 |> OverloadedClassName.S2 // expected error - The field, constructor or member 'S2' is not defined +module OptionTypeOpImplicitsIgnored = + let x1 : int option = 3 + let x2 : string option = "a" + diff --git a/tests/fsharp/typecheck/sigs/neg80.vsbsl b/tests/fsharp/typecheck/sigs/neg80.vsbsl index d8bb6d1a0b..26c5bcafa2 100644 --- a/tests/fsharp/typecheck/sigs/neg80.vsbsl +++ b/tests/fsharp/typecheck/sigs/neg80.vsbsl @@ -3,6 +3,6 @@ neg80.fsx(79,5,79,6): parse error FS0010: Unexpected symbol '|' in pattern match neg80.fsx(79,5,79,6): parse error FS0010: Unexpected symbol '|' in pattern matching -neg80.fsx(79,6,79,6): typecheck error FS0001: All branches of a pattern match expression must return values of the same type as the first branch, which here is 'string'. This branch returns a value of type 'unit'. +neg80.fsx(79,6,79,6): typecheck error FS0001: All branches of a pattern match expression must return values implicitly convertible to the type of the first branch, which here is 'string'. This branch returns a value of type 'unit'. neg80.fsx(76,11,76,13): typecheck error FS0025: Incomplete pattern matches on this expression. For example, the value 'Horizontal (_, _)' may indicate a case not covered by the pattern(s). diff --git a/tests/fsharp/typecheck/sigs/version47/neg24.bsl b/tests/fsharp/typecheck/sigs/version47/neg24.bsl index f276c01968..e2471fb7b8 100644 --- a/tests/fsharp/typecheck/sigs/version47/neg24.bsl +++ b/tests/fsharp/typecheck/sigs/version47/neg24.bsl @@ -17,9 +17,9 @@ neg24.fs(300,29,300,30): typecheck error FS0020: The result of this expression h neg24.fs(301,17,301,18): typecheck error FS0020: The result of this expression has type 'int' and is implicitly ignored. Consider using 'ignore' to discard this value explicitly, e.g. 'expr |> ignore', or 'let' to bind the result to a name, e.g. 'let result = expr'. -neg24.fs(302,33,302,34): typecheck error FS0001: All elements of a list must be of the same type as the first element, which here is 'unit'. This element has type 'int'. +neg24.fs(302,33,302,34): typecheck error FS0001: All elements of a list must be implicitly convertible to the type of the first element, which here is 'unit'. This element has type 'int'. -neg24.fs(302,36,302,37): typecheck error FS0001: All elements of a list must be of the same type as the first element, which here is 'unit'. This element has type 'int'. +neg24.fs(302,36,302,37): typecheck error FS0001: All elements of a list must be implicitly convertible to the type of the first element, which here is 'unit'. This element has type 'int'. neg24.fs(304,11,305,32): typecheck error FS0193: Type constraint mismatch. The type 'int' diff --git a/tests/fsharp/typecheck/sigs/version47/neg24.fs b/tests/fsharp/typecheck/sigs/version47/neg24.fs index 6e1e072cf1..38cb01cf2d 100644 --- a/tests/fsharp/typecheck/sigs/version47/neg24.fs +++ b/tests/fsharp/typecheck/sigs/version47/neg24.fs @@ -299,7 +299,7 @@ module BuilderPositive2 = module ListNegative2 = let v4 = [ if true then 1 else yield 2 ] // expect warning about "1" being ignored. There is a 'yield' so statements are statements. let l11 = [ 4; yield 1; yield 2 ] // expect warning about "1" being ignored. There is a 'yield' so statements are statements. - let l9 = [ printfn "hello"; 1; 2 ] // Note, this is interpreted as a "SimpleSemicolonSequence", so we get "All elements of a list must be of the same type as the first element, which here is 'unit'. This element..." + let l9 = [ printfn "hello"; 1; 2 ] // Note, this is interpreted as a "SimpleSemicolonSequence", so we get "All elements of a list must be implicitly convertible to the type of the first element, which here is 'unit'. This element..." let v3a : unit list = [ printfn "hello" if true then 1 else 2 ] From 7a7d51db1813c97d5ab86baf140dd9435c3d8e0f Mon Sep 17 00:00:00 2001 From: Don Syme Date: Sat, 7 May 2022 13:44:00 +0100 Subject: [PATCH 2/7] merge and format --- src/fsharp/SyntaxTree.fsi | 17 ++++++++--------- src/fsharp/TypedTreeOps.fsi | 2 +- src/fsharp/infos.fsi | 15 +++++++++++---- 3 files changed, 20 insertions(+), 14 deletions(-) diff --git a/src/fsharp/SyntaxTree.fsi b/src/fsharp/SyntaxTree.fsi index 3dd8f9d78a..d4a64cfd4b 100644 --- a/src/fsharp/SyntaxTree.fsi +++ b/src/fsharp/SyntaxTree.fsi @@ -466,12 +466,14 @@ type SynType = | AnonRecd of isStruct: bool * fields: (Ident * SynType) list * range: range /// Erased union type definition, type X = (A | B) - | ErasedUnion of - erasedUnionCases: SynErasedUnionCase list * - range: range/// - + | ErasedUnion of erasedUnionCases: SynErasedUnionCase list * range: range + /// /// F# syntax: type[] - | Array of rank: int * elementType: SynType * range: range + | Array of + + rank: int * + elementType: SynType * + range: range /// F# syntax: type -> type | Fun of argType: SynType * returnType: SynType * range: range @@ -1353,10 +1355,7 @@ type SynUnionCase = type SynErasedUnionCase = /// The untyped, unchecked syntax tree for one case in a union definition. - | SynErasedUnionCase of - typ: SynType * - xmlDoc: PreXmlDoc * - range: range + | SynErasedUnionCase of typ: SynType * xmlDoc: PreXmlDoc * range: range member Range: range diff --git a/src/fsharp/TypedTreeOps.fsi b/src/fsharp/TypedTreeOps.fsi index 76750ad4ff..a8585055b6 100755 --- a/src/fsharp/TypedTreeOps.fsi +++ b/src/fsharp/TypedTreeOps.fsi @@ -2342,7 +2342,7 @@ val NormalizeAndAdjustPossibleSubsumptionExprs: TcGlobals -> Expr -> Expr // Erased union helper //------------------------------------------------------------------------- -val tryUnsortedErasedUnionTyCases : TcGlobals -> TType -> TTypes ValueOption +val tryUnsortedErasedUnionTyCases: TcGlobals -> TType -> TTypes ValueOption //------------------------------------------------------------------------- // XmlDoc signatures, used by both VS mode and XML-help emit diff --git a/src/fsharp/infos.fsi b/src/fsharp/infos.fsi index 427f1ab2b1..80acaf97d3 100644 --- a/src/fsharp/infos.fsi +++ b/src/fsharp/infos.fsi @@ -101,7 +101,13 @@ val AllSuperTypesOfType: TType list /// Get all super types of the type, including the type itself -val AllPrimarySuperTypesOfType: g:TcGlobals -> amap:ImportMap -> m:range -> allowMultiIntfInst:AllowMultiIntfInstantiations -> ty:TType -> TType list +val AllPrimarySuperTypesOfType: + g: TcGlobals -> + amap: ImportMap -> + m: range -> + allowMultiIntfInst: AllowMultiIntfInstantiations -> + ty: TType -> + TType list /// Get all interfaces of a type, including the type itself if it is an interface val AllInterfacesOfType: @@ -126,11 +132,12 @@ val ExistsSameHeadTypeInHierarchy: val ExistsHeadTypeInEntireHierarchy: g: TcGlobals -> amap: ImportMap -> m: range -> typeToSearchFrom: TType -> tcrefToLookFor: TyconRef -> bool -/// Check if one (nominal) type is a subtype of another +/// Check if one (nominal) type is a subtype of another val isSubTypeOf: g: TcGlobals -> amap: ImportMap -> m: range -> typeToSearchFrom: TType -> typeToLookFor: TType -> bool -/// Check if one (nominal) type is a supertype of another -val isSuperTypeOf: g: TcGlobals -> amap: ImportMap -> m: range -> typeToSearchFrom: TType -> typeToLookFor: TType -> bool +/// Check if one (nominal) type is a supertype of another +val isSuperTypeOf: + g: TcGlobals -> amap: ImportMap -> m: range -> typeToSearchFrom: TType -> typeToLookFor: TType -> bool /// Get the common ancestor of a set of nominal types val getCommonAncestorOfTys: g: TcGlobals -> amap: ImportMap -> tys: TTypes -> m: range -> TType From 0d9388f528e6143bfb1518274841b7cc8ee5dccd Mon Sep 17 00:00:00 2001 From: Don Syme Date: Sat, 7 May 2022 16:42:06 +0100 Subject: [PATCH 3/7] fix build --- src/fsharp/CheckExpressions.fs | 7 ------- 1 file changed, 7 deletions(-) diff --git a/src/fsharp/CheckExpressions.fs b/src/fsharp/CheckExpressions.fs index 8fb01680ad..9de0998a0a 100644 --- a/src/fsharp/CheckExpressions.fs +++ b/src/fsharp/CheckExpressions.fs @@ -4414,18 +4414,11 @@ and TcTypeOrMeasure optKind cenv newOk checkCxs occ env (tpenv: UnscopedTyparEnv checkLanguageFeatureError cenv.g.langVersion LanguageFeature.ErasedUnions m TcErasedUnionTypeOr cenv env tpenv synCases m -<<<<<<< HEAD - | SynType.Fun(domainTy, resultTy, _) -> - let domainTy', tpenv = TcTypeAndRecover cenv newOk checkCxs occ env tpenv domainTy - let resultTy', tpenv = TcTypeAndRecover cenv newOk checkCxs occ env tpenv resultTy - (domainTy' --> resultTy'), tpenv -======= | SynType.Fun(domainTy, resultTy, _) -> let domainTyR, tpenv = TcTypeAndRecover cenv newOk checkCxs occ env tpenv domainTy let resultTyR, tpenv = TcTypeAndRecover cenv newOk checkCxs occ env tpenv resultTy let tyR = mkFunTy g domainTyR resultTyR tyR, tpenv ->>>>>>> 597446a4d3123316db356afcd205c49b05076642 | SynType.Array (n, elemTy, m) -> let elemTy, tpenv = TcTypeAndRecover cenv newOk checkCxs occ env tpenv elemTy From cc81eb5a388c2946fcb033817c3cad482836b0b7 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Wed, 18 May 2022 23:47:15 +0100 Subject: [PATCH 4/7] merge --- src/Compiler/Service/ServiceLexing.fsi | 1 - src/Compiler/TypedTree/TypedTree.fsi | 15 +++++++++++++++ 2 files changed, 15 insertions(+), 1 deletion(-) diff --git a/src/Compiler/Service/ServiceLexing.fsi b/src/Compiler/Service/ServiceLexing.fsi index df1dfdde29..5e2e5a9732 100755 --- a/src/Compiler/Service/ServiceLexing.fsi +++ b/src/Compiler/Service/ServiceLexing.fsi @@ -6,7 +6,6 @@ open System open System.Threading open FSharp.Compiler open FSharp.Compiler.Text - #nowarn "57" /// Represents encoded information for the end-of-line continuation of lexing diff --git a/src/Compiler/TypedTree/TypedTree.fsi b/src/Compiler/TypedTree/TypedTree.fsi index e7085c99a0..20c8c0a53e 100644 --- a/src/Compiler/TypedTree/TypedTree.fsi +++ b/src/Compiler/TypedTree/TypedTree.fsi @@ -2902,6 +2902,9 @@ type TType = /// 'flags' is a placeholder for future features, in particular nullness analysis | TType_var of typar: Typar * flags: byte + /// Indicates the type is a union type, containing common ancestor type and the disjoint cases + | TType_erased_union of unionInfo: ErasedUnionInfo * choices: TTypes + /// Indicates the type is a unit-of-measure expression being used as an argument to a type or member | TType_measure of measure: Measure @@ -2939,6 +2942,18 @@ type AnonRecdTypeInfo = member IsLinked: bool +[] +type ErasedUnionInfo = + { + /// Common ancestor type for all cases in this union, used for ILgen + CommonAncestorTy: TType + + /// Indices representing order of cases they were defined in + UnsortedCaseSourceIndices: int[] + } + + static member Create: commonAncestorTy: TType * unsortedCaseSourceIndices: int[] -> ErasedUnionInfo + [] type TupInfo = From 9d85e84816aa8a63865e174c00571177b49593ee Mon Sep 17 00:00:00 2001 From: Don Syme Date: Wed, 18 May 2022 23:51:38 +0100 Subject: [PATCH 5/7] update xlf --- src/Compiler/xlf/FSComp.txt.cs.xlf | 10 ++++++++++ src/Compiler/xlf/FSComp.txt.de.xlf | 10 ++++++++++ src/Compiler/xlf/FSComp.txt.es.xlf | 10 ++++++++++ src/Compiler/xlf/FSComp.txt.fr.xlf | 10 ++++++++++ src/Compiler/xlf/FSComp.txt.it.xlf | 10 ++++++++++ src/Compiler/xlf/FSComp.txt.ja.xlf | 10 ++++++++++ src/Compiler/xlf/FSComp.txt.ko.xlf | 10 ++++++++++ src/Compiler/xlf/FSComp.txt.pl.xlf | 10 ++++++++++ src/Compiler/xlf/FSComp.txt.pt-BR.xlf | 10 ++++++++++ src/Compiler/xlf/FSComp.txt.ru.xlf | 10 ++++++++++ src/Compiler/xlf/FSComp.txt.tr.xlf | 10 ++++++++++ src/Compiler/xlf/FSComp.txt.zh-Hans.xlf | 10 ++++++++++ src/Compiler/xlf/FSComp.txt.zh-Hant.xlf | 10 ++++++++++ 13 files changed, 130 insertions(+) diff --git a/src/Compiler/xlf/FSComp.txt.cs.xlf b/src/Compiler/xlf/FSComp.txt.cs.xlf index b1fa4e2cf7..61f3e62d9e 100644 --- a/src/Compiler/xlf/FSComp.txt.cs.xlf +++ b/src/Compiler/xlf/FSComp.txt.cs.xlf @@ -62,6 +62,11 @@ Dostupná přetížení:\n{0} + + The erased union type '{0}' is not compatible with the erased union type '{1}' + The erased union type '{0}' is not compatible with the erased union type '{1}' + + A generic construct requires that a generic type parameter be known as a struct or reference type. Consider adding a type annotation. Obecná konstrukce vyžaduje, aby byl parametr obecného typu známý jako typ struct nebo reference. Zvažte možnost přidat anotaci typu. @@ -157,6 +162,11 @@ literál float32 bez tečky + + erased unions + erased unions + + more types support units of measure více typů podporuje měrné jednotky diff --git a/src/Compiler/xlf/FSComp.txt.de.xlf b/src/Compiler/xlf/FSComp.txt.de.xlf index 4d6f3fc0b0..4ccd4cef07 100644 --- a/src/Compiler/xlf/FSComp.txt.de.xlf +++ b/src/Compiler/xlf/FSComp.txt.de.xlf @@ -62,6 +62,11 @@ Verfügbare Überladungen:\n{0} + + The erased union type '{0}' is not compatible with the erased union type '{1}' + The erased union type '{0}' is not compatible with the erased union type '{1}' + + A generic construct requires that a generic type parameter be known as a struct or reference type. Consider adding a type annotation. Für ein generisches Konstrukt muss ein generischer Typparameter als Struktur- oder Verweistyp bekannt sein. Erwägen Sie das Hinzufügen einer Typanmerkung. @@ -157,6 +162,11 @@ punktloses float32-Literal + + erased unions + erased unions + + more types support units of measure Maßeinheitenunterstützung durch weitere Typen diff --git a/src/Compiler/xlf/FSComp.txt.es.xlf b/src/Compiler/xlf/FSComp.txt.es.xlf index 8d9e613caa..bf49158ac2 100644 --- a/src/Compiler/xlf/FSComp.txt.es.xlf +++ b/src/Compiler/xlf/FSComp.txt.es.xlf @@ -62,6 +62,11 @@ Sobrecargas disponibles:\n{0} + + The erased union type '{0}' is not compatible with the erased union type '{1}' + The erased union type '{0}' is not compatible with the erased union type '{1}' + + A generic construct requires that a generic type parameter be known as a struct or reference type. Consider adding a type annotation. Una construcción genérica requiere que un parámetro de tipo genérico se conozca como tipo de referencia o estructura. Puede agregar una anotación de tipo. @@ -157,6 +162,11 @@ literal float32 sin punto + + erased unions + erased unions + + more types support units of measure más tipos admiten las unidades de medida diff --git a/src/Compiler/xlf/FSComp.txt.fr.xlf b/src/Compiler/xlf/FSComp.txt.fr.xlf index abb9cac58f..b359929b81 100644 --- a/src/Compiler/xlf/FSComp.txt.fr.xlf +++ b/src/Compiler/xlf/FSComp.txt.fr.xlf @@ -62,6 +62,11 @@ Surcharges disponibles :\n{0} + + The erased union type '{0}' is not compatible with the erased union type '{1}' + The erased union type '{0}' is not compatible with the erased union type '{1}' + + A generic construct requires that a generic type parameter be known as a struct or reference type. Consider adding a type annotation. L'utilisation d'une construction générique est possible uniquement si un paramètre de type générique est connu en tant que type struct ou type référence. Ajoutez une annotation de type. @@ -157,6 +162,11 @@ littéral float32 sans point + + erased unions + erased unions + + more types support units of measure d'autres types prennent en charge les unités de mesure diff --git a/src/Compiler/xlf/FSComp.txt.it.xlf b/src/Compiler/xlf/FSComp.txt.it.xlf index ea42495717..8edc0a3f3a 100644 --- a/src/Compiler/xlf/FSComp.txt.it.xlf +++ b/src/Compiler/xlf/FSComp.txt.it.xlf @@ -62,6 +62,11 @@ Overload disponibili:\n{0} + + The erased union type '{0}' is not compatible with the erased union type '{1}' + The erased union type '{0}' is not compatible with the erased union type '{1}' + + A generic construct requires that a generic type parameter be known as a struct or reference type. Consider adding a type annotation. Un costrutto generico richiede che un parametro di tipo generico sia noto come tipo riferimento o struct. Provare ad aggiungere un'annotazione di tipo. @@ -157,6 +162,11 @@ valore letterale float32 senza punti + + erased unions + erased unions + + more types support units of measure più tipi supportano le unità di misura diff --git a/src/Compiler/xlf/FSComp.txt.ja.xlf b/src/Compiler/xlf/FSComp.txt.ja.xlf index 7aca147daf..a9621fa99a 100644 --- a/src/Compiler/xlf/FSComp.txt.ja.xlf +++ b/src/Compiler/xlf/FSComp.txt.ja.xlf @@ -62,6 +62,11 @@ 使用可能なオーバーロード:\n{0} + + The erased union type '{0}' is not compatible with the erased union type '{1}' + The erased union type '{0}' is not compatible with the erased union type '{1}' + + A generic construct requires that a generic type parameter be known as a struct or reference type. Consider adding a type annotation. ジェネリック コンストラクトでは、ジェネリック型パラメーターが構造体または参照型として認識されている必要があります。型の注釈の追加を検討してください。 @@ -157,6 +162,11 @@ ドットなしの float32 リテラル + + erased unions + erased unions + + more types support units of measure 単位をサポートするその他の型 diff --git a/src/Compiler/xlf/FSComp.txt.ko.xlf b/src/Compiler/xlf/FSComp.txt.ko.xlf index 756adccd3c..f0782dbba7 100644 --- a/src/Compiler/xlf/FSComp.txt.ko.xlf +++ b/src/Compiler/xlf/FSComp.txt.ko.xlf @@ -62,6 +62,11 @@ 사용 가능한 오버로드:\n{0} + + The erased union type '{0}' is not compatible with the erased union type '{1}' + The erased union type '{0}' is not compatible with the erased union type '{1}' + + A generic construct requires that a generic type parameter be known as a struct or reference type. Consider adding a type annotation. 제네릭 구문을 사용하려면 구조체 또는 참조 형식의 제네릭 형식 매개 변수가 필요합니다. 형식 주석을 추가하세요. @@ -157,6 +162,11 @@ 점이 없는 float32 리터럴 + + erased unions + erased unions + + more types support units of measure 더 많은 형식이 측정 단위를 지원함 diff --git a/src/Compiler/xlf/FSComp.txt.pl.xlf b/src/Compiler/xlf/FSComp.txt.pl.xlf index 2f3076f0c5..81e1984d7c 100644 --- a/src/Compiler/xlf/FSComp.txt.pl.xlf +++ b/src/Compiler/xlf/FSComp.txt.pl.xlf @@ -62,6 +62,11 @@ Dostępne przeciążenia:\n{0} + + The erased union type '{0}' is not compatible with the erased union type '{1}' + The erased union type '{0}' is not compatible with the erased union type '{1}' + + A generic construct requires that a generic type parameter be known as a struct or reference type. Consider adding a type annotation. Konstrukcja ogólna wymaga, aby parametr typu ogólnego był znany jako struktura lub typ referencyjny. Rozważ dodanie adnotacji typu. @@ -157,6 +162,11 @@ bezkropkowy literał float32 + + erased unions + erased unions + + more types support units of measure więcej typów obsługuje jednostki miary diff --git a/src/Compiler/xlf/FSComp.txt.pt-BR.xlf b/src/Compiler/xlf/FSComp.txt.pt-BR.xlf index fe4f138ba4..edd445b43b 100644 --- a/src/Compiler/xlf/FSComp.txt.pt-BR.xlf +++ b/src/Compiler/xlf/FSComp.txt.pt-BR.xlf @@ -62,6 +62,11 @@ Sobrecargas disponíveis:\n{0} + + The erased union type '{0}' is not compatible with the erased union type '{1}' + The erased union type '{0}' is not compatible with the erased union type '{1}' + + A generic construct requires that a generic type parameter be known as a struct or reference type. Consider adding a type annotation. Um constructo genérico exige que um parâmetro de tipo genérico seja conhecido como um tipo de referência ou struct. Considere adicionar uma anotação de tipo. @@ -157,6 +162,11 @@ literal float32 sem ponto + + erased unions + erased unions + + more types support units of measure mais tipos dão suporte para unidades de medida diff --git a/src/Compiler/xlf/FSComp.txt.ru.xlf b/src/Compiler/xlf/FSComp.txt.ru.xlf index 9869da2579..f8d45e4fe6 100644 --- a/src/Compiler/xlf/FSComp.txt.ru.xlf +++ b/src/Compiler/xlf/FSComp.txt.ru.xlf @@ -62,6 +62,11 @@ Доступные перегрузки:\n{0} + + The erased union type '{0}' is not compatible with the erased union type '{1}' + The erased union type '{0}' is not compatible with the erased union type '{1}' + + A generic construct requires that a generic type parameter be known as a struct or reference type. Consider adding a type annotation. В универсальной конструкции требуется использовать параметр универсального типа, известный как структура или ссылочный тип. Рекомендуется добавить заметку с типом. @@ -157,6 +162,11 @@ литерал float32 без точки + + erased unions + erased unions + + more types support units of measure другие типы поддерживают единицы измерения diff --git a/src/Compiler/xlf/FSComp.txt.tr.xlf b/src/Compiler/xlf/FSComp.txt.tr.xlf index 96a4421fcd..304881d9e7 100644 --- a/src/Compiler/xlf/FSComp.txt.tr.xlf +++ b/src/Compiler/xlf/FSComp.txt.tr.xlf @@ -62,6 +62,11 @@ Kullanılabilir aşırı yüklemeler:\n{0} + + The erased union type '{0}' is not compatible with the erased union type '{1}' + The erased union type '{0}' is not compatible with the erased union type '{1}' + + A generic construct requires that a generic type parameter be known as a struct or reference type. Consider adding a type annotation. Genel yapı, genel bir tür parametresinin yapı veya başvuru türü olarak bilinmesini gerektirir. Tür ek açıklaması eklemeyi düşünün. @@ -157,6 +162,11 @@ noktasız float32 sabit değeri + + erased unions + erased unions + + more types support units of measure tür daha ölçü birimlerini destekler diff --git a/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf b/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf index 745af28b56..c4a79af8bb 100644 --- a/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf +++ b/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf @@ -62,6 +62,11 @@ 可用重载:\n{0} + + The erased union type '{0}' is not compatible with the erased union type '{1}' + The erased union type '{0}' is not compatible with the erased union type '{1}' + + A generic construct requires that a generic type parameter be known as a struct or reference type. Consider adding a type annotation. 泛型构造要求泛型类型参数被视为结构或引用类型。请考虑添加类型注释。 @@ -157,6 +162,11 @@ 无点 float32 文本 + + erased unions + erased unions + + more types support units of measure 更多类型支持度量单位 diff --git a/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf b/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf index 84c81465e8..1adbdb876d 100644 --- a/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf +++ b/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf @@ -62,6 +62,11 @@ 可用的多載:\n{0} + + The erased union type '{0}' is not compatible with the erased union type '{1}' + The erased union type '{0}' is not compatible with the erased union type '{1}' + + A generic construct requires that a generic type parameter be known as a struct or reference type. Consider adding a type annotation. 泛型建構要求泛型型別參數必須指定為結構或參考型別。請考慮新增型別註解。 @@ -157,6 +162,11 @@ 無點號的 float32 常值 + + erased unions + erased unions + + more types support units of measure 更多支援測量單位的類型 From 1acc20065c0e8e51aac528b60b6caa2295ca0232 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Thu, 19 May 2022 00:01:49 +0100 Subject: [PATCH 6/7] merge --- src/Compiler/Checking/infos.fs | 422 --------------------------------- 1 file changed, 422 deletions(-) diff --git a/src/Compiler/Checking/infos.fs b/src/Compiler/Checking/infos.fs index 0971a0d820..28c4382f91 100755 --- a/src/Compiler/Checking/infos.fs +++ b/src/Compiler/Checking/infos.fs @@ -25,428 +25,6 @@ open FSharp.Compiler.TypeProviders #endif //------------------------------------------------------------------------- -<<<<<<< HEAD:src/fsharp/infos.fs -// From IL types to F# types -//------------------------------------------------------------------------- - -/// Import an IL type as an F# type. importInst gives the context for interpreting type variables. -let ImportILType scoref amap m importInst ilty = - ilty |> rescopeILType scoref |> Import.ImportILType amap m importInst - -let CanImportILType scoref amap m ilty = - ilty |> rescopeILType scoref |> Import.CanImportILType amap m - -//------------------------------------------------------------------------- -// Fold the hierarchy. -// REVIEW: this code generalizes the iteration used below for member lookup. -//------------------------------------------------------------------------- - -/// Indicates if an F# type is the type associated with an F# exception declaration -let isExnDeclTy g ty = - match tryTcrefOfAppTy g ty with - | ValueSome tcref -> tcref.IsExceptionDecl - | _ -> false - -/// Get the base type of a type, taking into account type instantiations. Return None if the -/// type has no base type. -let GetSuperTypeOfType g amap m ty = -#if !NO_TYPEPROVIDERS - let ty = - match tryTcrefOfAppTy g ty with - | ValueSome tcref when tcref.IsProvided -> stripTyEqns g ty - | _ -> stripTyEqnsAndMeasureEqns g ty -#else - let ty = stripTyEqnsAndMeasureEqns g ty -#endif - - match metadataOfTy g ty with -#if !NO_TYPEPROVIDERS - | ProvidedTypeMetadata info -> - let st = info.ProvidedType - let superOpt = st.PApplyOption((fun st -> match st.BaseType with null -> None | t -> Some t), m) - match superOpt with - | None -> None - | Some super -> Some(Import.ImportProvidedType amap m super) -#endif - | ILTypeMetadata (TILObjectReprData(scoref, _, tdef)) -> - let tinst = argsOfAppTy g ty - match tdef.Extends with - | None -> None - | Some ilty -> Some (ImportILType scoref amap m tinst ilty) - - | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> - if isFSharpObjModelTy g ty || isExnDeclTy g ty then - let tcref = tcrefOfAppTy g ty - Some (instType (mkInstForAppTy g ty) (superOfTycon g tcref.Deref)) - elif isArrayTy g ty then - Some g.system_Array_ty - elif isRefTy g ty && not (isObjTy g ty) then - Some g.obj_ty - elif isStructTupleTy g ty then - Some g.system_Value_ty - elif isFSharpStructOrEnumTy g ty then - if isFSharpEnumTy g ty then - Some g.system_Enum_ty - else - Some g.system_Value_ty - elif isStructAnonRecdTy g ty then - Some g.system_Value_ty - elif isAnonRecdTy g ty then - Some g.obj_ty - elif isRecdTy g ty || isUnionTy g ty then - Some g.obj_ty - else - None - -/// Make a type for System.Collections.Generic.IList -let mkSystemCollectionsGenericIListTy (g: TcGlobals) ty = - TType_app(g.tcref_System_Collections_Generic_IList, [ty], g.knownWithoutNull) - -/// Indicates whether we can skip interface types that lie outside the reference set -[] -type SkipUnrefInterfaces = Yes | No - -let GetImmediateInterfacesOfMetadataType g amap m skipUnref ty (tcref: TyconRef) tinst = - [ - match metadataOfTy g ty with -#if !NO_TYPEPROVIDERS - | ProvidedTypeMetadata info -> - for ity in info.ProvidedType.PApplyArray((fun st -> st.GetInterfaces()), "GetInterfaces", m) do - Import.ImportProvidedType amap m ity -#endif - | ILTypeMetadata (TILObjectReprData(scoref, _, tdef)) -> - // ImportILType may fail for an interface if the assembly load set is incomplete and the interface - // comes from another assembly. In this case we simply skip the interface: - // if we don't skip it, then compilation will just fail here, and if type checking - // succeeds with fewer non-dereferencable interfaces reported then it would have - // succeeded with more reported. There are pathological corner cases where this - // doesn't apply: e.g. for mscorlib interfaces like IComparable, but we can always - // assume those are present. - for ity in tdef.Implements do - if skipUnref = SkipUnrefInterfaces.No || CanImportILType scoref amap m ity then - ImportILType scoref amap m tinst ity - | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> - for ity in tcref.ImmediateInterfaceTypesOfFSharpTycon do - instType (mkInstForAppTy g ty) ity ] - -/// Collect the set of immediate declared interface types for an F# type, but do not -/// traverse the type hierarchy to collect further interfaces. -// -// NOTE: Anonymous record types are not directly considered to implement IComparable, -// IComparable or IEquatable. This is because whether they support these interfaces depend on their -// consitutent types, which may not yet be known in type inference. -let rec GetImmediateInterfacesOfType skipUnref g amap m ty = - [ - match tryAppTy g ty with - | ValueSome(tcref, tinst) -> - // Check if this is a measure-annotated type - match tcref.TypeReprInfo with - | TMeasureableRepr reprTy -> - yield! GetImmediateInterfacesOfMeasureAnnotatedType skipUnref g amap m ty reprTy - | _ -> - yield! GetImmediateInterfacesOfMetadataType g amap m skipUnref ty tcref tinst - - | ValueNone -> - // For tuple types, func types, check if we can eliminate to a type with metadata. - let tyWithMetadata = convertToTypeWithMetadataIfPossible g ty - match tryAppTy g tyWithMetadata with - | ValueSome (tcref, tinst) -> - if isAnyTupleTy g ty then - yield! GetImmediateInterfacesOfMetadataType g amap m skipUnref tyWithMetadata tcref tinst - | _ -> () - - // .NET array types are considered to implement IList - if isArray1DTy g ty then - mkSystemCollectionsGenericIListTy g (destArrayTy g ty) - ] - -// Report the interfaces supported by a measure-annotated type. -// -// For example, consider: -// -// [] -// type A<[] 'm> = A -// -// This measure-annotated type is considered to support the interfaces on its representation type A, -// with the exception that -// -// 1. we rewrite the IComparable and IEquatable interfaces, so that -// IComparable --> IComparable> -// IEquatable --> IEquatable> -// -// 2. we emit any other interfaces that derive from IComparable and IEquatable interfaces -// -// This rule is conservative and only applies to IComparable and IEquatable interfaces. -// -// This rule may in future be extended to rewrite the "trait" interfaces associated with .NET 7. -and GetImmediateInterfacesOfMeasureAnnotatedType skipUnref g amap m ty reprTy = - [ - // Report any interfaces that don't derive from IComparable<_> or IEquatable<_> - for ity in GetImmediateInterfacesOfType skipUnref g amap m reprTy do - if not (ExistsHeadTypeInInterfaceHierarchy g.system_GenericIComparable_tcref skipUnref g amap m ity) && - not (ExistsHeadTypeInInterfaceHierarchy g.system_GenericIEquatable_tcref skipUnref g amap m ity) then - ity - - // NOTE: we should really only report the IComparable> interface for measure-annotated types - // if the original type supports IComparable somewhere in the hierarchy, likeiwse IEquatable>. - // - // However since F# 2.0 we have always reported these interfaces for all measure-annotated types. - - //if ExistsInInterfaceHierarchy (typeEquiv g (mkAppTy g.system_GenericIComparable_tcref [reprTy])) skipUnref g amap m ty then - mkAppTy g.system_GenericIComparable_tcref [ty] - - //if ExistsInInterfaceHierarchy (typeEquiv g (mkAppTy g.system_GenericIEquatable_tcref [reprTy])) skipUnref g amap m ty then - mkAppTy g.system_GenericIEquatable_tcref [ty] - ] - -// Check for IComparable, IEquatable and interfaces that derive from these -and ExistsHeadTypeInInterfaceHierarchy target skipUnref g amap m ity = - ExistsInInterfaceHierarchy (function AppTy g (tcref,_) -> tyconRefEq g tcref target | _ -> false) skipUnref g amap m ity - -// Check for IComparable, IEquatable and interfaces that derive from these -and ExistsInInterfaceHierarchy p skipUnref g amap m ity = - match ity with - | AppTy g (tcref, tinst) -> - p ity || - (GetImmediateInterfacesOfMetadataType g amap m skipUnref ity tcref tinst - |> List.exists (ExistsInInterfaceHierarchy p skipUnref g amap m)) - | _ -> false - -/// Indicates whether we should visit multiple instantiations of the same generic interface or not -[] -type AllowMultiIntfInstantiations = Yes | No - -/// Traverse the type hierarchy, e.g. f D (f C (f System.Object acc)). -/// Visit base types and interfaces first. -let private FoldHierarchyOfTypeAux followInterfaces allowMultiIntfInst skipUnref visitor g amap m ty acc = - let rec loop ndeep ty (visitedTycon, visited: TyconRefMultiMap<_>, acc as state) = - - let seenThisTycon = - match tryTcrefOfAppTy g ty with - | ValueSome tcref -> Set.contains tcref.Stamp visitedTycon - | _ -> false - - // Do not visit the same type twice. Could only be doing this if we've seen this tycon - if seenThisTycon && List.exists (typeEquiv g ty) (visited.Find (tcrefOfAppTy g ty)) then state else - - // Do not visit the same tycon twice, e.g. I and I, collect I only, unless directed to allow this - if seenThisTycon && allowMultiIntfInst = AllowMultiIntfInstantiations.No then state else - - let state = - match tryTcrefOfAppTy g ty with - | ValueSome tcref -> - let visitedTycon = Set.add tcref.Stamp visitedTycon - visitedTycon, visited.Add (tcref, ty), acc - | _ -> - state - - if ndeep > 100 then (errorR(Error((FSComp.SR.recursiveClassHierarchy (showType ty)), m)); (visitedTycon, visited, acc)) else - let visitedTycon, visited, acc = - if isInterfaceTy g ty then - List.foldBack - (loop (ndeep+1)) - (GetImmediateInterfacesOfType skipUnref g amap m ty) - (loop ndeep g.obj_ty state) - else - match tryDestTyparTy g ty with - | ValueSome tp -> - let state = loop (ndeep+1) g.obj_ty state - List.foldBack - (fun x vacc -> - match x with - | TyparConstraint.MayResolveMember _ - | TyparConstraint.DefaultsTo _ - | TyparConstraint.SupportsComparison _ - | TyparConstraint.SupportsEquality _ - | TyparConstraint.IsEnum _ - | TyparConstraint.IsDelegate _ - | TyparConstraint.SupportsNull _ - | TyparConstraint.IsNonNullableStruct _ - | TyparConstraint.IsUnmanaged _ - | TyparConstraint.IsReferenceType _ - | TyparConstraint.SimpleChoice _ - | TyparConstraint.RequiresDefaultConstructor _ -> vacc - | TyparConstraint.CoercesTo(cty, _) -> - loop (ndeep + 1) cty vacc) - tp.Constraints - state - | _ -> - let state = - if followInterfaces then - List.foldBack - (loop (ndeep+1)) - (GetImmediateInterfacesOfType skipUnref g amap m ty) - state - else - state - let state = - Option.foldBack - (loop (ndeep+1)) - (GetSuperTypeOfType g amap m ty) - state - state - let acc = visitor ty acc - (visitedTycon, visited, acc) - loop 0 ty (Set.empty, TyconRefMultiMap<_>.Empty, acc) |> p33 - -/// Fold, do not follow interfaces (unless the type is itself an interface) -let FoldPrimaryHierarchyOfType f g amap m allowMultiIntfInst ty acc = - FoldHierarchyOfTypeAux false allowMultiIntfInst SkipUnrefInterfaces.No f g amap m ty acc - -/// Fold, following interfaces. Skipping interfaces that lie outside the referenced assembly set is allowed. -let FoldEntireHierarchyOfType f g amap m allowMultiIntfInst ty acc = - FoldHierarchyOfTypeAux true allowMultiIntfInst SkipUnrefInterfaces.Yes f g amap m ty acc - -/// Iterate, following interfaces. Skipping interfaces that lie outside the referenced assembly set is allowed. -let IterateEntireHierarchyOfType f g amap m allowMultiIntfInst ty = - FoldHierarchyOfTypeAux true allowMultiIntfInst SkipUnrefInterfaces.Yes (fun ty () -> f ty) g amap m ty () - -/// Search for one element satisfying a predicate, following interfaces -let ExistsInEntireHierarchyOfType f g amap m allowMultiIntfInst ty = - FoldHierarchyOfTypeAux true allowMultiIntfInst SkipUnrefInterfaces.Yes (fun ty acc -> acc || f ty ) g amap m ty false - -/// Search for one element where a function returns a 'Some' result, following interfaces -let SearchEntireHierarchyOfType f g amap m ty = - FoldHierarchyOfTypeAux true AllowMultiIntfInstantiations.Yes SkipUnrefInterfaces.Yes - (fun ty acc -> - match acc with - | None -> if f ty then Some ty else None - | Some _ -> acc) - g amap m ty None - -let AllPrimarySuperTypesOfType g amap m allowMultiIntfInst ty = - FoldPrimaryHierarchyOfType (ListSet.insert (typeEquiv g)) g amap m allowMultiIntfInst ty [] - -/// Get all super types of the type, including the type itself -let AllSuperTypesOfType g amap m allowMultiIntfInst ty = - FoldHierarchyOfTypeAux true allowMultiIntfInst SkipUnrefInterfaces.No (ListSet.insert (typeEquiv g)) g amap m ty [] - -/// Get all interfaces of a type, including the type itself if it is an interface -let AllInterfacesOfType g amap m allowMultiIntfInst ty = - AllSuperTypesOfType g amap m allowMultiIntfInst ty |> List.filter (isInterfaceTy g) - -/// Check if two types have the same nominal head type -let HaveSameHeadType g ty1 ty2 = - match tryTcrefOfAppTy g ty1 with - | ValueSome tcref1 -> - match tryTcrefOfAppTy g ty2 with - | ValueSome tcref2 -> tyconRefEq g tcref1 tcref2 - | _ -> false - | _ -> false - -/// Check if a type has a particular head type -let HasHeadType g tcref ty2 = - match tryTcrefOfAppTy g ty2 with - | ValueSome tcref2 -> tyconRefEq g tcref tcref2 - | ValueNone -> false - -let isSubTypeOf g amap m typeToSearchFrom typeToLookFor = - ExistsInEntireHierarchyOfType (typeEquiv g typeToLookFor) g amap m AllowMultiIntfInstantiations.Yes typeToSearchFrom - -let isSuperTypeOf g amap m typeToSearchFrom typeToLookFor = - isSubTypeOf g amap m typeToLookFor typeToSearchFrom - -let getCommonAncestorOfTys g amap tys m = - let superTypes = List.map (AllPrimarySuperTypesOfType g amap m AllowMultiIntfInstantiations.No) tys - List.fold (ListSet.intersect (typeEquiv g)) (List.head superTypes) (List.tail superTypes) |> List.head - -/// choose if a type exists somewhere in the hierarchy which has the same head type as the given type (note, the given type need not have a head type at all) -let ChooseSameHeadTypeInHierarchy g amap m typeToSearchFrom typeToLookFor = - SearchEntireHierarchyOfType (HaveSameHeadType g typeToLookFor) g amap m typeToSearchFrom - -/// Check if a type exists somewhere in the hierarchy which has the same head type as the given type (note, the given type need not have a head type at all) -let ExistsSameHeadTypeInHierarchy g amap m typeToSearchFrom typeToLookFor = - ExistsInEntireHierarchyOfType (HaveSameHeadType g typeToLookFor) g amap m AllowMultiIntfInstantiations.Yes typeToSearchFrom - -/// Check if a type exists somewhere in the hierarchy which has the given head type. -let ExistsHeadTypeInEntireHierarchy g amap m typeToSearchFrom tcrefToLookFor = - ExistsInEntireHierarchyOfType (HasHeadType g tcrefToLookFor) g amap m AllowMultiIntfInstantiations.Yes typeToSearchFrom - -/// Read an Abstract IL type from metadata and convert to an F# type. -let ImportILTypeFromMetadata amap m scoref tinst minst ilty = - ImportILType scoref amap m (tinst@minst) ilty - -/// Read an Abstract IL type from metadata, including any attributes that may affect the type itself, and convert to an F# type. -let ImportILTypeFromMetadataWithAttributes amap m scoref tinst minst ilty getCattrs = - let ty = ImportILType scoref amap m (tinst@minst) ilty - // If the type is a byref and one of attributes from a return or parameter has IsReadOnly, then it's a inref. - if isByrefTy amap.g ty && TryFindILAttribute amap.g.attrib_IsReadOnlyAttribute (getCattrs ()) then - mkInByrefTy amap.g (destByrefTy amap.g ty) - else - ty - -/// Get the parameter type of an IL method. -let ImportParameterTypeFromMetadata amap m ilty getCattrs scoref tinst mist = - ImportILTypeFromMetadataWithAttributes amap m scoref tinst mist ilty getCattrs - -/// Get the return type of an IL method, taking into account instantiations for type, return attributes and method generic parameters, and -/// translating 'void' to 'None'. -let ImportReturnTypeFromMetadata amap m ilty getCattrs scoref tinst minst = - match ilty with - | ILType.Void -> None - | retTy -> Some(ImportILTypeFromMetadataWithAttributes amap m scoref tinst minst retTy getCattrs) - - -/// Copy constraints. If the constraint comes from a type parameter associated -/// with a type constructor then we are simply renaming type variables. If it comes -/// from a generic method in a generic class (e.g. ty.M<_>) then we may be both substituting the -/// instantiation associated with 'ty' as well as copying the type parameters associated with -/// M and instantiating their constraints -/// -/// Note: this now looks identical to constraint instantiation. - -let CopyTyparConstraints m tprefInst (tporig: Typar) = - tporig.Constraints - |> List.map (fun tpc -> - match tpc with - | TyparConstraint.CoercesTo(ty, _) -> - TyparConstraint.CoercesTo (instType tprefInst ty, m) - | TyparConstraint.DefaultsTo(priority, ty, _) -> - TyparConstraint.DefaultsTo (priority, instType tprefInst ty, m) - | TyparConstraint.SupportsNull _ -> - TyparConstraint.SupportsNull m - | TyparConstraint.IsEnum (uty, _) -> - TyparConstraint.IsEnum (instType tprefInst uty, m) - | TyparConstraint.SupportsComparison _ -> - TyparConstraint.SupportsComparison m - | TyparConstraint.SupportsEquality _ -> - TyparConstraint.SupportsEquality m - | TyparConstraint.IsDelegate(aty, bty, _) -> - TyparConstraint.IsDelegate (instType tprefInst aty, instType tprefInst bty, m) - | TyparConstraint.IsNonNullableStruct _ -> - TyparConstraint.IsNonNullableStruct m - | TyparConstraint.IsUnmanaged _ -> - TyparConstraint.IsUnmanaged m - | TyparConstraint.IsReferenceType _ -> - TyparConstraint.IsReferenceType m - | TyparConstraint.SimpleChoice (tys, _) -> - TyparConstraint.SimpleChoice (List.map (instType tprefInst) tys, m) - | TyparConstraint.RequiresDefaultConstructor _ -> - TyparConstraint.RequiresDefaultConstructor m - | TyparConstraint.MayResolveMember(traitInfo, _) -> - TyparConstraint.MayResolveMember (instTrait tprefInst traitInfo, m)) - -/// The constraints for each typar copied from another typar can only be fixed up once -/// we have generated all the new constraints, e.g. f List, B :> List> ... -let FixupNewTypars m (formalEnclosingTypars: Typars) (tinst: TType list) (tpsorig: Typars) (tps: Typars) = - // Checks.. These are defensive programming against early reported errors. - let n0 = formalEnclosingTypars.Length - let n1 = tinst.Length - let n2 = tpsorig.Length - let n3 = tps.Length - if n0 <> n1 then error(Error((FSComp.SR.tcInvalidTypeArgumentCount(n0, n1)), m)) - if n2 <> n3 then error(Error((FSComp.SR.tcInvalidTypeArgumentCount(n2, n3)), m)) - - // The real code.. - let renaming, tptys = mkTyparToTyparRenaming tpsorig tps - let tprefInst = mkTyparInst formalEnclosingTypars tinst @ renaming - (tpsorig, tps) ||> List.iter2 (fun tporig tp -> tp.SetConstraints (CopyTyparConstraints m tprefInst tporig)) - renaming, tptys - - -//------------------------------------------------------------------------- -======= ->>>>>>> e063dd2a7005faf953619ab4f232d1e3606c7ed2:src/Compiler/Checking/infos.fs // Predicates and properties on values and members type ValRef with From d667c94176097f9bd48813e52e98d8420bc00193 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Thu, 19 May 2022 00:11:26 +0100 Subject: [PATCH 7/7] fix build --- src/Compiler/Checking/CheckExpressions.fs | 2 ++ src/Compiler/Checking/TypeHierarchy.fsi | 10 ++++++++++ src/Compiler/Service/ServiceLexing.fsi | 1 + 3 files changed, 13 insertions(+) diff --git a/src/Compiler/Checking/CheckExpressions.fs b/src/Compiler/Checking/CheckExpressions.fs index c109da8981..4685130d84 100644 --- a/src/Compiler/Checking/CheckExpressions.fs +++ b/src/Compiler/Checking/CheckExpressions.fs @@ -7,6 +7,7 @@ module internal FSharp.Compiler.CheckExpressions open System open System.Collections.Generic +open Internal.Utilities open Internal.Utilities.Collections open Internal.Utilities.Library open Internal.Utilities.Library.Extras @@ -34,6 +35,7 @@ open FSharp.Compiler.TcGlobals open FSharp.Compiler.Text open FSharp.Compiler.Text.Position open FSharp.Compiler.Text.Range +open FSharp.Compiler.TypeRelations open FSharp.Compiler.Xml open FSharp.Compiler.TypedTree open FSharp.Compiler.TypedTreeBasics diff --git a/src/Compiler/Checking/TypeHierarchy.fsi b/src/Compiler/Checking/TypeHierarchy.fsi index 26672d6b45..2494757508 100644 --- a/src/Compiler/Checking/TypeHierarchy.fsi +++ b/src/Compiler/Checking/TypeHierarchy.fsi @@ -124,6 +124,16 @@ val ExistsSameHeadTypeInHierarchy: val ExistsHeadTypeInEntireHierarchy: g: TcGlobals -> amap: ImportMap -> m: range -> typeToSearchFrom: TType -> tcrefToLookFor: TyconRef -> bool +/// Check if one (nominal) type is a subtype of another +val isSubTypeOf: g: TcGlobals -> amap: ImportMap -> m: range -> typeToSearchFrom: TType -> typeToLookFor: TType -> bool + +/// Check if one (nominal) type is a supertype of another +val isSuperTypeOf: + g: TcGlobals -> amap: ImportMap -> m: range -> typeToSearchFrom: TType -> typeToLookFor: TType -> bool + +/// Get the common ancestor of a set of nominal types +val getCommonAncestorOfTys: g: TcGlobals -> amap: ImportMap -> tys: TTypes -> m: range -> TType + /// Read an Abstract IL type from metadata and convert to an F# type. val ImportILTypeFromMetadata: amap: ImportMap -> m: range -> scoref: ILScopeRef -> tinst: TType list -> minst: TType list -> ilTy: ILType -> TType diff --git a/src/Compiler/Service/ServiceLexing.fsi b/src/Compiler/Service/ServiceLexing.fsi index 5e2e5a9732..df1dfdde29 100755 --- a/src/Compiler/Service/ServiceLexing.fsi +++ b/src/Compiler/Service/ServiceLexing.fsi @@ -6,6 +6,7 @@ open System open System.Threading open FSharp.Compiler open FSharp.Compiler.Text + #nowarn "57" /// Represents encoded information for the end-of-line continuation of lexing