From 6452dbaf1d2a05081babe2dd642221ec9408eb2d Mon Sep 17 00:00:00 2001 From: Don Syme Date: Mon, 20 Jan 2020 13:20:35 +0000 Subject: [PATCH] extension witness implementation --- src/fsharp/AccessibilityLogic.fs | 3 + src/fsharp/CheckFormatStrings.fs | 2 +- src/fsharp/CompileOptions.fs | 1 - src/fsharp/ConstraintSolver.fs | 352 +++++++++++------- src/fsharp/ConstraintSolver.fsi | 23 +- src/fsharp/FSComp.txt | 2 +- src/fsharp/FindUnsolved.fs | 2 +- src/fsharp/MethodCalls.fs | 12 +- src/fsharp/NameResolution.fs | 35 +- src/fsharp/NameResolution.fsi | 15 +- src/fsharp/NicePrint.fs | 16 +- src/fsharp/PostInferenceChecks.fs | 4 +- src/fsharp/TastOps.fs | 125 +++++-- src/fsharp/TastOps.fsi | 18 +- src/fsharp/TastPickle.fs | 9 +- src/fsharp/TypeChecker.fs | 136 +++---- src/fsharp/infos.fs | 50 ++- src/fsharp/symbols/Exprs.fs | 2 +- src/fsharp/symbols/Symbols.fs | 5 +- src/fsharp/tast.fs | 31 +- .../core/members/basics-hw-mutrec/test.fs | 6 +- tests/fsharp/core/members/basics-hw/test.fsx | 6 +- tests/fsharp/core/members/basics/test.fs | 6 +- tests/fsharp/core/members/ops-mutrec/test.fs | 4 +- tests/fsharp/core/subtype/test.fsx | 2 - tests/fsharp/tests.fs | 23 ++ tests/fsharp/typecheck/sigs/neg45.bsl | 2 +- tests/fsharp/typecheck/sigs/neg99.bsl | 2 +- tests/fsharp/typecheck/sigs/neg99.fs | 2 +- .../basic/E_ExtensionOperator01.fs | 20 +- .../E_MemberConstraint02.fs | 2 +- 31 files changed, 609 insertions(+), 309 deletions(-) diff --git a/src/fsharp/AccessibilityLogic.fs b/src/fsharp/AccessibilityLogic.fs index 4070ea9b402..0f1f2b67e30 100644 --- a/src/fsharp/AccessibilityLogic.fs +++ b/src/fsharp/AccessibilityLogic.fs @@ -37,6 +37,8 @@ type AccessorDomain = /// An AccessorDomain which returns all items | AccessibleFromSomewhere + interface TraitAccessorDomain + // Hashing and comparison is used for the memoization tables keyed by an accessor domain. // It is dependent on a TcGlobals because of the TyconRef in the data structure static member CustomGetHashCode(ad:AccessorDomain) = @@ -45,6 +47,7 @@ type AccessorDomain = | AccessibleFromEverywhere -> 2 | AccessibleFromSomeFSharpCode -> 3 | AccessibleFromSomewhere -> 4 + static member CustomEquals(g:TcGlobals, ad1:AccessorDomain, ad2:AccessorDomain) = match ad1, ad2 with | AccessibleFrom(cs1, tc1), AccessibleFrom(cs2, tc2) -> (cs1 = cs2) && (match tc1, tc2 with None, None -> true | Some tc1, Some tc2 -> tyconRefEq g tc1 tc2 | _ -> false) diff --git a/src/fsharp/CheckFormatStrings.fs b/src/fsharp/CheckFormatStrings.fs index 1622a61351c..eb78165819e 100644 --- a/src/fsharp/CheckFormatStrings.fs +++ b/src/fsharp/CheckFormatStrings.fs @@ -15,7 +15,7 @@ open FSharp.Compiler.NameResolution type FormatItem = Simple of TType | FuncAndVal let copyAndFixupFormatTypar m tp = - let _,_,tinst = FreshenAndFixupTypars m TyparRigidity.Flexible [] [] [tp] + let _,_,tinst = FreshenAndFixupTypars None m TyparRigidity.Flexible [] [] [tp] List.head tinst let lowestDefaultPriority = 0 (* See comment on TyparConstraint.DefaultsTo *) diff --git a/src/fsharp/CompileOptions.fs b/src/fsharp/CompileOptions.fs index 65107906686..c949cfc6988 100644 --- a/src/fsharp/CompileOptions.fs +++ b/src/fsharp/CompileOptions.fs @@ -1716,7 +1716,6 @@ let ApplyAllOptimizations (tcConfig:TcConfig, tcGlobals, tcVal, outfile, importM let optSettings = tcConfig.optSettings let optSettings = { optSettings with abstractBigTargets = tcConfig.doTLR } let optSettings = { optSettings with reportingPhase = true } - let results, (optEnvFirstLoop, _, _, _) = ((optEnv0, optEnv0, optEnv0, SignatureHidingInfo.Empty), implFiles) diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index 0360d253dd1..3e032d8f983 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -42,6 +42,7 @@ open FSharp.Compiler.ErrorLogger open FSharp.Compiler.Infos open FSharp.Compiler.AccessibilityLogic open FSharp.Compiler.AttributeChecking +open FSharp.Compiler.NameResolution open FSharp.Compiler.Lib open FSharp.Compiler.MethodCalls open FSharp.Compiler.PrettyNaming @@ -92,30 +93,35 @@ let NewByRefKindInferenceType (g: TcGlobals) m = let NewInferenceTypes l = l |> List.map (fun _ -> NewInferenceType ()) +/// Freshen a trait for use at a particular location +type TraitFreshener = (TraitConstraintInfo -> TraitPossibleExtensionMemberSolutions * TraitAccessorDomain) + // QUERY: should 'rigid' ever really be 'true'? We set this when we know // we are going to have to generalize a typar, e.g. when implementing a // abstract generic method slot. But we later check the generalization // condition anyway, so we could get away with a non-rigid typar. This // would sort of be cleaner, though give errors later. -let FreshenAndFixupTypars m rigid fctps tinst tpsorig = +let FreshenAndFixupTypars (traitFreshner: TraitFreshener option) m rigid fctps tinst tpsorig = let copy_tyvar (tp: Typar) = NewCompGenTypar (tp.Kind, rigid, tp.StaticReq, (if rigid=TyparRigidity.Rigid then TyparDynamicReq.Yes else TyparDynamicReq.No), false) let tps = tpsorig |> List.map copy_tyvar - let renaming, tinst = FixupNewTypars m fctps tinst tpsorig tps + let renaming, tinst = FixupNewTypars traitFreshner m fctps tinst tpsorig tps tps, renaming, tinst -let FreshenTypeInst m tpsorig = FreshenAndFixupTypars m TyparRigidity.Flexible [] [] tpsorig +let FreshenTypeInst traitFreshner m tpsorig = + FreshenAndFixupTypars traitFreshner m TyparRigidity.Flexible [] [] tpsorig -let FreshMethInst m fctps tinst tpsorig = FreshenAndFixupTypars m TyparRigidity.Flexible fctps tinst tpsorig +let FreshenMethInst traitFreshner m fctps tinst tpsorig = + FreshenAndFixupTypars traitFreshner m TyparRigidity.Flexible fctps tinst tpsorig -let FreshenTypars m tpsorig = +let FreshenTypars traitFreshner m tpsorig = match tpsorig with | [] -> [] | _ -> - let _, _, tptys = FreshenTypeInst m tpsorig + let _, _, tptys = FreshenTypeInst traitFreshner m tpsorig tptys -let FreshenMethInfo m (minfo: MethInfo) = - let _, _, tptys = FreshMethInst m (minfo.GetFormalTyparsOfDeclaringType m) minfo.DeclaringTypeInst minfo.FormalMethodTypars +let FreshenMethInfo traitFreshner m (minfo: MethInfo) = + let _, _, tptys = FreshenMethInst traitFreshner m (minfo.GetFormalTyparsOfDeclaringType m) minfo.DeclaringTypeInst minfo.FormalMethodTypars tptys @@ -241,7 +247,6 @@ type ConstraintSolverEnv = m: range EquivEnv: TypeEquivEnv - DisplayEnv: DisplayEnv } @@ -334,6 +339,22 @@ let IsNumericType g ty = IsNonDecimalNumericType g ty || isDecimalTy g ty let IsRelationalType g ty = IsNumericType g ty || isStringTy g ty || isCharTy g ty || isBoolTy g ty +/// Some additional solutions are forced prior to generalization (permitWeakResolution=true). These are, roughly speaking, rules +/// for binary-operand constraints arising from constructs such as "1.0 + x" where "x" is an unknown type. THe constraint here +/// involves two type parameters - one for the left, and one for the right. The left is already known to be Double. +/// In this situation (and in the absence of other evidence prior to generalization), constraint solving forces an assumption that +/// the right is also Double - this is "weak" because there is only weak evidence for it. +/// +/// permitWeakResolution also applies to resolutions of multi-type-variable constraints via method overloads. Method overloading gets applied even if +/// only one of the two type variables is known. +/// +/// During code gen we run with permitWeakResolution on, but we only apply it where one of the argument types for the built-in constraint resolution is +/// a variable type. +type PermitWeakResolution = + | Yes of codegen: bool + | No + member x.Permit = match x with Yes _ -> true | No -> false + // Get measure of type, float<_> or float32<_> or decimal<_> but not float=float<1> or float32=float32<1> or decimal=decimal<1> let GetMeasureOfType g ty = match ty with @@ -343,6 +364,78 @@ let GetMeasureOfType g ty = | _ -> None | _ -> None +let IsCharOrStringType g ty = isCharTy g ty || isStringTy g ty + +let IsAddSubModType nm g ty = IsNumericOrIntegralEnumType g ty || (nm = "op_Addition" && IsCharOrStringType g ty) + +let IsBitwiseOpType g ty = isIntegerOrIntegerEnumTy g ty || (isEnumTy g ty) + +// For weak resolution, require a relevant primitive on one side +// For strong resolution +// - if there are relevant methods require an exact primitive on the other side. +// - if there are no relevant methods just require a non-variable type on the other side. +let IsBinaryOpArgTypePair p1 p2 permitWeakResolution minfos g ty1 ty2 = + p1 ty1 && + + match permitWeakResolution with + // During regular inference we apply a builtin resolution if either there are no relevant methods to solve traits (and the type is nominal), or if + // there are relevant methods we check that the type is precisely correct + | PermitWeakResolution.No -> + if isNil minfos then + // compat path + not (isTyparTy g ty2) + else + // normal path + p2 ty2 + + // During regular canonicalization (weak resolution) we don't do any check on the other type at all - we + // ignore the possibility that method overloads may resolve the constraint + | PermitWeakResolution.Yes false -> true + + // During codegen we only apply a builtin resolution if both the types are correct + | PermitWeakResolution.Yes true -> p2 ty2 + +let IsSymmetricBinaryOpArgTypePair p permitWeakResolution minfos g ty1 ty2 = + IsBinaryOpArgTypePair p p permitWeakResolution minfos g ty1 ty2 || + IsBinaryOpArgTypePair p p permitWeakResolution minfos g ty2 ty1 + +/// Checks if the knowledge we have of the argument types is enough to commit to a path that simulates that a +/// type supports the op_Addition, op_Subtraction or op_Modulus static members +let IsAddSubModTypePair nm permitWeakResolution minfos g ty1 ty2 = + IsSymmetricBinaryOpArgTypePair (IsAddSubModType nm g) permitWeakResolution minfos g ty1 ty2 + +/// Checks if the knowledge we have of the argument types is enough to commit to a path that simulates that +/// a type supports the op_LessThan, op_LessThanOrEqual, op_GreaterThan, op_GreaterThanOrEqual, op_Equality or op_Inequality static members +let IsRelationalOpArgTypePair permitWeakResolution minfos g ty1 ty2 = + IsSymmetricBinaryOpArgTypePair (IsRelationalType g) permitWeakResolution minfos g ty1 ty2 + +/// Checks if the knowledge we have of the argument types is enough to commit to a path that simulates that +/// a type supports the op_BitwiseAnd, op_BitwiseOr or op_ExclusiveOr static members +let IsBitwiseOpArgTypePair permitWeakResolution minfos g ty1 ty2 = + IsSymmetricBinaryOpArgTypePair (IsBitwiseOpType g) permitWeakResolution minfos g ty1 ty2 + +let IsMulDivTypeArgPairOneWay permitWeakResolution minfos g ty1 ty2 = + IsBinaryOpArgTypePair + (IsNumericOrIntegralEnumType g) + // This next condition checks that either + // - Neither type contributes any methods OR + // - We have the special case "decimal<_> * decimal". In this case we have some + // possibly-relevant methods from "decimal" but we ignore them in this case. + (fun ty2 -> IsNumericOrIntegralEnumType g ty2 || (Option.isSome (GetMeasureOfType g ty1) && isDecimalTy g ty2)) + permitWeakResolution + minfos + g + ty1 ty2 + +let IsMulDivTypeArgPair permitWeakResolution minfos g ty1 ty2 = + IsMulDivTypeArgPairOneWay permitWeakResolution minfos g ty1 ty2 || + IsMulDivTypeArgPairOneWay permitWeakResolution minfos g ty2 ty1 + +/// Checks if the knowledge we have of the argument types is enough to commit to a path that simulates that +/// a type supports the get_Sign instance member +let IsSignType g ty = + isSignedIntegerTy g ty || isFpTy g ty || isDecimalTy g ty + type TraitConstraintSolution = | TTraitUnsolved | TTraitBuiltIn @@ -778,10 +871,12 @@ let rec SolveTyparEqualsType (csenv: ConstraintSolverEnv) ndeep m2 (trace: Optio // Only solve constraints if this is not an error var if r.IsFromError then () else + // Check to see if this type variable is relevant to any trait constraints. // If so, re-solve the relevant constraints. if csenv.SolverState.ExtraCxs.ContainsKey r.Stamp then - do! RepeatWhileD ndeep (fun ndeep -> SolveRelevantMemberConstraintsForTypar csenv ndeep false trace r) + do! RepeatWhileD ndeep (fun ndeep -> SolveRelevantMemberConstraintsForTypar csenv ndeep PermitWeakResolution.No trace r) + // Re-solve the other constraints associated with this type variable return! solveTypMeetsTyparConstraints csenv ndeep m2 trace ty r @@ -826,7 +921,7 @@ and solveTypMeetsTyparConstraints (csenv: ConstraintSolverEnv) ndeep m2 trace ty | TyparConstraint.SimpleChoice(tys, m2) -> SolveTypeChoice csenv ndeep m2 trace ty tys | TyparConstraint.CoercesTo(ty2, m2) -> SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m2 trace None ty2 ty | TyparConstraint.MayResolveMember(traitInfo, m2) -> - SolveMemberConstraint csenv false false ndeep m2 trace traitInfo |> OperationResult.ignore + SolveMemberConstraint csenv false PermitWeakResolution.No ndeep m2 trace traitInfo |> OperationResult.ignore } @@ -1093,16 +1188,9 @@ and SolveDimensionlessNumericType (csenv: ConstraintSolverEnv) ndeep m2 trace ty /// don't. The type-directed static optimization rules in the library code that makes use of this /// will deal with the problem. /// -/// 2. Some additional solutions are forced prior to generalization (permitWeakResolution=true). These are, roughly speaking, rules -/// for binary-operand constraints arising from constructs such as "1.0 + x" where "x" is an unknown type. THe constraint here -/// involves two type parameters - one for the left, and one for the right. The left is already known to be Double. -/// In this situation (and in the absence of other evidence prior to generalization), constraint solving forces an assumption that -/// the right is also Double - this is "weak" because there is only weak evidence for it. -/// -/// permitWeakResolution also applies to resolutions of multi-type-variable constraints via method overloads. Method overloading gets applied even if -/// only one of the two type variables is known -/// -and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload permitWeakResolution ndeep m2 trace (TTrait(tys, nm, memFlags, argtys, rty, sln)): OperationResult = trackErrors { +/// 2. Some additional solutions are forced prior to generalization (permitWeakResolution= Yes or YesDuringCodeGen). See above +and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload (permitWeakResolution: PermitWeakResolution) ndeep m2 trace traitInfo : OperationResult = trackErrors { + let (TTrait(tys, nm, memFlags, traitObjAndArgTys, rty, sln, extSlns, traitAD)) = traitInfo // Do not re-solve if already solved if sln.Value.IsSome then return true else let g = csenv.g @@ -1115,66 +1203,31 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload // Remove duplicates from the set of types in the support let tys = ListSet.setify (typeAEquiv g aenv) tys + // Rebuild the trait info after removing duplicates - let traitInfo = TTrait(tys, nm, memFlags, argtys, rty, sln) + let traitInfo = TTrait(tys, nm, memFlags, traitObjAndArgTys, rty, sln, extSlns, traitAD) let rty = GetFSharpViewOfReturnType g rty + let traitAD = match traitAD with None -> AccessibilityLogic.AccessibleFromEverywhere | Some ad -> (ad :?> AccessorDomain) // Assert the object type if the constraint is for an instance member if memFlags.IsInstance then - match tys, argtys with + match tys, traitObjAndArgTys with | [ty], (h :: _) -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace h ty | _ -> do! ErrorD (ConstraintSolverError(FSComp.SR.csExpectedArguments(), m, m2)) + // Trait calls are only supported on pseudo type (variables) for e in tys do do! SolveTypStaticReq csenv trace HeadTypeStaticReq e - let argtys = if memFlags.IsInstance then List.tail argtys else argtys - + let argtys = if memFlags.IsInstance then List.tail traitObjAndArgTys else traitObjAndArgTys let minfos = GetRelevantMethodsForTrait csenv permitWeakResolution nm traitInfo let! res = trackErrors { - match minfos, tys, memFlags.IsInstance, nm, argtys with - | _, _, false, ("op_Division" | "op_Multiply"), [argty1;argty2] + match tys, memFlags.IsInstance, nm, argtys with + | _, false, ("op_Division" | "op_Multiply"), [argty1;argty2] when - // This simulates the existence of - // float * float -> float - // float32 * float32 -> float32 - // float<'u> * float<'v> -> float<'u 'v> - // float32<'u> * float32<'v> -> float32<'u 'v> - // decimal<'u> * decimal<'v> -> decimal<'u 'v> - // decimal<'u> * decimal -> decimal<'u> - // float32<'u> * float32<'v> -> float32<'u 'v> - // int * int -> int - // int64 * int64 -> int64 - // - // The rule is triggered by these sorts of inputs when permitWeakResolution=false - // float * float - // float * float32 // will give error - // decimal * decimal - // decimal * decimal <-- Note this one triggers even though "decimal" has some possibly-relevant methods - // float * Matrix // the rule doesn't trigger for this one since Matrix has overloads we can use and we prefer those instead - // float * Matrix // the rule doesn't trigger for this one since Matrix has overloads we can use and we prefer those instead - // - // The rule is triggered by these sorts of inputs when permitWeakResolution=true - // float * 'a - // 'a * float - // decimal<'u> * 'a - (let checkRuleAppliesInPreferenceToMethods argty1 argty2 = - // Check that at least one of the argument types is numeric - (IsNumericOrIntegralEnumType g argty1) && - // Check that the support of type variables is empty. That is, - // if we're canonicalizing, then having one of the types nominal is sufficient. - // If not, then both must be nominal (i.e. not a type variable). - (permitWeakResolution || not (isTyparTy g argty2)) && - // This next condition checks that either - // - Neither type contributes any methods OR - // - We have the special case "decimal<_> * decimal". In this case we have some - // possibly-relevant methods from "decimal" but we ignore them in this case. - (isNil minfos || (Option.isSome (GetMeasureOfType g argty1) && isDecimalTy g argty2)) in - - checkRuleAppliesInPreferenceToMethods argty1 argty2 || - checkRuleAppliesInPreferenceToMethods argty2 argty1) -> + IsMulDivTypeArgPair permitWeakResolution minfos g argty1 argty2 -> match GetMeasureOfType g argty1 with | Some (tcref, ms1) -> @@ -1198,52 +1251,48 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty1 return TTraitBuiltIn - | _, _, false, ("op_Addition" | "op_Subtraction" | "op_Modulus"), [argty1;argty2] - when // Ignore any explicit +/- overloads from any basic integral types - (minfos |> List.forall (fun minfo -> isIntegerTy g minfo.ApparentEnclosingType ) && - ( (IsNumericOrIntegralEnumType g argty1 || (nm = "op_Addition" && (isCharTy g argty1 || isStringTy g argty1))) && (permitWeakResolution || not (isTyparTy g argty2)) - || (IsNumericOrIntegralEnumType g argty2 || (nm = "op_Addition" && (isCharTy g argty2 || isStringTy g argty2))) && (permitWeakResolution || not (isTyparTy g argty1)))) -> + | _, false, ("op_Addition" | "op_Subtraction" | "op_Modulus"), [argty1;argty2] + when IsAddSubModTypePair nm permitWeakResolution minfos g argty1 argty2 -> + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty2 argty1 do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty1 return TTraitBuiltIn - | _, _, false, ("op_LessThan" | "op_LessThanOrEqual" | "op_GreaterThan" | "op_GreaterThanOrEqual" | "op_Equality" | "op_Inequality" ), [argty1;argty2] - when // Ignore any explicit overloads from any basic integral types - (minfos |> List.forall (fun minfo -> isIntegerTy g minfo.ApparentEnclosingType ) && - ( (IsRelationalType g argty1 && (permitWeakResolution || not (isTyparTy g argty2))) - || (IsRelationalType g argty2 && (permitWeakResolution || not (isTyparTy g argty1))))) -> + | _, false, ("op_LessThan" | "op_LessThanOrEqual" | "op_GreaterThan" | "op_GreaterThanOrEqual" | "op_Equality" | "op_Inequality" ), [argty1;argty2] + when IsRelationalOpArgTypePair permitWeakResolution minfos g argty1 argty2 -> + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty2 argty1 do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty g.bool_ty return TTraitBuiltIn // We pretend for uniformity that the numeric types have a static property called Zero and One // As with constants, only zero is polymorphic in its units - | [], [ty], false, "get_Zero", [] + | [ty], false, "get_Zero", [] when IsNumericType g ty -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty ty return TTraitBuiltIn - | [], [ty], false, "get_One", [] + | [ty], false, "get_One", [] when IsNumericType g ty || isCharTy g ty -> do! SolveDimensionlessNumericType csenv ndeep m2 trace ty do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty ty return TTraitBuiltIn - | [], _, false, ("DivideByInt"), [argty1;argty2] + | _, false, "DivideByInt", [argty1;argty2] when isFpTy g argty1 || isDecimalTy g argty1 -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty2 g.int_ty do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty1 return TTraitBuiltIn // We pretend for uniformity that the 'string' and 'array' types have an indexer property called 'Item' - | [], [ty], true, ("get_Item"), [argty1] + | [ty], true, "get_Item", [argty1] when isStringTy g ty -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty1 g.int_ty do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty g.char_ty return TTraitBuiltIn - | [], [ty], true, ("get_Item"), argtys + | [ty], true, "get_Item", argtys when isArrayTy g ty -> if rankOfArrayTy g ty <> argtys.Length then do! ErrorD(ConstraintSolverError(FSComp.SR.csIndexArgumentMismatch((rankOfArrayTy g ty), argtys.Length), m, m2)) @@ -1253,7 +1302,7 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty ety return TTraitBuiltIn - | [], [ty], true, ("set_Item"), argtys + | [ty], true, "set_Item", argtys when isArrayTy g ty -> if rankOfArrayTy g ty <> argtys.Length - 1 then do! ErrorD(ConstraintSolverError(FSComp.SR.csIndexArgumentMismatch((rankOfArrayTy g ty), (argtys.Length - 1)), m, m2)) @@ -1264,55 +1313,54 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace ety etys return TTraitBuiltIn - | [], _, false, ("op_BitwiseAnd" | "op_BitwiseOr" | "op_ExclusiveOr"), [argty1;argty2] - when (isIntegerOrIntegerEnumTy g argty1 || (isEnumTy g argty1)) && (permitWeakResolution || not (isTyparTy g argty2)) - || (isIntegerOrIntegerEnumTy g argty2 || (isEnumTy g argty2)) && (permitWeakResolution || not (isTyparTy g argty1)) -> + | _, false, ("op_BitwiseAnd" | "op_BitwiseOr" | "op_ExclusiveOr"), [argty1;argty2] + when IsBitwiseOpArgTypePair permitWeakResolution minfos g argty1 argty2 -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty2 argty1 do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty1 do! SolveDimensionlessNumericType csenv ndeep m2 trace argty1 return TTraitBuiltIn - | [], _, false, ("op_LeftShift" | "op_RightShift"), [argty1;argty2] - when isIntegerOrIntegerEnumTy g argty1 -> + | _, false, ("op_LeftShift" | "op_RightShift"), [argty1;argty2] + when isIntegerOrIntegerEnumTy g argty1 -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty2 g.int_ty do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty1 do! SolveDimensionlessNumericType csenv ndeep m2 trace argty1 return TTraitBuiltIn - | _, _, false, ("op_UnaryPlus"), [argty] + | _, false, "op_UnaryPlus", [argty] when IsNumericOrIntegralEnumType g argty -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty return TTraitBuiltIn - | _, _, false, ("op_UnaryNegation"), [argty] + | _, false, "op_UnaryNegation", [argty] when isSignedIntegerTy g argty || isFpTy g argty || isDecimalTy g argty -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty return TTraitBuiltIn - | _, _, true, ("get_Sign"), [] + | _, true, "get_Sign", [] when (let argty = tys.Head in isSignedIntegerTy g argty || isFpTy g argty || isDecimalTy g argty) -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty g.int32_ty return TTraitBuiltIn - | _, _, false, ("op_LogicalNot" | "op_OnesComplement"), [argty] + | _, false, ("op_LogicalNot" | "op_OnesComplement"), [argty] when isIntegerOrIntegerEnumTy g argty -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty do! SolveDimensionlessNumericType csenv ndeep m2 trace argty return TTraitBuiltIn - | _, _, false, ("Abs"), [argty] + | _, false, "Abs", [argty] when isSignedIntegerTy g argty || isFpTy g argty || isDecimalTy g argty -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty return TTraitBuiltIn - | _, _, false, "Sqrt", [argty1] + | _, false, "Sqrt", [argty1] when isFpTy g argty1 -> match GetMeasureOfType g argty1 with | Some (tcref, _) -> @@ -1324,14 +1372,15 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty1 return TTraitBuiltIn - | _, _, false, ("Sin" | "Cos" | "Tan" | "Sinh" | "Cosh" | "Tanh" | "Atan" | "Acos" | "Asin" | "Exp" | "Ceiling" | "Floor" | "Round" | "Truncate" | "Log10" | "Log" | "Sqrt"), [argty] + | _, false, ("Sin" | "Cos" | "Tan" | "Sinh" | "Cosh" | "Tanh" | "Atan" | "Acos" | "Asin" | "Exp" | "Ceiling" | "Floor" | "Round" | "Truncate" | "Log10" | "Log" | "Sqrt"), [argty] when isFpTy g argty -> do! SolveDimensionlessNumericType csenv ndeep m2 trace argty do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty return TTraitBuiltIn - | _, _, false, ("op_Explicit"), [argty] + // Simulate solutions to op_Implicit and op_Explicit + | _, false, "op_Explicit", [argty] when (// The input type. (IsNonDecimalNumericOrIntegralEnumType g argty || isStringTy g argty || isCharTy g argty) && // The output type @@ -1344,7 +1393,7 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload return TTraitBuiltIn - | _, _, false, ("op_Explicit"), [argty] + | _, false, "op_Explicit", [argty] when (// The input type. (IsNumericOrIntegralEnumType g argty || isStringTy g argty) && // The output type @@ -1352,16 +1401,17 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload return TTraitBuiltIn - | [], _, false, "Pow", [argty1; argty2] + | _, false, "Pow", [argty1; argty2] when isFpTy g argty1 -> do! SolveDimensionlessNumericType csenv ndeep m2 trace argty1 do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty2 argty1 - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty1 + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty1 return TTraitBuiltIn - | _, _, false, ("Atan2"), [argty1; argty2] + | _, false, "Atan2", [argty1; argty2] when isFpTy g argty1 -> + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty2 argty1 match GetMeasureOfType g argty1 with | None -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty1 @@ -1380,11 +1430,11 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload let propName = nm.[4..] let props = tys |> List.choose (fun ty -> - match TryFindIntrinsicNamedItemOfType csenv.InfoReader (propName, AccessibleFromEverywhere) FindMemberFlag.IgnoreOverrides m ty with + match TryFindIntrinsicNamedItemOfType csenv.InfoReader (propName, traitAD) FindMemberFlag.IgnoreOverrides m ty with | Some (RecdFieldItem rfinfo) when (isGetProp || rfinfo.RecdField.IsMutable) && (rfinfo.IsStatic = not memFlags.IsInstance) && - IsRecdFieldAccessible amap m AccessibleFromEverywhere rfinfo.RecdFieldRef && + IsRecdFieldAccessible amap m traitAD rfinfo.RecdFieldRef && not rfinfo.LiteralValue.IsSome && not rfinfo.RecdField.IsCompilerGenerated -> Some (rfinfo, isSetProp) @@ -1446,12 +1496,13 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload |> List.choose (fun minfo -> if minfo.IsCurried then None else let callerArgs = argtys |> List.map (fun argty -> CallerArg(argty, m, false, dummyExpr)) - let minst = FreshenMethInfo m minfo - let objtys = minfo.GetObjArgTypes(amap, m, minst) - Some(CalledMeth(csenv.InfoReader, None, false, FreshenMethInfo, m, AccessibleFromEverywhere, minfo, minst, minst, None, objtys, [(callerArgs, [])], false, false, None))) + let minst = FreshenMethInfo None m minfo + let callerObjTys = if memFlags.IsInstance then [ List.head traitObjAndArgTys ] else [] + Some(CalledMeth(csenv.InfoReader, None, false, FreshenMethInfo None, m, traitAD, minfo, minst, minst, None, callerObjTys, [(callerArgs, [])], false, false, None))) let methOverloadResult, errors = - trace.CollectThenUndoOrCommit (fun (a, _) -> Option.isSome a) (fun trace -> ResolveOverloading csenv (WithTrace trace) nm ndeep (Some traitInfo) (0, 0) AccessibleFromEverywhere calledMethGroup false (Some rty)) + trace.CollectThenUndoOrCommit (fun (a, _) -> Option.isSome a) (fun trace -> + ResolveOverloading csenv (WithTrace trace) nm ndeep (Some traitInfo) (0, 0) traitAD calledMethGroup false (Some rty)) match anonRecdPropSearch, recdPropSearch, methOverloadResult with | Some (anonInfo, tinst, i), None, None -> @@ -1489,7 +1540,7 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload // If there's nothing left to learn then raise the errors. // Note: we should likely call MemberConstraintIsReadyForResolution here when permitWeakResolution=false but for stability // reasons we use the more restrictive isNil frees. - if (permitWeakResolution && MemberConstraintIsReadyForWeakResolution csenv traitInfo) || isNil frees then + if (permitWeakResolution.Permit && MemberConstraintIsReadyForWeakResolution csenv traitInfo) || isNil frees then do! errors // Otherwise re-record the trait waiting for canonicalization else @@ -1546,6 +1597,7 @@ and MemberConstraintSolutionOfMethInfo css m minfo minst = FSMethSln(ty, vref, minst) | MethInfo.DefaultStructCtor _ -> error(InternalError("the default struct constructor was the unexpected solution to a trait constraint", m)) + #if !NO_EXTENSIONTYPING | ProvidedMeth(amap, mi, _, m) -> let g = amap.g @@ -1576,11 +1628,21 @@ and TransactMemberConstraintSolution traitInfo (trace: OptionalTrace) sln = let prev = traitInfo.Solution trace.Exec (fun () -> traitInfo.Solution <- Some sln) (fun () -> traitInfo.Solution <- prev) +and GetRelevantExtensionMethodsForTrait m (amap: Import.ImportMap) (traitInfo: TraitConstraintInfo) = + + // TODO: check the use of 'allPairs' - not all these extensions apply to each type variable. + (traitInfo.SupportTypes, traitInfo.PossibleExtensionSolutions) + ||> List.allPairs + |> List.choose (fun (traitSupportTy,extMem) -> + match (extMem :?> ExtensionMember) with + | FSExtMem (vref, pri) -> Some (FSMeth(amap.g, traitSupportTy, vref, Some pri) ) + | ILExtMem (actualParent, minfo, pri) -> TrySelectExtensionMethInfoOfILExtMem m amap traitSupportTy (actualParent, minfo, pri)) + /// Only consider overload resolution if canonicalizing or all the types are now nominal. /// That is, don't perform resolution if more nominal information may influence the set of available overloads -and GetRelevantMethodsForTrait (csenv: ConstraintSolverEnv) permitWeakResolution nm (TTrait(tys, _, memFlags, argtys, rty, soln) as traitInfo): MethInfo list = +and GetRelevantMethodsForTrait (csenv: ConstraintSolverEnv) (permitWeakResolution: PermitWeakResolution) nm (TTrait(tys, _, memFlags, argtys, rty, soln, extSlns, ad) as traitInfo) : MethInfo list = let results = - if permitWeakResolution || MemberConstraintSupportIsReadyForDeterminingOverloads csenv traitInfo then + if permitWeakResolution.Permit || MemberConstraintSupportIsReadyForDeterminingOverloads csenv traitInfo then let m = csenv.m let minfos = match memFlags.MemberKind with @@ -1593,6 +1655,17 @@ and GetRelevantMethodsForTrait (csenv: ConstraintSolverEnv) permitWeakResolution // We merge based on whether minfos use identical metadata or not. let minfos = List.reduce (ListSet.unionFavourLeft MethInfo.MethInfosUseIdenticalDefinitions) minfos + // Get the extension method that may be relevant to solving the constraint as MethInfo objects. + // Extension members are not used when canonicalizing prior to generalization (permitWeakResolution=true) + let extMInfos = + if MemberConstraintSupportIsReadyForDeterminingOverloads csenv traitInfo then + GetRelevantExtensionMethodsForTrait csenv.m csenv.amap traitInfo + else [] + + let extMInfos = extMInfos |> ListSet.setify MethInfo.MethInfosUseIdenticalDefinitions + + let minfos = minfos @ extMInfos + /// Check that the available members aren't hiding a member from the parent (depth 1 only) let relevantMinfos = minfos |> List.filter(fun minfo -> not minfo.IsDispatchSlot && not minfo.IsVirtual && minfo.IsInstance) minfos @@ -1602,19 +1675,20 @@ and GetRelevantMethodsForTrait (csenv: ConstraintSolverEnv) permitWeakResolution |> List.exists (fun minfo2 -> MethInfosEquivByNameAndSig EraseAll true csenv.g csenv.amap m minfo2 minfo1))) else [] + // The trait name "op_Explicit" also covers "op_Implicit", so look for that one too. if nm = "op_Explicit" then - results @ GetRelevantMethodsForTrait csenv permitWeakResolution "op_Implicit" (TTrait(tys, "op_Implicit", memFlags, argtys, rty, soln)) + results @ GetRelevantMethodsForTrait csenv permitWeakResolution "op_Implicit" (TTrait(tys, "op_Implicit", memFlags, argtys, rty, soln, extSlns, ad)) else results /// The nominal support of the member constraint -and GetSupportOfMemberConstraint (csenv: ConstraintSolverEnv) (TTrait(tys, _, _, _, _, _)) = +and GetSupportOfMemberConstraint (csenv: ConstraintSolverEnv) (TTrait(tys, _, _, _, _, _, _, _)) = tys |> List.choose (tryAnyParTyOption csenv.g) /// Check if the support is fully solved. -and SupportOfMemberConstraintIsFullySolved (csenv: ConstraintSolverEnv) (TTrait(tys, _, _, _, _, _)) = +and SupportOfMemberConstraintIsFullySolved (csenv: ConstraintSolverEnv) (TTrait(tys, _, _, _, _, _, _, _)) = tys |> List.forall (isAnyParTy csenv.g >> not) // This may be relevant to future bug fixes, see https://github.com/Microsoft/visualfsharp/issues/3814 @@ -1623,7 +1697,7 @@ and SupportOfMemberConstraintIsFullySolved (csenv: ConstraintSolverEnv) (TTrait( // tys |> List.exists (isAnyParTy csenv.g >> not) /// Get all the unsolved typars (statically resolved or not) relevant to the member constraint -and GetFreeTyparsOfMemberConstraint (csenv: ConstraintSolverEnv) (TTrait(tys, _, _, argtys, rty, _)) = +and GetFreeTyparsOfMemberConstraint (csenv: ConstraintSolverEnv) (TTrait(tys, _, _, argtys, rty, _, _, _)) = freeInTypesLeftToRightSkippingConstraints csenv.g (tys@argtys@ Option.toList rty) and MemberConstraintIsReadyForWeakResolution csenv traitInfo = @@ -1651,7 +1725,13 @@ and SolveRelevantMemberConstraints (csenv: ConstraintSolverEnv) ndeep permitWeak | ValueNone -> ResultD false)) -and SolveRelevantMemberConstraintsForTypar (csenv: ConstraintSolverEnv) ndeep permitWeakResolution (trace: OptionalTrace) tp = +and GetTraitFreshner (ad: AccessorDomain) (nenv: NameResolutionEnv) (traitInfo: TraitConstraintInfo) = + let slns = + NameMultiMap.find traitInfo.MemberName nenv.eExtensionMembersByName + |> List.map (fun extMem -> (extMem :> TraitPossibleExtensionMemberSolution)) + slns, (ad :> TraitAccessorDomain) + +and SolveRelevantMemberConstraintsForTypar (csenv:ConstraintSolverEnv) ndeep (permitWeakResolution: PermitWeakResolution) (trace:OptionalTrace) tp = let cxst = csenv.SolverState.ExtraCxs let tpn = tp.Stamp let cxs = cxst.FindAll tpn @@ -1666,9 +1746,9 @@ and SolveRelevantMemberConstraintsForTypar (csenv: ConstraintSolverEnv) ndeep pe SolveMemberConstraint csenv true permitWeakResolution (ndeep+1) m2 trace traitInfo) and CanonicalizeRelevantMemberConstraints (csenv: ConstraintSolverEnv) ndeep trace tps = - SolveRelevantMemberConstraints csenv ndeep true trace tps + SolveRelevantMemberConstraints csenv ndeep (PermitWeakResolution.Yes false) trace tps -and AddMemberConstraint (csenv: ConstraintSolverEnv) ndeep m2 trace traitInfo support frees = +and AddMemberConstraint (csenv: ConstraintSolverEnv) ndeep m2 (trace: OptionalTrace) traitInfo support (frees: Typar list) = let g = csenv.g let aenv = csenv.EquivEnv let cxst = csenv.SolverState.ExtraCxs @@ -1683,7 +1763,7 @@ and AddMemberConstraint (csenv: ConstraintSolverEnv) ndeep m2 trace traitInfo su let cxs = cxst.FindAll tpn // check the constraint is not already listed for this type variable - if not (cxs |> List.exists (fun (traitInfo2, _) -> traitsAEquiv g aenv traitInfo traitInfo2)) then + if not (cxs |> List.exists (fun (traitInfo2, _valRefs) -> traitsAEquiv g aenv traitInfo traitInfo2)) then trace.Exec (fun () -> csenv.SolverState.ExtraCxs.Add (tpn, (traitInfo, m2))) (fun () -> csenv.SolverState.ExtraCxs.Remove tpn) ) @@ -1710,8 +1790,8 @@ and AddConstraint (csenv: ConstraintSolverEnv) ndeep m2 trace tp newConstraint // may require type annotations. See FSharp 1.0 bug 6477. let consistent tpc1 tpc2 = match tpc1, tpc2 with - | (TyparConstraint.MayResolveMember(TTrait(tys1, nm1, memFlags1, argtys1, rty1, _), _), - TyparConstraint.MayResolveMember(TTrait(tys2, nm2, memFlags2, argtys2, rty2, _), _)) + | (TyparConstraint.MayResolveMember(TTrait(tys1, nm1, memFlags1, argtys1, rty1, _, _, _), _), + TyparConstraint.MayResolveMember(TTrait(tys2, nm2, memFlags2, argtys2, rty2, _, _, _), _)) when (memFlags1 = memFlags2 && nm1 = nm2 && // Multiple op_Explicit and op_Implicit constraints can exist for the same type variable. @@ -2795,7 +2875,7 @@ let AddCxMethodConstraint denv css m trace traitInfo = TryD (fun () -> trackErrors { do! - SolveMemberConstraint (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) true false 0 m trace traitInfo + SolveMemberConstraint (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) true PermitWeakResolution.No 0 m trace traitInfo |> OperationResult.ignore }) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) @@ -2855,31 +2935,45 @@ let CodegenWitnessThatTypeSupportsTraitConstraint tcVal g amap m (traitInfo: Tra InfoReader = new InfoReader(g, amap) } let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m (DisplayEnv.Empty g) - let! _res = SolveMemberConstraint csenv true true 0 m NoTrace traitInfo + let! _res = SolveMemberConstraint csenv true (PermitWeakResolution.Yes true) 0 m NoTrace traitInfo let sln = match traitInfo.Solution with | None -> Choice5Of5() | Some sln -> + + // Given the solution information, reconstruct the MethInfo for the solution match sln with - | ILMethSln(origTy, extOpt, mref, minst) -> - let metadataTy = convertToTypeWithMetadataIfPossible g origTy - let tcref = tcrefOfAppTy g metadataTy - let mdef = IL.resolveILMethodRef tcref.ILTyconRawMetadata mref + | ILMethSln(apparentTy, extOpt, mref, minst) -> + + let metadataTy = convertToTypeWithMetadataIfPossible g apparentTy + + // Find the actual type containing the solution + let actualTyconRef = + match extOpt with + | None -> tcrefOfAppTy g metadataTy + | Some ilActualTypeRef -> Import.ImportILTypeRef amap m ilActualTypeRef + + let mdef = IL.resolveILMethodRef actualTyconRef.ILTyconRawMetadata mref + let ilMethInfo = match extOpt with - | None -> MethInfo.CreateILMeth(amap, m, origTy, mdef) - | Some ilActualTypeRef -> - let actualTyconRef = Import.ImportILTypeRef amap m ilActualTypeRef - MethInfo.CreateILExtensionMeth(amap, m, origTy, actualTyconRef, None, mdef) + | None -> MethInfo.CreateILMeth(amap, m, apparentTy, mdef) + | Some _ -> MethInfo.CreateILExtensionMeth(amap, m, apparentTy, actualTyconRef, None, mdef) + Choice1Of5 (ilMethInfo, minst) + | FSMethSln(ty, vref, minst) -> Choice1Of5 (FSMeth(g, ty, vref, None), minst) + | FSRecdFieldSln(tinst, rfref, isSetProp) -> Choice2Of5 (tinst, rfref, isSetProp) + | FSAnonRecdFieldSln(anonInfo, tinst, i) -> Choice3Of5 (anonInfo, tinst, i) + | BuiltInSln -> Choice5Of5 () + | ClosedExprSln expr -> Choice4Of5 expr return! @@ -2894,6 +2988,7 @@ let CodegenWitnessThatTypeSupportsTraitConstraint tcVal g amap m (traitInfo: Tra let argTypes = minfo.GetParamTypes(amap, m, methArgTys) |> List.concat + // do not apply coercion to the 'receiver' argument let receiverArgOpt, argExprs = if minfo.IsInstance then @@ -2901,6 +2996,7 @@ let CodegenWitnessThatTypeSupportsTraitConstraint tcVal g amap m (traitInfo: Tra | h :: t -> Some h, t | argExprs -> None, argExprs else None, argExprs + let convertedArgs = (argExprs, argTypes) ||> List.map2 (fun expr expectedTy -> mkCoerceIfNeeded g expectedTy (tyOfExpr g expr) expr) match receiverArgOpt with | Some r -> r :: convertedArgs @@ -2986,7 +3082,7 @@ let IsApplicableMethApprox g amap m (minfo: MethInfo) availObjTy = ExtraCxs = HashMultiMap(10, HashIdentity.Structural) InfoReader = new InfoReader(g, amap) } let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m (DisplayEnv.Empty g) - let minst = FreshenMethInfo m minfo + let minst = FreshenMethInfo None m minfo match minfo.GetObjArgTypes(amap, m, minst) with | [reqdObjTy] -> let reqdObjTy = if isByrefTy g reqdObjTy then destByrefTy g reqdObjTy else reqdObjTy // This is to support byref extension methods. diff --git a/src/fsharp/ConstraintSolver.fsi b/src/fsharp/ConstraintSolver.fsi index 6aa40c6ea96..5608c8070cc 100644 --- a/src/fsharp/ConstraintSolver.fsi +++ b/src/fsharp/ConstraintSolver.fsi @@ -7,6 +7,7 @@ open FSharp.Compiler open FSharp.Compiler.AccessibilityLogic open FSharp.Compiler.Ast open FSharp.Compiler.ErrorLogger +open FSharp.Compiler.NameResolution open FSharp.Compiler.Tast open FSharp.Compiler.Range open FSharp.Compiler.Import @@ -34,18 +35,27 @@ val NewErrorMeasure : unit -> Measure /// Create a list of inference type variables, one for each element in the input list val NewInferenceTypes : 'a list -> TType list +/// Freshen a trait for use at a particular location +type TraitFreshener = (TraitConstraintInfo -> TraitPossibleExtensionMemberSolutions * TraitAccessorDomain) + /// Given a set of formal type parameters and their constraints, make new inference type variables for /// each and ensure that the constraints on the new type variables are adjusted to refer to these. -val FreshenAndFixupTypars : range -> TyparRigidity -> Typars -> TType list -> Typars -> Typars * TyparInst * TType list +val FreshenAndFixupTypars : TraitFreshener option -> range -> TyparRigidity -> Typars -> TType list -> Typars -> Typars * TyparInst * TType list + +/// Make new type inference variables for the use of a generic construct at a particular location +val FreshenTypeInst : TraitFreshener option -> range -> Typars -> Typars * TyparInst * TType list -val FreshenTypeInst : range -> Typars -> Typars * TyparInst * TType list +/// Make new type inference variables for the use of a generic construct at a particular location +val FreshenTypars : TraitFreshener option -> range -> Typars -> TType list -val FreshenTypars : range -> Typars -> TType list +/// Make new type inference variables for the use of a method at a particular location +val FreshenMethInfo : TraitFreshener option -> range -> MethInfo -> TType list -val FreshenMethInfo : range -> MethInfo -> TType list +/// Get the trait freshener for a particular location +val GetTraitFreshner : AccessorDomain -> NameResolutionEnv -> TraitFreshener [] -/// Information about the context of a type equation. +/// Information about the context of a type equation, for better error reporting type ContextInfo = /// No context was given. @@ -163,4 +173,7 @@ val CodegenWitnessThatTypeSupportsTraitConstraint : TcValF -> TcGlobals -> Impor val ChooseTyparSolutionAndSolve : ConstraintSolverState -> DisplayEnv -> Typar -> unit +/// Get the type variables that may help provide solutions to a statically resolved member trait constraint +val GetSupportOfMemberConstraint : ConstraintSolverEnv -> TraitConstraintInfo -> Typar list + val IsApplicableMethApprox : TcGlobals -> ImportMap -> range -> MethInfo -> TType -> bool diff --git a/src/fsharp/FSComp.txt b/src/fsharp/FSComp.txt index de26c9b349a..465a4c7995f 100644 --- a/src/fsharp/FSComp.txt +++ b/src/fsharp/FSComp.txt @@ -1080,7 +1080,7 @@ lexIndentOffForML,"Consider using a file with extension '.ml' or '.mli' instead" 1212,tcOptionalArgsMustComeAfterNonOptionalArgs,"Optional arguments must come at the end of the argument list, after any non-optional arguments" 1213,tcConditionalAttributeUsage,"Attribute 'System.Diagnostics.ConditionalAttribute' is only valid on methods or attribute classes" #1214,monoRegistryBugWorkaround,"Could not determine highest installed .NET framework version from Registry keys, using version 2.0" -1215,tcMemberOperatorDefinitionInExtrinsic,"Extension members cannot provide operator overloads. Consider defining the operator as part of the type definition instead." +#1215,tcMemberOperatorDefinitionInExtrinsic,"Extension members cannot provide operator overloads. Consider defining the operator as part of the type definition instead." 1216,ilwriteMDBFileNameCannotBeChangedWarning,"The name of the MDB file must be .mdb. The --pdb option will be ignored." 1217,ilwriteMDBMemberMissing,"MDB generation failed. Could not find compatible member %s" 1218,ilwriteErrorCreatingMdb,"Cannot generate MDB debug information. Failed to load the 'MonoSymbolWriter' type from the 'Mono.CompilerServices.SymbolWriter.dll' assembly." diff --git a/src/fsharp/FindUnsolved.fs b/src/fsharp/FindUnsolved.fs index d11a1284176..02c5e56b151 100644 --- a/src/fsharp/FindUnsolved.fs +++ b/src/fsharp/FindUnsolved.fs @@ -135,7 +135,7 @@ and accOp cenv env (op, tyargs, args, _m) = accTypeInst cenv env enclTypeArgs accTypeInst cenv env methTypeArgs accTypeInst cenv env tys - | TOp.TraitCall (TTrait(tys, _nm, _, argtys, rty, _sln)) -> + | TOp.TraitCall (TTrait(tys, _nm, _, argtys, rty, _sln, _extSlns, _ad)) -> argtys |> accTypeInst cenv env rty |> Option.iter (accTy cenv env) tys |> List.iter (accTy cenv env) diff --git a/src/fsharp/MethodCalls.fs b/src/fsharp/MethodCalls.fs index 9b657f6f8b9..c604b0f2c04 100644 --- a/src/fsharp/MethodCalls.fs +++ b/src/fsharp/MethodCalls.fs @@ -1037,12 +1037,12 @@ let BuildFSharpMethodApp g m (vref: ValRef) vexp vexprty (args: Exprs) = retTy /// Build a call to an F# method. -let BuildFSharpMethodCall g m (ty, vref: ValRef) valUseFlags minst args = +let BuildFSharpMethodCall g m (vref: ValRef) valUseFlags declaringTypeInst minst args = let vexp = Expr.Val (vref, valUseFlags, m) let vexpty = vref.Type - let tpsorig, tau = vref.TypeScheme - let vtinst = argsOfAppTy g ty @ minst - if tpsorig.Length <> vtinst.Length then error(InternalError("BuildFSharpMethodCall: unexpected List.length mismatch", m)) + let tpsorig,tau = vref.TypeScheme + let vtinst = declaringTypeInst @ minst + if tpsorig.Length <> vtinst.Length then error(InternalError("BuildFSharpMethodCall: unexpected typar length mismatch",m)) let expr = mkTyAppExpr m (vexp, vexpty) vtinst let exprty = instType (mkTyparInst tpsorig vtinst) tau BuildFSharpMethodApp g m vref expr exprty args @@ -1060,8 +1060,8 @@ let MakeMethInfoCall amap m minfo minst args = let isProp = false // not necessarily correct, but this is only used post-creflect where this flag is irrelevant BuildILMethInfoCall g amap m isProp ilminfo valUseFlags minst direct args |> fst - | FSMeth(g, ty, vref, _) -> - BuildFSharpMethodCall g m (ty, vref) valUseFlags minst args |> fst + | FSMeth(g, _, vref, _) -> + BuildFSharpMethodCall g m vref valUseFlags minfo.DeclaringTypeInst minst args |> fst | DefaultStructCtor(_, ty) -> mkDefault (m, ty) diff --git a/src/fsharp/NameResolution.fs b/src/fsharp/NameResolution.fs index 10e330f2070..08a8d5a7ee5 100644 --- a/src/fsharp/NameResolution.fs +++ b/src/fsharp/NameResolution.fs @@ -284,6 +284,8 @@ type ExtensionMember = /// IL-style extension member, backed by some kind of method with an [] attribute | ILExtMem of TyconRef * MethInfo * ExtensionMethodPriority + interface TraitPossibleExtensionMemberSolution + /// Check if two extension members refer to the same definition static member Equality g e1 e2 = match e1, e2 with @@ -309,7 +311,12 @@ type ExtensionMember = | FSExtMem (_, pri) -> pri | ILExtMem (_, _, pri) -> pri -type FullyQualifiedFlag = + member x.LogicalName = + match x with + | FSExtMem (vref, _) -> vref.LogicalName + | ILExtMem (_, minfo, _) -> minfo.LogicalName + +type FullyQualifiedFlag = /// Only resolve full paths | FullyQualified /// Resolve any paths accessible via 'open' @@ -369,6 +376,9 @@ type NameResolutionEnv = /// Extension members by type and name eIndexedExtensionMembers: TyconRefMultiMap + /// Extension members by name + eExtensionMembersByName: NameMultiMap + /// Other extension members unindexed by type eUnindexedExtensionMembers: ExtensionMember list @@ -391,6 +401,7 @@ type NameResolutionEnv = eFullyQualifiedTyconsByAccessNames = LayeredMultiMap.Empty eFullyQualifiedTyconsByDemangledNameAndArity = LayeredMap.Empty eIndexedExtensionMembers = TyconRefMultiMap<_>.Empty + eExtensionMembersByName = NameMultiMap<_>.Empty eUnindexedExtensionMembers = [] eTypars = Map.empty } @@ -658,6 +669,17 @@ let AddValRefToExtensionMembers pri (eIndexedExtensionMembers: TyconRefMultiMap< else eIndexedExtensionMembers +/// Add an F# value to the table of available extension members, if necessary, as an FSharp-style extension member +let AddValRefToExtensionMembersByNameTable logicalName (eExtensionMembersByName: NameMultiMap<_>) extMemInfo = + NameMultiMap.add logicalName extMemInfo eExtensionMembersByName + +/// Add an F# value to the table of available extension members, if necessary, as an FSharp-style extension member +let AddValRefToExtensionMembersByName pri (eExtensionMembersByName: NameMultiMap<_>) (vref:ValRef) = + if vref.IsMember && vref.IsExtensionMember then + AddValRefToExtensionMembersByNameTable vref.LogicalName eExtensionMembersByName (FSExtMem (vref,pri)) + else + eExtensionMembersByName + /// This entry point is used to add some extra items to the environment for Visual Studio, e.g. static members let AddFakeNamedValRefToNameEnv nm nenv vref = @@ -688,6 +710,7 @@ let AddValRefsToNameEnvWithPriority bulkAddMode pri nenv (vrefs: ValRef []) = { nenv with eUnqualifiedItems = AddValRefsToItems bulkAddMode nenv.eUnqualifiedItems vrefs eIndexedExtensionMembers = (nenv.eIndexedExtensionMembers, vrefs) ||> Array.fold (AddValRefToExtensionMembers pri) + eExtensionMembersByName = (nenv.eExtensionMembersByName, vrefs) ||> Array.fold (AddValRefToExtensionMembersByName pri) ePatItems = (nenv.ePatItems, vrefs) ||> Array.fold AddValRefsToActivePatternsNameEnv } /// Add a single F# value to the environment. @@ -700,6 +723,7 @@ let AddValRefToNameEnv nenv (vref: ValRef) = else nenv.eUnqualifiedItems eIndexedExtensionMembers = AddValRefToExtensionMembers pri nenv.eIndexedExtensionMembers vref + eExtensionMembersByName = AddValRefToExtensionMembersByName pri nenv.eExtensionMembersByName vref ePatItems = AddValRefsToActivePatternsNameEnv nenv.ePatItems vref } @@ -808,12 +832,12 @@ let private AddPartsOfTyconRefToNameEnv bulkAddMode ownDefinition (g: TcGlobals) let ucrefs = if isIL then [] else tcref.UnionCasesAsList |> List.map tcref.MakeNestedUnionCaseRef let flds = if isIL then [| |] else tcref.AllFieldsArray - let eIndexedExtensionMembers, eUnindexedExtensionMembers = + let eIndexedExtensionMembers, eExtensionMembersByName, eUnindexedExtensionMembers = let ilStyleExtensionMeths = GetCSharpStyleIndexedExtensionMembersForTyconRef amap m tcref - ((nenv.eIndexedExtensionMembers, nenv.eUnindexedExtensionMembers), ilStyleExtensionMeths) ||> List.fold (fun (tab1, tab2) extMemInfo -> + ((nenv.eIndexedExtensionMembers, nenv.eExtensionMembersByName, nenv.eUnindexedExtensionMembers),ilStyleExtensionMeths) ||> List.fold (fun (tab1,tab2,tab3) extMemInfo -> match extMemInfo with - | Choice1Of2 (tcref, extMemInfo) -> tab1.Add (tcref, extMemInfo), tab2 - | Choice2Of2 extMemInfo -> tab1, extMemInfo :: tab2) + | Choice1Of2 (tcref, extMemInfo) -> tab1.Add (tcref, extMemInfo), AddValRefToExtensionMembersByNameTable extMemInfo.LogicalName tab2 extMemInfo, tab3 + | Choice2Of2 extMemInfo -> tab1, AddValRefToExtensionMembersByNameTable extMemInfo.LogicalName tab2 extMemInfo, extMemInfo :: tab3) let isILOrRequiredQualifiedAccess = isIL || (not ownDefinition && HasFSharpAttribute g g.attrib_RequireQualifiedAccessAttribute tcref.Attribs) let eFieldLabels = @@ -871,6 +895,7 @@ let private AddPartsOfTyconRefToNameEnv bulkAddMode ownDefinition (g: TcGlobals) eUnqualifiedItems = eUnqualifiedItems ePatItems = ePatItems eIndexedExtensionMembers = eIndexedExtensionMembers + eExtensionMembersByName = eExtensionMembersByName eUnindexedExtensionMembers = eUnindexedExtensionMembers } let nenv = diff --git a/src/fsharp/NameResolution.fsi b/src/fsharp/NameResolution.fsi index c0121ce153e..be426bf5823 100755 --- a/src/fsharp/NameResolution.fsi +++ b/src/fsharp/NameResolution.fsi @@ -150,6 +150,11 @@ type ExtensionMember = /// IL-style extension member, backed by some kind of method with an [] attribute | ILExtMem of TyconRef * MethInfo * ExtensionMethodPriority + interface TraitPossibleExtensionMemberSolution + + /// The logical name, e.g. for constraint solving + member LogicalName : string + /// Describes the sequence order of the introduction of an extension method. Extension methods that are introduced /// later through 'open' get priority in overload resolution. member Priority : ExtensionMethodPriority @@ -169,8 +174,9 @@ type NameResolutionEnv = /// Modules accessible via "." notation. Note this is a multi-map. /// Adding a module abbreviation adds it a local entry to this List.map. /// Likewise adding a ccu or opening a path adds entries to this List.map. + eModulesAndNamespaces: NameMultiMap - + /// Fully qualified modules and namespaces. 'open' does not change this. eFullyQualifiedModulesAndNamespaces: NameMultiMap @@ -195,6 +201,9 @@ type NameResolutionEnv = /// Extension members by type and name eIndexedExtensionMembers: TyconRefMultiMap + /// Extension members by name + eExtensionMembersByName: NameMultiMap + /// Other extension members unindexed by type eUnindexedExtensionMembers: ExtensionMember list @@ -589,5 +598,5 @@ val GetVisibleNamespacesAndModulesAtPoint : NameResolver -> NameResolutionEnv -> val IsItemResolvable : NameResolver -> NameResolutionEnv -> range -> AccessorDomain -> string list -> Item -> bool -val TrySelectExtensionMethInfoOfILExtMem : range -> ImportMap -> TType -> TyconRef * MethInfo * ExtensionMethodPriority -> MethInfo option - \ No newline at end of file +val TrySelectExtensionMethInfoOfILExtMem : range -> ImportMap -> TType -> TyconRef * MethInfo * ExtensionMethodPriority -> MethInfo option + diff --git a/src/fsharp/NicePrint.fs b/src/fsharp/NicePrint.fs index 6479d6c6729..598a963341b 100644 --- a/src/fsharp/NicePrint.fs +++ b/src/fsharp/NicePrint.fs @@ -864,7 +864,7 @@ module private PrintTypes = WordL.arrow ^^ (layoutTyparRefWithInfo denv env tp)) |> longConstraintPrefix] - and private layoutTraitWithInfo denv env (TTrait(tys, nm, memFlags, argtys, rty, _)) = + and private layoutTraitWithInfo denv env (TTrait(tys, nm, memFlags, argtys, rty, _, _, _)) = let nm = DemangleOperatorName nm if denv.shortConstraints then WordL.keywordMember ^^ wordL (tagMember nm) @@ -876,9 +876,19 @@ module private PrintTypes = match tys with | [ty] -> layoutTypeWithInfo denv env ty | tys -> bracketL (layoutTypesWithInfoAndPrec denv env 2 (wordL (tagKeyword "or")) tys) - tysL ^^ wordL (tagPunctuation ":") --- + + let argtys = + if memFlags.IsInstance then + match argtys with + | [] | [_] -> [denv.g.unit_ty] + | _ :: rest -> rest + else argtys + + let argtysL = layoutTypesWithInfoAndPrec denv env 2 (wordL (tagPunctuation "*")) argtys + + tysL ^^ wordL (tagPunctuation ":") --- bracketL (stat ++ wordL (tagMember nm) ^^ wordL (tagPunctuation ":") --- - ((layoutTypesWithInfoAndPrec denv env 2 (wordL (tagPunctuation "*")) argtys --- wordL (tagPunctuation "->")) --- (layoutTypeWithInfo denv env rty))) + ((argtysL --- wordL (tagPunctuation "->")) --- (layoutTypeWithInfo denv env rty))) /// Layout a unit expression diff --git a/src/fsharp/PostInferenceChecks.fs b/src/fsharp/PostInferenceChecks.fs index aedf7252d9c..fc29a6d2607 100644 --- a/src/fsharp/PostInferenceChecks.fs +++ b/src/fsharp/PostInferenceChecks.fs @@ -325,7 +325,7 @@ let rec CheckTypeDeep (cenv: cenv) ((visitTy, visitTyconRefOpt, visitAppTyOpt, v | TType_var tp when tp.Solution.IsSome -> for cx in tp.Constraints do match cx with - | TyparConstraint.MayResolveMember((TTrait(_, _, _, _, _, soln)), _) -> + | TyparConstraint.MayResolveMember((TTrait(_, _, _, _, _, soln, _, _)), _) -> match visitTraitSolutionOpt, !soln with | Some visitTraitSolution, Some sln -> visitTraitSolution sln | _ -> () @@ -402,7 +402,7 @@ and CheckTypeConstraintDeep cenv f g env x = | TyparConstraint.IsReferenceType _ | TyparConstraint.RequiresDefaultConstructor _ -> () -and CheckTraitInfoDeep cenv ((_, _, _, visitTraitSolutionOpt, _) as f) g env (TTrait(tys, _, _, argtys, rty, soln)) = +and CheckTraitInfoDeep cenv ((_, _, _, visitTraitSolutionOpt, _) as f) g env (TTrait(tys, _, _, argtys, rty, soln, _extSlns, _ad)) = CheckTypesDeep cenv f g env tys CheckTypesDeep cenv f g env argtys Option.iter (CheckTypeDeep cenv f g env true ) rty diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs index 3d474dadbcc..53b818df190 100644 --- a/src/fsharp/TastOps.fs +++ b/src/fsharp/TastOps.fs @@ -62,7 +62,7 @@ type TyconRefMap<'T>(imap: StampMap<'T>) = member m.Add (v: TyconRef) x = TyconRefMap (imap.Add (v.Stamp, x)) member m.Remove (v: TyconRef) = TyconRefMap (imap.Remove v.Stamp) member m.IsEmpty = imap.IsEmpty - + member m.Contents = imap static member Empty: TyconRefMap<'T> = TyconRefMap Map.empty static member OfList vs = (vs, TyconRefMap<'T>.Empty) ||> List.foldBack (fun (x, y) acc -> acc.Add x y) @@ -103,13 +103,17 @@ type Remap = tyconRefRemap: TyconRefRemap /// Remove existing trait solutions? - removeTraitSolutions: bool } + removeTraitSolutions: bool + + /// A map indicating how to fill in extSlns for traits as we copy an expression. Indexed by the member name of the trait + extSlnsMap: Map } let emptyRemap = { tpinst = emptyTyparInst tyconRefRemap = emptyTyconRefRemap valRemap = ValMap.Empty - removeTraitSolutions = false } + removeTraitSolutions = false + extSlnsMap = Map.empty } type Remap with static member Empty = emptyRemap @@ -244,25 +248,25 @@ and remapTypesAux tyenv types = List.mapq (remapTypeAux tyenv) types and remapTyparConstraintsAux tyenv cs = cs |> List.choose (fun x -> match x with - | TyparConstraint.CoercesTo(ty, m) -> - Some(TyparConstraint.CoercesTo (remapTypeAux tyenv ty, m)) + | TyparConstraint.CoercesTo(ty,m) -> + Some(TyparConstraint.CoercesTo (remapTypeAux tyenv ty,m)) | TyparConstraint.MayResolveMember(traitInfo, m) -> - Some(TyparConstraint.MayResolveMember (remapTraitAux tyenv traitInfo, m)) - | TyparConstraint.DefaultsTo(priority, ty, m) -> Some(TyparConstraint.DefaultsTo(priority, remapTypeAux tyenv ty, m)) - | TyparConstraint.IsEnum(uty, m) -> - Some(TyparConstraint.IsEnum(remapTypeAux tyenv uty, m)) - | TyparConstraint.IsDelegate(uty1, uty2, m) -> - Some(TyparConstraint.IsDelegate(remapTypeAux tyenv uty1, remapTypeAux tyenv uty2, m)) - | TyparConstraint.SimpleChoice(tys, m) -> Some(TyparConstraint.SimpleChoice(remapTypesAux tyenv tys, m)) - | TyparConstraint.SupportsComparison _ - | TyparConstraint.SupportsEquality _ + Some(TyparConstraint.MayResolveMember (remapTraitAux tyenv traitInfo,m)) + | TyparConstraint.DefaultsTo(priority,ty,m) -> Some(TyparConstraint.DefaultsTo(priority,remapTypeAux tyenv ty,m)) + | TyparConstraint.IsEnum(uty,m) -> + Some(TyparConstraint.IsEnum(remapTypeAux tyenv uty,m)) + | TyparConstraint.IsDelegate(uty1,uty2,m) -> + Some(TyparConstraint.IsDelegate(remapTypeAux tyenv uty1,remapTypeAux tyenv uty2,m)) + | TyparConstraint.SimpleChoice(tys,m) -> Some(TyparConstraint.SimpleChoice(remapTypesAux tyenv tys,m)) + | TyparConstraint.SupportsComparison _ + | TyparConstraint.SupportsEquality _ | TyparConstraint.SupportsNull _ | TyparConstraint.IsUnmanaged _ | TyparConstraint.IsNonNullableStruct _ | TyparConstraint.IsReferenceType _ | TyparConstraint.RequiresDefaultConstructor _ -> Some x) -and remapTraitAux tyenv (TTrait(tys, nm, mf, argtys, rty, slnCell)) = +and remapTraitAux tyenv (TTrait(tys, nm, mf, argtys, rty, slnCell, extSlns, ad)) = let slnCell = match !slnCell with | None -> None @@ -283,7 +287,14 @@ and remapTraitAux tyenv (TTrait(tys, nm, mf, argtys, rty, slnCell)) = | ClosedExprSln e -> ClosedExprSln e // no need to remap because it is a closed expression, referring only to external types Some sln - // Note: we reallocate a new solution cell on every traversal of a trait constraint + + let extSlnsNew = + if tyenv.extSlnsMap.ContainsKey nm then + tyenv.extSlnsMap.[nm] + else + extSlns // TODO: do we need to remap here??? + + // Note: we reallocate a new solution cell (though keep existing solutions unless 'removeTraitSolutions'=true) on every traversal of a trait constraint // This feels incorrect for trait constraints that are quantified: it seems we should have // formal binders for trait constraints when they are quantified, just as // we have formal binders for type variables. @@ -291,7 +302,7 @@ and remapTraitAux tyenv (TTrait(tys, nm, mf, argtys, rty, slnCell)) = // The danger here is that a solution for one syntactic occurrence of a trait constraint won't // be propagated to other, "linked" solutions. However trait constraints don't appear in any algebra // in the same way as types - TTrait(remapTypesAux tyenv tys, nm, mf, remapTypesAux tyenv argtys, Option.map (remapTypeAux tyenv) rty, ref slnCell) + TTrait(remapTypesAux tyenv tys, nm, mf, remapTypesAux tyenv argtys, Option.map (remapTypeAux tyenv) rty, ref slnCell, extSlnsNew, ad) and bindTypars tps tyargs tpinst = match tps with @@ -384,12 +395,14 @@ let mkInstRemap tpinst = { tyconRefRemap = emptyTyconRefRemap tpinst = tpinst valRemap = ValMap.Empty - removeTraitSolutions = false } + removeTraitSolutions = false + extSlnsMap = Map.empty } // entry points for "typar -> TType" instantiation -let instType tpinst x = if isNil tpinst then x else remapTypeAux (mkInstRemap tpinst) x -let instTypes tpinst x = if isNil tpinst then x else remapTypesAux (mkInstRemap tpinst) x -let instTrait tpinst x = if isNil tpinst then x else remapTraitAux (mkInstRemap tpinst) x +let instType tpinst x = if isNil tpinst then x else remapTypeAux (mkInstRemap tpinst) x +let instTypes tpinst x = if isNil tpinst then x else remapTypesAux (mkInstRemap tpinst) x +let instTrait tpinst x = if isNil tpinst then x else remapTraitAux (mkInstRemap tpinst) x +let instValRef tpinst x = if isNil tpinst then x else remapValRef (mkInstRemap tpinst) x let instTyparConstraints tpinst x = if isNil tpinst then x else remapTyparConstraintsAux (mkInstRemap tpinst) x let instSlotSig tpinst ss = remapSlotSig (fun _ -> []) (mkInstRemap tpinst) ss let copySlotSig ss = remapSlotSig (fun _ -> []) Remap.Empty ss @@ -896,8 +909,8 @@ type TypeEquivEnv with TypeEquivEnv.Empty.BindEquivTypars tps1 tps2 let rec traitsAEquivAux erasureFlag g aenv traitInfo1 traitInfo2 = - let (TTrait(tys1, nm, mf1, argtys, rty, _)) = traitInfo1 - let (TTrait(tys2, nm2, mf2, argtys2, rty2, _)) = traitInfo2 + let (TTrait(tys1, nm, mf1, argtys, rty, _, _extSlnsNew, _ad)) = traitInfo1 + let (TTrait(tys2, nm2, mf2, argtys2, rty2, _, _extSlnsNew2, _ad2)) = traitInfo2 mf1 = mf2 && nm = nm2 && ListSet.equals (typeAEquivAux erasureFlag g aenv) tys1 tys2 && @@ -1418,6 +1431,7 @@ type TyconRefMultiMap<'T>(contents: TyconRefMap<'T list>) = | _ -> [] member m.Add (v, x) = TyconRefMultiMap<'T>(contents.Add v (x :: m.Find v)) + member m.Contents = contents static member Empty = TyconRefMultiMap<'T>(TyconRefMap<_>.Empty) static member OfList vs = (vs, TyconRefMultiMap<'T>.Empty) ||> List.foldBack (fun (x, y) acc -> acc.Add (x, y)) @@ -2033,7 +2047,7 @@ and accFreeInTyparConstraint opts tpc acc = | TyparConstraint.IsUnmanaged _ | TyparConstraint.RequiresDefaultConstructor _ -> acc -and accFreeInTrait opts (TTrait(tys, _, _, argtys, rty, sln)) acc = +and accFreeInTrait opts (TTrait(tys, _, _, argtys, rty, sln, _, _ad)) acc = Option.foldBack (accFreeInTraitSln opts) sln.Value (accFreeInTypes opts tys (accFreeInTypes opts argtys @@ -2153,10 +2167,11 @@ and accFreeInTyparConstraintLeftToRight g cxFlag thruFlag acc tpc = | TyparConstraint.IsReferenceType _ | TyparConstraint.RequiresDefaultConstructor _ -> acc -and accFreeInTraitLeftToRight g cxFlag thruFlag acc (TTrait(tys, _, _, argtys, rty, _)) = +and accFreeInTraitLeftToRight g cxFlag thruFlag acc (TTrait(tys, _, _, argtys, rty, _, _extSlns, _ad)) = let acc = accFreeInTypesLeftToRight g cxFlag thruFlag acc tys let acc = accFreeInTypesLeftToRight g cxFlag thruFlag acc argtys let acc = Option.fold (accFreeInTypeLeftToRight g cxFlag thruFlag) acc rty + // Note, the _extSlns are _not_ considered free. acc and accFreeTyparRefLeftToRight g cxFlag thruFlag acc (tp: Typar) = @@ -2215,6 +2230,52 @@ let valOfBind (b: Binding) = b.Var let valsOfBinds (binds: Bindings) = binds |> List.map (fun b -> b.Var) +//-------------------------------------------------------------------------- +// Collect extSlns. This is done prior to beta reduction of type parameters when inlining. We take the (solved) +// type arguments and strip them for extSlns, and record those extSlns in the remapped/copied/instantiated body +// of the implementation. +//-------------------------------------------------------------------------- + +let rec accExtSlnsInTyparConstraints acc cxs = + List.fold accExtSlnsInTyparConstraint acc cxs + +and accExtSlnsInTyparConstraint acc tpc = + match tpc with + | TyparConstraint.MayResolveMember (traitInfo, _) -> accExtSlnsInTrait acc traitInfo + | _ -> acc + +and accExtSlnsInTrait acc (TTrait(_typs, nm, _, _argtys, _rty, _, extSlns, _ad)) = + // We don't traverse the contents of traits, that wouldn't terminate and is not necessary since the type variables individiaull contain the extSlns we need + //let acc = accExtSlnsInTypes g acc typs + //let acc = accExtSlnsInTypes g acc argtys + //let acc = Option.fold (accExtSlnsInType g) acc rty + // Only record the extSlns if they have been solved in a useful way + if isNil extSlns then acc else + Map.add nm extSlns acc + +and accExtSlnsTyparRef acc (tp:Typar) = + let acc = accExtSlnsInTyparConstraints acc tp.Constraints + match tp.Solution with + | None -> acc + | Some sln -> accExtSlnsInType acc sln + +and accExtSlnsInType acc ty = + // NOTE: Unlike almost everywhere else, we do NOT strip ANY equations here. + // We _must_ traverse the solved typar containing the new extSlns for the grounded typar constraint, that's the whole point + match ty with + | TType_tuple (_, tys) + | TType_anon (_, tys) + | TType_app (_, tys) + | TType_ucase (_, tys) -> accExtSlnsInTypes acc tys + | TType_fun (d, r) -> accExtSlnsInType (accExtSlnsInType acc d) r + | TType_var r -> accExtSlnsTyparRef acc r + | TType_forall (_tps, r) -> accExtSlnsInType acc r + | TType_measure unt -> List.foldBack (fun (tp, _) acc -> accExtSlnsTyparRef acc tp) (ListMeasureVarOccsWithNonZeroExponents unt) acc + +and accExtSlnsInTypes acc tys = (acc, tys) ||> List.fold accExtSlnsInType + +let extSlnsInTypes tys = accExtSlnsInTypes Map.empty tys + //-------------------------------------------------------------------------- // Values representing member functions on F# types //-------------------------------------------------------------------------- @@ -3411,7 +3472,7 @@ module DebugPrint = and auxTraitL env (ttrait: TraitConstraintInfo) = #if DEBUG - let (TTrait(tys, nm, memFlags, argtys, rty, _)) = ttrait + let (TTrait(tys, nm, memFlags, argtys, rty, _, _extSlns, _ad)) = ttrait match global_g with | None -> wordL (tagText "") | Some g -> @@ -4008,7 +4069,8 @@ let mkRepackageRemapping mrpi = { valRemap = ValMap.OfList (mrpi.RepackagedVals |> List.map (fun (vref, x) -> vref.Deref, x)) tpinst = emptyTyparInst tyconRefRemap = TyconRefMap.OfList mrpi.RepackagedEntities - removeTraitSolutions = false } + removeTraitSolutions = false + extSlnsMap = Map.empty } //-------------------------------------------------------------------------- // Compute instances of the above for mty -> mty @@ -4243,7 +4305,7 @@ let IsHidden setF accessF remapF = check rest (remapF rpi x)) fun mrmi x -> check mrmi x - + let IsHiddenTycon mrmi x = IsHidden (fun mhi -> mhi.HiddenTycons) (fun tc -> tc.Accessibility) (fun rpi x -> (remapTyconRef rpi.tyconRefRemap (mkLocalTyconRef x)).Deref) mrmi x let IsHiddenTyconRepr mrmi x = IsHidden (fun mhi -> mhi.HiddenTyconReprs) (fun v -> v.TypeReprAccessibility) (fun rpi x -> (remapTyconRef rpi.tyconRefRemap (mkLocalTyconRef x)).Deref) mrmi x @@ -4641,7 +4703,7 @@ and accFreeInOp opts op acc = | TOp.Reraise -> accUsesRethrow true acc - | TOp.TraitCall (TTrait(tys, _, _, argtys, rty, sln)) -> + | TOp.TraitCall (TTrait (tys, _, _, argtys, rty, sln, _extSlns, _ad)) -> Option.foldBack (accFreeVarsInTraitSln opts) sln.Value (accFreeVarsInTys opts tys (accFreeVarsInTys opts argtys @@ -5507,7 +5569,10 @@ let copyExpr g compgen e = remapExpr g compgen Remap.Empty e let copyImplFile g compgen e = remapImplFile g compgen Remap.Empty e |> fst -let instExpr g tpinst e = remapExpr g CloneAll (mkInstRemap tpinst) e +/// Copy an expression applying a type instantiation. +let instExpr g tpinst e = + let extSlnsMap = extSlnsInTypes (List.map snd tpinst) + remapExpr g CloneAll { mkInstRemap tpinst with extSlnsMap = extSlnsMap } e //-------------------------------------------------------------------------- // Replace Marks - adjust debugging marks when a lambda gets diff --git a/src/fsharp/TastOps.fsi b/src/fsharp/TastOps.fsi index 176f64df72c..ea358d68725 100755 --- a/src/fsharp/TastOps.fsi +++ b/src/fsharp/TastOps.fsi @@ -488,6 +488,8 @@ type TyconRefMultiMap<'T> = /// Make a new map, containing a new entry for the given type definition member Add : TyconRef * 'T -> TyconRefMultiMap<'T> + member Contents : TyconRefMap<'T list> + /// The empty map static member Empty : TyconRefMultiMap<'T> @@ -529,9 +531,18 @@ type ValRemap = ValMap [] type Remap = { tpinst : TyparInst + + /// Values to remap valRemap: ValRemap + + /// TyconRefs to remap tyconRefRemap : TyconRefRemap - removeTraitSolutions: bool } + + /// Remove existing trait solutions? + removeTraitSolutions: bool + + /// A map indicating how to fill in extSlns for traits as we copy an expression. Indexed by the member name of the trait + extSlnsMap: Map } static member Empty : Remap @@ -552,6 +563,7 @@ val instTypes : TyparInst -> TypeInst -> TypeInst val instTyparConstraints : TyparInst -> TyparConstraint list -> TyparConstraint list val instTrait : TyparInst -> TraitConstraintInfo -> TraitConstraintInfo +val instValRef : TyparInst -> ValRef -> ValRef //------------------------------------------------------------------------- // From typars to types @@ -1454,6 +1466,10 @@ type TypeDefMetadata = /// Extract metadata from a type definition val metadataOfTycon : Tycon -> TypeDefMetadata +#if EXTENSIONTYPING +val extensionInfoOfTy : TcGlobals -> TType -> TyconRepresentation +#endif + /// Extract metadata from a type val metadataOfTy : TcGlobals -> TType -> TypeDefMetadata diff --git a/src/fsharp/TastPickle.fs b/src/fsharp/TastPickle.fs index ffdf31efbdf..5ce2a657c51 100644 --- a/src/fsharp/TastPickle.fs +++ b/src/fsharp/TastPickle.fs @@ -1504,7 +1504,8 @@ let p_trait_sln sln st = p_byte 5 st; p_tup3 p_anonInfo p_tys p_int (a, b, c) st -let p_trait (TTrait(a, b, c, d, e, f)) st = +let p_trait (TTrait(a, b, c, d, e, f, _extSlns, _ad)) st = + // The _extSlns do not get pickled. We are assuming this is a generic or solved constraint p_tup6 p_tys p_string p_MemberFlags p_tys (p_option p_ty) (p_option p_trait_sln) (a, b, c, d, e, !f) st let u_anonInfo_data st = @@ -1536,10 +1537,10 @@ let u_trait_sln st = FSAnonRecdFieldSln(a, b, c) | _ -> ufailwith st "u_trait_sln" -let u_trait st = +let u_trait st = let a, b, c, d, e, f = u_tup6 u_tys u_string u_MemberFlags u_tys (u_option u_ty) (u_option u_trait_sln) st - TTrait (a, b, c, d, e, ref f) - + // extSlns starts empty. TODO: check the ramifications of this when inlining solved trait calls from other assemblies + TTrait (a, b, c, d, e, ref f, [], None) let p_rational q st = p_int32 (GetNumerator q) st; p_int32 (GetDenominator q) st diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs index 6609d5ad959..8b6174ad598 100644 --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -219,6 +219,8 @@ type TcEnv = member tenv.AccessRights = tenv.eAccessRights + member tenv.TraitFreshner = Some (GetTraitFreshner tenv.AccessRights tenv.NameEnv) + override tenv.ToString() = "TcEnv(...)" /// Compute the value of this computed, cached field @@ -309,6 +311,8 @@ let addInternalsAccessibility env (ccu: CcuThunk) = eAccessRights = computeAccessRights env.eAccessPath eInternalsVisibleCompPaths env.eFamilyType // update this computed field eInternalsVisibleCompPaths = compPath :: env.eInternalsVisibleCompPaths } +let ModifyNameResEnv f env = { env with eNameResEnv = f env.NameEnv } + /// Add a local value to TcEnv let AddLocalValPrimitive (v: Val) env = { env with @@ -368,7 +372,7 @@ let AddLocalTycons g amap m (tycons: Tycon list) env = /// Add a list of type definitions to TcEnv and report them to the sink let AddLocalTyconsAndReport tcSink scopem g amap m tycons env = let env = AddLocalTycons g amap m tycons env - CallEnvSink tcSink (scopem, env.NameEnv, env.eAccessRights) + CallEnvSink tcSink (scopem, env.NameEnv, env.AccessRights) env /// Adjust the TcEnv to account for opening the set of modules, namespaces or static classes implied by an `open` declaration @@ -444,7 +448,7 @@ let AddLocalSubModule g amap m env (modul: ModuleOrNamespace) = /// Add a "module X = ..." definition to the TcEnv and report it to the sink let AddLocalSubModuleAndReport tcSink scopem g amap m env (modul: ModuleOrNamespace) = let env = AddLocalSubModule g amap m env modul - CallEnvSink tcSink (scopem, env.NameEnv, env.eAccessRights) + CallEnvSink tcSink (scopem, env.NameEnv, env.AccessRights) env /// Add a set of explicitly declared type parameters as being available in the TcEnv @@ -514,7 +518,7 @@ type cenv = /// Create a new compilation environment static member Create (g, isScript, niceNameGen, amap, topCcu, isSig, haveSig, conditionalDefines, tcSink, tcVal, isInternalTestSpanStackReferring) = let infoReader = new InfoReader(g, amap) - let instantiationGenerator m tpsorig = ConstraintSolver.FreshenTypars m tpsorig + let instantiationGenerator m tpsorig = ConstraintSolver.FreshenTypars None m tpsorig // TODO: check 'None' here for env.TraitFreshner let nameResolver = new NameResolver(g, amap, infoReader, instantiationGenerator) { g = g amap = amap @@ -537,8 +541,8 @@ type cenv = override __.ToString() = "" -let CopyAndFixupTypars m rigid tpsorig = - ConstraintSolver.FreshenAndFixupTypars m rigid [] [] tpsorig +let CopyAndFixupTypars traitFreshner m rigid tpsorig = + ConstraintSolver.FreshenAndFixupTypars traitFreshner m rigid [] [] tpsorig let UnifyTypes cenv (env: TcEnv) m actualTy expectedTy = ConstraintSolver.AddCxTypeEqualsType env.eContextInfo env.DisplayEnv cenv.css m (tryNormalizeMeasureInType cenv.g actualTy) (tryNormalizeMeasureInType cenv.g expectedTy) @@ -1066,9 +1070,6 @@ let MakeMemberDataAndMangledNameForMemberVal(g, tcref, isExtrinsic, attrs, optIm if n<>3 && opTakesThreeArgs then warning(Error(FSComp.SR.memberOperatorDefinitionWithNonTripleArgument(name, n), m)) if not (isNil otherArgs) then warning(Error(FSComp.SR.memberOperatorDefinitionWithCurriedArguments name, m)) - if isExtrinsic && IsMangledOpName id.idText then - warning(Error(FSComp.SR.tcMemberOperatorDefinitionInExtrinsic(), id.idRange)) - ValMemberInfoTransient(memberInfo, logicalName, compiledName) type OverridesOK = @@ -1912,33 +1913,33 @@ let MakeAndPublishSimpleVals cenv env m names mergeNamesInOneNameresEnv = // to C<_> occurs then generate C for a fresh type inference variable ?ty. //------------------------------------------------------------------------- -let FreshenTyconRef m rigid (tcref: TyconRef) declaredTyconTypars = +let FreshenTyconRef traitFreshner m rigid (tcref: TyconRef) declaredTyconTypars = let tpsorig = declaredTyconTypars let tps = copyTypars tpsorig if rigid <> TyparRigidity.Rigid then tps |> List.iter (fun tp -> tp.SetRigidity rigid) - let renaming, tinst = FixupNewTypars m [] [] tpsorig tps + let renaming, tinst = FixupNewTypars traitFreshner m [] [] tpsorig tps (TType_app(tcref, List.map mkTyparTy tpsorig), tps, renaming, TType_app(tcref, tinst)) -let FreshenPossibleForallTy g m rigid ty = +let FreshenPossibleForallTy traitFreshner g m rigid ty = let tpsorig, tau = tryDestForallTy g ty if isNil tpsorig then [], [], [], tau else // tps may be have been equated to other tps in equi-recursive type inference and units-of-measure type inference. Normalize them here let tpsorig = NormalizeDeclaredTyparsForEquiRecursiveInference g tpsorig - let tps, renaming, tinst = CopyAndFixupTypars m rigid tpsorig + let tps, renaming, tinst = CopyAndFixupTypars traitFreshner m rigid tpsorig tpsorig, tps, tinst, instType renaming tau -let FreshenTyconRef2 m (tcref: TyconRef) = - let tps, renaming, tinst = FreshenTypeInst m (tcref.Typars m) +let FreshenTyconRef2 traitFreshner m (tcref: TyconRef) = + let tps, renaming, tinst = FreshenTypeInst traitFreshner m (tcref.Typars m) tps, renaming, tinst, TType_app (tcref, tinst) /// Given a abstract method, which may be a generic method, freshen the type in preparation /// to apply it as a constraint to the method that implements the abstract slot -let FreshenAbstractSlot g amap m synTyparDecls absMethInfo = +let FreshenAbstractSlot traitFreshner g amap m synTyparDecls absMethInfo = // Work out if an explicit instantiation has been given. If so then the explicit type // parameters will be made rigid and checked for generalization. If not then auto-generalize @@ -1960,7 +1961,7 @@ let FreshenAbstractSlot g amap m synTyparDecls absMethInfo = let ttps = absMethInfo.GetFormalTyparsOfDeclaringType m let ttinst = argsOfAppTy g absMethInfo.ApparentEnclosingType let rigid = if typarsFromAbsSlotAreRigid then TyparRigidity.Rigid else TyparRigidity.Flexible - ConstraintSolver.FreshenAndFixupTypars m rigid ttps ttinst fmtps + ConstraintSolver.FreshenAndFixupTypars traitFreshner m rigid ttps ttinst fmtps // Work out the required type of the member let argTysFromAbsSlot = argTys |> List.mapSquared (instType typarInstFromAbsSlot) @@ -2012,7 +2013,7 @@ let BuildFieldMap cenv env isPartial ty flds m = // Record the precise resolution of the field for intellisense let item = FreshenRecdFieldRef cenv.nameResolver m fref2 - CallNameResolutionSink cenv.tcSink ((snd fld).idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, ad) + CallNameResolutionSink cenv.tcSink ((snd fld).idRange, env.eNameResEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, ad) CheckRecdFieldAccessible cenv.amap m env.eAccessRights fref2 |> ignore CheckFSharpAttributes cenv.g fref2.PropertyAttribs m |> CommitOperationResult @@ -2677,11 +2678,11 @@ module EventDeclarationNormalization = /// Make a copy of the "this" type for a generic object type, e.g. List<'T> --> List<'?> for a fresh inference variable. /// Also adjust the "this" type to take into account whether the type is a struct. -let FreshenObjectArgType cenv m rigid tcref isExtrinsic declaredTyconTypars = +let FreshenObjectArgType cenv traitFreshner m rigid tcref isExtrinsic declaredTyconTypars = #if EXTENDED_EXTENSION_MEMBERS // indicates if extension members can add additional constraints to type parameters let tcrefObjTy, enclosingDeclaredTypars, renaming, objTy = FreshenTyconRef m (if isExtrinsic then TyparRigidity.Flexible else rigid) tcref declaredTyconTypars #else - let tcrefObjTy, enclosingDeclaredTypars, renaming, objTy = FreshenTyconRef m rigid tcref declaredTyconTypars + let tcrefObjTy, enclosingDeclaredTypars, renaming, objTy = FreshenTyconRef traitFreshner m rigid tcref declaredTyconTypars #endif // Struct members have a byref 'this' type (unless they are extrinsic extension members) let thisTy = @@ -2748,10 +2749,10 @@ let TcValEarlyGeneralizationConsistencyCheck cenv (env: TcEnv) (v: Val, vrec, ti /// F# object model member, in which case the optInst is the type instantiation /// inferred by member overload resolution, and vrefFlags indicate if the /// member is being used in a special way, i.e. may be one of: -/// | CtorValUsedAsSuperInit "inherit Panel()" -/// | CtorValUsedAsSelfInit "new() = new OwnType(3)" -/// | VSlotDirectCall "base.OnClick(eventArgs)" -let TcVal checkAttributes cenv env tpenv (vref: ValRef) optInst optAfterResolution m = +/// | CtorValUsedAsSuperInit "inherit Panel()" +/// | CtorValUsedAsSelfInit "new() = new OwnType(3)" +/// | VSlotDirectCall "base.OnClick(eventArgs)" +let TcVal traitFreshner checkAttributes cenv env tpenv (vref: ValRef) optInst optAfterResolution m = let (tpsorig, _, _, _, tinst, _) as res = let v = vref.Deref let vrec = v.RecursiveValInfo @@ -2772,7 +2773,7 @@ let TcVal checkAttributes cenv env tpenv (vref: ValRef) optInst optAfterResoluti // The value may still be generic, e.g. // [] // let Null = null - let tpsorig, _, tinst, tau = FreshenPossibleForallTy cenv.g m TyparRigidity.Flexible vty + let tpsorig, _, tinst, tau = FreshenPossibleForallTy traitFreshner cenv.g m TyparRigidity.Flexible vty tpsorig, Expr.Const (c, m, tau), isSpecial, tau, tinst, tpenv | None -> @@ -2802,8 +2803,8 @@ let TcVal checkAttributes cenv env tpenv (vref: ValRef) optInst optAfterResoluti tpsorig, NormalValUse, tinst, tau, tpenv | ValInRecScope true | ValNotInRecScope -> - let tpsorig, _, tinst, tau = FreshenPossibleForallTy cenv.g m TyparRigidity.Flexible vty - tpsorig, NormalValUse, tinst, tau, tpenv + let tpsorig, _, tptys, tau = FreshenPossibleForallTy traitFreshner cenv.g m TyparRigidity.Flexible vty + tpsorig, NormalValUse, tptys, tau, tpenv // If we have got an explicit instantiation then use that | Some(vrefFlags, checkTys) -> @@ -2823,7 +2824,7 @@ let TcVal checkAttributes cenv env tpenv (vref: ValRef) optInst optAfterResoluti tpsorig, vrefFlags, tinst, tau2, tpenv | ValInRecScope true | ValNotInRecScope -> - let tpsorig, tps, tptys, tau = FreshenPossibleForallTy cenv.g m TyparRigidity.Flexible vty + let tpsorig, tps, tptys, tau = FreshenPossibleForallTy traitFreshner cenv.g m TyparRigidity.Flexible vty //dprintfn "After Freshen: tau = %s" (Layout.showL (typeL tau)) let (tinst: TypeInst), tpenv = checkTys tpenv (tps |> List.map (fun tp -> tp.Kind)) checkInst tinst @@ -2833,7 +2834,7 @@ let TcVal checkAttributes cenv env tpenv (vref: ValRef) optInst optAfterResoluti TcValEarlyGeneralizationConsistencyCheck cenv env (v, vrec, tinst, vty, tau, m) //dprintfn "After Unify: tau = %s" (Layout.showL (typeL tau)) - tpsorig, vrefFlags, tinst, tau, tpenv + tpsorig, vrefFlags, tptys, tau, tpenv let exprForVal = Expr.Val (vref, vrefFlags, m) let exprForVal = mkTyAppExpr m (exprForVal, vty) tinst @@ -2862,13 +2863,13 @@ let LightweightTcValForUsingInBuildMethodCall g (vref: ValRef) vrefFlags (vrefTy else match v.LiteralValue with | Some c -> - let _, _, _, tau = FreshenPossibleForallTy g m TyparRigidity.Flexible vty + let _, _, _, tau = FreshenPossibleForallTy None g m TyparRigidity.Flexible vty Expr.Const (c, m, tau), tau | None -> // Instantiate the value let tau = // If we have got an explicit instantiation then use that - let _, tps, tptys, tau = FreshenPossibleForallTy g m TyparRigidity.Flexible vty + let _, tps, tptys, tau = FreshenPossibleForallTy None g m TyparRigidity.Flexible vty if tptys.Length <> vrefTypeInst.Length then error(Error(FSComp.SR.tcTypeParameterArityMismatch(tps.Length, vrefTypeInst.Length), m)) instType (mkTyparInst tps vrefTypeInst) tau @@ -3045,7 +3046,7 @@ let BuildPossiblyConditionalMethodCall cenv env isMutable m isProp minfo valUseF | _ -> #endif let tcVal valref valUse ttypes m = - let _, a, _, b, _, _ = TcVal true cenv env emptyUnscopedTyparEnv valref (Some (valUse, (fun x _ -> ttypes, x))) None m + let _, a, _, b, _, _ = TcVal env.TraitFreshner true cenv env emptyUnscopedTyparEnv valref (Some (valUse, (fun x _ -> ttypes, x))) None m a, b BuildMethodCall tcVal cenv.g cenv.amap isMutable m isProp minfo valUseFlags minst objArgs args @@ -3301,7 +3302,7 @@ let AnalyzeArbitraryExprAsEnumerable cenv (env: TcEnv) localAlloc m exprty expr | Exception e -> Exception e | Result getEnumerator_minfo -> - let getEnumerator_minst = FreshenMethInfo m getEnumerator_minfo + let getEnumerator_minst = FreshenMethInfo env.TraitFreshner m getEnumerator_minfo let retTypeOfGetEnumerator = getEnumerator_minfo.GetFSharpReturnTy(cenv.amap, m, getEnumerator_minst) if hasArgs getEnumerator_minfo getEnumerator_minst then err true tyToSearchForGetEnumeratorAndItem else @@ -3309,7 +3310,7 @@ let AnalyzeArbitraryExprAsEnumerable cenv (env: TcEnv) localAlloc m exprty expr | Exception e -> Exception e | Result moveNext_minfo -> - let moveNext_minst = FreshenMethInfo m moveNext_minfo + let moveNext_minst = FreshenMethInfo env.TraitFreshner m moveNext_minfo let retTypeOfMoveNext = moveNext_minfo.GetFSharpReturnTy(cenv.amap, m, moveNext_minst) if not (typeEquiv cenv.g cenv.g.bool_ty retTypeOfMoveNext) then err false retTypeOfGetEnumerator else if hasArgs moveNext_minfo moveNext_minst then err false retTypeOfGetEnumerator else @@ -3318,7 +3319,7 @@ let AnalyzeArbitraryExprAsEnumerable cenv (env: TcEnv) localAlloc m exprty expr | Exception e -> Exception e | Result get_Current_minfo -> - let get_Current_minst = FreshenMethInfo m get_Current_minfo + let get_Current_minst = FreshenMethInfo env.TraitFreshner m get_Current_minfo if hasArgs get_Current_minfo get_Current_minst then err false retTypeOfGetEnumerator else let enumElemTy = get_Current_minfo.GetFSharpReturnTy(cenv.amap, m, get_Current_minst) @@ -4385,7 +4386,7 @@ let rec TcTyparConstraint ridx cenv newOk checkCxs occ (env: TcEnv) tpenv c = | WhereTyparSupportsMember(tps, memSpfn, m) -> let traitInfo, tpenv = TcPseudoMemberSpec cenv newOk env tps tpenv memSpfn m match traitInfo with - | TTrait(objtys, ".ctor", memberFlags, argTys, returnTy, _) when memberFlags.MemberKind = MemberKind.Constructor -> + | TTrait(objtys, ".ctor", memberFlags, argTys, returnTy, _, _, _) when memberFlags.MemberKind = MemberKind.Constructor -> match objtys, argTys with | [ty], [] when typeEquiv cenv.g ty (GetFSharpViewOfReturnType cenv.g returnTy) -> AddCxTypeMustSupportDefaultCtor env.DisplayEnv cenv.css m NoTrace ty @@ -4421,8 +4422,12 @@ and TcPseudoMemberSpec cenv newOk env synTypes tpenv memSpfn m = let item = Item.ArgName (id, memberConstraintTy, None) CallNameResolutionSink cenv.tcSink (id.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.AccessRights) - TTrait(tys, logicalCompiledName, memberFlags, argTys, returnTy, ref None), tpenv + // extSlns starts off empty because the trait has some support + // ad starts off as None because the trait has some support + TTrait(tys, logicalCompiledName, memberFlags, argTys, returnTy, ref None, [], None), tpenv + | _ -> error(Error(FSComp.SR.tcInvalidConstraint(), m)) + | _ -> error(Error(FSComp.SR.tcInvalidConstraint(), m)) @@ -4435,7 +4440,7 @@ and TcValSpec cenv env declKind newOk containerInfo memFlagsOpt thisTyOpt tpenv match tcrefContainerInfo with | Some(MemberOrValContainerInfo(tcref, _, _, _, declaredTyconTypars)) -> let isExtrinsic = (declKind = ExtrinsicExtensionBinding) - let _, enclosingDeclaredTypars, _, _, thisTy = FreshenObjectArgType cenv m TyparRigidity.Rigid tcref isExtrinsic declaredTyconTypars + let _, enclosingDeclaredTypars, _, _, thisTy = FreshenObjectArgType cenv env.TraitFreshner m TyparRigidity.Rigid tcref isExtrinsic declaredTyconTypars // An implemented interface type is in terms of the type's type parameters. // We need a signature in terms of the values' type parameters. // let optIntfSlotTy = Option.map (instType renaming) optIntfSlotTy in @@ -4582,7 +4587,7 @@ and TcTyparOrMeasurePar optKind cenv (env: TcEnv) newOk tpenv (Typar(id, _, _) a let item = Item.TypeVar(id.idText, res) CallNameResolutionSink cenv.tcSink (id.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.UseInType, env.DisplayEnv, env.AccessRights) // record the ' as well for tokenization - // CallNameResolutionSink cenv.tcSink (tp.Range.StartRange, env.NameEnv, item, item, ItemOccurence.UseInType, env.DisplayEnv, env.eAccessRights) + // CallNameResolutionSink cenv.tcSink (tp.Range.StartRange, env.NameEnv, item, item, ItemOccurence.UseInType, env.DisplayEnv, env.AccessRights) res, tpenv let key = id.idText match env.eNameResEnv.eTypars.TryGetValue key with @@ -4593,7 +4598,7 @@ and TcTyparOrMeasurePar optKind cenv (env: TcEnv) newOk tpenv (Typar(id, _, _) a | None -> if newOk = NoNewTypars then let suggestTypeParameters (addToBuffer: string -> unit) = - for p in env.eNameResEnv.eTypars do + for p in env.NameEnv.eTypars do addToBuffer ("'" + p.Key) match tpenv with @@ -4627,7 +4632,7 @@ and TcTyparDecl cenv env (TyparDecl(Attributes synAttrs, (Typar(id, _, _) as stp | None -> () let item = Item.TypeVar(id.idText, tp) - CallNameResolutionSink cenv.tcSink (id.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.UseInType, env.DisplayEnv, env.eAccessRights) + CallNameResolutionSink cenv.tcSink (id.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.UseInType, env.DisplayEnv, env.AccessRights) tp @@ -5069,7 +5074,7 @@ and TcTypeApp cenv newOk checkCxs occ env tpenv m tcref pathTypeArgs (synArgTys: if tcref.Deref.IsProvided then TcProvidedTypeApp cenv env tpenv tcref synArgTys m else #endif - let tps, _, tinst, _ = FreshenTyconRef2 m tcref + let tps, _, tinst, _ = FreshenTyconRef2 env.TraitFreshner m tcref // If we're not checking constraints, i.e. when we first assert the super/interfaces of a type definition, then just // clear the constraint lists of the freshly generated type variables. A little ugly but fairly localized. @@ -5364,7 +5369,7 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty p | Item.ActivePatternCase(APElemRef(apinfo, vref, idx)) as item -> let args = match args with SynConstructorArgs.Pats args -> args | _ -> error(Error(FSComp.SR.tcNamedActivePattern(apinfo.ActiveTags.[idx]), m)) // TOTAL/PARTIAL ACTIVE PATTERNS - let _, vexp, _, _, tinst, _ = TcVal true cenv env tpenv vref None None m + let _, vexp, _, _, tinst, _ = TcVal env.TraitFreshner true cenv env tpenv vref None None m let vexp = MakeApplicableExprWithFlex cenv env vexp let vexpty = vexp.Type @@ -5530,7 +5535,7 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty p match vref.LiteralValue with | None -> error (Error(FSComp.SR.tcNonLiteralCannotBeUsedInPattern(), m)) | Some lit -> - let _, _, _, vexpty, _, _ = TcVal true cenv env tpenv vref None None m + let _, _, _, vexpty, _, _ = TcVal env.TraitFreshner true cenv env tpenv vref None None m CheckValAccessible m env.AccessRights vref CheckFSharpAttributes cenv.g vref.Attribs m |> CommitOperationResult checkNoArgsForLiteral() @@ -5563,7 +5568,7 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty p | SynPat.Record (flds, m) -> let tcref, fldsmap, _fldsList = BuildFieldMap cenv env true ty flds m // REVIEW: use _fldsList to type check pattern in code order not field defn order - let _, inst, tinst, gtyp = FreshenTyconRef2 m tcref + let _, inst, tinst, gtyp = FreshenTyconRef2 env.TraitFreshner m tcref UnifyTypes cenv env m ty gtyp let fields = tcref.TrueInstanceFieldsAsList let ftys = fields |> List.map (fun fsp -> actualTyOfRecdField inst fsp, fsp) @@ -5970,7 +5975,7 @@ and TcExprUndelayed cenv overallTy env tpenv (synExpr: SynExpr) = TcNewExpr cenv env tpenv objTy (Some synObjTy.Range) superInit arg mNewExpr | SynExpr.ObjExpr (objTy, argopt, binds, extraImpls, mNewExpr, m) -> - CallExprHasTypeSink cenv.tcSink (m, env.NameEnv, overallTy, env.DisplayEnv, env.eAccessRights) + CallExprHasTypeSink cenv.tcSink (m, env.NameEnv, overallTy, env.DisplayEnv, env.AccessRights) TcObjectExpr cenv overallTy env tpenv (objTy, argopt, binds, extraImpls, mNewExpr, m) | SynExpr.Record (inherits, optOrigExpr, flds, mWholeExpr) -> @@ -6623,7 +6628,7 @@ and TcRecordConstruction cenv overallTy env tpenv optOrigExprInfo objTy fldsList // Check accessibility: this is also done in BuildFieldMap, but also need to check // for fields in { new R with a=1 and b=2 } constructions and { r with a=1 } copy-and-update expressions rfrefs |> List.iter (fun rfref -> - CheckRecdFieldAccessible cenv.amap m env.eAccessRights rfref |> ignore + CheckRecdFieldAccessible cenv.amap m env.AccessRights rfref |> ignore CheckFSharpAttributes cenv.g rfref.PropertyAttribs m |> CommitOperationResult) let args = List.map snd fldsList @@ -6720,8 +6725,7 @@ and FreshenObjExprAbstractSlot cenv (env: TcEnv) (implty: TType) virtNameAndArit | [(_, absSlot)] -> - let typarsFromAbsSlotAreRigid, typarsFromAbsSlot, argTysFromAbsSlot, retTyFromAbsSlot - = FreshenAbstractSlot cenv.g cenv.amap mBinding synTyparDecls absSlot + let typarsFromAbsSlotAreRigid, typarsFromAbsSlot, argTysFromAbsSlot, retTyFromAbsSlot = FreshenAbstractSlot env.TraitFreshner cenv.g cenv.amap mBinding synTyparDecls absSlot // Work out the required type of the member let bindingTy = implty --> (mkMethodTy cenv.g argTysFromAbsSlot retTyFromAbsSlot) @@ -7134,7 +7138,7 @@ and TcRecdExpr cenv overallTy env tpenv (inherits, optOrigExpr, flds, mWholeExpr | [] -> [] | _ -> let tcref, _, fldsList = BuildFieldMap cenv env hasOrigExpr overallTy flds mWholeExpr - let _, _, _, gtyp = FreshenTyconRef2 mWholeExpr tcref + let _, _, _, gtyp = FreshenTyconRef2 env.TraitFreshner mWholeExpr tcref UnifyTypes cenv env mWholeExpr overallTy gtyp [ for n, v in fldsList do @@ -9047,8 +9051,8 @@ and TcItemThen cenv overallTy env tpenv (item, mItem, rest, afterResolution) del let mkConstrApp _mArgs = function [arg] -> arg | _ -> error(InternalError("ApplyUnionCaseOrExn", mItem)) mkConstrApp, [ucaseAppTy], [ for (s, m) in apinfo.ActiveTagsWithRanges -> mkSynId m s ] | _ -> - let ucref = mkChoiceCaseRef g mItem aparity n - let _, _, tinst, _ = FreshenTyconRef2 mItem ucref.TyconRef + let ucref = mkChoiceCaseRef cenv.g mItem aparity n + let _, _, tinst, _ = FreshenTyconRef2 env.TraitFreshner mItem ucref.TyconRef let ucinfo = UnionCaseInfo (tinst, ucref) ApplyUnionCaseOrExnTypes mItem cenv env ucaseAppTy (Item.UnionCase(ucinfo, false)) | _ -> @@ -9330,7 +9334,9 @@ and TcItemThen cenv overallTy env tpenv (item, mItem, rest, afterResolution) del let memberFlags = StaticMemberFlags MemberKind.Member let logicalCompiledName = ComputeLogicalName id memberFlags - let traitInfo = TTrait(argTys, logicalCompiledName, memberFlags, argTys, Some retTy, sln) + + let traitInfo = TTrait(argTys, logicalCompiledName, memberFlags, argTys, Some retTy, sln, [], None) + let traitInfo = FreshenTrait env.TraitFreshner traitInfo let expr = Expr.Op (TOp.TraitCall traitInfo, [], ves, mItem) let expr = mkLambdas mItem [] vs (expr, retTy) @@ -9475,7 +9481,7 @@ and TcItemThen cenv overallTy env tpenv (item, mItem, rest, afterResolution) del // - it isn't a CtorValUsedAsSelfInit // - it isn't a VSlotDirectCall (uses of base values do not take type arguments let checkTys tpenv kinds = TcTypesOrMeasures (Some kinds) cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv tys mItem - let _, vexp, isSpecial, _, _, tpenv = TcVal true cenv env tpenv vref (Some (NormalValUse, checkTys)) (Some afterResolution) mItem + let _, vexp, isSpecial, _, _, tpenv = TcVal env.TraitFreshner true cenv env tpenv vref (Some (NormalValUse, checkTys)) (Some afterResolution) mItem let vexpFlex = (if isSpecial then MakeApplicableExprNoFlex cenv vexp else MakeApplicableExprWithFlex cenv env vexp) // We need to eventually record the type resolution for an expression, but this is done // inside PropagateThenTcDelayed, so we don't have to explicitly call 'CallExprHasTypeSink' here @@ -9483,7 +9489,7 @@ and TcItemThen cenv overallTy env tpenv (item, mItem, rest, afterResolution) del // Value get | _ -> - let _, vexp, isSpecial, _, _, tpenv = TcVal true cenv env tpenv vref None (Some afterResolution) mItem + let _, vexp, isSpecial, _, _, tpenv = TcVal env.TraitFreshner true cenv env tpenv vref None (Some afterResolution) mItem let vexpFlex = (if isSpecial then MakeApplicableExprNoFlex cenv vexp else MakeApplicableExprWithFlex cenv env vexp) PropagateThenTcDelayed cenv overallTy env tpenv mItem vexpFlex vexpFlex.Type ExprAtomicFlag.Atomic delayed @@ -10074,12 +10080,12 @@ and TcMethodApplication let callerArgs = List.zip unnamedCurriedCallerArgs namedCurriedCallerArgs let makeOneCalledMeth (minfo, pinfoOpt, usesParamArrayConversion) = - let minst = FreshenMethInfo mItem minfo + let minst = FreshenMethInfo env.TraitFreshner mItem minfo let callerTyArgs = match tyargsOpt with | Some tyargs -> minfo.AdjustUserTypeInstForFSharpStyleIndexedExtensionMembers tyargs | None -> minst - CalledMeth(cenv.infoReader, Some(env.NameEnv), isCheckingAttributeCall, FreshenMethInfo, mMethExpr, ad, minfo, minst, callerTyArgs, pinfoOpt, callerObjArgTys, callerArgs, usesParamArrayConversion, true, objTyOpt) + CalledMeth(cenv.infoReader, Some(env.NameEnv), isCheckingAttributeCall, FreshenMethInfo env.TraitFreshner, mMethExpr, ad, minfo, minst, callerTyArgs, pinfoOpt, callerObjArgTys, callerArgs, usesParamArrayConversion, true, objTyOpt) let preArgumentTypeCheckingCalledMethGroup = [ for (minfo, pinfoOpt) in candidateMethsAndProps do @@ -10179,7 +10185,7 @@ and TcMethodApplication match tyargsOpt with | Some tyargs -> minfo.AdjustUserTypeInstForFSharpStyleIndexedExtensionMembers tyargs | None -> minst - CalledMeth(cenv.infoReader, Some(env.NameEnv), isCheckingAttributeCall, FreshenMethInfo, mMethExpr, ad, minfo, minst, callerTyArgs, pinfoOpt, callerObjArgTys, callerArgs, usesParamArrayConversion, true, objTyOpt)) + CalledMeth(cenv.infoReader, Some(env.NameEnv), isCheckingAttributeCall, FreshenMethInfo env.TraitFreshner, mMethExpr, ad, minfo, minst, callerTyArgs, pinfoOpt, callerObjArgTys, callerArgs, usesParamArrayConversion, true, objTyOpt)) let callerArgCounts = (unnamedCurriedCallerArgs.Length, namedCurriedCallerArgs.Length) let csenv = MakeConstraintSolverEnv ContextInfo.NoContext cenv.css mMethExpr denv @@ -11385,7 +11391,7 @@ and ApplyAbstractSlotInference (cenv: cenv) (envinner: TcEnv) (bindingTy, m, syn let uniqueAbstractMeth = uniqueAbstractMeth.Instantiate(cenv.amap, m, renaming) let typarsFromAbsSlotAreRigid, typarsFromAbsSlot, argTysFromAbsSlot, retTyFromAbsSlot = - FreshenAbstractSlot cenv.g cenv.amap m synTyparDecls uniqueAbstractMeth + FreshenAbstractSlot None cenv.g cenv.amap m synTyparDecls uniqueAbstractMeth let declaredTypars = (if typarsFromAbsSlotAreRigid then typarsFromAbsSlot else declaredTypars) @@ -11442,7 +11448,7 @@ and ApplyAbstractSlotInference (cenv: cenv) (envinner: TcEnv) (bindingTy, m, syn let uniqueAbstractMeth = uniqueAbstractMeth.Instantiate(cenv.amap, m, renaming) let _, typarsFromAbsSlot, argTysFromAbsSlot, retTyFromAbsSlot = - FreshenAbstractSlot cenv.g cenv.amap m synTyparDecls uniqueAbstractMeth + FreshenAbstractSlot None cenv.g cenv.amap m synTyparDecls uniqueAbstractMeth if not (isNil typarsFromAbsSlot) then errorR(InternalError("Unexpected generic property", memberId.idRange)) @@ -11519,7 +11525,7 @@ and AnalyzeRecursiveStaticMemberOrValDecl error(Error(FSComp.SR.tcConstructorsDisallowedInExceptionAugmentation(), id.idRange)) let isExtrinsic = (declKind = ExtrinsicExtensionBinding) - let _, enclosingDeclaredTypars, _, objTy, thisTy = FreshenObjectArgType cenv mBinding TyparRigidity.WillBeRigid tcref isExtrinsic declaredTyconTypars + let _, enclosingDeclaredTypars, _, objTy, thisTy = FreshenObjectArgType cenv None mBinding TyparRigidity.WillBeRigid tcref isExtrinsic declaredTyconTypars let envinner = AddDeclaredTypars CheckForDuplicateTypars enclosingDeclaredTypars envinner let envinner = MakeInnerEnvForTyconRef envinner tcref isExtrinsic @@ -11589,7 +11595,7 @@ and AnalyzeRecursiveInstanceMemberDecl // The type being augmented tells us the type of 'this' let isExtrinsic = (declKind = ExtrinsicExtensionBinding) - let tcrefObjTy, enclosingDeclaredTypars, renaming, objTy, thisTy = FreshenObjectArgType cenv mBinding TyparRigidity.WillBeRigid tcref isExtrinsic declaredTyconTypars + let tcrefObjTy, enclosingDeclaredTypars, renaming, objTy, thisTy = FreshenObjectArgType cenv None mBinding TyparRigidity.WillBeRigid tcref isExtrinsic declaredTyconTypars let envinner = AddDeclaredTypars CheckForDuplicateTypars enclosingDeclaredTypars envinner @@ -12074,7 +12080,7 @@ and TcLetrecComputeAndGeneralizeGenericTyparsForBinding cenv denv freeInEnv (pgr let maxInferredTypars = freeInTypeLeftToRight cenv.g false tau let canGeneralizeConstrained = GeneralizationHelpers.CanGeneralizeConstrainedTyparsForDecl rbinfo.DeclKind - let generalizedTypars = GeneralizationHelpers.ComputeAndGeneralizeGenericTypars (cenv, denv, m, freeInEnv, canInferTypars, canGeneralizeConstrained, inlineFlag, Some expr, allDeclaredTypars, maxInferredTypars, tau, isCtor) + let generalizedTypars = GeneralizationHelpers.ComputeAndGeneralizeGenericTypars (cenv, denv, m, freeInEnv, canInferTypars, canGeneralizeConstrained, inlineFlag, Some expr, allDeclaredTypars, maxInferredTypars,tau,isCtor) generalizedTypars /// Compute the type variables which may have member constraints that need to be canonicalized prior to generalization @@ -12316,7 +12322,7 @@ let TcAndPublishValSpec (cenv, env, containerInfo: ContainerInfo, declKind, memF let flex = ExplicitTyparInfo(declaredTypars, declaredTypars, synCanInferTypars) - let generalizedTypars = GeneralizationHelpers.ComputeAndGeneralizeGenericTypars(cenv, denv, id.idRange, emptyFreeTypars, canInferTypars, CanGeneralizeConstrainedTypars, inlineFlag, None, allDeclaredTypars, freeInType, ty, false) + let generalizedTypars = GeneralizationHelpers.ComputeAndGeneralizeGenericTypars(cenv, denv, id.idRange, emptyFreeTypars, canInferTypars, CanGeneralizeConstrainedTypars, inlineFlag, None, allDeclaredTypars,freeInType, ty, false) let valscheme1 = PrelimValScheme1(id, flex, ty, Some partialValReprInfo, memberInfoOpt, mutableFlag, inlineFlag, NormalVal, noArgOrRetAttribs, vis, false) @@ -13540,7 +13546,7 @@ module MutRecBindingChecking = AddLocalTyconRefs true g cenv.amap tcref.Range [tcref] initialEnvForTycon // Make fresh version of the class type for type checking the members and lets * - let _, copyOfTyconTypars, _, objTy, thisTy = FreshenObjectArgType cenv tcref.Range TyparRigidity.WillBeRigid tcref isExtrinsic declaredTyconTypars + let _, copyOfTyconTypars, _, objTy, thisTy = FreshenObjectArgType cenv None tcref.Range TyparRigidity.WillBeRigid tcref isExtrinsic declaredTyconTypars // The basic iteration over the declarations in a single type definition @@ -14270,7 +14276,7 @@ module MutRecBindingChecking = for tp in unsolvedTyparsForRecursiveBlockInvolvingGeneralizedVariables do //printfn "solving unsolvedTyparsInvolvingGeneralizedVariable: %s #%d" tp.DisplayName tp.Stamp if (tp.Rigidity <> TyparRigidity.Rigid) && not tp.IsSolved then - ConstraintSolver.ChooseTyparSolutionAndSolve cenv.css denv tp + ConstraintSolver.ChooseTyparSolutionAndSolve cenv.css denv tp // Now that we know what we've generalized we can adjust the recursive references let defnsCs = TcMutRecBindings_Phase2C_FixupRecursiveReferences cenv (denv, defnsBs, generalizedTyparsForRecursiveBlock, generalizedRecBinds, scopem) diff --git a/src/fsharp/infos.fs b/src/fsharp/infos.fs index 1db4e36b356..bb9f47e04c1 100755 --- a/src/fsharp/infos.fs +++ b/src/fsharp/infos.fs @@ -297,6 +297,23 @@ let ImportReturnTypeFromMetadata amap m ilty cattrs scoref tinst minst = | retTy -> Some(ImportILTypeFromMetadataWithAttributes amap m scoref tinst minst retTy cattrs) + +/// Search for the relevant extension values again if a name resolution environment is provided +/// Basically, if you use a generic thing, then the extension members in scope at the point of _use_ +/// are the ones available to solve the constraint +let FreshenTrait traitFreshner traitInfo = + let (TTrait(typs, nm, mf, argtys, rty, slnCell, extSlns, ad)) = traitInfo + + // Call the trait freshner if it is provided + let extSlns2, ad2 = + match traitFreshner with + | None -> extSlns, ad + | Some f -> + let extSlns2, ad2 = f traitInfo + extSlns2, Some ad2 + + TTrait(typs, nm, mf, argtys, rty, slnCell, extSlns2, ad2) + /// 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 @@ -305,15 +322,15 @@ let ImportReturnTypeFromMetadata amap m ilty cattrs scoref tinst minst = /// /// 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, _) -> +let CopyTyparConstraints traitFreshner 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, ty, _) -> TyparConstraint.DefaultsTo (priority, instType tprefInst ty, m) - | TyparConstraint.SupportsNull _ -> + | TyparConstraint.SupportsNull _ -> TyparConstraint.SupportsNull m | TyparConstraint.IsEnum (uty, _) -> TyparConstraint.IsEnum (instType tprefInst uty, m) @@ -333,12 +350,13 @@ let CopyTyparConstraints m tprefInst (tporig: Typar) = TyparConstraint.SimpleChoice (List.map (instType tprefInst) tys, m) | TyparConstraint.RequiresDefaultConstructor _ -> TyparConstraint.RequiresDefaultConstructor m - | TyparConstraint.MayResolveMember(traitInfo, _) -> - TyparConstraint.MayResolveMember (instTrait tprefInst traitInfo, m)) + | TyparConstraint.MayResolveMember(traitInfo, _) -> + let traitInfo2 = FreshenTrait traitFreshner traitInfo + TyparConstraint.MayResolveMember (instTrait tprefInst traitInfo2, 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) = +/// 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 traitFreshner 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 @@ -350,7 +368,7 @@ let FixupNewTypars m (formalEnclosingTypars: Typars) (tinst: TType list) (tpsori // 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)) + (tpsorig, tps) ||> List.iter2 (fun tporig tp -> tp.SetConstraints (CopyTyparConstraints traitFreshner m tprefInst tporig)) renaming, tptys @@ -1526,10 +1544,10 @@ type MethInfo = let tcref = tcrefOfAppTy g x.ApparentEnclosingAppType let formalEnclosingTyparsOrig = tcref.Typars m let formalEnclosingTypars = copyTypars formalEnclosingTyparsOrig - let _, formalEnclosingTyparTys = FixupNewTypars m [] [] formalEnclosingTyparsOrig formalEnclosingTypars + let _, formalEnclosingTyparTys = FixupNewTypars None m [] [] formalEnclosingTyparsOrig formalEnclosingTypars let formalMethTypars = copyTypars x.FormalMethodTypars - let _, formalMethTyparTys = FixupNewTypars m formalEnclosingTypars formalEnclosingTyparTys x.FormalMethodTypars formalMethTypars - let formalRetTy, formalParams = + let _, formalMethTyparTys = FixupNewTypars None m formalEnclosingTypars formalEnclosingTyparTys x.FormalMethodTypars formalMethTypars + let formalRetTy, formalParams = match x with | ILMeth(_, ilminfo, _) -> let ftinfo = ILTypeInfo.FromType g (TType_app(tcref, formalEnclosingTyparTys)) diff --git a/src/fsharp/symbols/Exprs.fs b/src/fsharp/symbols/Exprs.fs index 16ada4ec575..ec0a3cf1f6c 100644 --- a/src/fsharp/symbols/Exprs.fs +++ b/src/fsharp/symbols/Exprs.fs @@ -827,7 +827,7 @@ module FSharpExprConvert = let typR = ConvType cenv (mkAppTy tycr tyargs) E.UnionCaseTag(ConvExpr cenv env arg1, typR) - | TOp.TraitCall (TTrait(tys, nm, memFlags, argtys, _rty, _solution)), _, _ -> + | TOp.TraitCall (TTrait(tys, nm, memFlags, argtys, _rty, _solution, _extSlns, _ad)), _, _ -> let tysR = ConvTypes cenv tys let tyargsR = ConvTypes cenv tyargs let argtysR = ConvTypes cenv argtys diff --git a/src/fsharp/symbols/Symbols.fs b/src/fsharp/symbols/Symbols.fs index 295e42b02cb..a287ab97f8a 100644 --- a/src/fsharp/symbols/Symbols.fs +++ b/src/fsharp/symbols/Symbols.fs @@ -1219,7 +1219,8 @@ and FSharpAbstractSignature(cenv, info: SlotSig) = member __.DeclaringType = FSharpType(cenv, info.ImplementedType) and FSharpGenericParameterMemberConstraint(cenv, info: TraitConstraintInfo) = - let (TTrait(tys, nm, flags, atys, rty, _)) = info + let (TTrait(tys, nm, flags, atys, rty, _, _extSlns, _ad)) = info + member __.MemberSources = tys |> List.map (fun ty -> FSharpType(cenv, ty)) |> makeReadOnlyCollection @@ -1277,7 +1278,7 @@ and FSharpGenericParameterConstraint(cenv, cx: TyparConstraint) = member __.MemberConstraintData = match cx with - | TyparConstraint.MayResolveMember(info, _) -> FSharpGenericParameterMemberConstraint(cenv, info) + | TyparConstraint.MayResolveMember(info, _) -> FSharpGenericParameterMemberConstraint(cenv, info) | _ -> invalidOp "not a member constraint" member __.IsNonNullableValueTypeConstraint = diff --git a/src/fsharp/tast.fs b/src/fsharp/tast.fs index 27caa7b6008..4a91d212c2b 100644 --- a/src/fsharp/tast.fs +++ b/src/fsharp/tast.fs @@ -2344,6 +2344,14 @@ and override x.ToString() = x.Name +and TraitPossibleExtensionMemberSolutions = TraitPossibleExtensionMemberSolution list + +/// Only satisfied by type 'ExtensionMember'. Not stored in TastPickle. +and TraitPossibleExtensionMemberSolution = interface end + +/// Only satisfied by 'AccessorDomain'. Not stored in TastPickle. +and TraitAccessorDomain = interface end + and [] TyparConstraint = @@ -2399,25 +2407,34 @@ and [] TraitConstraintInfo = - /// TTrait(tys, nm, memFlags, argtys, rty, solution) + /// TTrait(tys, nm, memFlags, argtys, rty, solutionCell, extSlns, ad) /// /// Indicates the signature of a member constraint. Contains a mutable solution cell /// to store the inferred solution of the constraint. - | TTrait of TTypes * string * MemberFlags * TTypes * TType option * TraitConstraintSln option ref + | TTrait of TTypes * string * MemberFlags * TTypes * TType option * TraitConstraintSln option ref * extSlns: TraitPossibleExtensionMemberSolutions * ad: TraitAccessorDomain option + + /// Get the support types that can help provide members to solve the constraint + member x.SupportTypes= (let (TTrait(tys,_,_,_,_,_,_,_)) = x in tys) /// Get the member name associated with the member constraint. - member x.MemberName = (let (TTrait(_, nm, _, _, _, _)) = x in nm) + member x.MemberName = (let (TTrait(_, nm, _, _, _, _, _, _)) = x in nm) /// Get the argument types required of a member in order to solve the constraint - member x.ArgumentTypes = (let (TTrait(_, _, _, argtys, _, _)) = x in argtys) + member x.ArgumentTypes = (let (TTrait(_, _, _, argtys, _, _, _, _)) = x in argtys) /// Get the return type recorded in the member constraint. - member x.ReturnType = (let (TTrait(_, _, _, _, ty, _)) = x in ty) + member x.ReturnType = (let (TTrait(_, _, _, _, rty, _, _, _)) = x in rty) /// Get or set the solution of the member constraint during inference member x.Solution - with get() = (let (TTrait(_, _, _, _, _, sln)) = x in sln.Value) - and set v = (let (TTrait(_, _, _, _, _, sln)) = x in sln.Value <- v) + with get() = (let (TTrait(_, _, _, _, _, sln, _, _)) = x in sln.Value) + and set v = (let (TTrait(_, _, _, _, _, sln, _, _)) = x in sln.Value <- v) + + /// Get possible extension member solutions available for a use of a trait at a particular location + member x.PossibleExtensionSolutions = (let (TTrait(_, _, _, _, _, _, extSlns, _)) = x in extSlns) + + /// Get access rights for a use of a trait at a particular location + member x.AccessorDomain = (let (TTrait(_, _, _, _, _, _, _, ad)) = x in ad) [] member x.DebugText = x.ToString() diff --git a/tests/fsharp/core/members/basics-hw-mutrec/test.fs b/tests/fsharp/core/members/basics-hw-mutrec/test.fs index 7a1fb2a049a..7b3e1256a76 100644 --- a/tests/fsharp/core/members/basics-hw-mutrec/test.fs +++ b/tests/fsharp/core/members/basics-hw-mutrec/test.fs @@ -1606,9 +1606,9 @@ module MultipleOverloadedOperatorTests = begin let f1 (x:DateTime) (y:TimeSpan) : DateTime = x - y let g1 (x:DateTime) (y:DateTime) : TimeSpan = x - y - // Return type is also sufficient: - let f2 (x:DateTime) y : DateTime = x - y - let g2 (x:DateTime) y : TimeSpan = x - y + // // Return type is not sufficient: + // let f2 (x:DateTime) y : DateTime = x - y + // let g2 (x:DateTime) y : TimeSpan = x - y // Just argument types are also sufficient: let f3 (x:DateTime) (y:TimeSpan) = x - y let g3 (x:DateTime) (y:DateTime) = x - y diff --git a/tests/fsharp/core/members/basics-hw/test.fsx b/tests/fsharp/core/members/basics-hw/test.fsx index 58420e78210..5d4eb41e2eb 100644 --- a/tests/fsharp/core/members/basics-hw/test.fsx +++ b/tests/fsharp/core/members/basics-hw/test.fsx @@ -1621,9 +1621,9 @@ module MultipleOverloadedOperatorTests = begin let f1 (x:DateTime) (y:TimeSpan) : DateTime = x - y let g1 (x:DateTime) (y:DateTime) : TimeSpan = x - y - // Return type is also sufficient: - let f2 (x:DateTime) y : DateTime = x - y - let g2 (x:DateTime) y : TimeSpan = x - y + // // Return type is not sufficient: + // let f2 (x:DateTime) y : DateTime = x - y + // let g2 (x:DateTime) y : TimeSpan = x - y // Just argument types are also sufficient: let f3 (x:DateTime) (y:TimeSpan) = x - y let g3 (x:DateTime) (y:DateTime) = x - y diff --git a/tests/fsharp/core/members/basics/test.fs b/tests/fsharp/core/members/basics/test.fs index a5da244c0a6..b9f8392e018 100644 --- a/tests/fsharp/core/members/basics/test.fs +++ b/tests/fsharp/core/members/basics/test.fs @@ -1910,9 +1910,9 @@ module MultipleOverloadedOperatorTests = begin let f1 (x:DateTime) (y:TimeSpan) : DateTime = x - y let g1 (x:DateTime) (y:DateTime) : TimeSpan = x - y - // Return type is also sufficient: - let f2 (x:DateTime) y : DateTime = x - y - let g2 (x:DateTime) y : TimeSpan = x - y + // Return type is not sufficient: + //let f2 (x:DateTime) y : DateTime = x - y + //let g2 (x:DateTime) y : TimeSpan = x - y // Just argument types are also sufficient: let f3 (x:DateTime) (y:TimeSpan) = x - y let g3 (x:DateTime) (y:DateTime) = x - y diff --git a/tests/fsharp/core/members/ops-mutrec/test.fs b/tests/fsharp/core/members/ops-mutrec/test.fs index 8b816fa7def..211f3940a51 100644 --- a/tests/fsharp/core/members/ops-mutrec/test.fs +++ b/tests/fsharp/core/members/ops-mutrec/test.fs @@ -214,8 +214,8 @@ module BasicOverloadTests = // This gets type int -> int let f5 x = 1 - x - // This gets type DateTime -> DateTime -> TimeSpan, through non-conservative resolution. - let f6 x1 (x2:System.DateTime) = x1 - x2 + // // This gets type DateTime -> DateTime -> TimeSpan, through non-conservative resolution. + // let f6 x1 (x2:System.DateTime) = x1 - x2 // This gets type TimeSpan -> TimeSpan -> TimeSpan, through default type propagation let f7 x1 (x2:System.TimeSpan) = x1 - x2 diff --git a/tests/fsharp/core/subtype/test.fsx b/tests/fsharp/core/subtype/test.fsx index 9751d03e6e3..cb4995e2a70 100644 --- a/tests/fsharp/core/subtype/test.fsx +++ b/tests/fsharp/core/subtype/test.fsx @@ -1778,8 +1778,6 @@ module MethodOverloadingForTraitConstraintsIsNotDeterminedUntilSignatureIsKnnown let inline Test2< ^t> a = Test a - // NOTE, this is seen to be a bug, see https://github.com/Microsoft/visualfsharp/issues/3814 - // The result should be 2. // This test has been added to pin down current behaviour pending a future bug fix. check "slvde0vver90u1" (Test2 0) 1 check "slvde0vver90u2" (Test2 0L) 1 diff --git a/tests/fsharp/tests.fs b/tests/fsharp/tests.fs index 2247c318f6a..08130fe71d2 100644 --- a/tests/fsharp/tests.fs +++ b/tests/fsharp/tests.fs @@ -526,6 +526,29 @@ module CoreTests = exec cfg ("." ++ "testcs.exe") "" + [] + let extconstraint () = + let cfg = testConfig "core/extconstraint" + + fsc cfg "%s" cfg.fsc_flags ["test.fsx"] + + peverify cfg "test.exe" + + begin + use testOkFile = fileguard cfg "test.ok" + + exec cfg ("." ++ "test.exe") "" + + testOkFile.CheckExists() + end + + begin + use testOkFile = fileguard cfg "test.ok" + + fsi cfg "" ["test.fsx"] + + testOkFile.CheckExists() + end // // Shadowcopy does not work for public signed assemblies diff --git a/tests/fsharp/typecheck/sigs/neg45.bsl b/tests/fsharp/typecheck/sigs/neg45.bsl index 466a998514d..aa1cc2435e6 100644 --- a/tests/fsharp/typecheck/sigs/neg45.bsl +++ b/tests/fsharp/typecheck/sigs/neg45.bsl @@ -77,6 +77,6 @@ neg45.fs(144,13,144,23): typecheck error FS0001: The type 'A1' does not support neg45.fs(145,13,145,23): typecheck error FS0001: The type 'A2' does not support the operator 'get_Name' -neg45.fs(146,13,146,23): typecheck error FS0001: The type 'B' has a method 'get_Name' (full name 'get_Name'), but the method is not static +neg45.fs(146,13,146,23): typecheck error FS0001: get_Name is not a static method neg45.fs(147,15,147,25): typecheck error FS0001: The type 'StaticMutableClassExplicit' does not support the operator 'get_Name' diff --git a/tests/fsharp/typecheck/sigs/neg99.bsl b/tests/fsharp/typecheck/sigs/neg99.bsl index 9f6010f249d..1d050dfedd9 100644 --- a/tests/fsharp/typecheck/sigs/neg99.bsl +++ b/tests/fsharp/typecheck/sigs/neg99.bsl @@ -3,4 +3,4 @@ neg99.fs(19,16,19,64): typecheck error FS0077: Member constraints with the name neg99.fs(22,18,22,64): typecheck error FS0077: Member constraints with the name 'op_Explicit' are given special status by the F# compiler as certain .NET types are implicitly augmented with this member. This may result in runtime failures if you attempt to invoke the member constraint from your own code. -neg99.fs(25,39,25,43): typecheck error FS0043: The type 'CrashFSC.OhOh.MyByte' does not support a conversion to the type 'CrashFSC.OhOh.MyByte' +neg99.fs(25,39,25,43): typecheck error FS0043: The type 'MyByte' does not support a conversion to the type ''a' diff --git a/tests/fsharp/typecheck/sigs/neg99.fs b/tests/fsharp/typecheck/sigs/neg99.fs index 6c3007c74ab..b7d248f13ab 100644 --- a/tests/fsharp/typecheck/sigs/neg99.fs +++ b/tests/fsharp/typecheck/sigs/neg99.fs @@ -12,7 +12,7 @@ module OhOh = static member inline op_Explicit (x: int64): MyByte = MyByte (byte x) static member inline op_Explicit (x: float): MyByte = MyByte (byte x) - static member inline op_Explicit (MyByte x): 'a = failwith "cannot convert" + //static member inline op_Explicit (MyByte x): 'a = failwith "cannot convert" /// testing testing let inline ( !>>> ) (a: ^a) min: ^b option = diff --git a/tests/fsharpqa/Source/Conformance/ObjectOrientedTypeDefinitions/TypeExtensions/basic/E_ExtensionOperator01.fs b/tests/fsharpqa/Source/Conformance/ObjectOrientedTypeDefinitions/TypeExtensions/basic/E_ExtensionOperator01.fs index e038022643b..a2d10e07e4a 100644 --- a/tests/fsharpqa/Source/Conformance/ObjectOrientedTypeDefinitions/TypeExtensions/basic/E_ExtensionOperator01.fs +++ b/tests/fsharpqa/Source/Conformance/ObjectOrientedTypeDefinitions/TypeExtensions/basic/E_ExtensionOperator01.fs @@ -1,26 +1,26 @@ // #Regression #Conformance #ObjectOrientedTypes #TypeExtensions // Regression for FSHARP1.0:3592 // Can't use extension methods to define operators -//Extension members cannot provide operator overloads\. Consider defining the operator as part of the type definition instead\. -//Extension members cannot provide operator overloads\. Consider defining the operator as part of the type definition instead\. //The type 'Exception' does not support the operator '\+'$ //The type 'Exception' does not support the operator '\+'$ //The type 'MyType' does not support the operator '\+'$ //The type 'MyType' does not support the operator '\+'$ + + open System type MyType() = member this.X = 1 -module TestExtensions = - type MyType with - static member (+) (e1: MyType, e2: MyType) = - new MyType() - - type System.Exception with - static member (+) (e1: Exception, e2: Exception) = - new Exception(e1.Message + " " + e2.Message) +//module TestExtensions = +// type MyType with +// static member (+) (e1: MyType, e2: MyType) = +// new MyType() +// +// type System.Exception with +// static member (+) (e1: Exception, e2: Exception) = +// new Exception(e1.Message + " " + e2.Message) let e1 = Exception() let e2 = Exception() diff --git a/tests/fsharpqa/Source/Conformance/TypesAndTypeConstraints/CheckingSyntacticTypes/E_MemberConstraint02.fs b/tests/fsharpqa/Source/Conformance/TypesAndTypeConstraints/CheckingSyntacticTypes/E_MemberConstraint02.fs index 023f7c8a06a..6d2edd7c4fb 100644 --- a/tests/fsharpqa/Source/Conformance/TypesAndTypeConstraints/CheckingSyntacticTypes/E_MemberConstraint02.fs +++ b/tests/fsharpqa/Source/Conformance/TypesAndTypeConstraints/CheckingSyntacticTypes/E_MemberConstraint02.fs @@ -1,5 +1,5 @@ // #Conformance #TypeConstraints #Diagnostics -//The type 'Foo' has a method 'someFunc' \(full name 'someFunc'\), but the method is not static$ +//someFunc is not a static method$ let inline testFunc (a : ^x) = (^x : (static member someFunc : unit -> ^x) ())