diff --git a/fcs/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.Tests.fsproj b/fcs/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.Tests.fsproj index 2c80e36b015..a070bb8cdac 100644 --- a/fcs/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.Tests.fsproj +++ b/fcs/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.Tests.fsproj @@ -1,4 +1,4 @@ - + @@ -61,6 +61,9 @@ TreeVisitorTests.fs + + PatternMatchCompilationTests.fs + ScriptOptionsTests.fs diff --git a/src/fsharp/FindUnsolved.fs b/src/fsharp/FindUnsolved.fs index d11a1284176..0d5b162d8a7 100644 --- a/src/fsharp/FindUnsolved.fs +++ b/src/fsharp/FindUnsolved.fs @@ -188,6 +188,7 @@ and accDiscrim cenv env d = | DecisionTreeTest.ActivePatternCase (exp, tys, _, _, _) -> accExpr cenv env exp accTypeInst cenv env tys + | DecisionTreeTest.Error _ -> () and accAttrib cenv env (Attrib(_, _k, args, props, _, _, _m)) = args |> List.iter (fun (AttribExpr(expr1, expr2)) -> diff --git a/src/fsharp/IlxGen.fs b/src/fsharp/IlxGen.fs index b29d597bbfd..0adcad2f2f1 100644 --- a/src/fsharp/IlxGen.fs +++ b/src/fsharp/IlxGen.fs @@ -5083,6 +5083,7 @@ and GenDecisionTreeSwitch cenv cgbuf inplabOpt stackAtTargets eenv e cases defau error(InternalError("non-dense integer matches not implemented in codegen - these should have been removed by the pattern match compiler", switchm)) GenDecisionTreeCases cenv cgbuf stackAtTargets eenv defaultTargetOpt targets repeatSP targetInfos sequel caseLabels cases contf | _ -> error(InternalError("these matches should never be needed", switchm)) + | DecisionTreeTest.Error m -> error(InternalError("Trying to compile error recovery branch", m)) and GenDecisionTreeCases cenv cgbuf stackAtTargets eenv defaultTargetOpt targets repeatSP targetInfos sequel caseLabels cases (contf: Zmap<_,_> -> FakeUnit) = diff --git a/src/fsharp/PatternMatchCompilation.fs b/src/fsharp/PatternMatchCompilation.fs index 915db6e45c4..100551533c4 100644 --- a/src/fsharp/PatternMatchCompilation.fs +++ b/src/fsharp/PatternMatchCompilation.fs @@ -45,6 +45,8 @@ type Pattern = | TPat_range of char * char * range | TPat_null of range | TPat_isinst of TType * TType * PatternValBinding option * range + | TPat_error of range + member this.Range = match this with | TPat_const(_, m) -> m @@ -61,6 +63,7 @@ type Pattern = | TPat_range(_, _, m) -> m | TPat_null m -> m | TPat_isinst(_, _, _, m) -> m + | TPat_error m -> m and PatternValBinding = PBind of Val * TypeScheme @@ -419,7 +422,11 @@ let getDiscrimOfPattern (g: TcGlobals) tpinst t = | TPat_array (args, ty, _m) -> Some(DecisionTreeTest.ArrayLength (args.Length, ty)) | TPat_query ((activePatExpr, resTys, apatVrefOpt, idx, apinfo), _, _m) -> - Some(DecisionTreeTest.ActivePatternCase (activePatExpr, instTypes tpinst resTys, apatVrefOpt, idx, apinfo)) + Some (DecisionTreeTest.ActivePatternCase (activePatExpr, instTypes tpinst resTys, apatVrefOpt, idx, apinfo)) + + | TPat_error range -> + Some (DecisionTreeTest.Error range) + | _ -> None let constOfDiscrim discrim = @@ -459,10 +466,10 @@ let rec chooseSimultaneousEdgeSet prevOpt f l = | [] -> [], [] | h :: t -> match f prevOpt h with - | Some x, _ -> + | Some x -> let l, r = chooseSimultaneousEdgeSet (Some x) f t x :: l, r - | None, _cont -> + | None -> let l, r = chooseSimultaneousEdgeSet prevOpt f t l, h :: r @@ -490,6 +497,11 @@ let discrimsHaveSameSimultaneousClass g d1 d2 = | _ -> false +let canInvestigate (pat: Pattern) = + match pat with + | TPat_null _ | TPat_isinst _ | TPat_exnconstr _ | TPat_unioncase _ + | TPat_array _ | TPat_const _ | TPat_query _ | TPat_range _ | TPat_error _ -> true + | _ -> false /// Decide the next pattern to investigate let ChooseInvestigationPointLeftToRight frontiers = @@ -498,8 +510,7 @@ let ChooseInvestigationPointLeftToRight frontiers = let rec choose l = match l with | [] -> failwith "ChooseInvestigationPointLeftToRight: no non-immediate patterns in first rule" - | (Active(_, _, (TPat_null _ | TPat_isinst _ | TPat_exnconstr _ | TPat_unioncase _ | TPat_array _ | TPat_const _ | TPat_query _ | TPat_range _)) as active) - :: _ -> active + | Active (_, _, pat) as active :: _ when canInvestigate pat -> active | _ :: t -> choose t choose actives | [] -> failwith "ChooseInvestigationPointLeftToRight: no frontiers!" @@ -698,6 +709,7 @@ let rec isPatternPartial p = | TPat_range _ -> false | TPat_null _ -> false | TPat_isinst _ -> false + | TPat_error _ -> false let rec erasePartialPatterns inpp = match inpp with @@ -716,7 +728,8 @@ let rec erasePartialPatterns inpp = | TPat_wild _ | TPat_range _ | TPat_null _ - | TPat_isinst _ -> inpp + | TPat_isinst _ + | TPat_error _ -> inpp and erasePartials inps = List.map erasePartialPatterns inps @@ -736,14 +749,14 @@ let CompilePatternBasic warnOnIncomplete actionOnFailure (origInputVal, origInputValTypars, _origInputExprOpt: Expr option) - (clausesL: TypedMatchClause list) + (typedClauses: TypedMatchClause list) inputTy resultTy = // Add the targets to a match builder. // Note the input expression has already been evaluated and saved into a variable, // hence no need for a new sequence point. let matchBuilder = MatchBuilder (NoSequencePointAtInvisibleBinding, exprm) - clausesL |> List.iter (fun c -> matchBuilder.AddTarget c.Target |> ignore) + typedClauses |> List.iter (fun c -> matchBuilder.AddTarget c.Target |> ignore) // Add the incomplete or rethrow match clause on demand, // printing a warning if necessary (only if it is ever exercised). @@ -807,8 +820,8 @@ let CompilePatternBasic | Some c -> c // Helpers to get the variables bound at a target. - // We conceptually add a dummy clause that will always succeed with a "throw" - let clausesA = Array.ofList clausesL + // We conceptually add a dummy clause that will always succeed with a "throw". + let clausesA = Array.ofList typedClauses let nClauses = clausesA.Length let GetClause i refuted = if i < nClauses then @@ -842,14 +855,10 @@ let CompilePatternBasic | _ -> // Otherwise choose a point (i.e. a path) to investigate. let (Active(path, subexpr, pat)) = ChooseInvestigationPointLeftToRight frontiers - match pat with - // All these constructs should have been eliminated in BindProjectionPattern - | TPat_as _ | TPat_tuple _ | TPat_wild _ | TPat_disjs _ | TPat_conjs _ | TPat_recd _ -> + if not (canInvestigate pat) then + // All these constructs should have been eliminated in BindProjectionPattern failwith "Unexpected pattern" - - // Leaving the ones where we have real work to do. - | _ -> - + else let simulSetOfEdgeDiscrims, fallthroughPathFrontiers = ChooseSimultaneousEdges frontiers path let inpExprOpt, bindOpt = ChoosePreBinder simulSetOfEdgeDiscrims subexpr @@ -861,8 +870,7 @@ let CompilePatternBasic // Work out what the default/fall-through tree looks like, is any // Check if match is complete, if so optimize the default case away. - - let defaultTreeOpt : DecisionTree option = CompileFallThroughTree fallthroughPathFrontiers path refuted simulSetOfCases + let defaultTreeOpt = CompileFallThroughTree fallthroughPathFrontiers path refuted simulSetOfCases // OK, build the whole tree and whack on the binding if any let finalDecisionTree = @@ -879,7 +887,7 @@ let CompilePatternBasic let es2 = vs2 |> List.map (fun v -> match valMap.TryFind v with - | None -> error(Error(FSComp.SR.patcMissingVariable(v.DisplayName), v.Range)) + | None -> mkUnit g v.Range | Some res -> res) let rhs' = TDSuccess(es2, i) match GetWhenGuardOfClause i refuted with @@ -913,14 +921,14 @@ let CompilePatternBasic match getDiscrimOfPattern p with | Some discrim -> if (match prevOpt with None -> true | Some (EdgeDiscrim(_, discrimPrev, _)) -> discrimsHaveSameSimultaneousClass g discrim discrimPrev) then - Some (EdgeDiscrim(i', discrim, p.Range)), true + Some (EdgeDiscrim(i', discrim, p.Range)) else - None, false + None | None -> - None, true + None else - None, true) + None) and IsCopyableInputExpr origInputExpr = match origInputExpr with @@ -1235,8 +1243,17 @@ let CompilePatternBasic | _ -> [frontier] + | TPat_error range -> + match discrim with + | DecisionTreeTest.Error testRange when range = testRange -> + [Frontier (i, active', valMap)] + | _ -> + [frontier] + | _ -> failwith "pattern compilation: GenerateNewFrontiersAfterSuccessfulInvestigation" - else [frontier] + + else + [frontier] and BindProjectionPattern (Active(path, subExpr, p) as inp) ((accActive, accValMap) as s) = let (SubExpr(accessf, ve)) = subExpr @@ -1286,11 +1303,11 @@ let CompilePatternBasic and BindProjectionPatterns ps s = List.foldBack (fun p sofar -> List.collect (BindProjectionPattern p) sofar) ps [s] - (* The setup routine of the match compiler *) + // The setup routine of the match compiler. let frontiers = - ((clausesL + ((typedClauses |> List.mapi (fun i c -> - let initialSubExpr = SubExpr((fun _tpinst x -> x), (exprForVal origInputVal.Range origInputVal, origInputVal)) + let initialSubExpr = SubExpr((fun _ x -> x), (exprForVal origInputVal.Range origInputVal, origInputVal)) let investigations = BindProjectionPattern (Active(PathEmpty inputTy, initialSubExpr, c.Pattern)) ([], ValMap<_>.Empty) mkFrontiers investigations i) |> List.concat) @@ -1308,7 +1325,7 @@ let CompilePatternBasic if warnOnUnused then let used = HashSet<_>(accTargetsOfDecisionTree dtree [], HashIdentity.Structural) - clausesL |> List.iteri (fun i c -> + typedClauses |> List.iteri (fun i c -> if not (used.Contains i) then warning (RuleNeverMatched c.Range)) dtree, targets diff --git a/src/fsharp/PatternMatchCompilation.fsi b/src/fsharp/PatternMatchCompilation.fsi index b35b5f42b27..35a489af378 100644 --- a/src/fsharp/PatternMatchCompilation.fsi +++ b/src/fsharp/PatternMatchCompilation.fsi @@ -34,6 +34,7 @@ type Pattern = | TPat_range of char * char * range | TPat_null of range | TPat_isinst of TType * TType * PatternValBinding option * range + | TPat_error of range member Range: range diff --git a/src/fsharp/PostInferenceChecks.fs b/src/fsharp/PostInferenceChecks.fs index 6a675eb566e..dca281e2920 100644 --- a/src/fsharp/PostInferenceChecks.fs +++ b/src/fsharp/PostInferenceChecks.fs @@ -1584,6 +1584,7 @@ and CheckDecisionTreeTest cenv env m discrim = | DecisionTreeTest.IsNull -> () | DecisionTreeTest.IsInst (srcTy, tgtTy) -> CheckTypeNoInnerByrefs cenv env m srcTy; CheckTypeNoInnerByrefs cenv env m tgtTy | DecisionTreeTest.ActivePatternCase (exp, _, _, _, _) -> CheckExprNoByrefs cenv env exp + | DecisionTreeTest.Error _ -> () and CheckAttrib cenv env (Attrib(_, _, args, props, _, _, _)) = props |> List.iter (fun (AttribNamedArg(_, _, _, expr)) -> CheckAttribExpr cenv env expr) diff --git a/src/fsharp/QuotationTranslator.fs b/src/fsharp/QuotationTranslator.fs index debc8c666b3..28baf66d755 100644 --- a/src/fsharp/QuotationTranslator.fs +++ b/src/fsharp/QuotationTranslator.fs @@ -933,6 +933,8 @@ and ConvDecisionTree cenv env tgs typR x = | DecisionTreeTest.ActivePatternCase _ -> wfail(InternalError( "DecisionTreeTest.ActivePatternCase test in quoted expression", m)) | DecisionTreeTest.ArrayLength _ -> wfail(Error(FSComp.SR.crefQuotationsCantContainArrayPatternMatching(), m)) + + | DecisionTreeTest.Error m -> wfail(InternalError( "DecisionTreeTest.Error in quoted expression", m)) ) EmitDebugInfoIfNecessary cenv env m converted diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs index 3dd76a50749..b1f3b2cafd4 100644 --- a/src/fsharp/TastOps.fs +++ b/src/fsharp/TastOps.fs @@ -3944,6 +3944,7 @@ module DebugPrint = | (DecisionTreeTest.IsNull ) -> wordL(tagText "isnull") | (DecisionTreeTest.IsInst (_, ty)) -> wordL(tagText "isinst") ^^ typeL ty | (DecisionTreeTest.ActivePatternCase (exp, _, _, _, _)) -> wordL(tagText "query") ^^ exprL g exp + | (DecisionTreeTest.Error _) -> wordL (tagText "error recovery") and targetL g i (TTarget (argvs, body, _)) = leftL(tagText "T") ^^ intL i ^^ tupleL (flatValsL argvs) ^^ rightL(tagText ":") --- exprL g body @@ -4421,6 +4422,7 @@ and accFreeInTest (opts: FreeVarOptions) discrim acc = accFreeInExpr opts exp (accFreeVarsInTys opts tys (Option.foldBack (fun (vref, tinst) acc -> accFreeValRef opts vref (accFreeVarsInTys opts tinst acc)) activePatIdentity acc)) + | DecisionTreeTest.Error _ -> acc and accFreeInDecisionTree opts x (acc: FreeVars) = match x with @@ -5227,6 +5229,7 @@ and remapDecisionTree g compgen tmenv x = | DecisionTreeTest.IsInst (srcty, tgty) -> DecisionTreeTest.IsInst (remapType tmenv srcty, remapType tmenv tgty) | DecisionTreeTest.IsNull -> DecisionTreeTest.IsNull | DecisionTreeTest.ActivePatternCase _ -> failwith "DecisionTreeTest.ActivePatternCase should only be used during pattern match compilation" + | DecisionTreeTest.Error _ -> failwith "DecisionTreeTest.Error should only be used during pattern match compilation" TCase(test', remapDecisionTree g compgen tmenv y)) csl, Option.map (remapDecisionTree g compgen tmenv) dflt, m) diff --git a/src/fsharp/TastPickle.fs b/src/fsharp/TastPickle.fs index ffdf31efbdf..395d9e37e6e 100644 --- a/src/fsharp/TastPickle.fs +++ b/src/fsharp/TastPickle.fs @@ -2397,7 +2397,8 @@ and p_dtree_discrim x st = | DecisionTreeTest.IsNull -> p_byte 2 st | DecisionTreeTest.IsInst (srcty, tgty) -> p_byte 3 st; p_ty srcty st; p_ty tgty st | DecisionTreeTest.ArrayLength (n, ty) -> p_byte 4 st; p_tup2 p_int p_ty (n, ty) st - | DecisionTreeTest.ActivePatternCase _ -> pfailwith st "DecisionTreeTest.ActivePatternCase: only used during pattern match compilation" + | DecisionTreeTest.ActivePatternCase _ -> pfailwith st "DecisionTreeTest.ActivePatternCase: only used during pattern match compilation" + | DecisionTreeTest.Error _ -> pfailwith st "DecisionTreeTest.Error: only used during pattern match compilation" and p_target (TTarget(a, b, _)) st = p_tup2 p_Vals p_expr (a, b) st and p_bind (TBind(a, b, _)) st = p_tup2 p_Val p_expr (a, b) st diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs old mode 100755 new mode 100644 index a3f38aacadd..aa186ead26c --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -5247,7 +5247,7 @@ and TcPatAndRecover warnOnUpper cenv (env: TcEnv) topValInfo vFlags (tpenv, name let m = pat.Range errorRecovery e m //solveTypAsError cenv env.DisplayEnv m ty - (fun _ -> TPat_wild m), (tpenv, names, takenNames) + (fun _ -> TPat_error m), (tpenv, names, takenNames) /// Typecheck a pattern. Patterns are type-checked in three phases: /// 1. TcPat builds a List.map from simple variable names to inferred types for @@ -5265,12 +5265,19 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty p | SynConst.Bytes (bytes, m) -> UnifyTypes cenv env m ty (mkByteArrayTy cenv.g) TcPat warnOnUpper cenv env None vFlags (tpenv, names, takenNames) ty (SynPat.ArrayOrList (true, [ for b in bytes -> SynPat.Const(SynConst.Byte b, m) ], m)) + | SynConst.UserNum _ -> - error(Error(FSComp.SR.tcInvalidNonPrimitiveLiteralInPatternMatch(), m)) - | _ -> - let c' = TcConst cenv ty m env c - (fun (_: TcPatPhase2Input) -> TPat_const(c', m)), (tpenv, names, takenNames) - + errorR (Error (FSComp.SR.tcInvalidNonPrimitiveLiteralInPatternMatch (), m)) + (fun _ -> TPat_error m), (tpenv, names, takenNames) + + | _ -> + try + let c' = TcConst cenv ty m env c + (fun _ -> TPat_const (c', m)), (tpenv, names, takenNames) + with e -> + errorRecovery e m + (fun _ -> TPat_error m), (tpenv, names, takenNames) + | SynPat.Wild m -> (fun _ -> TPat_wild m), (tpenv, names, takenNames) @@ -5288,8 +5295,10 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty p (tpenv, names, takenNames) | _ -> failwith "TcPat" - | SynPat.OptionalVal (_, m) -> - error(Error(FSComp.SR.tcOptionalArgsOnlyOnMembers(), m)) + | SynPat.OptionalVal (id, m) -> + errorR (Error (FSComp.SR.tcOptionalArgsOnlyOnMembers (), m)) + let bindf, names, takenNames = TcPatBindingName cenv env id ty false None topValInfo vFlags (names, takenNames) + (fun values -> TPat_as (TPat_wild m, bindf values, m)), (tpenv, names, takenNames) | SynPat.Named (p, id, isMemberThis, vis, m) -> let bindf, names, takenNames = TcPatBindingName cenv env id ty isMemberThis vis topValInfo vFlags (names, takenNames) @@ -5302,22 +5311,28 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty p UnifyTypes cenv env m ty cty' TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty p - | SynPat.Attrib (_, _, m) -> - error(Error(FSComp.SR.tcAttributesInvalidInPatterns(), m)) + | SynPat.Attrib (p, attrs, _) -> + errorR (Error (FSComp.SR.tcAttributesInvalidInPatterns (), rangeOfNonNilAttrs attrs)) + for attrList in attrs do + TcAttributes cenv env Unchecked.defaultof<_> attrList.Attributes |> ignore + TcPat warnOnUpper cenv env None vFlags (tpenv, names, takenNames) ty p | SynPat.Or (pat1, pat2, m) -> let pat1', (tpenv, names1, takenNames1) = TcPat warnOnUpper cenv env None vFlags (tpenv, names, takenNames) ty pat1 let pat2', (tpenv, names2, takenNames2) = TcPat warnOnUpper cenv env None vFlags (tpenv, names, takenNames) ty pat2 if not (takenNames1 = takenNames2) then - // We don't try to recover from this error since we get later bad internal errors during pattern - // matching - error (UnionPatternsBindDifferentNames m) - names1 |> Map.iter (fun _ (PrelimValScheme1(id1, _, ty1, _, _, _, _, _, _, _, _)) -> - match names2.TryGetValue id1.idText with - | true, PrelimValScheme1(_, _, ty2, _, _, _, _, _, _, _, _) -> - UnifyTypes cenv env m ty1 ty2 - | _ -> ()) - (fun values -> TPat_disjs ([pat1' values;pat2' values.RightPath], m)), (tpenv, names1, takenNames1) + errorR (UnionPatternsBindDifferentNames m) + + names1 |> Map.iter (fun _ (PrelimValScheme1 (id1, _, ty1, _, _, _, _, _, _, _, _)) -> + match names2.TryGetValue id1.idText with + | true, PrelimValScheme1 (id2, _, ty2, _, _, _, _, _, _, _, _) -> + try UnifyTypes cenv env id2.idRange ty1 ty2 + with e -> errorRecovery e m + | _ -> ()) + + let names = NameMap.layer names1 names2 + let takenNames = Set.union takenNames1 takenNames2 + (fun values -> TPat_disjs ([pat1' values; pat2' values.RightPath], m)), (tpenv, names, takenNames) | SynPat.Ands (pats, m) -> let pats', acc = TcPatterns warnOnUpper cenv env vFlags (tpenv, names, takenNames) (List.map (fun _ -> ty) pats) pats @@ -5330,22 +5345,42 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty p | SynConstructorArgs.Pats [] -> warnOnUpper | _ -> AllIdsOK - let checkNoArgsForLiteral() = - let numArgs = - match args with - | SynConstructorArgs.Pats args -> args.Length - | SynConstructorArgs.NamePatPairs (pairs, _) -> pairs.Length - if numArgs <> 0 then error(Error(FSComp.SR.tcLiteralDoesNotTakeArguments(), m)) + let lidRange = rangeOfLid longId + + let checkNoArgsForLiteral () = + match args with + | SynConstructorArgs.Pats [] + | SynConstructorArgs.NamePatPairs ([], _) -> () + | _ -> errorR (Error (FSComp.SR.tcLiteralDoesNotTakeArguments (), m)) + + let getArgPatterns () = + match args with + | SynConstructorArgs.Pats args -> args + | SynConstructorArgs.NamePatPairs (pairs, _) -> List.map snd pairs + + let tcArgPatterns () = + let args = getArgPatterns () + TcPatterns warnOnUpper cenv env vFlags (tpenv, names, takenNames) (NewInferenceTypes args) args match ResolvePatternLongIdent cenv.tcSink cenv.nameResolver warnOnUpperForId false m ad env.NameEnv TypeNameResolutionInfo.Default longId with | Item.NewDef id -> - match args with - | SynConstructorArgs.Pats [] - | SynConstructorArgs.NamePatPairs ([], _)-> TcPat warnOnUpperForId cenv env topValInfo vFlags (tpenv, names, takenNames) ty (mkSynPatVar vis id) - | _ -> error (UndefinedName(0, FSComp.SR.undefinedNamePatternDiscriminator, id, NoSuggestions)) + let _, acc = tcArgPatterns () + match getArgPatterns () with + | [] -> TcPat warnOnUpperForId cenv env topValInfo vFlags acc ty (mkSynPatVar vis id) + | _ -> + errorR (UndefinedName (0, FSComp.SR.undefinedNamePatternDiscriminator, id, NoSuggestions)) + (fun _ -> TPat_error m), acc + + | Item.ActivePatternCase (APElemRef (apinfo, vref, idx)) as item -> + // Report information about the 'active recognizer' occurrence to IDE + CallNameResolutionSink cenv.tcSink (rangeOfLid longId, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Pattern, env.DisplayEnv, env.eAccessRights) + + match args with + | SynConstructorArgs.Pats _ -> () + | _ -> errorR (Error (FSComp.SR.tcNamedActivePattern (apinfo.ActiveTags.[idx]), m)) + + let args = getArgPatterns () - | Item.ActivePatternCase(APElemRef(apinfo, vref, idx)) as item -> - let args = match args with SynConstructorArgs.Pats args -> args | _ -> error(Error(FSComp.SR.tcNamedActivePattern(apinfo.ActiveTags.[idx]), m)) // TOTAL/PARTIAL ACTIVE PATTERNS let _, vexp, _, _, tinst, _ = TcVal true cenv env tpenv vref None None m let vexp = MakeApplicableExprWithFlex cenv env vexp @@ -5365,18 +5400,18 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty p List.frontAndBack args if not (isNil activePatArgsAsSynPats) && apinfo.ActiveTags.Length <> 1 then - error(Error(FSComp.SR.tcRequireActivePatternWithOneResult(), m)) + errorR (Error (FSComp.SR.tcRequireActivePatternWithOneResult (), m)) // Parse the arguments to an active pattern // Note we parse arguments to parameterized pattern labels as patterns, not expressions. // This means the range of syntactic expression forms that can be used here is limited. let rec convSynPatToSynExpr x = match x with - | SynPat.FromParseError(p, _) -> convSynPatToSynExpr p + | SynPat.FromParseError (p, _) -> convSynPatToSynExpr p | SynPat.Const (c, m) -> SynExpr.Const (c, m) | SynPat.Named (SynPat.Wild _, id, _, None, _) -> SynExpr.Ident id | SynPat.Typed (p, cty, m) -> SynExpr.Typed (convSynPatToSynExpr p, cty, m) - | SynPat.LongIdent (LongIdentWithDots(longId, dotms) as lidwd, _, _tyargs, args, None, m) -> + | SynPat.LongIdent (LongIdentWithDots (longId, dotms) as lidwd, _, _tyargs, args, None, m) -> let args = match args with SynConstructorArgs.Pats args -> args | _ -> failwith "impossible: active patterns can be used only with SynConstructorArgs.Pats" let e = if dotms.Length = longId.Length then @@ -5401,135 +5436,183 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty p if idx >= activePatResTys.Length then error(Error(FSComp.SR.tcInvalidIndexIntoActivePatternArray(), m)) let argty = List.item idx activePatResTys - let arg', (tpenv, names, takenNames) = TcPat warnOnUpper cenv env None vFlags (tpenv, names, takenNames) argty patarg - + let arg', acc = TcPat warnOnUpper cenv env None vFlags (tpenv, names, takenNames) argty patarg + // The identity of an active pattern consists of its value and the types it is applied to. // If there are any expression args then we've lost identity. let activePatIdentity = if isNil activePatArgsAsSynExprs then Some (vref, tinst) else None (fun values -> - // Report information about the 'active recognizer' occurrence to IDE - CallNameResolutionSink cenv.tcSink (rangeOfLid longId, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Pattern, env.DisplayEnv, env.AccessRights) - TPat_query((activePatExpr, activePatResTys, activePatIdentity, idx, apinfo), arg' values, m)), - (tpenv, names, takenNames) + TPat_query((activePatExpr, activePatResTys, activePatIdentity, idx, apinfo), arg' values, m)), acc | (Item.UnionCase _ | Item.ExnCase _) as item -> - // DATA MATCH CONSTRUCTORS + // Report information about the case occurrence to IDE + CallNameResolutionSink cenv.tcSink (lidRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Pattern, env.DisplayEnv, env.eAccessRights) + let mkf, argTys, argNames = ApplyUnionCaseOrExnTypesForPat m cenv env ty item let numArgTys = argTys.Length - let args = + let args, extraPatternsFromNames = match args with - | SynConstructorArgs.Pats args -> args + | SynConstructorArgs.Pats args -> args, [] | SynConstructorArgs.NamePatPairs (pairs, m) -> - // rewrite patterns from the form (name-N = pat-N...) to (..._, pat-N, _...) + // rewrite patterns from the form (name-N = pat-N; ...) to (..._, pat-N, _...) // so type T = Case of name: int * value: int // | Case(value = v) // will become // | Case(_, v) let result = Array.zeroCreate numArgTys + let extraPatterns = List () + for (id, pat) in pairs do match argNames |> List.tryFindIndex (fun id2 -> id.idText = id2.idText) with | None -> + extraPatterns.Add pat match item with | Item.UnionCase(uci, _) -> - error(Error(FSComp.SR.tcUnionCaseConstructorDoesNotHaveFieldWithGivenName(uci.Name, id.idText), id.idRange)) + errorR (Error (FSComp.SR.tcUnionCaseConstructorDoesNotHaveFieldWithGivenName (uci.Name, id.idText), id.idRange)) | Item.ExnCase tcref -> - error(Error(FSComp.SR.tcExceptionConstructorDoesNotHaveFieldWithGivenName(tcref.DisplayName, id.idText), id.idRange)) + errorR (Error (FSComp.SR.tcExceptionConstructorDoesNotHaveFieldWithGivenName (tcref.DisplayName, id.idText), id.idRange)) | _ -> - error(Error(FSComp.SR.tcConstructorDoesNotHaveFieldWithGivenName(id.idText), id.idRange)) + errorR (Error (FSComp.SR.tcConstructorDoesNotHaveFieldWithGivenName (id.idText), id.idRange)) | Some idx -> + let argContainerOpt = + match item with + | Item.UnionCase (uci, _) -> Some (ArgumentContainer.UnionCase uci) + | Item.ExnCase tref -> Some (ArgumentContainer.Type tref) + | _ -> None + + let argItem = Item.ArgName (argNames.[idx], argTys.[idx], argContainerOpt) + CallNameResolutionSink cenv.tcSink (id.idRange, env.NameEnv, argItem, argItem, emptyTyparInst, ItemOccurence.Pattern, env.DisplayEnv, ad) + match box result.[idx] with - | null -> - result.[idx] <- pat - let argContainerOpt = match item with - | Item.UnionCase(uci, _) -> Some(ArgumentContainer.UnionCase uci) - | Item.ExnCase tref -> Some(ArgumentContainer.Type tref) - | _ -> None - let argItem = Item.ArgName (argNames.[idx], argTys.[idx], argContainerOpt) - CallNameResolutionSink cenv.tcSink (id.idRange, env.NameEnv, argItem, argItem, emptyTyparInst, ItemOccurence.Pattern, env.DisplayEnv, ad) + | null -> result.[idx] <- pat | _ -> - error(Error(FSComp.SR.tcUnionCaseFieldCannotBeUsedMoreThanOnce(id.idText), id.idRange)) + extraPatterns.Add pat + errorR (Error (FSComp.SR.tcUnionCaseFieldCannotBeUsedMoreThanOnce (id.idText), id.idRange)) + for i = 0 to numArgTys - 1 do if isNull (box result.[i]) then - result.[i] <- SynPat.Wild(m.MakeSynthetic()) + result.[i] <- SynPat.Wild (m.MakeSynthetic()) + + let extraPatterns = + if isNull extraPatterns then [] else List.ofSeq extraPatterns let args = List.ofArray result - if result.Length = 1 then args - else [ SynPat.Tuple(false, args, m) ] - - let args = - match args with - | []-> [] - // note: the next will always be parenthesized - | [SynPatErrorSkip(SynPat.Tuple (false, args, _)) | SynPatErrorSkip(SynPat.Paren(SynPatErrorSkip(SynPat.Tuple (false, args, _)), _))] when numArgTys > 1 -> args - - // note: we allow both 'C _' and 'C (_)' regardless of number of argument of the pattern - | [SynPatErrorSkip(SynPat.Wild _ as e) | SynPatErrorSkip(SynPat.Paren(SynPatErrorSkip(SynPat.Wild _ as e), _))] -> List.replicate numArgTys e - | [arg] -> [arg] - | _ when numArgTys = 0 -> error(Error(FSComp.SR.tcUnionCaseDoesNotTakeArguments(), m)) - | _ when numArgTys = 1 -> error(Error(FSComp.SR.tcUnionCaseRequiresOneArgument(), m)) - | _ -> error(Error(FSComp.SR.tcUnionCaseExpectsTupledArguments numArgTys, m)) - UnionCaseOrExnCheck env numArgTys args.Length m + if result.Length = 1 then args, extraPatterns + else [ SynPat.Tuple(false, args, m) ], extraPatterns + + let args, extraPatterns = + match args with + | [] -> [], [] + + // note: the next will always be parenthesized + | [SynPatErrorSkip(SynPat.Tuple (false, args, _)) | SynPatErrorSkip(SynPat.Paren(SynPatErrorSkip(SynPat.Tuple (false, args, _)), _))] when numArgTys > 1 -> args, [] + + // note: we allow both 'C _' and 'C (_)' regardless of number of argument of the pattern + | [SynPatErrorSkip(SynPat.Wild _ as e) | SynPatErrorSkip(SynPat.Paren(SynPatErrorSkip(SynPat.Wild _ as e), _))] -> List.replicate numArgTys e, [] + + + | args when numArgTys = 0 -> + errorR (Error (FSComp.SR.tcUnionCaseDoesNotTakeArguments (), m)) + [], args + + + | arg :: rest when numArgTys = 1 -> + if numArgTys = 1 && not (List.isEmpty rest) then + errorR (Error (FSComp.SR.tcUnionCaseRequiresOneArgument (), m)) + [arg], rest + | [arg] -> [arg], [] + + | args -> + errorR (Error (FSComp.SR.tcUnionCaseExpectsTupledArguments numArgTys, m)) + [], args + + let args, extraPatterns = + let numArgs = args.Length + if numArgs = numArgTys then + args, extraPatterns + else + if numArgs < numArgTys then + if numArgs <> 0 && numArgTys <> 0 then + errorR (UnionCaseWrongArguments (env.DisplayEnv, numArgTys, numArgs, m)) + args @ (List.init (numArgTys - numArgs) (fun _ -> SynPat.Wild (m.MakeSynthetic()))), extraPatterns + else + let args, remaining = args |> List.splitAt numArgTys + for remainingArg in remaining do + errorR (UnionCaseWrongArguments (env.DisplayEnv, numArgTys, numArgs, remainingArg.Range)) + args, extraPatterns @ remaining + + let extraPatterns = extraPatterns @ extraPatternsFromNames let args', acc = TcPatterns warnOnUpper cenv env vFlags (tpenv, names, takenNames) argTys args - (fun values -> - // Report information about the case occurrence to IDE - CallNameResolutionSink cenv.tcSink (rangeOfLid longId, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Pattern, env.DisplayEnv, env.AccessRights) - mkf m (List.map (fun f -> f values) args')), acc + let _, acc = TcPatterns warnOnUpper cenv env vFlags acc (NewInferenceTypes extraPatterns) extraPatterns + (fun values -> mkf m (List.map (fun f -> f values) args')), acc | Item.ILField finfo -> - // LITERAL .NET FIELDS - CheckILFieldInfoAccessible cenv.g cenv.amap m env.AccessRights finfo - if not finfo.IsStatic then errorR (Error (FSComp.SR.tcFieldIsNotStatic(finfo.FieldName), m)) + CheckILFieldInfoAccessible cenv.g cenv.amap lidRange env.AccessRights finfo + if not finfo.IsStatic then + errorR (Error (FSComp.SR.tcFieldIsNotStatic (finfo.FieldName), lidRange)) CheckILFieldAttributes cenv.g finfo m match finfo.LiteralValue with - | None -> error (Error(FSComp.SR.tcFieldNotLiteralCannotBeUsedInPattern(), m)) + | None -> error (Error (FSComp.SR.tcFieldNotLiteralCannotBeUsedInPattern (), lidRange)) | Some lit -> - checkNoArgsForLiteral() - UnifyTypes cenv env m ty (finfo.FieldType(cenv.amap, m)) - let c' = TcFieldInit m lit + checkNoArgsForLiteral () + let _, acc = tcArgPatterns () + + UnifyTypes cenv env m ty (finfo.FieldType (cenv.amap, m)) + let c' = TcFieldInit lidRange lit let item = Item.ILField finfo - CallNameResolutionSink cenv.tcSink (m, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Pattern, env.DisplayEnv, env.AccessRights) - (fun _ -> TPat_const (c', m)), (tpenv, names, takenNames) - + CallNameResolutionSink cenv.tcSink (lidRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Pattern, env.DisplayEnv, env.AccessRights) + (fun _ -> TPat_const (c', m)), acc + | Item.RecdField rfinfo -> - // LITERAL F# FIELDS - CheckRecdFieldInfoAccessible cenv.amap m env.AccessRights rfinfo - if not rfinfo.IsStatic then errorR (Error (FSComp.SR.tcFieldIsNotStatic(rfinfo.Name), m)) - CheckRecdFieldInfoAttributes cenv.g rfinfo m |> CommitOperationResult + CheckRecdFieldInfoAccessible cenv.amap lidRange env.AccessRights rfinfo + if not rfinfo.IsStatic then errorR (Error (FSComp.SR.tcFieldIsNotStatic(rfinfo.Name), lidRange)) + CheckRecdFieldInfoAttributes cenv.g rfinfo lidRange |> CommitOperationResult match rfinfo.LiteralValue with - | None -> error (Error(FSComp.SR.tcFieldNotLiteralCannotBeUsedInPattern(), m)) + | None -> error (Error(FSComp.SR.tcFieldNotLiteralCannotBeUsedInPattern(), lidRange)) | Some lit -> checkNoArgsForLiteral() + let _, acc = tcArgPatterns () + UnifyTypes cenv env m ty rfinfo.FieldType let item = Item.RecdField rfinfo // FUTURE: can we do better than emptyTyparInst here, in order to display instantiations // of type variables in the quick info provided in the IDE. - CallNameResolutionSink cenv.tcSink (m, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Pattern, env.DisplayEnv, env.AccessRights) - (fun _ -> TPat_const (lit, m)), (tpenv, names, takenNames) + CallNameResolutionSink cenv.tcSink (lidRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Pattern, env.DisplayEnv, env.AccessRights) + (fun _ -> TPat_const (lit, m)), acc | Item.Value vref -> match vref.LiteralValue with | None -> error (Error(FSComp.SR.tcNonLiteralCannotBeUsedInPattern(), m)) | Some lit -> - let _, _, _, vexpty, _, _ = TcVal true cenv env tpenv vref None None m - CheckValAccessible m env.AccessRights vref - CheckFSharpAttributes cenv.g vref.Attribs m |> CommitOperationResult + let _, _, _, vexpty, _, _ = TcVal true cenv env tpenv vref None None lidRange + CheckValAccessible lidRange env.AccessRights vref + CheckFSharpAttributes cenv.g vref.Attribs lidRange |> CommitOperationResult checkNoArgsForLiteral() + let _, acc = tcArgPatterns () + UnifyTypes cenv env m ty vexpty let item = Item.Value vref - CallNameResolutionSink cenv.tcSink (m, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Pattern, env.DisplayEnv, env.AccessRights) - (fun _ -> TPat_const (lit, m)), (tpenv, names, takenNames) + CallNameResolutionSink cenv.tcSink (lidRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Pattern, env.DisplayEnv, env.AccessRights) + (fun _ -> TPat_const (lit, m)), acc | _ -> error (Error(FSComp.SR.tcRequireVarConstRecogOrLiteral(), m)) - | SynPat.QuoteExpr(_, m) -> error (Error(FSComp.SR.tcInvalidPattern(), m)) - + | SynPat.QuoteExpr(_, m) -> + errorR (Error(FSComp.SR.tcInvalidPattern(), m)) + (fun _ -> TPat_error m), (tpenv, names, takenNames) + | SynPat.Tuple (isExplicitStruct, args, m) -> - let tupInfo, argTys = UnifyTupleTypeAndInferCharacteristics env.eContextInfo cenv env.DisplayEnv m ty isExplicitStruct args - let args', acc = TcPatterns warnOnUpper cenv env vFlags (tpenv, names, takenNames) argTys args - (fun values -> TPat_tuple(tupInfo, List.map (fun f -> f values) args', argTys, m)), acc + try + let tupInfo, argTys = UnifyTupleTypeAndInferCharacteristics env.eContextInfo cenv env.DisplayEnv m ty isExplicitStruct args + let args', acc = TcPatterns warnOnUpper cenv env vFlags (tpenv, names, takenNames) argTys args + (fun values -> TPat_tuple(tupInfo, List.map (fun f -> f values) args', argTys, m)), acc + with e -> + errorRecovery e m + let _, acc = TcPatterns warnOnUpper cenv env vFlags (tpenv, names, takenNames) (NewInferenceTypes args) args + (fun _ -> TPat_error m), acc | SynPat.Paren (p, _) -> TcPat warnOnUpper cenv env None vFlags (tpenv, names, takenNames) ty p @@ -5564,7 +5647,8 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty p (fun _ -> TPat_range(c1, c2, m)), (tpenv, names, takenNames) | SynPat.Null m -> - AddCxTypeMustSupportNull env.DisplayEnv cenv.css m NoTrace ty + try AddCxTypeMustSupportNull env.DisplayEnv cenv.css m NoTrace ty + with e -> errorRecovery e m (fun _ -> TPat_null m), (tpenv, names, takenNames) | SynPat.InstanceMember (_, _, _, _, m) -> diff --git a/src/fsharp/ast.fs b/src/fsharp/ast.fs index 012611ed0ee..f937db4fd80 100644 --- a/src/fsharp/ast.fs +++ b/src/fsharp/ast.fs @@ -2028,6 +2028,10 @@ type SynExpr with type SynReturnInfo = SynReturnInfo of (SynType * SynArgInfo) * range: range +let unionRangeWithListBy projectRangeFromThing m listOfThing = + (m, listOfThing) ||> List.fold (fun m thing -> unionRanges m (projectRangeFromThing thing)) + + let mkAttributeList attrs range = [{ Attributes = attrs Range = range }] @@ -2040,6 +2044,9 @@ let ConcatAttributesLists (attrsLists: SynAttributeList list) = let (|Attributes|) synAttributes = ConcatAttributesLists synAttributes +let rangeOfNonNilAttrs (attrs: SynAttributes) = + (attrs.Head.Range, attrs.Tail) ||> unionRangeWithListBy (fun a -> a.Range) + /// Operations related to the syntactic analysis of arguments of value, function and member definitions and signatures. /// /// Function and member definitions have strongly syntactically constrained arities. We infer diff --git a/src/fsharp/pars.fsy b/src/fsharp/pars.fsy index 59a07765b3e..093194c45e6 100644 --- a/src/fsharp/pars.fsy +++ b/src/fsharp/pars.fsy @@ -145,12 +145,6 @@ let checkForMultipleAugmentations m a1 a2 = let grabXmlDoc(parseState:IParseState,elemIdx) = LexbufLocalXmlDocStore.GrabXmlDocBeforeMarker(parseState.LexBuffer,rhs parseState elemIdx) -let unionRangeWithListBy projectRangeFromThing m listOfThing = - (m, listOfThing) ||> List.fold (fun m thing -> unionRanges m (projectRangeFromThing thing)) - -let rangeOfNonNilAttrs(attrs:SynAttributes) = - (attrs.Head.Range,attrs.Tail) ||> unionRangeWithListBy (fun a -> a.Range) - let rangeOfLongIdent(lid:LongIdent) = System.Diagnostics.Debug.Assert(not lid.IsEmpty, "the parser should never produce a long-id that is the empty list") (lid.Head.idRange,lid) ||> unionRangeWithListBy (fun id -> id.idRange) diff --git a/src/fsharp/symbols/Exprs.fs b/src/fsharp/symbols/Exprs.fs index 16ada4ec575..04db4fcab14 100644 --- a/src/fsharp/symbols/Exprs.fs +++ b/src/fsharp/symbols/Exprs.fs @@ -1206,7 +1206,8 @@ module FSharpExprConvert = let e1R = ConvExpr cenv env e1 E.IfThenElse (E.TypeTest (ConvType cenv tgty, e1R) |> Mk cenv m cenv.g.bool_ty, ConvDecisionTree cenv env dtreeRetTy dtree m, acc) | DecisionTreeTest.ActivePatternCase _ -> wfail("unexpected Test.ActivePatternCase test in quoted expression", m) - | DecisionTreeTest.ArrayLength _ -> wfail("FSharp.Compiler.Service cannot yet return array pattern matching", m)) + | DecisionTreeTest.ArrayLength _ -> wfail("FSharp.Compiler.Service cannot yet return array pattern matching", m) + | DecisionTreeTest.Error m -> wfail("error recovery", m)) | TDSuccess (args, n) -> // TAST stores pattern bindings in reverse order for some reason diff --git a/src/fsharp/symbols/SymbolHelpers.fs b/src/fsharp/symbols/SymbolHelpers.fs index 39ca96934b2..cddf6005b37 100644 --- a/src/fsharp/symbols/SymbolHelpers.fs +++ b/src/fsharp/symbols/SymbolHelpers.fs @@ -42,13 +42,17 @@ type FSharpErrorSeverity = | Warning | Error -type FSharpErrorInfo(fileName, s: pos, e: pos, severity: FSharpErrorSeverity, message: string, subcategory: string, errorNum: int) = +type FSharpErrorInfo(fileName, s: pos, e: pos, severity: FSharpErrorSeverity, message: string, subcategory: string, errorNum: int) = + member __.Start = s + member __.End = e + member __.StartLine = Line.toZ s.Line member __.StartLineAlternate = s.Line member __.EndLine = Line.toZ e.Line member __.EndLineAlternate = e.Line member __.StartColumn = s.Column member __.EndColumn = e.Column + member __.Severity = severity member __.Message = message member __.Subcategory = subcategory diff --git a/src/fsharp/symbols/SymbolHelpers.fsi b/src/fsharp/symbols/SymbolHelpers.fsi index e6ece6fa2ca..fda3e73bd1e 100755 --- a/src/fsharp/symbols/SymbolHelpers.fsi +++ b/src/fsharp/symbols/SymbolHelpers.fsi @@ -29,6 +29,8 @@ type public FSharpErrorSeverity = [] type public FSharpErrorInfo = member FileName: string + member Start: pos + member End: pos member StartLineAlternate:int member EndLineAlternate:int member StartColumn:int diff --git a/src/fsharp/tast.fs b/src/fsharp/tast.fs index 2aeceb3bac9..6bc836e703b 100644 --- a/src/fsharp/tast.fs +++ b/src/fsharp/tast.fs @@ -4568,6 +4568,9 @@ and /// activePatternInfo -- The extracted info for the active pattern. | ActivePatternCase of Expr * TTypes * (ValRef * TypeInst) option * int * ActivePatternInfo + /// Used in error recovery + | Error of range + // %+A formatting is used, so this is not needed //[] //member x.DebugText = x.ToString() diff --git a/tests/fsharp/typecheck/sigs/neg103.bsl b/tests/fsharp/typecheck/sigs/neg103.bsl index 422a9e3bf81..d2a0cc1220d 100644 --- a/tests/fsharp/typecheck/sigs/neg103.bsl +++ b/tests/fsharp/typecheck/sigs/neg103.bsl @@ -19,6 +19,8 @@ neg103.fs(21,7,21,9): typecheck error FS0001: This expression was expected to ha but here has type 'int' +neg103.fs(20,5,20,29): typecheck error FS0025: Incomplete pattern matches on this expression. + neg103.fs(25,11,25,19): typecheck error FS0001: This expression was expected to have type 'int' but here has type diff --git a/tests/fsharp/typecheck/sigs/neg103.vsbsl b/tests/fsharp/typecheck/sigs/neg103.vsbsl index 422a9e3bf81..d2a0cc1220d 100644 --- a/tests/fsharp/typecheck/sigs/neg103.vsbsl +++ b/tests/fsharp/typecheck/sigs/neg103.vsbsl @@ -19,6 +19,8 @@ neg103.fs(21,7,21,9): typecheck error FS0001: This expression was expected to ha but here has type 'int' +neg103.fs(20,5,20,29): typecheck error FS0025: Incomplete pattern matches on this expression. + neg103.fs(25,11,25,19): typecheck error FS0001: This expression was expected to have type 'int' but here has type diff --git a/tests/fsharp/typecheck/sigs/neg16.bsl b/tests/fsharp/typecheck/sigs/neg16.bsl index 555e62a1024..72bcb7e0b85 100644 --- a/tests/fsharp/typecheck/sigs/neg16.bsl +++ b/tests/fsharp/typecheck/sigs/neg16.bsl @@ -63,12 +63,16 @@ but here has type neg16.fs(85,8,85,18): typecheck error FS0039: The pattern discriminator 'FooA++' is not defined. +neg16.fs(85,7,85,22): typecheck error FS0025: Incomplete pattern matches on this expression. + neg16.fs(87,50,87,54): typecheck error FS0039: The value or constructor 'OneA' is not defined. neg16.fs(87,60,87,69): typecheck error FS0039: The value or constructor 'TwoA+' is not defined. neg16.fs(90,8,90,18): typecheck error FS0039: The pattern discriminator 'FooB++' is not defined. +neg16.fs(90,7,90,22): typecheck error FS0025: Incomplete pattern matches on this expression. + neg16.fs(97,15,97,16): typecheck error FS0823: The 'VolatileField' attribute may only be used on 'let' bindings in classes neg16.fs(100,11,100,14): typecheck error FS0823: The 'VolatileField' attribute may only be used on 'let' bindings in classes diff --git a/tests/fsharpqa/Source/Conformance/DeclarationElements/LetBindings/Basic/E_AttributesOnLet01.fs b/tests/fsharpqa/Source/Conformance/DeclarationElements/LetBindings/Basic/E_AttributesOnLet01.fs index 23ce8e6a083..88b6421e126 100644 --- a/tests/fsharpqa/Source/Conformance/DeclarationElements/LetBindings/Basic/E_AttributesOnLet01.fs +++ b/tests/fsharpqa/Source/Conformance/DeclarationElements/LetBindings/Basic/E_AttributesOnLet01.fs @@ -4,7 +4,10 @@ // Regression test for FSharp1.0:3744 - Unable to apply attributes on individual patterns in a tupled pattern match let binding - Implementation doesn't match spec // Test against error emitted when attributes applied within pattern -//Attributes are not allowed within patterns +//Attributes are not allowed within patterns +//This attribute is not valid for use on this language element +//Attributes are not allowed within patterns +//This attribute is not valid for use on this language element open System diff --git a/tests/fsharpqa/Source/Conformance/PatternMatching/Union/E_UnionCapturesDiffType01.fs b/tests/fsharpqa/Source/Conformance/PatternMatching/Union/E_UnionCapturesDiffType01.fs index b96c7a37045..def92d6297b 100644 --- a/tests/fsharpqa/Source/Conformance/PatternMatching/Union/E_UnionCapturesDiffType01.fs +++ b/tests/fsharpqa/Source/Conformance/PatternMatching/Union/E_UnionCapturesDiffType01.fs @@ -1,6 +1,6 @@ // #Regression #Conformance #PatternMatching #Unions // Verify error if two union rules capture values with different types -//This expression was expected to have type. 'int' .but here has type. 'float' +//This expression was expected to have type. 'int' .but here has type. 'float' let testMatch x = match x with diff --git a/tests/service/Common.fs b/tests/service/Common.fs index e62233448bd..171713a7540 100644 --- a/tests/service/Common.fs +++ b/tests/service/Common.fs @@ -1,11 +1,14 @@ +[] module internal FSharp.Compiler.Service.Tests.Common open System open System.IO open System.Collections.Generic open FSharp.Compiler +open FSharp.Compiler.Range open FSharp.Compiler.SourceCodeServices open FsUnit +open NUnit.Framework #if NETCOREAPP let readRefs (folder : string) (projectFile: string) = @@ -303,16 +306,29 @@ let rec allSymbolsInEntities compGen (entities: IList) = yield (x :> FSharpSymbol) yield! allSymbolsInEntities compGen e.NestedEntities ] - let getParseAndCheckResults (source: string) = - parseAndCheckScript("/home/user/Test.fsx", source) + parseAndCheckScript("/home/user/Test.fsx", source) + +let inline dumpErrors results = + (^TResults: (member Errors: FSharpErrorInfo[]) results) + |> Array.map (fun e -> + let range = mkRange e.FileName e.Start e.End + let message = + e.Message.Split('\n') + |> Array.map (fun s -> s.Trim()) + |> String.concat " " + sprintf "%s: %s" (range.ToShortString()) message) + |> List.ofArray -let getSymbolUses (source: string) = - let _, typeCheckResults = parseAndCheckScript("/home/user/Test.fsx", source) + +let getSymbolUses (results: FSharpCheckFileResults) = + results.GetAllUsesOfAllSymbolsInFile() |> Async.RunSynchronously + +let getSymbolUsesFromSource (source: string) = + let _, typeCheckResults = getParseAndCheckResults source typeCheckResults.GetAllUsesOfAllSymbolsInFile() |> Async.RunSynchronously -let getSymbols (source: string) = - let symbolUses = getSymbolUses source +let getSymbols (symbolUses: FSharpSymbolUse[]) = symbolUses |> Array.map (fun symbolUse -> symbolUse.Symbol) @@ -329,13 +345,30 @@ let getSymbolName (symbol: FSharpSymbol) = let assertContainsSymbolWithName name source = - let symbols = getSymbols source - let names = symbols |> Array.choose getSymbolName - - names + getSymbols source + |> Array.choose getSymbolName |> Array.contains name |> shouldEqual true +let assertContainsSymbolsWithNames (names: string list) source = + let symbolNames = + getSymbols source + |> Array.choose getSymbolName + + for name in names do + symbolNames + |> Array.contains name + |> shouldEqual true + +let assertHasSymbolUsages (names: string list) (results: FSharpCheckFileResults) = + let symbolNames = + getSymbolUses results + |> getSymbols + |> Array.choose getSymbolName + |> set + + for name in names do + Assert.That(Set.contains name symbolNames, name) let coreLibAssemblyName = #if NETCOREAPP diff --git a/tests/service/EditorTests.fs b/tests/service/EditorTests.fs index 459aa75ea96..ca0ce605d0a 100644 --- a/tests/service/EditorTests.fs +++ b/tests/service/EditorTests.fs @@ -1328,18 +1328,18 @@ let ``FSharpField.IsNameGenerated`` () = [] let ``ValNoMutable recovery`` () = - let source = """ + let _, checkResults = getParseAndCheckResults """ let x = 1 x <- let y = 1 y """ - assertContainsSymbolWithName "y" source + assertHasSymbolUsages ["y"] checkResults [] let ``PropertyCannotBeSet recovery`` () = - let source = """ + let _, checkResults = getParseAndCheckResults """ type T = static member P = 1 @@ -1347,12 +1347,12 @@ T.P <- let y = 1 y """ - assertContainsSymbolWithName "y" source + assertHasSymbolUsages ["y"] checkResults [] let ``FieldNotMutable recovery`` () = - let source = """ + let _, checkResults = getParseAndCheckResults """ type R = { F: int } @@ -1360,15 +1360,15 @@ type R = let y = 1 y """ - assertContainsSymbolWithName "y" source + assertHasSymbolUsages ["y"] checkResults [] let ``Inherit ctor arg recovery`` () = - let source = """ + let _, checkResults = getParseAndCheckResults """ type T() as this = inherit System.Exception('a', 'a') let x = this """ - assertContainsSymbolWithName "x" source + assertHasSymbolUsages ["x"] checkResults diff --git a/tests/service/PatternMatchCompilationTests.fs b/tests/service/PatternMatchCompilationTests.fs new file mode 100644 index 00000000000..60f6327d3ca --- /dev/null +++ b/tests/service/PatternMatchCompilationTests.fs @@ -0,0 +1,297 @@ +module FSharp.Compiler.Service.Tests.PatternMatchCompilationTests + +open FsUnit +open NUnit.Framework + + +[] +let ``Wrong type 01 - Match`` () = + let _, checkResults = getParseAndCheckResults """ +match () with +| "" -> () +| x -> let y = () in () +""" + assertHasSymbolUsages ["x"; "y"] checkResults + dumpErrors checkResults |> shouldEqual [ + "(3,2--3,4): This expression was expected to have type 'unit' but here has type 'string'" + ] + + +[] +let ``Wrong type 02 - Binding`` () = + let _, checkResults = getParseAndCheckResults """ +let ("": unit), (x: int) = let y = () in () +""" + assertHasSymbolUsages ["x"; "y"] checkResults + dumpErrors checkResults |> shouldEqual [ + "(2,5--2,7): This expression was expected to have type 'unit' but here has type 'string'" + "(2,41--2,43): This expression was expected to have type 'unit * int' but here has type 'unit'" + "(2,4--2,24): Incomplete pattern matches on this expression." + ] + + +[] +let ``Attributes 01 `` () = + let _, checkResults = getParseAndCheckResults """ +match () with +| [] x -> let y = () in () +""" + assertHasSymbolUsages ["x"; "y"; "CompiledNameAttribute"] checkResults + dumpErrors checkResults |> shouldEqual [ + "(3,2--3,25): Attributes are not allowed within patterns" + "(3,4--3,16): This attribute is not valid for use on this language element" + ] + + +[] +let ``Optional val 01 `` () = + let _, checkResults = getParseAndCheckResults """ +match () with +| ?x -> let y = () in () +""" + assertHasSymbolUsages ["x"; "y"] checkResults + dumpErrors checkResults |> shouldEqual [ + "(3,2--3,4): Optional arguments are only permitted on type members" + ] + + +[] +let ``Null 01`` () = + let _, checkResults = getParseAndCheckResults """ +match 1, 2 with +| null -> let y = () in () +""" + assertHasSymbolUsages ["y"] checkResults + dumpErrors checkResults |> shouldEqual [ + "(3,2--3,6): The type '(int * int)' does not have 'null' as a proper value" + "(2,6--2,10): Incomplete pattern matches on this expression. For example, the value '( some-non-null-value )' may indicate a case not covered by the pattern(s)." + ] + + +[] +let ``Union case 01 - Missing field`` () = + let _, checkResults = getParseAndCheckResults """ +type U = + | A + | B of int * int * int + +match A with +| B (x, _) -> let y = x + 1 in () +""" + assertHasSymbolUsages ["x"; "y"] checkResults + dumpErrors checkResults |> shouldEqual [ + "(7,2--7,10): This constructor is applied to 2 argument(s) but expects 3" + "(6,6--6,7): Incomplete pattern matches on this expression. For example, the value 'A' may indicate a case not covered by the pattern(s)." + ] + + +[] +let ``Union case 02 - Extra args`` () = + let _, checkResults = getParseAndCheckResults """ +type U = + | A + | B of int + +match A with +| B (_, _, x) -> let y = x + 1 in () +""" + assertHasSymbolUsages ["x"; "y"] checkResults + dumpErrors checkResults |> shouldEqual [ + "(7,5--7,12): This expression was expected to have type 'int' but here has type ''a * 'b * 'c'" + "(6,6--6,7): Incomplete pattern matches on this expression." + ] + + +[] +let ``Union case 03 - Extra args`` () = + let _, checkResults = getParseAndCheckResults """ +type U = + | A + | B of int * int + +match A with +| B (_, _, x) -> let y = x + 1 in () +""" + assertHasSymbolUsages ["x"; "y"] checkResults + dumpErrors checkResults |> shouldEqual [ + "(7,11--7,12): This constructor is applied to 3 argument(s) but expects 2" + "(6,6--6,7): Incomplete pattern matches on this expression. For example, the value 'A' may indicate a case not covered by the pattern(s)." + ] + +[] +let ``Union case 04 - Extra args`` () = + let _, checkResults = getParseAndCheckResults """ +type U = + | A + | B of int + +match A with +| A x -> let y = x + 1 in () +""" + assertHasSymbolUsages ["x"; "y"] checkResults + dumpErrors checkResults |> shouldEqual [ + "(7,2--7,5): This union case does not take arguments" + "(6,6--6,7): Incomplete pattern matches on this expression. For example, the value 'B (_)' may indicate a case not covered by the pattern(s)." + ] + +[] +let ``Union case 05 - Single arg, no errors`` () = + let _, checkResults = getParseAndCheckResults """ +type U = + | A + | B of int + +match A with +| B x -> let y = x + 1 in () +""" + assertHasSymbolUsages ["x"; "y"] checkResults + dumpErrors checkResults |> shouldEqual [ + "(6,6--6,7): Incomplete pattern matches on this expression. For example, the value 'A' may indicate a case not covered by the pattern(s)." + ] + + +[] +let ``Union case 06 - Named args - Wrong field name`` () = + let _, checkResults = getParseAndCheckResults """ +type U = + | A + | B of field: int + +match A with +| B (name = x) -> let y = x + 1 in () +""" + assertHasSymbolUsages ["x"; "y"] checkResults + dumpErrors checkResults |> shouldEqual [ + "(7,5--7,9): The union case 'B' does not have a field named 'name'." + "(6,6--6,7): Incomplete pattern matches on this expression. For example, the value 'A' may indicate a case not covered by the pattern(s)." + ] + + +[] +let ``Union case 07 - Named args - Name used twice`` () = + let _, checkResults = getParseAndCheckResults """ +type U = + | A + | B of field: int * int + +match A with +| B (field = x; field = z) -> let y = x + z + 1 in () +""" + assertHasSymbolUsages ["x"; "y"; "z"] checkResults + dumpErrors checkResults |> shouldEqual [ + "(7,16--7,21): Union case/exception field 'field' cannot be used more than once." + "(6,6--6,7): Incomplete pattern matches on this expression. For example, the value 'A' may indicate a case not covered by the pattern(s)." + ] + + +[] +let ``Union case 08 - Multiple tupled args`` () = + let _, checkResults = getParseAndCheckResults """ +type U = + | A + | B of field: int * int + +match A with +| B x z -> let y = x + z + 1 in () +""" + assertHasSymbolUsages ["x"; "y"; "z"] checkResults + dumpErrors checkResults |> shouldEqual [ + "(7,2--7,7): This union case expects 2 arguments in tupled form" + "(6,6--6,7): Incomplete pattern matches on this expression. For example, the value 'A' may indicate a case not covered by the pattern(s)." + ] + + +[] +let ``Union case 09 - Single arg`` () = + let _, checkResults = getParseAndCheckResults """ +match None with +| None -> () +| Some (x, z) -> let y = x + z + 1 in () +""" + assertHasSymbolUsages ["x"; "y"; "z"] checkResults + dumpErrors checkResults |> shouldEqual [ + ] + + +[] +let ``Active pattern 01 - Named args`` () = + let _, checkResults = getParseAndCheckResults """ +let (|Foo|) x = x + +match 1 with +| Foo (field = x) -> let y = x + 1 in () +""" + assertHasSymbolUsages ["x"; "y"] checkResults + dumpErrors checkResults |> shouldEqual [ + "(5,2--5,17): Foo is an active pattern and cannot be treated as a discriminated union case with named fields." + ] + + +[] +let ``Literal 01 - Args - F#`` () = + let _, checkResults = getParseAndCheckResults """ +let [] Foo = 1 + +match 1 with +| Foo x -> let y = x + 1 in () +""" + assertHasSymbolUsages ["x"; "y"] checkResults + dumpErrors checkResults |> shouldEqual [ + "(5,2--5,7): This literal pattern does not take arguments" + "(4,6--4,7): Incomplete pattern matches on this expression. For example, the value '0' may indicate a case not covered by the pattern(s)." + ] + + +[] +let ``Literal 02 - Args - IL`` () = + let _, checkResults = getParseAndCheckResults """ +open System.Diagnostics + +match TraceLevel.Off with +| TraceLevel.Off x -> let y = x + 1 in () +""" + assertHasSymbolUsages ["x"; "y"] checkResults + dumpErrors checkResults |> shouldEqual [ + "(5,2--5,18): This literal pattern does not take arguments" + "(4,6--4,20): Incomplete pattern matches on this expression. For example, the value 'TraceLevel.Error' may indicate a case not covered by the pattern(s)." + ] + + +[] +let ``Or 01 - No errors`` () = + let _, checkResults = getParseAndCheckResults """ +match 1 with +| x | x -> let y = x + 1 in () +""" + assertHasSymbolUsages ["x"; "y"] checkResults + dumpErrors checkResults |> shouldEqual [] + + +[] +let ``Or 02 - Different names`` () = + let _, checkResults = getParseAndCheckResults """ +match 1 with +| x | z -> let y = x + z + 1 in () +""" + assertHasSymbolUsages ["x"; "y"; "z"] checkResults + dumpErrors checkResults |> shouldEqual [ + "(3,2--3,7): The two sides of this 'or' pattern bind different sets of variables" + ] + + +[] +let ``Or 03 - Different names and types`` () = + let _, checkResults = getParseAndCheckResults """ +type U = + | A + | B of int * string + +match A with +| B (x, y) | B (a, x) -> let z = x + 1 in () +""" + assertHasSymbolUsages ["x"; "y"; "z"] checkResults + dumpErrors checkResults |> shouldEqual [ + "(7,2--7,21): The two sides of this 'or' pattern bind different sets of variables" + "(7,19--7,20): This expression was expected to have type 'int' but here has type 'string'" + "(6,6--6,7): Incomplete pattern matches on this expression. For example, the value 'A' may indicate a case not covered by the pattern(s)." + ] diff --git a/tests/service/ProjectAnalysisTests.fs b/tests/service/ProjectAnalysisTests.fs index bce8dd133c2..b80ed70bfc0 100644 --- a/tests/service/ProjectAnalysisTests.fs +++ b/tests/service/ProjectAnalysisTests.fs @@ -1529,9 +1529,9 @@ let ``Test project 5 all symbols`` () = ("val |Float|_|", "ActivePatterns.( |Float|_| )", "file1", ((13, 5), (13, 14)), ["defn"]); ("val str", "str", "file1", ((19, 17), (19, 20)), ["defn"]); ("val str", "str", "file1", ((20, 9), (20, 12)), []); - ("val f", "f", "file1", ((21, 11), (21, 12)), ["defn"]); ("symbol Float", "ActivePatterns.( |Float|_| ).Float", "file1", ((21, 5), (21, 10)), ["pattern"]); + ("val f", "f", "file1", ((21, 11), (21, 12)), ["defn"]); ("val printfn", "Microsoft.FSharp.Core.ExtraTopLevelOperators.printfn", "file1", ((21, 16), (21, 23)), []); ("val f", "f", "file1", ((21, 46), (21, 47)), []); @@ -1815,11 +1815,11 @@ let ``Test project 8 all symbols`` () = ("parameter yyy", "yyy", "file1", ((5, 17), (5, 20)), [], []); ("val b", "b", "file1", ((5, 4), (5, 5)), ["defn"], ["val"]); ("val b", "b", "file1", ((8, 10), (8, 11)), [], ["val"]); + ("B", "B", "file1", ((10, 6), (10, 7)), ["pattern"], []); ("parameter xxx", "xxx", "file1", ((10, 9), (10, 12)), ["pattern"], []); ("parameter yyy", "yyy", "file1", ((10, 18), (10, 21)), ["pattern"], []); ("val b", "b", "file1", ((10, 24), (10, 25)), ["defn"], []); ("val a", "a", "file1", ((10, 15), (10, 16)), ["defn"], []); - ("B", "B", "file1", ((10, 6), (10, 7)), ["pattern"], []); ("val x", "x", "file1", ((7, 4), (7, 5)), ["defn"], ["val"]); ("NamedUnionFields", "NamedUnionFields", "file1", ((2, 7), (2, 23)), ["defn"], ["module"])|]