diff --git a/docs/release-notes/.FSharp.Compiler.Service/11.0.0.md b/docs/release-notes/.FSharp.Compiler.Service/11.0.0.md index 2cde88c0d9..0469b0575f 100644 --- a/docs/release-notes/.FSharp.Compiler.Service/11.0.0.md +++ b/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 diff --git a/src/Compiler/Checking/CheckBasics.fs b/src/Compiler/Checking/CheckBasics.fs index adcfe505b9..835fd27bca 100644 --- a/src/Compiler/Checking/CheckBasics.fs +++ b/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 diff --git a/src/Compiler/Checking/CheckBasics.fsi b/src/Compiler/Checking/CheckBasics.fsi index 179752c394..c396283c07 100644 --- a/src/Compiler/Checking/CheckBasics.fsi +++ b/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) * diff --git a/src/Compiler/Checking/CheckPatterns.fs b/src/Compiler/Checking/CheckPatterns.fs index b7ad664fc6..eb61edf7ee 100644 --- a/src/Compiler/Checking/CheckPatterns.fs +++ b/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) = diff --git a/src/Compiler/Checking/CheckPatterns.fsi b/src/Compiler/Checking/CheckPatterns.fsi index da797b35a8..412044eda1 100644 --- a/src/Compiler/Checking/CheckPatterns.fsi +++ b/src/Compiler/Checking/CheckPatterns.fsi @@ -39,4 +39,5 @@ val TcSimplePats: env: TcEnv -> patEnv: TcPatLinearEnv -> synSimplePats: SynSimplePats -> + parsedPatterns: SynPat list * bool -> string list * TcPatLinearEnv diff --git a/src/Compiler/Checking/Expressions/CheckExpressions.fs b/src/Compiler/Checking/Expressions/CheckExpressions.fs index 6979f20f0e..9239165174 100644 --- a/src/Compiler/Checking/Expressions/CheckExpressions.fs +++ b/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 diff --git a/tests/FSharp.Compiler.ComponentTests/ErrorMessages/NameIsBoundMultipleTimesTests.fs b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/NameIsBoundMultipleTimesTests.fs new file mode 100644 index 0000000000..fe8887737c --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/ErrorMessages/NameIsBoundMultipleTimesTests.fs @@ -0,0 +1,246 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +namespace ErrorMessages + +open Xunit +open FSharp.Test.Compiler + +module NameIsBoundMultipleTimes = + [] + let ``Name is bound multiple times is reported``() = + Fsx """ +let f1 a a = () +""" + |> typecheck + |> shouldFail + |> withDiagnostics [ + (Error 38, Line 2, Col 10, Line 2, Col 11, "'a' is bound twice in this pattern") + ] + + [] + let ``Name is bound multiple times is reported in 'as' pattern 1``() = + Fsx """ +let f2 (a, b as c) c = () +""" + |> typecheck + |> shouldFail + |> withDiagnostics [ + (Error 38, Line 2, Col 20, Line 2, Col 21, "'c' is bound twice in this pattern") + ] + + [] + let ``Name is bound multiple times is reported in 'as' pattern 2``() = + Fsx """ +let f4 (a, b, c as d) a c = () +""" + |> typecheck + |> shouldFail + |> withDiagnostics [ + (Error 38, Line 2, Col 23, Line 2, Col 24, "'a' is bound twice in this pattern") + (Error 38, Line 2, Col 25, Line 2, Col 26, "'c' is bound twice in this pattern") + ] + + [] + let ``Name is bound multiple times is reported in 'as' pattern 3``() = + Fsx """ +let f5 (a, b, c as d) a d = () +""" + |> typecheck + |> shouldFail + |> withDiagnostics [ + (Error 38, Line 2, Col 23, Line 2, Col 24, "'a' is bound twice in this pattern"); + (Error 38, Line 2, Col 25, Line 2, Col 26, "'d' is bound twice in this pattern") + ] + + [] + let ``Name is bound multiple times is reported 2`` () = + Fsx """ +let (++) e1 e1 = if e1 then e1 else false +""" + |> typecheck + |> shouldFail + |> withDiagnostics [ + (Error 38, Line 2, Col 13, Line 2, Col 15, "'e1' is bound twice in this pattern") + ] + + [] + let ``Name is bound multiple times with nested parens and as pattern`` () = + Fsx """ +let f ((a, b as c)) c = () +""" + |> typecheck + |> shouldFail + |> withDiagnostics [ + (Error 38, Line 2, Col 21, Line 2, Col 22, "'c' is bound twice in this pattern") + ] + + [] + let ``Name is bound multiple times with nested parens tuple`` () = + Fsx """ +let g ((a, b)) a = () +""" + |> typecheck + |> shouldFail + |> withDiagnostics [ + (Error 38, Line 2, Col 16, Line 2, Col 17, "'a' is bound twice in this pattern") + ] + + [] + let ``Name is bound multiple times is reported in 'as' pattern in match case`` () = + Fsx """ +let h x = + match x with + | (a, b as c), c -> 0 +""" + |> typecheck + |> shouldFail + |> withDiagnostics [ + (Error 38, Line 4, Col 20, Line 4, Col 21, "'c' is bound twice in this pattern") + ] + + [] + let ``Name is bound multiple times is reported in 'as' pattern in nested match case`` () = + Fsx """ +let h x = + match x with + | ((a, b as c), d), c -> 0 +""" + |> typecheck + |> shouldFail + |> withDiagnostics [ + (Error 38, Line 4, Col 25, Line 4, Col 26, "'c' is bound twice in this pattern") + ] + + [] + let ``Name is bound multiple times is reported in 'as' pattern in nested match case 2`` () = + Fsx """ +let h x = + match x with + | ((a, b as c), d), c, d -> 0 +""" + |> typecheck + |> shouldFail + |> withDiagnostics [ + (Error 38, Line 4, Col 25, Line 4, Col 26, "'c' is bound twice in this pattern") + (Error 38, Line 4, Col 28, Line 4, Col 29, "'d' is bound twice in this pattern") + ] + + [] + let ``Name is bound multiple times is reported in 'as' pattern in nested match case 3`` () = + Fsx """ +let h x = + match x with + | ((a, b as c), d as e), c, e -> 0 +""" + |> typecheck + |> shouldFail + |> withDiagnostics [ + (Error 38, Line 4, Col 30, Line 4, Col 31, "'c' is bound twice in this pattern") + (Error 38, Line 4, Col 33, Line 4, Col 34, "'e' is bound twice in this pattern") + ] + + [] + let ``unitVar as user identifier in tuple binding does not clash with synthesized unit parameter name`` () = + Fsx """ +let (unitVar, ()) = 1, () +""" + |> typecheck + |> shouldSucceed + + [] + let ``unitVar as user identifier in function parameters does not clash with synthesized unit parameter name`` () = + Fsx """ +let f unitVar () = () +""" + |> typecheck + |> shouldSucceed + + [] + let ``unitVar as user identifier in function tuple parameter does not clash with synthesized unit parameter name`` () = + Fsx """ +let f (unitVar, ()) = () +""" + |> typecheck + |> shouldSucceed + + [] + let ``Name is bound multiple times is reported for combined bindings``() = + Fsx """ +let f1 a a = () +let f2 (a, b as c) c = () +let f3 (a, b as c) a = () +""" + |> typecheck + |> shouldFail + |> withDiagnostics [ + (Error 38, Line 2, Col 10, Line 2, Col 11, "'a' is bound twice in this pattern"); + (Error 38, Line 3, Col 20, Line 3, Col 21, "'c' is bound twice in this pattern"); + (Error 38, Line 4, Col 20, Line 4, Col 21, "'a' is bound twice in this pattern") + ] + + [] + let ``Name is bound multiple times is reported for combined bindings unitVar``() = + Fsx """ +let f1 unitVar unitVar = () +let f2 (unitVar, b as c) c = () +let f3 (a, unitVar as c) a = () +let f4 (a, b as c) unitVar = () +let f5 (unitVar, b as c) unitVar = () +let f6 (a, unitVar as c) unitVar = () +let f7 (a, b as unitVar) unitVar = () +""" + |> typecheck + |> shouldFail + |> withDiagnostics [ + (Error 38, Line 2, Col 16, Line 2, Col 23, "'unitVar' is bound twice in this pattern") + (Error 38, Line 3, Col 26, Line 3, Col 27, "'c' is bound twice in this pattern") + (Error 38, Line 4, Col 26, Line 4, Col 27, "'a' is bound twice in this pattern") + (Error 38, Line 6, Col 26, Line 6, Col 33, "'unitVar' is bound twice in this pattern") + (Error 38, Line 7, Col 26, Line 7, Col 33, "'unitVar' is bound twice in this pattern") + (Error 38, Line 8, Col 26, Line 8, Col 33, "'unitVar' is bound twice in this pattern") + ] + + [] + let ``Name is bound multiple times in lambdas with 'as' across groups; unitVar vs () not conflated`` () = + Fsx """ +let bad1 = fun (a, () as unitVar) unitVar -> () +let bad2 = fun a ((() as unitVar)) unitVar -> () + """ + |> typecheck + |> shouldFail + |> withDiagnostics [ + (Error 38, Line 2, Col 35, Line 2, Col 42, "'unitVar' is bound twice in this pattern") + (Error 38, Line 3, Col 36, Line 3, Col 43, "'unitVar' is bound twice in this pattern") + ] + + [] + let ``'as' across groups and unitVar vs () do not clash`` () = + Fsx """ +let f1 unitVar () = () +let f2 () unitVar = () +let f4 (unitVar, ()) a = () +let f5 ((), unitVar) = () +let f6 (unitVar, ()) () = () +let f7 (unitVar, b) () = () +let f8 (a, (unitVar as ())) () = () +let f9 (a, () as unitVar) () = () +let f10 (a, (() as unitVar)) () = () +""" + |> typecheck + |> shouldSucceed + + [] + let ``unitVar vs () do not clash in lambdas and matches`` () = + Fsx """ +let l1 = fun unitVar () -> () +let l2 = fun () unitVar -> () +let l3 = fun (unitVar, ()) -> () +let l4 = fun ((), unitVar) -> () +let l5 = fun (unitVar, b) () -> () +let structLam = fun struct (unitVar, ()) -> () +let okMatch x = + match x with + | (unitVar, ()) -> () + """ + |> typecheck + |> shouldSucceed \ No newline at end of file diff --git a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj index 960057baf9..29847415be 100644 --- a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj +++ b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj @@ -230,6 +230,7 @@ +