diff --git a/docs/release-notes/.FSharp.Compiler.Service/8.0.300.md b/docs/release-notes/.FSharp.Compiler.Service/8.0.300.md index 85735d5b430..0289b352060 100644 --- a/docs/release-notes/.FSharp.Compiler.Service/8.0.300.md +++ b/docs/release-notes/.FSharp.Compiler.Service/8.0.300.md @@ -13,6 +13,7 @@ * Parser recovers on complex primary constructor patterns, better tree representation for primary constructor patterns. ([PR #16425](https://github.com/dotnet/fsharp/pull/16425)) * Name resolution: keep type vars in subsequent checks ([PR #16456](https://github.com/dotnet/fsharp/pull/16456)) * Higher-order-function-based API for working with the untyped abstract syntax tree. ([PR #16462](https://github.com/dotnet/fsharp/pull/16462)) +* Allow returning bool instead of unit option for partial active patterns. ([Language suggestion #1041](https://github.com/fsharp/fslang-suggestions/issues/1041), [PR #16473](https://github.com/dotnet/fsharp/pull/16473)) ### Changed diff --git a/docs/release-notes/.Language/preview.md b/docs/release-notes/.Language/preview.md index 0fce580b51e..832dd924a44 100644 --- a/docs/release-notes/.Language/preview.md +++ b/docs/release-notes/.Language/preview.md @@ -3,6 +3,7 @@ * Better generic unmanaged structs handling. ([Language suggestion #692](https://github.com/fsharp/fslang-suggestions/issues/692), [PR #12154](https://github.com/dotnet/fsharp/pull/12154)) * Bidirectional F#/C# interop for 'unmanaged' constraint. ([PR #12154](https://github.com/dotnet/fsharp/pull/12154)) * Make `.Is*` discriminated union properties visible. ([Language suggestion #222](https://github.com/fsharp/fslang-suggestions/issues/222), [PR #16341](https://github.com/dotnet/fsharp/pull/16341)) +* Allow returning bool instead of unit option for partial active patterns. ([Language suggestion #1041](https://github.com/fsharp/fslang-suggestions/issues/1041), [PR #16473](https://github.com/dotnet/fsharp/pull/16473)) ### Fixed diff --git a/src/Compiler/Checking/CheckExpressions.fs b/src/Compiler/Checking/CheckExpressions.fs index 2cac6dfbec3..e59fb6bd5ff 100644 --- a/src/Compiler/Checking/CheckExpressions.fs +++ b/src/Compiler/Checking/CheckExpressions.fs @@ -5093,7 +5093,11 @@ and TcPatLongIdentActivePatternCase warnOnUpper (cenv: cenv) (env: TcEnv) vFlags if dtys.Length = args.Length + 1 && ((isOptionTy g retTy && isUnitTy g (destOptionTy g retTy)) || - (isValueOptionTy g retTy && isUnitTy g (destValueOptionTy g retTy))) then + (isValueOptionTy g retTy && isUnitTy g (destValueOptionTy g retTy))) || + // `bool` partial AP always be treated as `unit option` + // For `val (|P|_|) : _ -> bool`, only allow `match x with | P -> ...` + // For `val (|P|_|) : _ -> _ -> bool`, only allow `match x with | P parameter -> ...` + (not apinfo.IsTotal && isBoolTy g retTy) then args, SynPat.Const(SynConst.Unit, m) else List.frontAndBack args @@ -10752,14 +10756,25 @@ and TcNormalizedBinding declKind (cenv: cenv) env tpenv overallTy safeThisValOpt | Some (apinfo, apOverallTy, _) -> let activePatResTys = NewInferenceTypes g apinfo.ActiveTags let _, apReturnTy = stripFunTy g apOverallTy - - if isStructRetTy && apinfo.IsTotal then - errorR(Error(FSComp.SR.tcInvalidStructReturn(), mBinding)) - - if isStructRetTy then + let apRetTy = + if apinfo.IsTotal then + if isStructRetTy then errorR(Error(FSComp.SR.tcInvalidStructReturn(), mBinding)) + ActivePatternReturnKind.RefTypeWrapper + else + if isStructRetTy || isValueOptionTy cenv.g apReturnTy then ActivePatternReturnKind.StructTypeWrapper + elif isBoolTy cenv.g apReturnTy then ActivePatternReturnKind.Boolean + else ActivePatternReturnKind.RefTypeWrapper + + match apRetTy with + | ActivePatternReturnKind.Boolean -> + checkLanguageFeatureError g.langVersion LanguageFeature.BooleanReturningAndReturnTypeDirectedPartialActivePattern mBinding + | ActivePatternReturnKind.StructTypeWrapper when not isStructRetTy -> + checkLanguageFeatureError g.langVersion LanguageFeature.BooleanReturningAndReturnTypeDirectedPartialActivePattern mBinding + | ActivePatternReturnKind.StructTypeWrapper -> checkLanguageFeatureError g.langVersion LanguageFeature.StructActivePattern mBinding + | ActivePatternReturnKind.RefTypeWrapper -> () - UnifyTypes cenv env mBinding (apinfo.ResultType g rhsExpr.Range activePatResTys isStructRetTy) apReturnTy + UnifyTypes cenv env mBinding (apinfo.ResultType g rhsExpr.Range activePatResTys apRetTy) apReturnTy | None -> if isStructRetTy then diff --git a/src/Compiler/Checking/NameResolution.fs b/src/Compiler/Checking/NameResolution.fs index 21bfa7a2308..b70c297e988 100644 --- a/src/Compiler/Checking/NameResolution.fs +++ b/src/Compiler/Checking/NameResolution.fs @@ -87,9 +87,9 @@ let ActivePatternElemsOfValRef g (vref: ValRef) = match TryGetActivePatternInfo vref with | Some apinfo -> - let isStructRetTy = + let retKind = if apinfo.IsTotal then - false + ActivePatternReturnKind.RefTypeWrapper else let _, apReturnTy = stripFunTy g vref.TauType let hasStructAttribute() = @@ -97,8 +97,10 @@ let ActivePatternElemsOfValRef g (vref: ValRef) = |> List.exists (function | Attrib(targetsOpt = Some(System.AttributeTargets.ReturnValue)) as a -> IsMatchingFSharpAttribute g g.attrib_StructAttribute a | _ -> false) - isStructTy g apReturnTy || hasStructAttribute() - apinfo.ActiveTags |> List.mapi (fun i _ -> APElemRef(apinfo, vref, i, isStructRetTy)) + if isValueOptionTy g apReturnTy || hasStructAttribute() then ActivePatternReturnKind.StructTypeWrapper + elif isBoolTy g apReturnTy then ActivePatternReturnKind.Boolean + else ActivePatternReturnKind.RefTypeWrapper + apinfo.ActiveTags |> List.mapi (fun i _ -> APElemRef(apinfo, vref, i, retKind)) | None -> [] /// Try to make a reference to a value in a module. diff --git a/src/Compiler/Checking/PatternMatchCompilation.fs b/src/Compiler/Checking/PatternMatchCompilation.fs index 168bd86e60e..4e8ced8fadb 100644 --- a/src/Compiler/Checking/PatternMatchCompilation.fs +++ b/src/Compiler/Checking/PatternMatchCompilation.fs @@ -43,7 +43,7 @@ type Pattern = | TPat_as of Pattern * PatternValBinding * range (* note: can be replaced by TPat_var, i.e. equals TPat_conjs([TPat_var; pat]) *) | TPat_disjs of Pattern list * range | TPat_conjs of Pattern list * range - | TPat_query of (Expr * TType list * bool * (ValRef * TypeInst) option * int * ActivePatternInfo) * Pattern * range + | TPat_query of (Expr * TType list * ActivePatternReturnKind * (ValRef * TypeInst) option * int * ActivePatternInfo) * Pattern * range | TPat_unioncase of UnionCaseRef * TypeInst * Pattern list * range | TPat_exnconstr of TyconRef * Pattern list * range | TPat_tuple of TupInfo * Pattern list * TType list * range @@ -618,8 +618,8 @@ let getDiscrimOfPattern (g: TcGlobals) tpinst t = Some(DecisionTreeTest.UnionCase (c, instTypes tpinst tyargs')) | TPat_array (args, ty, _m) -> Some(DecisionTreeTest.ArrayLength (args.Length, ty)) - | TPat_query ((activePatExpr, resTys, isStructRetTy, apatVrefOpt, idx, apinfo), _, _m) -> - Some (DecisionTreeTest.ActivePatternCase (activePatExpr, instTypes tpinst resTys, isStructRetTy, apatVrefOpt, idx, apinfo)) + | TPat_query ((activePatExpr, resTys, retKind, apatVrefOpt, idx, apinfo), _, _m) -> + Some (DecisionTreeTest.ActivePatternCase (activePatExpr, instTypes tpinst resTys, retKind, apatVrefOpt, idx, apinfo)) | TPat_error range -> Some (DecisionTreeTest.Error range) @@ -941,8 +941,8 @@ let rec investigationPoints inpPat = let rec erasePartialPatterns inpPat = match inpPat with - | TPat_query ((expr, resTys, isStructRetTy, apatVrefOpt, idx, apinfo), p, m) -> - if apinfo.IsTotal then TPat_query ((expr, resTys, isStructRetTy, apatVrefOpt, idx, apinfo), erasePartialPatterns p, m) + | TPat_query ((expr, resTys, retKind, apatVrefOpt, idx, apinfo), p, m) -> + if apinfo.IsTotal then TPat_query ((expr, resTys, retKind, apatVrefOpt, idx, apinfo), erasePartialPatterns p, m) else TPat_disjs ([], m) (* always fail *) | TPat_as (p, x, m) -> TPat_as (erasePartialPatterns p, x, m) | TPat_disjs (subPats, m) -> TPat_disjs(erasePartials subPats, m) @@ -1293,15 +1293,20 @@ let CompilePatternBasic // Active pattern matches: create a variable to hold the results of executing the active pattern. // If a struct return we continue with an expression for taking the address of that location. - | EdgeDiscrim(_, DecisionTreeTest.ActivePatternCase(activePatExpr, resTys, isStructRetTy, _apatVrefOpt, _, apinfo), m) :: _ -> + | EdgeDiscrim(_, DecisionTreeTest.ActivePatternCase(activePatExpr, resTys, retKind, _apatVrefOpt, _, apinfo), m) :: _ -> if not (isNil origInputValTypars) then error(InternalError("Unexpected generalized type variables when compiling an active pattern", m)) - let resTy = apinfo.ResultType g m resTys isStructRetTy + let resTy = apinfo.ResultType g m resTys retKind let argExpr = GetSubExprOfInput subexpr let appExpr = mkApps g ((activePatExpr, tyOfExpr g activePatExpr), [], [argExpr], m) - let vOpt, addrExp, _readonly, _writeonly = mkExprAddrOfExprAux g isStructRetTy false NeverMutates appExpr None mMatch + let mustTakeAddress = + match retKind with + | ActivePatternReturnKind.StructTypeWrapper -> true + | ActivePatternReturnKind.RefTypeWrapper + | ActivePatternReturnKind.Boolean -> false + let vOpt, addrExp, _readonly, _writeonly = mkExprAddrOfExprAux g mustTakeAddress false NeverMutates appExpr None mMatch match vOpt with | None -> let v, vExpr = mkCompGenLocal m ("activePatternResult" + string (newUnique())) resTy @@ -1357,13 +1362,17 @@ let CompilePatternBasic // Convert active pattern edges to tests on results data let discrim' = match discrim with - | DecisionTreeTest.ActivePatternCase(_pexp, resTys, isStructRetTy, _apatVrefOpt, idx, apinfo) -> + | DecisionTreeTest.ActivePatternCase(_pexp, resTys, retKind, _apatVrefOpt, idx, apinfo) -> let aparity = apinfo.ActiveTags.Length let total = apinfo.IsTotal if not total && aparity > 1 then error(Error(FSComp.SR.patcPartialActivePatternsGenerateOneResult(), m)) - if not total then DecisionTreeTest.UnionCase(mkAnySomeCase g isStructRetTy, resTys) + if not total then + match retKind with + | ActivePatternReturnKind.Boolean -> DecisionTreeTest.Const(Const.Bool true) + | ActivePatternReturnKind.RefTypeWrapper -> DecisionTreeTest.UnionCase(mkAnySomeCase g false, resTys) + | ActivePatternReturnKind.StructTypeWrapper -> DecisionTreeTest.UnionCase(mkAnySomeCase g true, resTys) elif aparity <= 1 then DecisionTreeTest.Const(Const.Unit) else DecisionTreeTest.UnionCase(mkChoiceCaseRef g m aparity idx, resTys) | _ -> discrim @@ -1435,7 +1444,7 @@ let CompilePatternBasic let newActives = removeActive path actives match patAtActive with | TPat_wild _ | TPat_as _ | TPat_tuple _ | TPat_disjs _ | TPat_conjs _ | TPat_recd _ -> failwith "Unexpected projection pattern" - | TPat_query ((_, resTys, isStructRetTy, apatVrefOpt, idx, apinfo), p, m) -> + | TPat_query ((_, resTys, retKind, apatVrefOpt, idx, apinfo), p, m) -> if apinfo.IsTotal then // Total active patterns always return choice values let hasParam = (match apatVrefOpt with None -> true | Some (vref, _) -> doesActivePatternHaveFreeTypars g vref) @@ -1463,10 +1472,12 @@ let CompilePatternBasic if i = iInvestigated then let subAccess _j tpinst _ = let expr = Option.get inpExprOpt - if isStructRetTy then + match retKind with + | ActivePatternReturnKind.Boolean -> expr + | ActivePatternReturnKind.StructTypeWrapper -> // In this case, the inpExprOpt is already an address-of expression mkUnionCaseFieldGetProvenViaExprAddr (expr, mkValueSomeCase g, instTypes tpinst resTys, 0, mExpr) - else + | ActivePatternReturnKind.RefTypeWrapper -> mkUnionCaseFieldGetUnprovenViaExprAddr (expr, mkSomeCase g, instTypes tpinst resTys, 0, mExpr) mkSubFrontiers path subAccess newActives [p] (fun path j -> PathQuery(path, int64 j)) else diff --git a/src/Compiler/Checking/PatternMatchCompilation.fsi b/src/Compiler/Checking/PatternMatchCompilation.fsi index 5b2d94c8ff5..b4d68aa320c 100644 --- a/src/Compiler/Checking/PatternMatchCompilation.fsi +++ b/src/Compiler/Checking/PatternMatchCompilation.fsi @@ -27,7 +27,10 @@ type Pattern = | TPat_as of Pattern * PatternValBinding * range | TPat_disjs of Pattern list * range | TPat_conjs of Pattern list * range - | TPat_query of (Expr * TType list * bool * (ValRef * TypeInst) option * int * ActivePatternInfo) * Pattern * range + | TPat_query of + (Expr * TType list * ActivePatternReturnKind * (ValRef * TypeInst) option * int * ActivePatternInfo) * + Pattern * + range | TPat_unioncase of UnionCaseRef * TypeInst * Pattern list * range | TPat_exnconstr of TyconRef * Pattern list * range | TPat_tuple of TupInfo * Pattern list * TType list * range diff --git a/src/Compiler/FSComp.txt b/src/Compiler/FSComp.txt index 8df6fecfdfb..a9fc2692157 100644 --- a/src/Compiler/FSComp.txt +++ b/src/Compiler/FSComp.txt @@ -1593,6 +1593,7 @@ featurePreferExtensionMethodOverPlainProperty,"prefer extension method over plai featureWarningIndexedPropertiesGetSetSameType,"Indexed properties getter and setter must have the same type" featureChkTailCallAttrOnNonRec,"Raises warnings if the 'TailCall' attribute is used on non-recursive functions." featureUnionIsPropertiesVisible,"Union case test properties" +featureBooleanReturningAndReturnTypeDirectedPartialActivePattern,"Boolean-returning and return-type-directed partial active patterns" 3354,tcNotAFunctionButIndexerNamedIndexingNotYetEnabled,"This value supports indexing, e.g. '%s.[index]'. The syntax '%s[index]' requires /langversion:preview. See https://aka.ms/fsharp-index-notation." 3354,tcNotAFunctionButIndexerIndexingNotYetEnabled,"This expression supports indexing, e.g. 'expr.[index]'. The syntax 'expr[index]' requires /langversion:preview. See https://aka.ms/fsharp-index-notation." 3355,tcNotAnIndexerNamedIndexingNotYetEnabled,"The value '%s' is not a function and does not support index notation." diff --git a/src/Compiler/Facilities/LanguageFeatures.fs b/src/Compiler/Facilities/LanguageFeatures.fs index 643224b904a..e7c2a25ee3d 100644 --- a/src/Compiler/Facilities/LanguageFeatures.fs +++ b/src/Compiler/Facilities/LanguageFeatures.fs @@ -84,6 +84,7 @@ type LanguageFeature = | PreferExtensionMethodOverPlainProperty | WarningIndexedPropertiesGetSetSameType | WarningWhenTailCallAttrOnNonRec + | BooleanReturningAndReturnTypeDirectedPartialActivePattern /// LanguageVersion management type LanguageVersion(versionText) = @@ -195,6 +196,7 @@ type LanguageVersion(versionText) = LanguageFeature.WarningIndexedPropertiesGetSetSameType, previewVersion LanguageFeature.WarningWhenTailCallAttrOnNonRec, previewVersion LanguageFeature.UnionIsPropertiesVisible, previewVersion + LanguageFeature.BooleanReturningAndReturnTypeDirectedPartialActivePattern, previewVersion ] static let defaultLanguageVersion = LanguageVersion("default") @@ -336,6 +338,8 @@ type LanguageVersion(versionText) = | LanguageFeature.PreferExtensionMethodOverPlainProperty -> FSComp.SR.featurePreferExtensionMethodOverPlainProperty () | LanguageFeature.WarningIndexedPropertiesGetSetSameType -> FSComp.SR.featureWarningIndexedPropertiesGetSetSameType () | LanguageFeature.WarningWhenTailCallAttrOnNonRec -> FSComp.SR.featureChkTailCallAttrOnNonRec () + | LanguageFeature.BooleanReturningAndReturnTypeDirectedPartialActivePattern -> + FSComp.SR.featureBooleanReturningAndReturnTypeDirectedPartialActivePattern () /// Get a version string associated with the given feature. static member GetFeatureVersionString feature = diff --git a/src/Compiler/Facilities/LanguageFeatures.fsi b/src/Compiler/Facilities/LanguageFeatures.fsi index 7af2317e3c3..29d6c2c33a3 100644 --- a/src/Compiler/Facilities/LanguageFeatures.fsi +++ b/src/Compiler/Facilities/LanguageFeatures.fsi @@ -75,6 +75,7 @@ type LanguageFeature = | PreferExtensionMethodOverPlainProperty | WarningIndexedPropertiesGetSetSameType | WarningWhenTailCallAttrOnNonRec + | BooleanReturningAndReturnTypeDirectedPartialActivePattern /// LanguageVersion management type LanguageVersion = diff --git a/src/Compiler/TypedTree/TypedTree.fs b/src/Compiler/TypedTree/TypedTree.fs index 2109361291e..da8e43bfba5 100644 --- a/src/Compiler/TypedTree/TypedTree.fs +++ b/src/Compiler/TypedTree/TypedTree.fs @@ -4565,6 +4565,17 @@ type DecisionTreeCase = member x.DebugText = x.ToString() override x.ToString() = sprintf "DecisionTreeCase(...)" + +[] +type ActivePatternReturnKind = + | RefTypeWrapper + | StructTypeWrapper + | Boolean + member this.IsStruct with get () = + match this with + | RefTypeWrapper -> false + | StructTypeWrapper + | Boolean -> true [] type DecisionTreeTest = @@ -4585,20 +4596,20 @@ type DecisionTreeTest = /// Test if the input to a decision tree is an instance of the given type | IsInst of source: TType * target: TType - /// Test.ActivePatternCase(activePatExpr, activePatResTys, isStructRetTy, activePatIdentity, idx, activePatInfo) + /// Test.ActivePatternCase(activePatExpr, activePatResTys, activePatRetKind, activePatIdentity, idx, activePatInfo) /// /// Run the active pattern and bind a successful result to a /// variable in the remaining tree. /// activePatExpr -- The active pattern function being called, perhaps applied to some active pattern parameters. /// activePatResTys -- The result types (case types) of the active pattern. - /// isStructRetTy -- Is the active pattern a struct return + /// activePatRetKind -- Indicating what is returning from the active pattern /// activePatIdentity -- The value and the types it is applied to. If there are any active pattern parameters then this is empty. /// idx -- The case number of the active pattern which the test relates to. /// activePatternInfo -- The extracted info for the active pattern. | ActivePatternCase of activePatExpr: Expr * activePatResTys: TTypes * - isStructRetTy: bool * + activePatRetKind: ActivePatternReturnKind * activePatIdentity: (ValRef * TypeInst) option * idx: int * activePatternInfo: ActivePatternInfo @@ -4667,7 +4678,7 @@ type ActivePatternElemRef = activePatternInfo: ActivePatternInfo * activePatternVal: ValRef * caseIndex: int * - isStructRetTy: bool + activePatRetKind: ActivePatternReturnKind /// Get the full information about the active pattern being referred to member x.ActivePatternInfo = (let (APElemRef(info, _, _, _)) = x in info) @@ -4676,7 +4687,7 @@ type ActivePatternElemRef = member x.ActivePatternVal = (let (APElemRef(_, vref, _, _)) = x in vref) /// Get a reference to the value for the active pattern being referred to - member x.IsStructReturn = (let (APElemRef(_, _, _, isStructRetTy)) = x in isStructRetTy) + member x.ActivePatternRetKind = (let (APElemRef(_, _, _, activePatRetKind)) = x in activePatRetKind) /// Get the index of the active pattern element within the overall active pattern member x.CaseIndex = (let (APElemRef(_, _, n, _)) = x in n) diff --git a/src/Compiler/TypedTree/TypedTree.fsi b/src/Compiler/TypedTree/TypedTree.fsi index 3eb47b5eb47..7f0a0ef4ed3 100644 --- a/src/Compiler/TypedTree/TypedTree.fsi +++ b/src/Compiler/TypedTree/TypedTree.fsi @@ -3267,6 +3267,18 @@ type DecisionTreeCase = /// Get the discriminator associated with the case member Discriminator: DecisionTreeTest +/// Indicating what is returning from an AP +[] +type ActivePatternReturnKind = + /// Returning `_ option` or `Choice<_, _, .., _>` + | RefTypeWrapper + /// Returning `_ voption` + | StructTypeWrapper + /// Returning bool + | Boolean + + member IsStruct: bool + [] type DecisionTreeTest = @@ -3287,20 +3299,20 @@ type DecisionTreeTest = /// Test if the input to a decision tree is an instance of the given type | IsInst of source: TType * target: TType - /// Test.ActivePatternCase(activePatExpr, activePatResTys, isStructRetTy, activePatIdentity, idx, activePatInfo) + /// Test.ActivePatternCase(activePatExpr, activePatResTys, activePatRetKind, activePatIdentity, idx, activePatInfo) /// /// Run the active pattern type bind a successful result to a /// variable in the remaining tree. /// activePatExpr -- The active pattern function being called, perhaps applied to some active pattern parameters. /// activePatResTys -- The result types (case types) of the active pattern. - /// isStructRetTy -- Is the active pattern a struct return + /// activePatRetKind -- Indicating what is returning from the active pattern /// activePatIdentity -- The value type the types it is applied to. If there are any active pattern parameters then this is empty. /// idx -- The case number of the active pattern which the test relates to. /// activePatternInfo -- The extracted info for the active pattern. | ActivePatternCase of activePatExpr: Expr * activePatResTys: TTypes * - isStructRetTy: bool * + activePatRetKind: ActivePatternReturnKind * activePatIdentity: (ValRef * TypeInst) option * idx: int * activePatternInfo: Syntax.PrettyNaming.ActivePatternInfo @@ -3359,7 +3371,7 @@ type ActivePatternElemRef = activePatternInfo: Syntax.PrettyNaming.ActivePatternInfo * activePatternVal: ValRef * caseIndex: int * - isStructRetTy: bool + activePatRetKind: ActivePatternReturnKind override ToString: unit -> string @@ -3376,7 +3388,7 @@ type ActivePatternElemRef = member DebugText: string /// Get a reference to the value for the active pattern being referred to - member IsStructReturn: bool + member ActivePatternRetKind: ActivePatternReturnKind /// Records the "extra information" for a value compiled as a method (rather /// than a closure or a local), including argument names, attributes etc. diff --git a/src/Compiler/TypedTree/TypedTreeOps.fs b/src/Compiler/TypedTree/TypedTreeOps.fs index 7beb639a2ee..8ef6ce62182 100644 --- a/src/Compiler/TypedTree/TypedTreeOps.fs +++ b/src/Compiler/TypedTree/TypedTreeOps.fs @@ -3672,6 +3672,13 @@ let mkNullableTy (g: TcGlobals) ty = TType_app (g.system_Nullable_tcref, [ty], g let mkListTy (g: TcGlobals) ty = TType_app (g.list_tcr_nice, [ty], g.knownWithoutNull) +let isBoolTy (g: TcGlobals) ty = + match tryTcrefOfAppTy g ty with + | ValueNone -> false + | ValueSome tcref -> + tyconRefEq g g.system_Bool_tcref tcref || + tyconRefEq g g.bool_tcr tcref + let isValueOptionTy (g: TcGlobals) ty = match tryTcrefOfAppTy g ty with | ValueNone -> false @@ -9228,14 +9235,17 @@ type ActivePatternInfo with member x.DisplayNameByIdx idx = x.ActiveTags[idx] |> ConvertLogicalNameToDisplayName - member apinfo.ResultType g m retTys isStruct = + member apinfo.ResultType g m retTys retKind = let choicety = mkChoiceTy g m retTys if apinfo.IsTotal then choicety - elif isStruct then mkValueOptionTy g choicety - else mkOptionTy g choicety + else + match retKind with + | ActivePatternReturnKind.RefTypeWrapper -> mkOptionTy g choicety + | ActivePatternReturnKind.StructTypeWrapper -> mkValueOptionTy g choicety + | ActivePatternReturnKind.Boolean -> g.bool_ty - member apinfo.OverallType g m argTy retTys isStruct = - mkFunTy g argTy (apinfo.ResultType g m retTys isStruct) + member apinfo.OverallType g m argTy retTys retKind = + mkFunTy g argTy (apinfo.ResultType g m retTys retKind) //--------------------------------------------------------------------------- // Active pattern validation diff --git a/src/Compiler/TypedTree/TypedTreeOps.fsi b/src/Compiler/TypedTree/TypedTreeOps.fsi index 2345ac5eb40..bec1e031185 100755 --- a/src/Compiler/TypedTree/TypedTreeOps.fsi +++ b/src/Compiler/TypedTree/TypedTreeOps.fsi @@ -1528,6 +1528,9 @@ val mkVoidPtrTy: TcGlobals -> TType /// Build a single-dimensional array type val mkArrayType: TcGlobals -> TType -> TType +/// Determine if a type is a bool type +val isBoolTy: TcGlobals -> TType -> bool + /// Determine if a type is a value option type val isValueOptionTy: TcGlobals -> TType -> bool @@ -2449,10 +2452,11 @@ type PrettyNaming.ActivePatternInfo with member DisplayNameByIdx: idx: int -> string /// Get the result type for the active pattern - member ResultType: g: TcGlobals -> range -> TType list -> bool -> TType + member ResultType: g: TcGlobals -> range -> TType list -> ActivePatternReturnKind -> TType /// Get the overall type for a function that implements the active pattern - member OverallType: g: TcGlobals -> m: range -> argTy: TType -> retTys: TType list -> isStruct: bool -> TType + member OverallType: + g: TcGlobals -> m: range -> argTy: TType -> retTys: TType list -> retKind: ActivePatternReturnKind -> TType val doesActivePatternHaveFreeTypars: TcGlobals -> ValRef -> bool diff --git a/src/Compiler/xlf/FSComp.txt.cs.xlf b/src/Compiler/xlf/FSComp.txt.cs.xlf index c07ba0d7033..c7dbc64bac7 100644 --- a/src/Compiler/xlf/FSComp.txt.cs.xlf +++ b/src/Compiler/xlf/FSComp.txt.cs.xlf @@ -247,6 +247,11 @@ automatické generování vlastnosti Message pro deklarace exception + + Boolean-returning and return-type-directed partial active patterns + Boolean-returning and return-type-directed partial active patterns + + Allow implicit Extension attribute on declaring types, modules Povolit implicitní atribut Extension pro deklarující typy, moduly diff --git a/src/Compiler/xlf/FSComp.txt.de.xlf b/src/Compiler/xlf/FSComp.txt.de.xlf index d0feebf9d97..d5800420f00 100644 --- a/src/Compiler/xlf/FSComp.txt.de.xlf +++ b/src/Compiler/xlf/FSComp.txt.de.xlf @@ -247,6 +247,11 @@ Automatische Generierung der Eigenschaft „Message“ für „exception“-Deklarationen + + Boolean-returning and return-type-directed partial active patterns + Boolean-returning and return-type-directed partial active patterns + + Allow implicit Extension attribute on declaring types, modules Implizites Erweiterungsattribut für deklarierende Typen und Module zulassen diff --git a/src/Compiler/xlf/FSComp.txt.es.xlf b/src/Compiler/xlf/FSComp.txt.es.xlf index fae7ec8f032..dcfce175697 100644 --- a/src/Compiler/xlf/FSComp.txt.es.xlf +++ b/src/Compiler/xlf/FSComp.txt.es.xlf @@ -247,6 +247,11 @@ generación automática de la propiedad 'Message' para declaraciones 'exception' + + Boolean-returning and return-type-directed partial active patterns + Boolean-returning and return-type-directed partial active patterns + + Allow implicit Extension attribute on declaring types, modules Permitir atributo Extension implícito en tipos declarativo, módulos diff --git a/src/Compiler/xlf/FSComp.txt.fr.xlf b/src/Compiler/xlf/FSComp.txt.fr.xlf index 4a98252d56f..590c4fb8e15 100644 --- a/src/Compiler/xlf/FSComp.txt.fr.xlf +++ b/src/Compiler/xlf/FSComp.txt.fr.xlf @@ -247,6 +247,11 @@ génération automatique de la propriété « Message » pour les déclarations « exception » + + Boolean-returning and return-type-directed partial active patterns + Boolean-returning and return-type-directed partial active patterns + + Allow implicit Extension attribute on declaring types, modules Autoriser l’attribut implicite Extension lors de la déclaration des types, modules diff --git a/src/Compiler/xlf/FSComp.txt.it.xlf b/src/Compiler/xlf/FSComp.txt.it.xlf index 969c6716e2f..70613984b76 100644 --- a/src/Compiler/xlf/FSComp.txt.it.xlf +++ b/src/Compiler/xlf/FSComp.txt.it.xlf @@ -247,6 +247,11 @@ generazione automatica della proprietà 'Messaggio' per le dichiarazioni 'eccezione' + + Boolean-returning and return-type-directed partial active patterns + Boolean-returning and return-type-directed partial active patterns + + Allow implicit Extension attribute on declaring types, modules Consentire l'attributo estensione implicito per i tipi dichiarabili, i moduli diff --git a/src/Compiler/xlf/FSComp.txt.ja.xlf b/src/Compiler/xlf/FSComp.txt.ja.xlf index 440e83c32b9..84a9ca6ef70 100644 --- a/src/Compiler/xlf/FSComp.txt.ja.xlf +++ b/src/Compiler/xlf/FSComp.txt.ja.xlf @@ -247,6 +247,11 @@ `exception` 宣言の `Message` プロパティの自動生成 + + Boolean-returning and return-type-directed partial active patterns + Boolean-returning and return-type-directed partial active patterns + + Allow implicit Extension attribute on declaring types, modules 型、モジュールの宣言で暗黙的な拡張属性を許可する diff --git a/src/Compiler/xlf/FSComp.txt.ko.xlf b/src/Compiler/xlf/FSComp.txt.ko.xlf index 1a55695d885..38ffac7d32d 100644 --- a/src/Compiler/xlf/FSComp.txt.ko.xlf +++ b/src/Compiler/xlf/FSComp.txt.ko.xlf @@ -247,6 +247,11 @@ 'exception' 선언에 대한 'Message' 속성 자동 생성 + + Boolean-returning and return-type-directed partial active patterns + Boolean-returning and return-type-directed partial active patterns + + Allow implicit Extension attribute on declaring types, modules 유형, 모듈 선언에 암시적 확장 속성 허용 diff --git a/src/Compiler/xlf/FSComp.txt.pl.xlf b/src/Compiler/xlf/FSComp.txt.pl.xlf index fdf34864db0..ac1d54f63c4 100644 --- a/src/Compiler/xlf/FSComp.txt.pl.xlf +++ b/src/Compiler/xlf/FSComp.txt.pl.xlf @@ -247,6 +247,11 @@ Automatyczne generowanie właściwości „Wiadomość“ dla deklaracji „Wyjątek“ + + Boolean-returning and return-type-directed partial active patterns + Boolean-returning and return-type-directed partial active patterns + + Allow implicit Extension attribute on declaring types, modules Zezwalaj na niejawny atrybut Rozszerzenie dla deklarujących typów, modułów diff --git a/src/Compiler/xlf/FSComp.txt.pt-BR.xlf b/src/Compiler/xlf/FSComp.txt.pt-BR.xlf index 86ede3eed08..6beb1946267 100644 --- a/src/Compiler/xlf/FSComp.txt.pt-BR.xlf +++ b/src/Compiler/xlf/FSComp.txt.pt-BR.xlf @@ -247,6 +247,11 @@ geração automática da propriedade 'Message' para declarações de 'exception' + + Boolean-returning and return-type-directed partial active patterns + Boolean-returning and return-type-directed partial active patterns + + Allow implicit Extension attribute on declaring types, modules Permitir atributo de Extensão implícito em tipos declarativos, módulos diff --git a/src/Compiler/xlf/FSComp.txt.ru.xlf b/src/Compiler/xlf/FSComp.txt.ru.xlf index e5844060d67..1b83dc7cc6b 100644 --- a/src/Compiler/xlf/FSComp.txt.ru.xlf +++ b/src/Compiler/xlf/FSComp.txt.ru.xlf @@ -247,6 +247,11 @@ автоматическое создание свойства “Message” для объявлений “exception” + + Boolean-returning and return-type-directed partial active patterns + Boolean-returning and return-type-directed partial active patterns + + Allow implicit Extension attribute on declaring types, modules Разрешить атрибут неявного расширения для объявляющих типов, модулей diff --git a/src/Compiler/xlf/FSComp.txt.tr.xlf b/src/Compiler/xlf/FSComp.txt.tr.xlf index 6e5505f1b7f..43f5069b2eb 100644 --- a/src/Compiler/xlf/FSComp.txt.tr.xlf +++ b/src/Compiler/xlf/FSComp.txt.tr.xlf @@ -247,6 +247,11 @@ 'exception' bildirimleri için 'Message' özelliğinin otomatik olarak oluşturulması + + Boolean-returning and return-type-directed partial active patterns + Boolean-returning and return-type-directed partial active patterns + + Allow implicit Extension attribute on declaring types, modules Türler, modüller bildirirken örtük Extension özniteliğine izin ver diff --git a/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf b/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf index 3e5248d2115..91cad01e99e 100644 --- a/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf +++ b/src/Compiler/xlf/FSComp.txt.zh-Hans.xlf @@ -247,6 +247,11 @@ 自动生成“异常”声明的“消息”属性 + + Boolean-returning and return-type-directed partial active patterns + Boolean-returning and return-type-directed partial active patterns + + Allow implicit Extension attribute on declaring types, modules 允许对声明类型、模块使用隐式扩展属性 diff --git a/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf b/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf index a1b3568925f..f12b3fd0b5e 100644 --- a/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf +++ b/src/Compiler/xlf/FSComp.txt.zh-Hant.xlf @@ -247,6 +247,11 @@ 自動產生 'exception' 宣告的 'Message' 屬性 + + Boolean-returning and return-type-directed partial active patterns + Boolean-returning and return-type-directed partial active patterns + + Allow implicit Extension attribute on declaring types, modules 允許宣告類型、模組上的隱含擴充屬性 diff --git a/tests/FSharp.Compiler.ComponentTests/Conformance/Types/StructTypes/StructActivePatterns.fs b/tests/FSharp.Compiler.ComponentTests/Conformance/Types/StructTypes/StructActivePatterns.fs index 2d9a31d2c7b..1b121b27766 100644 --- a/tests/FSharp.Compiler.ComponentTests/Conformance/Types/StructTypes/StructActivePatterns.fs +++ b/tests/FSharp.Compiler.ComponentTests/Conformance/Types/StructTypes/StructActivePatterns.fs @@ -46,13 +46,11 @@ let rec (|IsOne|_|) someNumber = | 1 -> ValueSome 1 | _ -> ValueNone """ + |> withLangVersion80 |> withOptions ["--warnaserror+"] |> typecheck |> shouldFail - |> withSingleDiagnostic (Error 1,Line 2, Col 9 , Line 2, Col 31, """This expression was expected to have type - ''a option' -but here has type - 'int voption' """) + |> withSingleDiagnostic (Error 3350, Line 2, Col 9, Line 2, Col 31, "Feature 'Boolean-returning and return-type-directed partial active patterns' is not available in F# 8.0. Please use language version 'PREVIEW' or greater.") [] let ``Rec struct active pattern is possible`` () = diff --git a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj index a9dd5382893..ec4fc441f29 100644 --- a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj +++ b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj @@ -220,9 +220,10 @@ - - - + + + + diff --git a/tests/FSharp.Compiler.ComponentTests/Language/BooleanReturningAndReturnTypeDirectedPartialActivePatternTests.fs b/tests/FSharp.Compiler.ComponentTests/Language/BooleanReturningAndReturnTypeDirectedPartialActivePatternTests.fs new file mode 100644 index 00000000000..ce630714e64 --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/Language/BooleanReturningAndReturnTypeDirectedPartialActivePatternTests.fs @@ -0,0 +1,117 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +module Language.BooleanReturningAndReturnTypeDirectedPartialActivePatternTests + +open Xunit +open FSharp.Test.Compiler +open FSharp.Test.ScriptHelpers + +let fsiSession = getSessionForEval [||] LangVersion.Preview + +let runCode = evalInSharedSession fsiSession + +[] +let ``Partial struct active pattern returns ValueOption`1 without []`` () = + FSharp "let (|P1|_|) x = ValueNone" + |> withLangVersionPreview + |> typecheck + |> shouldSucceed + +[] +let ``Partial struct active pattern returns bool`` () = + FSharp "let (|P1|_|) x = false" + |> withLangVersionPreview + |> typecheck + |> shouldSucceed + +[] +let ``Single case active pattern returning bool should success`` () = + FSharp """ +let (|IsA|) x = x = "A" +let (IsA r) = "A" + """ + |> withLangVersionPreview + |> typecheck + |> shouldSucceed + +[] +let ``Partial struct active pattern results can be retrieved`` () = + Fsx """ +let fail msg = + printfn "%s" msg + failwith msg + +let (|P1|_|) x = x <> 0 +let (|EqualTo|_|) y x = x = y + +match 0, 1 with +| P1, _ -> fail "unit" +| _, P1 -> () +| _ -> fail "unit" + +match "x" with +| EqualTo "y" -> fail "with argument" +| EqualTo "x" -> () +| _ -> fail "with argument" + """ + |> withLangVersionPreview + |> runCode + |> shouldSucceed + +// negative tests + +[] +let ``bool active pattern (-langversion:8.0)`` () = + FSharp """let (|OddBool|_|) x = x % 2 = 1 +let (|OddVOption|_|) x = if x % 2 = 1 then ValueSome() else ValueNone + """ + |> withLangVersion80 + |> typecheck + |> shouldFail + |> withDiagnostics [ + (Error 3350, Line 1, Col 5, Line 1, Col 20, "Feature 'Boolean-returning and return-type-directed partial active patterns' is not available in F# 8.0. Please use language version 'PREVIEW' or greater.") + (Error 3350, Line 2, Col 5, Line 2, Col 23, "Feature 'Boolean-returning and return-type-directed partial active patterns' is not available in F# 8.0. Please use language version 'PREVIEW' or greater.") + ] + +[] +let ``Can not receive result from bool active pattern`` () = + FSharp """let (|IsA|_|) x = x = "A" + +match "A" with +| IsA result -> "A" +| _ -> "Not A" + +match "A" with +| IsA result -> result +| _ -> "Not A" + +match "A" with +| IsA "to match return value" -> "Matched" +| _ -> "not Matched" +""" + |> withLangVersionPreview + |> typecheck + |> shouldFail + |> withDiagnostics [ + (Error 1, Line 4, Col 3, Line 4, Col 13, + "This expression was expected to have type + 'string -> bool' +but here has type + 'bool' ") + (Error 39, Line 4, Col 7, Line 4, Col 13, + "The value or constructor 'result' is not defined. Maybe you want one of the following: + Result") + (Error 1, Line 8, Col 3, Line 8, Col 13, + "This expression was expected to have type + 'string -> bool' +but here has type + 'bool' ") + (Error 39, Line 8, Col 7, Line 8, Col 13, + "The value or constructor 'result' is not defined. Maybe you want one of the following: + Result") + (Error 1, Line 12, Col 3, Line 12, Col 30, + "This expression was expected to have type + 'string -> bool' +but here has type + 'bool' ") + ] diff --git a/tests/fsharp/Compiler/Language/StructActivePatternTests.fs b/tests/fsharp/Compiler/Language/StructActivePatternTests.fs index 8780e6c8469..c1e71755e1b 100644 --- a/tests/fsharp/Compiler/Language/StructActivePatternTests.fs +++ b/tests/fsharp/Compiler/Language/StructActivePatternTests.fs @@ -179,11 +179,8 @@ let (|Foo|_|) x = ValueNone """ [|(FSharpDiagnosticSeverity.Error, 842, (2, 3, 2, 9), "This attribute is not valid for use on this language element"); - (FSharpDiagnosticSeverity.Error, 1, (2, 1, 3, 16), - "This expression was expected to have type - ''a option' -but here has type - ''b voption' ")|] + (FSharpDiagnosticSeverity.Error, 3350, (2, 1, 3, 16), + "Feature 'Boolean-returning and return-type-directed partial active patterns' is not available in F# 8.0. Please use language version 'PREVIEW' or greater.")|] [] let ``StructAttribute not allowed on other bindings than partial active pattern definitions`` () =