Fix 11873: Name is bound multiple times is not reported in 'as' pattern (#18984)

Author: edgarfgp

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

@@ -2,6 +2,7 @@
 
 * Scripts: Fix resolving the dotnet host path when an SDK directory is specified. ([PR #18960](https://github.com/dotnet/fsharp/pull/18960))
 * Fix excessive StackGuard thread jumping ([PR #18971](https://github.com/dotnet/fsharp/pull/18971))
+* Fix name is bound multiple times is not reported in 'as' pattern ([PR #18984](https://github.com/dotnet/fsharp/pull/18984))
 
 ### Added
 

src/Compiler/Checking/CheckBasics.fs

@@ -319,7 +319,7 @@ type TcFileState =
       TcPat: WarnOnUpperFlag -> TcFileState -> TcEnv -> PrelimValReprInfo option -> TcPatValFlags -> TcPatLinearEnv -> TType -> SynPat -> (TcPatPhase2Input -> Pattern) * TcPatLinearEnv
 
       // forward call
-      TcSimplePats: TcFileState -> bool -> CheckConstraints -> TType -> TcEnv -> TcPatLinearEnv -> SynSimplePats -> string list * TcPatLinearEnv
+      TcSimplePats: TcFileState -> bool -> CheckConstraints -> TType -> TcEnv -> TcPatLinearEnv -> SynSimplePats -> SynPat list * bool -> string list * TcPatLinearEnv
 
       // forward call
       TcSequenceExpressionEntry: TcFileState -> TcEnv -> OverallTy -> UnscopedTyparEnv -> bool * SynExpr -> range -> Expr * UnscopedTyparEnv

src/Compiler/Checking/CheckBasics.fsi

@@ -295,6 +295,9 @@ type TcFileState =
                 -> TcEnv
                 -> TcPatLinearEnv
                 -> SynSimplePats
+                // SynPat list: Represents parsed patterns,
+                // bool: Indicates if this is the first pattern in a sequence of patterns
+                -> SynPat list * bool
                 -> string list * TcPatLinearEnv
 
         // forward call
@@ -345,6 +348,7 @@ type TcFileState =
                 -> TcEnv
                 -> TcPatLinearEnv
                 -> SynSimplePats
+                -> SynPat list * bool
                 -> string list * TcPatLinearEnv) *
         tcSequenceExpressionEntry:
             (TcFileState -> TcEnv -> OverallTy -> UnscopedTyparEnv -> bool * SynExpr -> range -> Expr * UnscopedTyparEnv) *

src/Compiler/Checking/CheckPatterns.fs

@@ -145,47 +145,84 @@ and ValidateOptArgOrder (synSimplePats: SynSimplePats) =
     List.iter (fun pat -> if isOptArg pat then hitOptArg <- true elif hitOptArg then error(Error(FSComp.SR.tcOptionalArgsMustComeAfterNonOptionalArgs(), m))) pats
 
 
-/// Bind the patterns used in argument position for a function, method or lambda.
-and TcSimplePats (cenv: cenv) optionalArgsOK checkConstraints ty env patEnv synSimplePats =
+/// Bind the patterns used in the argument position for a function, method or lambda.
+and TcSimplePats (cenv: cenv) optionalArgsOK checkConstraints ty env patEnv synSimplePats (parsedPatterns: SynPat list * bool) =
 
-    let g = cenv.g
-    let (TcPatLinearEnv(tpenv, names, takenNames)) = patEnv
-
-    // validate optional argument declaration
+    let rec collectBoundIdTextsFromPat (acc: string list) (p: SynPat) : string list =
+        match p with
+        | SynPat.FromParseError(p, _)
+        | SynPat.Paren(p, _) -> collectBoundIdTextsFromPat acc p
+        | SynPat.Tuple(_, ps, _, _)
+        | SynPat.ArrayOrList(_, ps, _) -> List.fold collectBoundIdTextsFromPat acc ps
+        | SynPat.As(lhs, rhs, _) -> collectBoundIdTextsFromPat (collectBoundIdTextsFromPat acc lhs) rhs
+        | SynPat.Named(SynIdent(id, _), _, _, _)
+        | SynPat.OptionalVal(id, _) -> id.idText :: acc
+        | SynPat.LongIdent(argPats = SynArgPats.Pats ps) -> List.fold collectBoundIdTextsFromPat acc ps
+        | SynPat.Or(p1, p2, _, _) -> collectBoundIdTextsFromPat (collectBoundIdTextsFromPat acc p1) p2
+        | SynPat.Ands(pats, _) -> List.fold collectBoundIdTextsFromPat acc pats
+        | SynPat.Record(fieldPats = fields) ->
+            (acc, fields)
+            ||> List.fold (fun acc (NamePatPairField(_, _, _, pat, _)) -> collectBoundIdTextsFromPat acc pat)
+        | SynPat.ListCons(lhsPat = l; rhsPat = r) -> collectBoundIdTextsFromPat (collectBoundIdTextsFromPat acc l) r
+        | _ -> acc
+
+    let augmentTakenNamesFromFirstGroup (parsedData: SynPat list * bool) (patEnvOut: TcPatLinearEnv) : TcPatLinearEnv =
+        match parsedData, patEnvOut with
+        | (pats ,true), TcPatLinearEnv(tpenvR, namesR, takenNamesR) ->
+            match pats with
+            | pat :: _ ->
+                let extra = collectBoundIdTextsFromPat [] pat |> Set.ofList
+                TcPatLinearEnv(tpenvR, namesR, Set.union takenNamesR extra)
+            | _ -> patEnvOut
+        | _ -> patEnvOut
+
+    let bindCurriedGroup (synSimplePats: SynSimplePats) : string list * TcPatLinearEnv =
+        let g = cenv.g
+        let (TcPatLinearEnv(tpenv, names, takenNames)) = patEnv
+        match synSimplePats with
+        | SynSimplePats.SimplePats ([], _, m) ->
+            // Unit "()" patterns in argument position become SynSimplePats.SimplePats([], _) in the
+            // syntactic translation when building bindings. This is done because the
+            // use of "()" has special significance for arity analysis and argument counting.
+            //
+            // Here we give a name to the single argument implied by those patterns.
+            // This is a little awkward since it would be nice if this was
+            // uniform with the process where we give names to other (more complex)
+            // patterns used in argument position, e.g. "let f (D(x)) = ..."
+            let id = ident("unitVar" + string takenNames.Count, m)
+            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)
+        | SynSimplePats.SimplePats ([sp], _, _) ->
+            // Single parameter: no tuple splitting, check directly
+            let v, patEnv' = TcSimplePat optionalArgsOK checkConstraints cenv ty env patEnv sp []
+            [ v ], patEnv'
+        | SynSimplePats.SimplePats (ps, _, m) ->
+            // Multiple parameters: treat a domain type as a ref-tuple and map each simple pat
+            let ptys = UnifyRefTupleType env.eContextInfo cenv env.DisplayEnv m ty ps
+            let namesOut, patEnvR =
+                (patEnv, List.zip ptys ps)
+                ||> List.mapFold (fun penv (pty, sp) -> TcSimplePat optionalArgsOK checkConstraints cenv pty env penv sp [])
+            namesOut, patEnvR
+
+    // 1) validate optional-arg ordering
     ValidateOptArgOrder synSimplePats
 
-    match synSimplePats with
-    | SynSimplePats.SimplePats ([],_, m) ->
-        // Unit "()" patterns in argument position become SynSimplePats.SimplePats([], _) in the
-        // syntactic translation when building bindings. This is done because the
-        // use of "()" has special significance for arity analysis and argument counting.
-        //
-        // Here we give a name to the single argument implied by those patterns.
-        // This is a little awkward since it would be nice if this was
-        // uniform with the process where we give names to other (more complex)
-        // patterns used in argument position, e.g. "let f (D(x)) = ..."
-        let id = ident("unitVar" + string takenNames.Count, m)
-        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)
-        let patEnvR = TcPatLinearEnv(tpenv, namesR, takenNamesR)
-        [id.idText], patEnvR
+    // 2) bind the current curried group
+    let namesOut, patEnvOut = bindCurriedGroup synSimplePats
 
-    | SynSimplePats.SimplePats (pats = [synSimplePat]) ->
-        let v, patEnv = TcSimplePat optionalArgsOK checkConstraints cenv ty env patEnv synSimplePat []
-        [v], patEnv
+    // 3) post-augment takenNames for later groups (using the original first-group pattern)
+    let patEnvOut = augmentTakenNamesFromFirstGroup parsedPatterns patEnvOut
 
-    | SynSimplePats.SimplePats (ps, _, m) ->
-        let ptys = UnifyRefTupleType env.eContextInfo cenv env.DisplayEnv m ty ps
-        let ps', patEnvR = (patEnv, List.zip ptys ps) ||> List.mapFold (fun patEnv (ty, pat) -> TcSimplePat optionalArgsOK checkConstraints cenv ty env patEnv pat [])
-        ps', patEnvR
+    namesOut, patEnvOut
 
 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 spats, _ = SimplePatsOfPat cenv.synArgNameGenerator pat
-    let names, patEnv = TcSimplePats cenv optionalArgsOK checkConstraints argTy env patEnv spats
+    let names, patEnv = TcSimplePats cenv optionalArgsOK checkConstraints argTy env patEnv spats ([], false)
     names, patEnv, spats
 
 and TcPatBindingName cenv env id ty isMemberThis vis1 valReprInfo (vFlags: TcPatValFlags) (names, takenNames: Set<string>) =

src/Compiler/Checking/CheckPatterns.fsi

@@ -39,4 +39,5 @@ val TcSimplePats:
     env: TcEnv ->
     patEnv: TcPatLinearEnv ->
     synSimplePats: SynSimplePats ->
+    parsedPatterns: SynPat list * bool ->
         string list * TcPatLinearEnv

src/Compiler/Checking/Expressions/CheckExpressions.fs

@@ -6484,10 +6484,15 @@ and TcExprILAssembly (cenv: cenv) overallTy env tpenv (ilInstrs, synTyArgs, synA
 and TcIteratedLambdas (cenv: cenv) isFirst (env: TcEnv) overallTy takenNames tpenv e =
     let g = cenv.g
     match e with
-    | SynExpr.Lambda (isMember, isSubsequent, synSimplePats, bodyExpr, _parsedData, m, _trivia) when isMember || isFirst || isSubsequent ->
+    | SynExpr.Lambda (isMember, isSubsequent, synSimplePats, bodyExpr, parsedData, m, _trivia) when isMember || isFirst || isSubsequent ->
         let domainTy, resultTy = UnifyFunctionType None cenv env.DisplayEnv m overallTy.Commit
+        let parsedPatterns =
+            parsedData
+            |> Option.map fst
+            |> Option.defaultValue []
+            
         let vs, (TcPatLinearEnv (tpenv, names, takenNames)) =
-            cenv.TcSimplePats cenv isMember CheckCxs domainTy env (TcPatLinearEnv (tpenv, Map.empty, takenNames)) synSimplePats
+            cenv.TcSimplePats cenv isMember CheckCxs domainTy env (TcPatLinearEnv (tpenv, Map.empty, takenNames)) synSimplePats (parsedPatterns, isFirst)
 
         let envinner, _, vspecMap = MakeAndPublishSimpleValsForMergedScope cenv env m names
         let byrefs = vspecMap |> Map.map (fun _ v -> isByrefTy g v.Type, v)
@@ -11296,6 +11301,8 @@ and TcNonRecursiveBinding declKind cenv env tpenv ty binding =
         | _ -> ()
     | _ -> ()
 
+
+
     let binding = BindingNormalization.NormalizeBinding ValOrMemberBinding cenv env binding
     let explicitTyparInfo, tpenv = TcNonrecBindingTyparDecls cenv env tpenv binding
     TcNormalizedBinding declKind cenv env tpenv ty None NoSafeInitInfo ([], explicitTyparInfo) binding
@@ -11743,7 +11750,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)
+        ignore (cenv.TcSimplePats cenv optionalArgsOK CheckCxs domainTy env (TcPatLinearEnv (tpenv, Map.empty, Set.empty)) 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