[FS-1140] add Boolean-returning and return-type-directed partial active patterns

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
 

src/Compiler/Checking/CheckExpressions.fs

@@ -5085,7 +5085,9 @@ 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`
+                (not apinfo.IsTotal && isBoolTy g retTy) then
                 args, SynPat.Const(SynConst.Unit, m)
             else
                 List.frontAndBack args
@@ -10744,14 +10746,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.WrapByRefType
+                else
+                    if isStructRetTy || isValueOptionTy cenv.g apReturnTy then ActivePatternReturnKind.WrapByStruct
+                    elif isBoolTy cenv.g apReturnTy then ActivePatternReturnKind.SimpleReturn
+                    else ActivePatternReturnKind.WrapByRefType
+
+            match apRetTy with
+            | ActivePatternReturnKind.SimpleReturn ->
+                checkLanguageFeatureError g.langVersion LanguageFeature.BoolPartialActivePattern mBinding
+            | ActivePatternReturnKind.WrapByStruct when not isStructRetTy ->
+                checkLanguageFeatureError g.langVersion LanguageFeature.BoolPartialActivePattern mBinding
+            | ActivePatternReturnKind.WrapByStruct ->
                 checkLanguageFeatureError g.langVersion LanguageFeature.StructActivePattern mBinding
+            | ActivePatternReturnKind.WrapByRefType -> ()
 
-            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

src/Compiler/Checking/NameResolution.fs

@@ -89,15 +89,17 @@ let ActivePatternElemsOfValRef g (vref: ValRef) =
 
         let isStructRetTy = 
             if apinfo.IsTotal then
-                false
+                ActivePatternReturnKind.WrapByRefType
             else
                 let _, apReturnTy = stripFunTy g vref.TauType
                 let hasStructAttribute() = 
                     vref.Attribs
                     |> List.exists (function 
                         | Attrib(targetsOpt = Some(System.AttributeTargets.ReturnValue)) as a -> IsMatchingFSharpAttribute g g.attrib_StructAttribute a  
                         | _ -> false)
-                isStructTy g apReturnTy || hasStructAttribute()
+                if isValueOptionTy g apReturnTy || hasStructAttribute() then ActivePatternReturnKind.WrapByStruct
+                elif isBoolTy g apReturnTy then ActivePatternReturnKind.SimpleReturn
+                else ActivePatternReturnKind.WrapByRefType
         apinfo.ActiveTags |> List.mapi (fun i _ -> APElemRef(apinfo, vref, i, isStructRetTy))
     | None -> []
 

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
@@ -1298,7 +1298,7 @@ let CompilePatternBasic
              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 vOpt, addrExp, _readonly, _writeonly = mkExprAddrOfExprAux g (isStructRetTy = ActivePatternReturnKind.WrapByStruct) false NeverMutates appExpr None mMatch
              match vOpt with
              | None -> 
                 let v, vExpr = mkCompGenLocal m ("activePatternResult" + string (newUnique())) resTy
@@ -1354,13 +1354,15 @@ 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 
+                            if retKind = ActivePatternReturnKind.SimpleReturn then DecisionTreeTest.Const(Const.Bool true)
+                            else DecisionTreeTest.UnionCase(mkAnySomeCase g retKind.IsStruct, resTys)
                          elif aparity <= 1 then DecisionTreeTest.Const(Const.Unit)
                          else DecisionTreeTest.UnionCase(mkChoiceCaseRef g m aparity idx, resTys)
                      | _ -> discrim
@@ -1432,7 +1434,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)
@@ -1460,10 +1462,12 @@ let CompilePatternBasic
                     if i = iInvestigated then
                         let subAccess _j tpinst _ =
                             let expr = Option.get inpExprOpt
-                            if isStructRetTy then 
+                            match retKind with
+                            | ActivePatternReturnKind.SimpleReturn -> expr
+                            | ActivePatternReturnKind.WrapByStruct ->
                                 // In this case, the inpExprOpt is already an address-of expression
                                 mkUnionCaseFieldGetProvenViaExprAddr (expr, mkValueSomeCase g, instTypes tpinst resTys, 0, mExpr)
-                            else
+                            | ActivePatternReturnKind.WrapByRefType ->
                                 mkUnionCaseFieldGetUnprovenViaExprAddr (expr, mkSomeCase g, instTypes tpinst resTys, 0, mExpr)
                         mkSubFrontiers path subAccess newActives [p] (fun path j -> PathQuery(path, int64 j))
                     else

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

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"
+featureBoolPartialActivePattern,"bool representation for partial pctive pattern"
 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."

src/Compiler/Facilities/LanguageFeatures.fs

@@ -84,6 +84,7 @@ type LanguageFeature =
     | PreferExtensionMethodOverPlainProperty
     | WarningIndexedPropertiesGetSetSameType
     | WarningWhenTailCallAttrOnNonRec
+    | BoolPartialActivePattern
 
 /// LanguageVersion management
 type LanguageVersion(versionText) =
@@ -195,6 +196,7 @@ type LanguageVersion(versionText) =
                 LanguageFeature.WarningIndexedPropertiesGetSetSameType, previewVersion
                 LanguageFeature.WarningWhenTailCallAttrOnNonRec, previewVersion
                 LanguageFeature.UnionIsPropertiesVisible, previewVersion
+                LanguageFeature.BoolPartialActivePattern, previewVersion
             ]
 
     static let defaultLanguageVersion = LanguageVersion("default")
@@ -336,6 +338,7 @@ type LanguageVersion(versionText) =
         | LanguageFeature.PreferExtensionMethodOverPlainProperty -> FSComp.SR.featurePreferExtensionMethodOverPlainProperty ()
         | LanguageFeature.WarningIndexedPropertiesGetSetSameType -> FSComp.SR.featureWarningIndexedPropertiesGetSetSameType ()
         | LanguageFeature.WarningWhenTailCallAttrOnNonRec -> FSComp.SR.featureChkTailCallAttrOnNonRec ()
+        | LanguageFeature.BoolPartialActivePattern -> FSComp.SR.featureBoolPartialActivePattern ()
 
     /// Get a version string associated with the given feature.
     static member GetFeatureVersionString feature =

src/Compiler/Facilities/LanguageFeatures.fsi

@@ -75,6 +75,7 @@ type LanguageFeature =
     | PreferExtensionMethodOverPlainProperty
     | WarningIndexedPropertiesGetSetSameType
     | WarningWhenTailCallAttrOnNonRec
+    | BoolPartialActivePattern
 
 /// LanguageVersion management
 type LanguageVersion =

src/Compiler/TypedTree/TypedTree.fs

@@ -4565,6 +4565,13 @@ type DecisionTreeCase =
     member x.DebugText = x.ToString()
 
     override x.ToString() = sprintf "DecisionTreeCase(...)"
+
+[<Struct; NoComparison; RequireQualifiedAccess>]
+type ActivePatternReturnKind =
+    | WrapByRefType
+    | WrapByStruct
+    | SimpleReturn
+    member this.IsStruct with get () = this <> WrapByRefType 
 
 [<NoEquality; NoComparison; RequireQualifiedAccess (*; StructuredFormatDisplay("{DebugText}") *) >]
 type DecisionTreeTest = 
@@ -4585,20 +4592,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 +4674,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 +4683,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)

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
+[<Struct; NoComparison; RequireQualifiedAccess>]
+type ActivePatternReturnKind =
+    /// Returning `_ option` or `Choice<_, _, .., _>`
+    | WrapByRefType
+    /// Returning `_ voption`
+    | WrapByStruct
+    /// Returning bool
+    | SimpleReturn
+
+    member IsStruct: bool
+
 [<NoEquality; NoComparison; RequireQualifiedAccess>]
 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.

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
@@ -9227,14 +9234,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.WrapByRefType -> mkOptionTy g choicety
+            | ActivePatternReturnKind.WrapByStruct -> mkValueOptionTy g choicety
+            | ActivePatternReturnKind.SimpleReturn -> 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