diff --git a/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md b/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md index e209c5e9efc..4dd5404bcaa 100644 --- a/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md +++ b/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md @@ -1,6 +1,7 @@ ### Fixed * Fix `NativePtr.stackalloc` nested in a larger expression (e.g. a call argument or the right of an assignment) producing an assembly that throws `InvalidProgramException` at load. ([Issue #8083](https://github.com/dotnet/fsharp/issues/8083), [PR #20302](https://github.com/dotnet/fsharp/pull/20302)) +* Fix internal error "Unexpected generalized type variables when compiling an active pattern" when an active pattern is used in a `let` binding whose right-hand side is a generic value, e.g. `let (T) = id`. Such a binding is now checked like the equivalent `match` and is not generalized. ([Issue #16856](https://github.com/dotnet/fsharp/issues/16856), [PR #20383](https://github.com/dotnet/fsharp/pull/20383)) * Fix Release-only (`--optimize+`) `System.InvalidProgramException` from `Seq.collect` / `yield!` over a value-type (struct) collection implementing `seq<'T>` (e.g. `ImmutableArray<_>`) when materialised with `List.ofSeq` / `Seq.toList` / `Seq.toArray` or a list/array comprehension. The collector lowering now boxes a struct sub-collection to `seq<'T>` before calling `AddMany`/`AddManyAndClose` (matching the coercion the type checker already inserts for `yield!`), and uses `unit` as the try/finally result type instead of the body type (removing a spurious `ldnull` store). ([Issue #20203](https://github.com/dotnet/fsharp/issues/20203)) * Fix recursive inline SRTP resolution being truncated by one currying level (e.g. FSharpPlus `memoizeN`), a regression from the function-domain unification order change in [PR #15181](https://github.com/dotnet/fsharp/pull/15181); the contravariant domain now keeps the inference variable that still carries the pending member constraint. ([PR #20247](https://github.com/dotnet/fsharp/pull/20247)) * Fix exponential (2^N) compile time in pattern matching with shared guards and partial active patterns. ([Issue #18425](https://github.com/dotnet/fsharp/issues/18425), [PR #20244](https://github.com/dotnet/fsharp/pull/20244)) diff --git a/src/Compiler/Checking/CheckBasics.fs b/src/Compiler/Checking/CheckBasics.fs index af876f3c08e..df2281a7655 100644 --- a/src/Compiler/Checking/CheckBasics.fs +++ b/src/Compiler/Checking/CheckBasics.fs @@ -86,7 +86,9 @@ type PrelimVal1 = type UnscopedTyparEnv = UnscopedTyparEnv of NameMap -type TcPatLinearEnv = TcPatLinearEnv of tpenv: UnscopedTyparEnv * names: NameMap * takenNames: Set +/// Represents the context flowed left-to-right through pattern checking. +/// 'usesActivePattern' is true if an active pattern occurs in the pattern; see TcLetBinding. +type TcPatLinearEnv = TcPatLinearEnv of tpenv: UnscopedTyparEnv * names: NameMap * takenNames: Set * usesActivePattern: bool /// Translation of patterns is split into three phases. The first collects names. /// The second is run after val_specs have been created for those names and inference diff --git a/src/Compiler/Checking/CheckBasics.fsi b/src/Compiler/Checking/CheckBasics.fsi index c2cecd40d06..d05dbc8d1c0 100644 --- a/src/Compiler/Checking/CheckBasics.fsi +++ b/src/Compiler/Checking/CheckBasics.fsi @@ -214,8 +214,14 @@ type TcPatPhase2Input = member WithRightPath: unit -> TcPatPhase2Input -/// Represents the context flowed left-to-right through pattern checking -type TcPatLinearEnv = TcPatLinearEnv of tpenv: UnscopedTyparEnv * names: NameMap * takenNames: Set +/// Represents the context flowed left-to-right through pattern checking. +/// 'usesActivePattern' is true if an active pattern occurs in the pattern; see TcLetBinding. +type TcPatLinearEnv = + | TcPatLinearEnv of + tpenv: UnscopedTyparEnv * + names: NameMap * + takenNames: Set * + usesActivePattern: bool /// Represents the flags passed to TcPat regarding the binding location type TcPatValFlags = diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index 24b6cf8fe5f..f83180baabd 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/src/Compiler/Checking/CheckDeclarations.fs @@ -2698,7 +2698,7 @@ module EstablishTypeDefinitionCores = | Some pat -> let ctorArgNames, patEnv, _ = TcSimplePatsOfUnknownType cenv true NoCheckCxs env tpenv pat - let (TcPatLinearEnv(_, names, _)) = patEnv + let (TcPatLinearEnv(_, names, _, _)) = patEnv for arg in ctorArgNames do let ty = names[arg].Type @@ -3928,7 +3928,7 @@ module EstablishTypeDefinitionCores = if tycon.IsFSharpStructOrEnumTycon then let ctorArgNames, patEnv, _ = TcSimplePatsOfUnknownType cenv true CheckCxs envinner tpenv pat - let (TcPatLinearEnv(_, names, _)) = patEnv + let (TcPatLinearEnv(_, names, _, _)) = patEnv for arg in ctorArgNames do let ty = names[arg].Type diff --git a/src/Compiler/Checking/CheckIncrementalClasses.fs b/src/Compiler/Checking/CheckIncrementalClasses.fs index a6513de2856..0fae2f06970 100644 --- a/src/Compiler/Checking/CheckIncrementalClasses.fs +++ b/src/Compiler/Checking/CheckIncrementalClasses.fs @@ -149,7 +149,7 @@ let TcImplicitCtorInfo_Phase2A(cenv: cenv, env, tpenv, tcref: TyconRef, vis, att for spat in spats do reportGeneratedPattern spat - let (TcPatLinearEnv(_, names, _)) = patEnv + let (TcPatLinearEnv(_, names, _, _)) = patEnv // Create the values with the given names let _, vspecs = MakeAndPublishSimpleVals cenv env names diff --git a/src/Compiler/Checking/CheckPatterns.fs b/src/Compiler/Checking/CheckPatterns.fs index 7ea6500dcfb..a65b06d4306 100644 --- a/src/Compiler/Checking/CheckPatterns.fs +++ b/src/Compiler/Checking/CheckPatterns.fs @@ -77,7 +77,7 @@ let rec TryAdjustHiddenVarNameToCompGenName (cenv: cenv) env (id: Ident) altName /// Bind the patterns used in a lambda. Not clear why we don't use TcPat. and TcSimplePat optionalArgsOK checkConstraints (cenv: cenv) ty env patEnv p (attribs: SynAttributes) = let g = cenv.g - let (TcPatLinearEnv(tpenv, names, takenNames)) = patEnv + let (TcPatLinearEnv(tpenv, names, takenNames, usesAP)) = patEnv match p with | SynSimplePat.Id (id, altNameRefCellOpt, isCompGen, isMemberThis, isOpt, m) -> @@ -99,7 +99,7 @@ and TcSimplePat optionalArgsOK checkConstraints (cenv: cenv) ty env patEnv p (at let vFlags = TcPatValFlags (ValInline.Optional, permitInferTypars, noArgOrRetAttribs, false, None, isCompGen) let _, names, takenNames = TcPatBindingName cenv env id ty isMemberThis None None vFlags (names, takenNames) - let patEnvR = TcPatLinearEnv(tpenv, names, takenNames) + let patEnvR = TcPatLinearEnv(tpenv, names, takenNames, usesAP) id.idText, patEnvR | SynSimplePat.Typed (p, cty, m) -> @@ -114,7 +114,7 @@ and TcSimplePat optionalArgsOK checkConstraints (cenv: cenv) ty env patEnv p (at UnifyTypes cenv env m ty optionalParamTy | _ -> UnifyTypes cenv env m ty ctyR - let patEnvR = TcPatLinearEnv(tpenv, names, takenNames) + let patEnvR = TcPatLinearEnv(tpenv, names, takenNames, usesAP) // Ensure the untyped typar name sticks match cty, ty with @@ -169,17 +169,17 @@ and TcSimplePats (cenv: cenv) optionalArgsOK checkConstraints ty env patEnv synS let augmentTakenNamesFromFirstGroup (parsedData: SynPat list * bool) (patEnvOut: TcPatLinearEnv) : TcPatLinearEnv = match parsedData, patEnvOut with - | (pats ,true), TcPatLinearEnv(tpenvR, namesR, takenNamesR) -> + | (pats ,true), TcPatLinearEnv(tpenvR, namesR, takenNamesR, usesAPR) -> match pats with | pat :: _ -> let extra = collectBoundIdTextsFromPat [] pat |> Set.ofList - TcPatLinearEnv(tpenvR, namesR, Set.union takenNamesR extra) + TcPatLinearEnv(tpenvR, namesR, Set.union takenNamesR extra, usesAPR) | _ -> patEnvOut | _ -> patEnvOut let bindCurriedGroup (synSimplePats: SynSimplePats) : string list * TcPatLinearEnv = let g = cenv.g - let (TcPatLinearEnv(tpenv, names, takenNames)) = patEnv + let (TcPatLinearEnv(tpenv, names, takenNames, usesAP)) = patEnv match synSimplePats with | SynSimplePats.SimplePats ([], _, m) -> // Unit "()" patterns in argument position become SynSimplePats.SimplePats([], _) in the @@ -194,7 +194,7 @@ and TcSimplePats (cenv: cenv) optionalArgsOK checkConstraints ty env patEnv synS UnifyTypes cenv env m ty g.unit_ty let vFlags = TcPatValFlags (ValInline.Optional, permitInferTypars, noArgOrRetAttribs, false, None, true) let _, namesR, takenNamesR = TcPatBindingName cenv env id ty false None None vFlags (names, takenNames) - [ id.idText ], TcPatLinearEnv(tpenv, namesR, takenNamesR) + [ id.idText ], TcPatLinearEnv(tpenv, namesR, takenNamesR, usesAP) | SynSimplePats.SimplePats ([sp], _, _) -> // Single parameter: no tuple splitting, check directly let v, patEnv' = TcSimplePat optionalArgsOK checkConstraints cenv ty env patEnv sp [] @@ -221,7 +221,7 @@ and TcSimplePats (cenv: cenv) optionalArgsOK checkConstraints ty env patEnv synS and TcSimplePatsOfUnknownType (cenv: cenv) optionalArgsOK checkConstraints env tpenv (pat: SynPat) = let g = cenv.g let argTy = NewInferenceType g - let patEnv = TcPatLinearEnv (tpenv, NameMap.empty, Set.empty) + let patEnv = TcPatLinearEnv (tpenv, NameMap.empty, Set.empty, false) let spats, _ = SimplePatsOfPat cenv.synArgNameGenerator pat let names, patEnv = TcSimplePats cenv optionalArgsOK checkConstraints argTy env patEnv spats ([], false) names, patEnv, spats @@ -314,16 +314,16 @@ and TcPat warnOnUpper (cenv: cenv) env valReprInfo vFlags (patEnv: TcPatLinearEn | SynPat.OptionalVal (id, m) -> errorR (Error (FSComp.SR.tcOptionalArgsOnlyOnMembers (), m)) - let (TcPatLinearEnv(tpenv, names, takenNames)) = patEnv + let (TcPatLinearEnv(tpenv, names, takenNames, usesAP)) = patEnv let bindf, namesR, takenNamesR = TcPatBindingName cenv env id ty false None valReprInfo vFlags (names, takenNames) - let patEnvR = TcPatLinearEnv(tpenv, namesR, takenNamesR) + let patEnvR = TcPatLinearEnv(tpenv, namesR, takenNamesR, usesAP) (fun values -> TPat_as (TPat_wild m, bindf values, m)), patEnvR | SynPat.Typed (p, cty, m) -> - let (TcPatLinearEnv(tpenv, names, takenNames)) = patEnv + let (TcPatLinearEnv(tpenv, names, takenNames, usesAP)) = patEnv let ctyR, tpenvR = TcTypeAndRecover cenv NewTyparsOK CheckCxs ItemOccurrence.UseInType WarnOnIWSAM.Yes env tpenv cty UnifyTypes cenv env m ty ctyR - let patEnvR = TcPatLinearEnv(tpenvR, names, takenNames) + let patEnvR = TcPatLinearEnv(tpenvR, names, takenNames, usesAP) TcPat warnOnUpper cenv env valReprInfo vFlags patEnvR ty p | SynPat.Attrib (innerPat, attrs, _) -> @@ -395,9 +395,9 @@ and TcConstPat warnOnUpper cenv env vFlags patEnv ty synConst m = (fun _ -> TPat_error m), patEnv and TcPatNamedAs warnOnUpper cenv env valReprInfo vFlags patEnv ty synInnerPat id isMemberThis vis m = - let (TcPatLinearEnv(tpenv, names, takenNames)) = patEnv + let (TcPatLinearEnv(tpenv, names, takenNames, usesAP)) = patEnv let bindf, namesR, takenNamesR = TcPatBindingName cenv env id ty isMemberThis vis valReprInfo vFlags (names, takenNames) - let patEnvR = TcPatLinearEnv(tpenv, namesR, takenNamesR) + let patEnvR = TcPatLinearEnv(tpenv, namesR, takenNamesR, usesAP) let innerPat, acc = TcPat warnOnUpper cenv env None vFlags patEnvR ty synInnerPat let phase2 values = TPat_as (innerPat values, bindf values, m) phase2, acc @@ -418,18 +418,18 @@ and TcPatUnnamedAs warnOnUpper cenv env vFlags patEnv ty pat1 pat2 m = phase2, patEnvR and TcPatNamed warnOnUpper cenv env vFlags patEnv id ty isMemberThis vis valReprInfo m = - let (TcPatLinearEnv(tpenv, names, takenNames)) = patEnv + let (TcPatLinearEnv(tpenv, names, takenNames, usesAP)) = patEnv let bindf, namesR, takenNamesR = TcPatBindingName cenv env id ty isMemberThis vis valReprInfo vFlags (names, takenNames) - let patEnvR = TcPatLinearEnv(tpenv, namesR, takenNamesR) + let patEnvR = TcPatLinearEnv(tpenv, namesR, takenNamesR, usesAP) let pat', acc = TcPat warnOnUpper cenv env None vFlags patEnvR ty (SynPat.Wild m) let phase2 values = TPat_as (pat' values, bindf values, m) phase2, acc and TcPatIsInstance warnOnUpper cenv env valReprInfo vFlags patEnv srcTy synPat synTargetTy m = - let (TcPatLinearEnv(tpenv, names, takenNames)) = patEnv + let (TcPatLinearEnv(tpenv, names, takenNames, usesAP)) = patEnv let tgtTy, tpenv = TcTypeAndRecover cenv NewTyparsOKButWarnIfNotRigid CheckCxs ItemOccurrence.UseInType WarnOnIWSAM.Yes env tpenv synTargetTy TcRuntimeTypeTest false true cenv env.DisplayEnv m tgtTy srcTy - let patEnv = TcPatLinearEnv(tpenv, names, takenNames) + let patEnv = TcPatLinearEnv(tpenv, names, takenNames, usesAP) match synPat with | SynPat.IsInst(_, m) -> (fun _ -> TPat_isinst (srcTy, tgtTy, None, m)), patEnv @@ -445,11 +445,11 @@ and TcPatAttributed warnOnUpper cenv env vFlags patEnv ty innerPat attrs = TcPat warnOnUpper cenv env None vFlags patEnv ty innerPat and TcPatOr warnOnUpper cenv env vFlags patEnv ty pat1 pat2 m = - let (TcPatLinearEnv(_, names, takenNames)) = patEnv + let (TcPatLinearEnv(_, names, takenNames, usesAP)) = patEnv let pat1R, patEnv1 = TcPat warnOnUpper cenv env None vFlags patEnv ty pat1 - let (TcPatLinearEnv(tpenv, names1, takenNames1)) = patEnv1 - let pat2R, patEnv2 = TcPat warnOnUpper cenv env None vFlags (TcPatLinearEnv(tpenv, names, takenNames)) ty pat2 - let (TcPatLinearEnv(tpenv, names2, takenNames2)) = patEnv2 + let (TcPatLinearEnv(tpenv, names1, takenNames1, usesAP1)) = patEnv1 + let pat2R, patEnv2 = TcPat warnOnUpper cenv env None vFlags (TcPatLinearEnv(tpenv, names, takenNames, usesAP)) ty pat2 + let (TcPatLinearEnv(tpenv, names2, takenNames2, usesAP2)) = patEnv2 if takenNames1 <> takenNames2 then errorR (UnionPatternsBindDifferentNames m) @@ -463,7 +463,7 @@ and TcPatOr warnOnUpper cenv env vFlags patEnv ty pat1 pat2 m = let namesR = NameMap.layer names1 names2 let takenNamesR = Set.union takenNames1 takenNames2 - let patEnvR = TcPatLinearEnv(tpenv, namesR, takenNamesR) + let patEnvR = TcPatLinearEnv(tpenv, namesR, takenNamesR, usesAP1 || usesAP2) let phase2 values = TPat_disjs ([pat1R values; pat2R (values.WithRightPath())], m) phase2, patEnvR @@ -622,7 +622,7 @@ and TcPatLongIdent warnOnUpper cenv env ad valReprInfo vFlags (patEnv: TcPatLine /// Check a long identifier in a pattern that has been not been resolved to anything else and represents a new value, or nameof and TcPatLongIdentNewDef warnOnUpperForId warnOnUpper (cenv: cenv) env ad valReprInfo vFlags patEnv ty (vis, id, args, m) = let g = cenv.g - let (TcPatLinearEnv(tpenv, _, _)) = patEnv + let (TcPatLinearEnv(tpenv, _, _, _)) = patEnv match GetSynArgPatterns args with | [] -> @@ -859,7 +859,7 @@ and TcPatLongIdentRecdField warnOnUpper cenv env vFlags patEnv ty (mLongId, rfin /// Check a long identifier that has been resolved to an F# value that is a literal and TcPatLongIdentLiteral warnOnUpper (cenv: cenv) env vFlags patEnv ty (mLongId, vref, args, m) = let g = cenv.g - let (TcPatLinearEnv(tpenv, _, _)) = patEnv + let (TcPatLinearEnv(tpenv, _, _, _)) = patEnv match vref.LiteralValue with | None -> error (Error(FSComp.SR.tcNonLiteralCannotBeUsedInPattern(), m)) diff --git a/src/Compiler/Checking/Expressions/CheckExpressions.fs b/src/Compiler/Checking/Expressions/CheckExpressions.fs index ff34ea0ae34..1e623e18578 100644 --- a/src/Compiler/Checking/Expressions/CheckExpressions.fs +++ b/src/Compiler/Checking/Expressions/CheckExpressions.fs @@ -434,7 +434,9 @@ type CheckedBindingInfo = debugPoint: DebugPointAtBinding * isCompilerGenerated: bool * literalValue: Const option * - isFixed: bool + isFixed: bool * + /// True if the pattern of the binding uses an active pattern; see TcLetBinding + patternUsesActivePattern: bool member x.Expr = let (CheckedBindingInfo(rhsExprChecked=expr)) = x in expr @@ -5316,7 +5318,7 @@ and ConvSynPatToSynExpr synPat = /// Check a long identifier 'Case' or 'Case argsR' that has been resolved to an active pattern case and TcPatLongIdentActivePatternCase warnOnUpper (cenv: cenv) (env: TcEnv) vFlags patEnv ty (mLongId, item, apref, args, m) = let g = cenv.g - let (TcPatLinearEnv(tpenv, names, takenNames)) = patEnv + let (TcPatLinearEnv(tpenv, names, takenNames, _)) = patEnv let (APElemRef (apinfo, vref, idx, isStructRetTy)) = apref let cenv = @@ -5454,7 +5456,7 @@ and TcPatLongIdentActivePatternCase warnOnUpper (cenv: cenv) (env: TcEnv) vFlags let activePatExpr, tpenv = PropagateThenTcDelayed cenv (MustEqual activePatType) env tpenv m vExpr vExprTy ExprAtomicFlag.NonAtomic delayed - let patEnvR = TcPatLinearEnv(tpenv, names, takenNames) + let patEnvR = TcPatLinearEnv(tpenv, names, takenNames, true) if idx >= activePatResTys.Length then error(Error(FSComp.SR.tcInvalidIndexIntoActivePatternArray(), m)) let argTy = List.item idx activePatResTys @@ -6684,8 +6686,8 @@ and TcIteratedLambdas (cenv: cenv) isFirst (env: TcEnv) overallTy takenNames tpe |> Option.map fst |> Option.defaultValue [] - let vs, TcPatLinearEnv (tpenv, names, takenNames) = - cenv.TcSimplePats cenv isMember CheckCxs domainTy env (TcPatLinearEnv (tpenv, Map.empty, takenNames)) synSimplePats (parsedPatterns, isFirst) + let vs, TcPatLinearEnv (tpenv, names, takenNames, _) = + cenv.TcSimplePats cenv isMember CheckCxs domainTy env (TcPatLinearEnv (tpenv, Map.empty, takenNames, false)) synSimplePats (parsedPatterns, isFirst) let envinner, _, vspecMap = MakeAndPublishSimpleValsForMergedScope cenv env m names let byrefs = vspecMap |> Map.map (fun _ v -> isByrefTy g v.Type, v) @@ -7345,7 +7347,7 @@ and TcObjectExprBinding (cenv: cenv) (env: TcEnv) implTy tpenv (absSlotInfo, bin | _ -> mkFunTy cenv.g implTy (NewInferenceType cenv.g) - let CheckedBindingInfo(inlineFlag, bindingAttribs, _, _, ExplicitTyparInfo(_, declaredTypars, _, _), nameToPrelimValSchemeMap, rhsExpr, _, _, m, _, _, _, _), tpenv = + let CheckedBindingInfo(inlineFlag, bindingAttribs, _, _, ExplicitTyparInfo(_, declaredTypars, _, _), nameToPrelimValSchemeMap, rhsExpr, _, _, m, _, _, _, _, _), tpenv = let explicitTyparInfo, tpenv = TcNonrecBindingTyparDecls cenv env tpenv bind TcNormalizedBinding ObjectExpressionOverrideBinding cenv env tpenv bindingTy None NoSafeInitInfo ([], explicitTyparInfo) bind @@ -11238,7 +11240,7 @@ and TcMatchPattern (cenv: cenv) inputTy env tpenv (synPat: SynPat) (synWhenExprO | TcTrueMatchClause.Yes -> WarnOnUpperUnionCaseLabel | TcTrueMatchClause.No -> WarnOnUpperVariablePatterns - let patf', TcPatLinearEnv (tpenv, names, _) = cenv.TcPat warnOnUpperFlag cenv env None (TcPatValFlags (ValInline.Optional, permitInferTypars, noArgOrRetAttribs, false, None, false)) (TcPatLinearEnv (tpenv, Map.empty, Set.empty)) inputTy synPat + let patf', TcPatLinearEnv (tpenv, names, _, _) = cenv.TcPat warnOnUpperFlag cenv env None (TcPatValFlags (ValInline.Optional, permitInferTypars, noArgOrRetAttribs, false, None, false)) (TcPatLinearEnv (tpenv, Map.empty, Set.empty, false)) inputTy synPat let envinner, values, vspecMap = MakeAndPublishSimpleValsForMergedScope cenv env m names let whenExprOpt, tpenv = @@ -11601,8 +11603,8 @@ and TcNormalizedBinding declKind (cenv: cenv) env tpenv overallTy safeThisValOpt let prelimValReprInfo = TranslateSynValInfo cenv mBinding (TcAttributes cenv env) valSynInfo // Check the pattern of the l.h.s. of the binding - let tcPatPhase2, TcPatLinearEnv (tpenv, nameToPrelimValSchemeMap, _) = - cenv.TcPat AllIdsOK cenv envinner (Some prelimValReprInfo) (TcPatValFlags (inlineFlag, explicitTyparInfo, argAndRetAttribs, isMutable, vis, isCompGen)) (TcPatLinearEnv (tpenv, NameMap.empty, Set.empty)) overallPatTy pat + let tcPatPhase2, TcPatLinearEnv (tpenv, nameToPrelimValSchemeMap, _, patternUsesActivePattern) = + cenv.TcPat AllIdsOK cenv envinner (Some prelimValReprInfo) (TcPatValFlags (inlineFlag, explicitTyparInfo, argAndRetAttribs, isMutable, vis, isCompGen)) (TcPatLinearEnv (tpenv, NameMap.empty, Set.empty, false)) overallPatTy pat // Add active pattern result names to the environment let apinfoOpt = @@ -11723,7 +11725,7 @@ and TcNormalizedBinding declKind (cenv: cenv) env tpenv overallTy safeThisValOpt if supportEnforceAttributeTargets then TcAttributeTargetsOnLetBindings { cenv with tcSink = TcResultsSink.NoSink } env attrs overallPatTy overallExprTy (not declaredTypars.IsEmpty) isClassLetBinding - CheckedBindingInfo(inlineFlag, valAttribs, xmlDoc, tcPatPhase2, explicitTyparInfo, nameToPrelimValSchemeMap, rhsExprChecked, argAndRetAttribs, overallPatTy, mBinding, debugPoint, isCompGen, literalValue, isFixed), tpenv + CheckedBindingInfo(inlineFlag, valAttribs, xmlDoc, tcPatPhase2, explicitTyparInfo, nameToPrelimValSchemeMap, rhsExprChecked, argAndRetAttribs, overallPatTy, mBinding, debugPoint, isCompGen, literalValue, isFixed, patternUsesActivePattern), tpenv // Note: // - Let bound values can only have attributes that uses AttributeTargets.Field ||| AttributeTargets.Property ||| AttributeTargets.ReturnValue @@ -12121,7 +12123,7 @@ and TcLetBinding (cenv: cenv) isUse env containerInfo declKind tpenv (synBinds, checkedBinds |> List.fold (fun (nonExt, ext) tbinfo -> - let (CheckedBindingInfo(inlineFlag, _, _, _, explicitTyparInfo, _, _, _, tauTy, _, _, _, _, _)) = + let (CheckedBindingInfo(inlineFlag, _, _, _, explicitTyparInfo, _, _, _, tauTy, _, _, _, _, _, _)) = tbinfo let (ExplicitTyparInfo(_, declaredTypars, _, _)) = explicitTyparInfo @@ -12145,14 +12147,18 @@ and TcLetBinding (cenv: cenv) isUse env containerInfo declKind tpenv (synBinds, // Generalize the bindings... ((id, env, tpenv), checkedBinds) ||> List.fold (fun (buildExpr, env, tpenv) tbinfo -> - let (CheckedBindingInfo(inlineFlag, attrs, xmlDoc, tcPatPhase2, explicitTyparInfo, nameToPrelimValSchemeMap, rhsExpr, _, tauTy, m, debugPoint, _, literalValue, isFixed)) = tbinfo + let (CheckedBindingInfo(inlineFlag, attrs, xmlDoc, tcPatPhase2, explicitTyparInfo, nameToPrelimValSchemeMap, rhsExpr, _, tauTy, m, debugPoint, _, literalValue, isFixed, patternUsesActivePattern)) = tbinfo let enclosingDeclaredTypars = [] let (ExplicitTyparInfo(_, declaredTypars, canInferTypars, hasExplicitTyparDecls)) = explicitTyparInfo let allDeclaredTypars = enclosingDeclaredTypars @ declaredTypars let generalizedTypars, prelimValSchemes2 = let canInferTypars = GeneralizationHelpers. ComputeCanInferExtraGeneralizableTypars (containerInfo.ParentRef, canInferTypars, None) - let maxInferredTypars = freeInTypeLeftToRight g false tauTy + // A binding whose pattern uses an active pattern evaluates it, so it is checked like + // 'match rhsExpr with pat -> ...' and is not generalized (see issue #16856). + let maxInferredTypars = + if patternUsesActivePattern then [] + else freeInTypeLeftToRight g false tauTy let generalizedTypars = if isNil maxInferredTypars && isNil allDeclaredTypars then @@ -12355,7 +12361,7 @@ and ApplyTypesFromArgumentPatterns (cenv: cenv, env, optionalArgsOK, ty, m, tpen let domainTy, resultTy = UnifyFunctionType None cenv env.DisplayEnv m ty // We apply the type information from the patterns by type checking the // "simple" patterns against 'domainTyR'. They get re-typechecked later. - ignore (cenv.TcSimplePats cenv optionalArgsOK CheckCxs domainTy env (TcPatLinearEnv (tpenv, Map.empty, Set.empty)) pushedPat ([], false)) + ignore (cenv.TcSimplePats cenv optionalArgsOK CheckCxs domainTy env (TcPatLinearEnv (tpenv, Map.empty, Set.empty, false)) pushedPat ([], false)) ApplyTypesFromArgumentPatterns (cenv, env, optionalArgsOK, resultTy, m, tpenv, NormalizedBindingRhs (morePushedPats, retInfoOpt, e), memberFlagsOpt) /// Check if the type annotations and inferred type information in a value give a @@ -13199,7 +13205,7 @@ and TcIncrementalLetRecGeneralization cenv scopem newGeneralizableBindings |> List.fold (fun (nonExt, ext) pgrbind -> - let (CheckedBindingInfo(inlineFlag, _, _, _, _, _, _, _, _, _, _, _, _, _)) = + let (CheckedBindingInfo(inlineFlag, _, _, _, _, _, _, _, _, _, _, _, _, _, _)) = pgrbind.CheckedBinding let support = TcLetrecComputeSupportForBinding cenv pgrbind @@ -13243,7 +13249,7 @@ and TcLetrecComputeAndGeneralizeGenericTyparsForBinding cenv denv freeInEnv (pgr let rbinfo = pgrbind.RecBindingInfo let vspec = rbinfo.Val - let (CheckedBindingInfo(inlineFlag, _, _, _, _, _, expr, _, _, m, _, _, _, _)) = pgrbind.CheckedBinding + let (CheckedBindingInfo(inlineFlag, _, _, _, _, _, expr, _, _, m, _, _, _, _, _)) = pgrbind.CheckedBinding let (ExplicitTyparInfo(rigidCopyOfDeclaredTypars, declaredTypars, _, _)) = rbinfo.ExplicitTyparInfo let allDeclaredTypars = rbinfo.EnclosingDeclaredTypars @ declaredTypars @@ -13283,7 +13289,7 @@ and TcLetrecGeneralizeBinding cenv denv generalizedTypars (pgrbind: PreGeneraliz let g = cenv.g let (RecursiveBindingInfo(_, _, enclosingDeclaredTypars, _, vspec, explicitTyparInfo, prelimValReprInfo, memberInfoOpt, _, _, _, vis, _, declKind)) = pgrbind.RecBindingInfo - let (CheckedBindingInfo(inlineFlag, _, _, _, _, _, expr, argAttribs, _, _, _, isCompGen, _, isFixed)) = pgrbind.CheckedBinding + let (CheckedBindingInfo(inlineFlag, _, _, _, _, _, expr, argAttribs, _, _, _, isCompGen, _, isFixed, _)) = pgrbind.CheckedBinding if isFixed then errorR(Error(FSComp.SR.tcFixedNotAllowed(), expr.Range)) diff --git a/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Named/ActivePatternInLetBindingBindsValue.fs b/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Named/ActivePatternInLetBindingBindsValue.fs new file mode 100644 index 00000000000..3c519593301 --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Named/ActivePatternInLetBindingBindsValue.fs @@ -0,0 +1,7 @@ +// #Conformance #PatternMatching #ActivePatterns +// Regression test for https://github.com/dotnet/fsharp/issues/16856 + +let (|Id|) f = f +let (Id g) = id + +if g 1 <> 1 then failwith "expected g to be usable at a concrete type" diff --git a/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Named/ActivePatternInLetBindingLocalScope.fs b/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Named/ActivePatternInLetBindingLocalScope.fs new file mode 100644 index 00000000000..fc3c3c4b28c --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Named/ActivePatternInLetBindingLocalScope.fs @@ -0,0 +1,13 @@ +// #Conformance #PatternMatching #ActivePatterns +// Regression test for https://github.com/dotnet/fsharp/issues/16856 + +let mutable count = 0 +let (|T|) (f: _ -> _) = count <- count + 1 + +let apply () = + let (T) = id + () + +apply () + +if count <> 1 then failwith "local let form: expected exactly one evaluation" diff --git a/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Named/ActivePatternInLetBindingTuplePattern.fs b/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Named/ActivePatternInLetBindingTuplePattern.fs new file mode 100644 index 00000000000..9d78345fd5a --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Named/ActivePatternInLetBindingTuplePattern.fs @@ -0,0 +1,7 @@ +// #Conformance #PatternMatching #ActivePatterns +// Regression test for https://github.com/dotnet/fsharp/issues/16856 + +let (|T|) (f: _ -> _) = () +let (T), x = id, 1 + +if x <> 1 then failwith "expected the tuple partner value to bind" diff --git a/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Named/ActivePatternInLetBindingWithGenericRhs.fs b/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Named/ActivePatternInLetBindingWithGenericRhs.fs new file mode 100644 index 00000000000..04158722286 --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Named/ActivePatternInLetBindingWithGenericRhs.fs @@ -0,0 +1,14 @@ +// #Conformance #PatternMatching #ActivePatterns +// Regression test for https://github.com/dotnet/fsharp/issues/16856 + +let mutable count = 0 +let (|T|) (f: _ -> _) = count <- count + 1 + +match id with +| T -> () + +if count <> 1 then failwith "match form: expected exactly one evaluation" + +let (T) = id + +if count <> 2 then failwith "let form: expected exactly one evaluation" diff --git a/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Named/E_ActivePatternInLetBindingTupleNotGeneralized.fs b/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Named/E_ActivePatternInLetBindingTupleNotGeneralized.fs new file mode 100644 index 00000000000..325c1544ebb --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Named/E_ActivePatternInLetBindingTupleNotGeneralized.fs @@ -0,0 +1,10 @@ +// #Conformance #PatternMatching #ActivePatterns +// Regression test for https://github.com/dotnet/fsharp/issues/16856 +// An active pattern anywhere in the pattern de-generalizes the whole binding, +// exactly like the equivalent 'match': neither 'g' nor its tuple partner 'h' is generalized. + +let (|Id|) f = f + +let (Id g), h = id, id + +let g2, h2 = match id, id with Id g, h -> g, h diff --git a/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Named/E_ActivePatternInLetBindingValueRestriction.fs b/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Named/E_ActivePatternInLetBindingValueRestriction.fs new file mode 100644 index 00000000000..54cc253255d --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Named/E_ActivePatternInLetBindingValueRestriction.fs @@ -0,0 +1,9 @@ +// #Conformance #PatternMatching #ActivePatterns +// Regression test for https://github.com/dotnet/fsharp/issues/16856 +// A value bound through an active pattern is not generalized, exactly like +// let g = match id with Id g -> g +// so leaving it unused reports the value restriction rather than an internal error. +//Value restriction: The value 'g' has an inferred generic function type + +let (|Id|) f = f +let (Id g) = id diff --git a/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Named/Named.fs b/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Named/Named.fs index ba48761e5f3..e1063b8f0fa 100644 --- a/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Named/Named.fs +++ b/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Named/Named.fs @@ -27,6 +27,69 @@ module Named = |> typecheck |> shouldSucceed + [] + let ``Named - ActivePatternInLetBindingWithGenericRhs_fs`` compilation = + compilation + |> getCompilation + |> asExe + |> compileExeAndRun + |> shouldSucceed + + [] + let ``Named - ActivePatternInLetBindingBindsValue_fs`` compilation = + compilation + |> getCompilation + |> asExe + |> compileExeAndRun + |> shouldSucceed + + [] + let ``Named - ActivePatternInLetBindingLocalScope_fs`` compilation = + compilation + |> getCompilation + |> asExe + |> compileExeAndRun + |> shouldSucceed + + [] + let ``Named - ActivePatternInLetBindingTuplePattern_fs`` compilation = + compilation + |> getCompilation + |> asExe + |> compileExeAndRun + |> shouldSucceed + + [] + let ``Named - PartialActivePatternInLetBinding_fs`` compilation = + compilation + |> getCompilation + |> asFs + |> withOptions ["--test:ErrorRanges"] + |> typecheck + |> shouldFail + |> withSingleDiagnostic (Warning 25, Line 5, Col 5, Line 5, Col 8, "Incomplete pattern matches on this expression.") + + [] + let ``Named - E_ActivePatternInLetBindingValueRestriction_fs`` compilation = + compilation + |> getCompilation + |> asFs + |> typecheck + |> shouldFail + |> withErrorCode 30 + |> withDiagnosticMessageMatches "Value restriction: The value 'g' has an inferred generic function type" + + [] + let ``Named - E_ActivePatternInLetBindingTupleNotGeneralized_fs`` compilation = + compilation + |> getCompilation + |> asFs + |> typecheck + |> shouldFail + |> withErrorCodes [30; 30; 30; 30] + |> withDiagnosticMessageMatches "Value restriction: The value 'h' has an inferred generic function type" + |> withDiagnosticMessageMatches "Value restriction: The value 'h2' has an inferred generic function type" + // This test was automatically generated (moved from FSharpQA suite - Conformance/PatternMatching/Named) [] let ``Named - activePatterns01_fs - --test:ErrorRanges`` compilation = diff --git a/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Named/PartialActivePatternInLetBinding.fs b/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Named/PartialActivePatternInLetBinding.fs new file mode 100644 index 00000000000..5128a491ee9 --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/Named/PartialActivePatternInLetBinding.fs @@ -0,0 +1,5 @@ +// #Conformance #PatternMatching #ActivePatterns +// Regression test for https://github.com/dotnet/fsharp/issues/16856 + +let (|P|_|) (f: _ -> _) = Some() +let (P) = id