Add error tcActivePatternArgumentCountNotMatch

docs/release-notes/.FSharp.Compiler.Service/8.0.400.md

@@ -14,3 +14,7 @@
 ### Added
 
 * Generate new `Equals` overload to avoid boxing for structural comparison ([PR #16857](https://github.com/dotnet/fsharp/pull/16857))
+
+### Changed
+
+* Improve error of Active Pattern case Argument Count Not Match ([PR #16846](https://github.com/dotnet/fsharp/pull/16846))

src/Compiler/Checking/CheckExpressions.fs

@@ -5119,22 +5119,77 @@ and TcPatLongIdentActivePatternCase warnOnUpper (cenv: cenv) (env: TcEnv) vFlags
     let vExprTy = vExpr.Type
 
     let activePatArgsAsSynPats, patArg =
-        match args with
-        | [] -> [], SynPat.Const(SynConst.Unit, m)
-        | _ ->
-            // This bit of type-directed analysis ensures that parameterized partial active patterns returning unit do not need to take an argument
-            let dtys, retTy = stripFunTy g vExprTy
-
-            if dtys.Length = args.Length + 1 &&
-                ((isOptionTy g retTy && isUnitTy g (destOptionTy g retTy)) ||
-                (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
+        let rec IsNotSolved ty =
+            match ty with
+            | TType_var(v, _) when v.IsSolved ->
+                match v.Solution with
+                | Some t -> IsNotSolved t
+                | None -> false
+            | TType_var _ -> true
+            | _ -> false
+
+        // only cases which return unit or unresolved type (in AP definition) can omit output arg 
+        let canOmit retTy = isUnitTy g retTy || IsNotSolved retTy 
+
+        // This bit of type-directed analysis ensures that parameterized partial active patterns returning unit do not need to take an argument
+        let dtys, retTy = stripFunTy g vExprTy
+        let paramCount = if dtys.Length = 0 then 0 else dtys.Length - 1
+
+        let showErrMsg returnCount =
+            let fmtExprArgs paramCount =
+                let rec loop i (sb: Text.StringBuilder) =
+                    let cutoff = 10
+                    if i > paramCount then sb.ToString()
+                    elif i > cutoff then sb.Append("...").ToString()
+                    else loop (i + 1) (sb.Append(" e").Append i)
+
+                loop 1 (Text.StringBuilder())
+
+            let caseName = apinfo.ActiveTags[idx]
+            let msg =
+                match paramCount, returnCount with
+                | 0, 0 -> FSComp.SR.tcActivePatternArgsCountNotMatchNoArgsNoPat(caseName, caseName)
+                | 0, _ -> FSComp.SR.tcActivePatternArgsCountNotMatchOnlyPat(caseName)
+                | _, 0 -> FSComp.SR.tcActivePatternArgsCountNotMatchArgs(paramCount, caseName, fmtExprArgs paramCount)
+                | _, _ -> FSComp.SR.tcActivePatternArgsCountNotMatchArgsAndPat(paramCount, caseName, fmtExprArgs paramCount)
+            error(Error(msg, m))
+
+        // partial active pattern (returning bool) doesn't have output arg
+        if (not apinfo.IsTotal && isBoolTy g retTy) then
+            checkLanguageFeatureError g.langVersion LanguageFeature.BooleanReturningAndReturnTypeDirectedPartialActivePattern m
+            if paramCount = List.length args then
                 args, SynPat.Const(SynConst.Unit, m)
             else
-                List.frontAndBack args
+                showErrMsg 0
+
+        // for single case active pattern, if not all parameter provided, output will be a function
+        // that takes the remaining parameter as input
+        elif apinfo.IsTotal && apinfo.ActiveTags.Length = 1 && dtys.Length >= args.Length && not args.IsEmpty then
+            List.frontAndBack args
+
+        // active pattern cases returning unit or unknown things (in AP definition) can omit output arg 
+        elif paramCount = args.Length then
+             let caseRetTy =
+                 if isOptionTy g retTy then destOptionTy g retTy
+                 elif isValueOptionTy g retTy then destValueOptionTy g retTy
+                 elif isChoiceTy g retTy then destChoiceTy g retTy idx
+                 else retTy
+
+             // only cases which return unit or unresolved type (in AP definition) can omit output arg 
+             if canOmit caseRetTy then
+                args, SynPat.Const(SynConst.Unit, m)
+             else
+                 showErrMsg 1
+
+        // active pattern in function param (e.g. let f (|P|_|) = ...)
+        elif IsNotSolved vExprTy then
+            List.frontAndBack args
+
+        // args count should equal to AP function params count
+        elif dtys.Length <> args.Length then
+            showErrMsg 1
+        else
+            List.frontAndBack args
 
     if not (isNil activePatArgsAsSynPats) && apinfo.ActiveTags.Length <> 1 then
         errorR (Error (FSComp.SR.tcRequireActivePatternWithOneResult (), m))

src/Compiler/FSComp.txt

@@ -1747,4 +1747,8 @@ featureReuseSameFieldsInStructUnions,"Share underlying fields in a [<Struct>] di
 3864,tooManyMethodsInDotNetTypeWritingAssembly,"The type '%s' has too many methods. Found: '%d', maximum: '%d'"
 3865,parsOnlySimplePatternsAreAllowedInConstructors,"Only simple patterns are allowed in primary constructors"
 3866,chkStaticAbstractInterfaceMembers,"A static abstract non-virtual interface member should only be called via type parameter (for example: 'T.%s)."
-3867,chkStaticAbstractMembersOnClasses,"Classes cannot contain static abstract members."
+3867,chkStaticAbstractMembersOnClasses,"Classes cannot contain static abstract members."
+3868,tcActivePatternArgsCountNotMatchNoArgsNoPat,"This active pattern does not expect any arguments, i.e., it should be used like '%s' instead of '%s x'."
+3868,tcActivePatternArgsCountNotMatchOnlyPat,"This active pattern expects exactly one pattern argument, e.g., '%s pat'."
+3868,tcActivePatternArgsCountNotMatchArgs,"This active pattern expects %d expression argument(s), e.g., '%s%s'."
+3868,tcActivePatternArgsCountNotMatchArgsAndPat,"This active pattern expects %d expression argument(s) and a pattern argument, e.g., '%s%s pat'."

src/Compiler/TypedTree/TypedTreeOps.fs

@@ -3689,6 +3689,17 @@ let isOptionTy (g: TcGlobals) ty =
     | ValueNone -> false
     | ValueSome tcref -> tyconRefEq g g.option_tcr_canon tcref
 
+let isChoiceTy (g: TcGlobals) ty = 
+    match tryTcrefOfAppTy g ty with 
+    | ValueNone -> false
+    | ValueSome tcref ->
+        tyconRefEq g g.choice2_tcr tcref ||
+        tyconRefEq g g.choice3_tcr tcref ||
+        tyconRefEq g g.choice4_tcr tcref ||
+        tyconRefEq g g.choice5_tcr tcref ||
+        tyconRefEq g g.choice6_tcr tcref ||
+        tyconRefEq g g.choice7_tcr tcref
+
 let tryDestOptionTy g ty = 
     match argsOfAppTy g ty with 
     | [ty1] when isOptionTy g ty -> ValueSome ty1
@@ -3699,6 +3710,11 @@ let tryDestValueOptionTy g ty =
     | [ty1] when isValueOptionTy g ty -> ValueSome ty1
     | _ -> ValueNone
 
+let tryDestChoiceTy g ty idx = 
+    match argsOfAppTy g ty with 
+    | ls when isChoiceTy g ty && ls.Length > idx -> ValueSome ls[idx]
+    | _ -> ValueNone
+
 let destOptionTy g ty = 
     match tryDestOptionTy g ty with 
     | ValueSome ty -> ty
@@ -3709,6 +3725,11 @@ let destValueOptionTy g ty =
     | ValueSome ty -> ty
     | ValueNone -> failwith "destValueOptionTy: not a value option type"
 
+let destChoiceTy g ty idx = 
+    match tryDestChoiceTy g ty idx with 
+    | ValueSome ty -> ty
+    | ValueNone -> failwith "destChoiceTy: not a Choice type"
+
 let isNullableTy (g: TcGlobals) ty = 
     match tryTcrefOfAppTy g ty with 
     | ValueNone -> false

src/Compiler/TypedTree/TypedTreeOps.fsi

@@ -1547,6 +1547,9 @@ val isValueOptionTy: TcGlobals -> TType -> bool
 /// Determine if a type is an option type
 val isOptionTy: TcGlobals -> TType -> bool
 
+/// Determine if a type is an Choice type
+val isChoiceTy: TcGlobals -> TType -> bool
+
 /// Take apart an option type
 val destOptionTy: TcGlobals -> TType -> TType
 
@@ -1556,6 +1559,12 @@ val tryDestOptionTy: TcGlobals -> TType -> TType voption
 /// Try to take apart an option type
 val destValueOptionTy: TcGlobals -> TType -> TType
 
+/// Take apart an Choice type
+val tryDestChoiceTy: TcGlobals -> TType -> int -> TType voption
+
+/// Try to take apart an Choice type
+val destChoiceTy: TcGlobals -> TType -> int -> TType
+
 /// Determine is a type is a System.Nullable type
 val isNullableTy: TcGlobals -> TType -> bool