From 01a2589e7e65ae7394d856cdf650f159796a6845 Mon Sep 17 00:00:00 2001 From: dawe Date: Thu, 12 Oct 2023 18:27:56 +0200 Subject: [PATCH 1/5] Show the exception issue from the FSharpExprPatterns --- src/Compiler/Symbols/Exprs.fs | 9 +- .../FSharp.Compiler.Service.Tests.fsproj | 1 + .../FSharpExprPatternsTests.fs | 173 ++++++++++++++++++ 3 files changed, 180 insertions(+), 3 deletions(-) create mode 100644 tests/FSharp.Compiler.Service.Tests/FSharpExprPatternsTests.fs diff --git a/src/Compiler/Symbols/Exprs.fs b/src/Compiler/Symbols/Exprs.fs index eabc11f3410..9dd95b759e4 100644 --- a/src/Compiler/Symbols/Exprs.fs +++ b/src/Compiler/Symbols/Exprs.fs @@ -1264,9 +1264,12 @@ module FSharpExprConvert = match x with | TDSwitch(inpExpr, csl, dfltOpt, m) -> let acc = - match dfltOpt with - | Some d -> ConvDecisionTreePrim cenv env dtreeRetTy d - | None -> wfail( "FSharp.Compiler.Service cannot yet return this kind of pattern match", m) + match dfltOpt, dtreeRetTy with + | Some d, _ -> ConvDecisionTreePrim cenv env dtreeRetTy d + // | None, TType.TType_app(tyconRef = _tyconRef; typeInstantiation = _typeInstantiation; flags = _flags) + // when _tyconRef.CompiledName = "int" || _tyconRef.CompiledName = "bool" -> + // E.DecisionTreeSuccess(0, []) + | None, _ -> wfail( "FSharp.Compiler.Service cannot yet return this kind of pattern match", m) (csl, acc) ||> List.foldBack (ConvDecisionTreeCase (cenv: SymbolEnv) env m inpExpr dtreeRetTy) diff --git a/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.Tests.fsproj b/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.Tests.fsproj index 1511ec6ddfc..16a1006e6d7 100644 --- a/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.Tests.fsproj +++ b/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.Tests.fsproj @@ -94,6 +94,7 @@ RangeTests.fs + Program.fs diff --git a/tests/FSharp.Compiler.Service.Tests/FSharpExprPatternsTests.fs b/tests/FSharp.Compiler.Service.Tests/FSharpExprPatternsTests.fs new file mode 100644 index 00000000000..5d31b6f74fc --- /dev/null +++ b/tests/FSharp.Compiler.Service.Tests/FSharpExprPatternsTests.fs @@ -0,0 +1,173 @@ +module FSharp.Compiler.Service.Tests.FSharpExprPatternsTests + +#nowarn "57" + +open FSharp.Compiler.CodeAnalysis +open FSharp.Compiler.Service.Tests.Common +open FSharp.Compiler.Text +open FSharp.Compiler.Symbols +open NUnit.Framework + +module TASTCollecting = + + open FSharp.Compiler.Symbols.FSharpExprPatterns + + type Handler = NewUnionCaseHandler of (string -> unit) + + let rec visitExpr (handler: Handler) (e: FSharpExpr) = + match e with + | AddressOf lvalueExpr -> visitExpr handler lvalueExpr + | AddressSet (lvalueExpr, rvalueExpr) -> + visitExpr handler lvalueExpr + visitExpr handler rvalueExpr + | Application (funcExpr, _typeArgs, argExprs) -> + visitExpr handler funcExpr + visitExprs handler argExprs + | Call (objExprOpt, memberOrFunc, _typeArgs1, _typeArgs2, argExprs) -> + visitObjArg handler objExprOpt + visitExprs handler argExprs + | Coerce (_targetType, inpExpr) -> visitExpr handler inpExpr + | FastIntegerForLoop (startExpr, limitExpr, consumeExpr, _isUp, _debugPointAtFor, _debugPointAtInOrTo) -> + visitExpr handler startExpr + visitExpr handler limitExpr + visitExpr handler consumeExpr + | ILAsm (_asmCode, _typeArgs, argExprs) -> visitExprs handler argExprs + | ILFieldGet (objExprOpt, _fieldType, _fieldName) -> visitObjArg handler objExprOpt + | ILFieldSet (objExprOpt, _fieldType, _fieldName, _valueExpr) -> visitObjArg handler objExprOpt + | IfThenElse (guardExpr, thenExpr, elseExpr) -> + visitExpr handler guardExpr + visitExpr handler thenExpr + visitExpr handler elseExpr + | Lambda (_lambdaVar, bodyExpr) -> visitExpr handler bodyExpr + | Let ((_bindingVar, bindingExpr, _debugPointAtBinding), bodyExpr) -> + visitExpr handler bindingExpr + visitExpr handler bodyExpr + | LetRec (recursiveBindings, bodyExpr) -> + let recursiveBindings' = + recursiveBindings |> List.map (fun (mfv, expr, _dp) -> (mfv, expr)) + + List.iter (snd >> visitExpr handler) recursiveBindings' + visitExpr handler bodyExpr + | NewArray (_arrayType, argExprs) -> visitExprs handler argExprs + | NewDelegate (_delegateType, delegateBodyExpr) -> visitExpr handler delegateBodyExpr + | NewObject (_objType, _typeArgs, argExprs) -> visitExprs handler argExprs + | NewRecord (_recordType, argExprs) -> visitExprs handler argExprs + | NewTuple (_tupleType, argExprs) -> visitExprs handler argExprs + | NewUnionCase (_unionType, unionCase, argExprs) -> + match handler with + | NewUnionCaseHandler h -> h unionCase.Name + + visitExprs handler argExprs + | Quote quotedExpr -> visitExpr handler quotedExpr + | FSharpFieldGet (objExprOpt, _recordOrClassType, _fieldInfo) -> visitObjArg handler objExprOpt + | FSharpFieldSet (objExprOpt, _recordOrClassType, _fieldInfo, argExpr) -> + visitObjArg handler objExprOpt + visitExpr handler argExpr + | Sequential (firstExpr, secondExpr) -> + visitExpr handler firstExpr + visitExpr handler secondExpr + | TryFinally (bodyExpr, finalizeExpr, _debugPointAtTry, _debugPointAtFinally) -> + visitExpr handler bodyExpr + visitExpr handler finalizeExpr + | TryWith (bodyExpr, _, _, _catchVar, catchExpr, _debugPointAtTry, _debugPointAtWith) -> + visitExpr handler bodyExpr + visitExpr handler catchExpr + | TupleGet (_tupleType, _tupleElemIndex, tupleExpr) -> visitExpr handler tupleExpr + | DecisionTree (decisionExpr, decisionTargets) -> + visitExpr handler decisionExpr + List.iter (snd >> visitExpr handler) decisionTargets + | DecisionTreeSuccess (_decisionTargetIdx, decisionTargetExprs) -> visitExprs handler decisionTargetExprs + | TypeLambda (_genericParam, bodyExpr) -> visitExpr handler bodyExpr + | TypeTest (_ty, inpExpr) -> visitExpr handler inpExpr + | UnionCaseSet (unionExpr, _unionType, _unionCase, _unionCaseField, valueExpr) -> + visitExpr handler unionExpr + visitExpr handler valueExpr + | UnionCaseGet (unionExpr, _unionType, _unionCase, _unionCaseField) -> visitExpr handler unionExpr + | UnionCaseTest (unionExpr, _unionType, _unionCase) -> visitExpr handler unionExpr + | UnionCaseTag (unionExpr, _unionType) -> visitExpr handler unionExpr + | ObjectExpr (_objType, baseCallExpr, overrides, interfaceImplementations) -> + visitExpr handler baseCallExpr + List.iter (visitObjMember handler) overrides + List.iter (snd >> List.iter (visitObjMember handler)) interfaceImplementations + | TraitCall (_sourceTypes, _traitName, _typeArgs, _typeInstantiation, _argTypes, argExprs) -> visitExprs handler argExprs + | ValueSet (_valToSet, valueExpr) -> visitExpr handler valueExpr + | WhileLoop (guardExpr, bodyExpr, _debugPointAtWhile) -> + visitExpr handler guardExpr + visitExpr handler bodyExpr + | BaseValue _baseType -> () + | DefaultValue _defaultType -> () + | ThisValue _thisType -> () + | Const (_constValueObj, _constType) -> () + | Value _valueToGet -> () + | CallWithWitnesses (expr, _mfv, _typeLst, _typeLst2, exprs1, exprs2) -> + expr |> Option.iter (visitExpr handler) + exprs1 |> List.iter (visitExpr handler) + exprs2 |> List.iter (visitExpr handler) + | NewAnonRecord (_, exprLst) -> exprLst |> List.iter (visitExpr handler) + | AnonRecordGet (expr, _, _) -> visitExpr handler expr + | DebugPoint (_d, expr) -> visitExpr handler expr + | WitnessArg _ -> () + | _ -> () + + and visitExprs f exprs = List.iter (visitExpr f) exprs + + and visitObjArg f objOpt = Option.iter (visitExpr f) objOpt + + and visitObjMember f memb = visitExpr f memb.Body + + let rec visitDeclaration f d = + match d with + | FSharpImplementationFileDeclaration.Entity (_e, subDecls) -> + for subDecl in subDecls do + visitDeclaration f subDecl + | FSharpImplementationFileDeclaration.MemberOrFunctionOrValue (_v, _vs, e) -> visitExpr f e + | FSharpImplementationFileDeclaration.InitAction e -> visitExpr f e + +let testPatterns handler source = + let files = Map.ofArray [| "A.fs", SourceText.ofString source |] + + let documentSource fileName = + Map.tryFind fileName files |> async.Return + + let projectOptions = + let _, projectOptions = mkTestFileAndOptions "" Array.empty + + { projectOptions with + SourceFiles = [| "A.fs" |] + } + + let checker = + FSharpChecker.Create(documentSource = DocumentSource.Custom documentSource, keepAssemblyContents = true) + + let checkResult = + checker.ParseAndCheckFileInProject("A.fs", 0, Map.find "A.fs" files, projectOptions) + |> Async.RunImmediate + + match checkResult with + | _, FSharpCheckFileAnswer.Succeeded (checkResults) -> + + match checkResults.ImplementationFile with + | Some implFile -> + for decl in implFile.Declarations do + TASTCollecting.visitDeclaration handler decl + | _ -> () + | _, _ -> () + +[] +let ``union case with type`` () = + let implSource = + """ +module M + +type T = Case1 of string + +let x = Case1 "bla" +""" + + let lst = ResizeArray() + + let handler: TASTCollecting.Handler = + TASTCollecting.Handler.NewUnionCaseHandler lst.Add + + Assert.DoesNotThrow(fun _ -> testPatterns handler implSource) + Assert.Contains("Case1", lst) From 40d003723e4bb2793abd6b6fa996bb8e550aa0fc Mon Sep 17 00:00:00 2001 From: dawe Date: Mon, 23 Oct 2023 17:26:24 +0200 Subject: [PATCH 2/5] enable the fix --- src/Compiler/Symbols/Exprs.fs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Compiler/Symbols/Exprs.fs b/src/Compiler/Symbols/Exprs.fs index 9dd95b759e4..7d7fbffaf6e 100644 --- a/src/Compiler/Symbols/Exprs.fs +++ b/src/Compiler/Symbols/Exprs.fs @@ -1266,9 +1266,9 @@ module FSharpExprConvert = let acc = match dfltOpt, dtreeRetTy with | Some d, _ -> ConvDecisionTreePrim cenv env dtreeRetTy d - // | None, TType.TType_app(tyconRef = _tyconRef; typeInstantiation = _typeInstantiation; flags = _flags) - // when _tyconRef.CompiledName = "int" || _tyconRef.CompiledName = "bool" -> - // E.DecisionTreeSuccess(0, []) + | None, TType.TType_app(tyconRef = _tyconRef; typeInstantiation = _typeInstantiation; flags = _flags) + when _tyconRef.CompiledName = "int" || _tyconRef.CompiledName = "bool" -> + E.DecisionTreeSuccess(0, []) | None, _ -> wfail( "FSharp.Compiler.Service cannot yet return this kind of pattern match", m) (csl, acc) ||> List.foldBack (ConvDecisionTreeCase (cenv: SymbolEnv) env m inpExpr dtreeRetTy) From 871e6487d86ea30fccde23a1e534140556926fae Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 24 Oct 2023 15:22:50 +0200 Subject: [PATCH 3/5] remove underscore prefix in used value --- src/Compiler/Symbols/Exprs.fs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Compiler/Symbols/Exprs.fs b/src/Compiler/Symbols/Exprs.fs index 7d7fbffaf6e..63bc0af15d8 100644 --- a/src/Compiler/Symbols/Exprs.fs +++ b/src/Compiler/Symbols/Exprs.fs @@ -1266,8 +1266,8 @@ module FSharpExprConvert = let acc = match dfltOpt, dtreeRetTy with | Some d, _ -> ConvDecisionTreePrim cenv env dtreeRetTy d - | None, TType.TType_app(tyconRef = _tyconRef; typeInstantiation = _typeInstantiation; flags = _flags) - when _tyconRef.CompiledName = "int" || _tyconRef.CompiledName = "bool" -> + | None, TType.TType_app(tyconRef = tyconRef; typeInstantiation = _typeInstantiation; flags = _flags) + when tyconRef.CompiledName = "int" || tyconRef.CompiledName = "bool" -> E.DecisionTreeSuccess(0, []) | None, _ -> wfail( "FSharp.Compiler.Service cannot yet return this kind of pattern match", m) From 981667bc8f4a4a58aee4b7c52e7a8c0ee654ddf5 Mon Sep 17 00:00:00 2001 From: dawe Date: Tue, 24 Oct 2023 16:11:35 +0200 Subject: [PATCH 4/5] stripTyEqns the ttype --- src/Compiler/Symbols/Exprs.fs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Compiler/Symbols/Exprs.fs b/src/Compiler/Symbols/Exprs.fs index 63bc0af15d8..9691a4d9a6a 100644 --- a/src/Compiler/Symbols/Exprs.fs +++ b/src/Compiler/Symbols/Exprs.fs @@ -1264,10 +1264,9 @@ module FSharpExprConvert = match x with | TDSwitch(inpExpr, csl, dfltOpt, m) -> let acc = - match dfltOpt, dtreeRetTy with + match dfltOpt, stripTyEqns cenv.g dtreeRetTy with | Some d, _ -> ConvDecisionTreePrim cenv env dtreeRetTy d - | None, TType.TType_app(tyconRef = tyconRef; typeInstantiation = _typeInstantiation; flags = _flags) - when tyconRef.CompiledName = "int" || tyconRef.CompiledName = "bool" -> + | None, TType.TType_app(tyconRef = tyconRef) when tyconRef.CompiledName = "Int32" || tyconRef.CompiledName = "Boolean" -> E.DecisionTreeSuccess(0, []) | None, _ -> wfail( "FSharp.Compiler.Service cannot yet return this kind of pattern match", m) From 1b6bb7c192c70c024da02315b3fd6059f00a11aa Mon Sep 17 00:00:00 2001 From: dawe Date: Fri, 27 Oct 2023 23:46:12 +0200 Subject: [PATCH 5/5] Don't limit removal of exception to two types. --- src/Compiler/Symbols/Exprs.fs | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/src/Compiler/Symbols/Exprs.fs b/src/Compiler/Symbols/Exprs.fs index 9691a4d9a6a..6734694d26d 100644 --- a/src/Compiler/Symbols/Exprs.fs +++ b/src/Compiler/Symbols/Exprs.fs @@ -1264,11 +1264,9 @@ module FSharpExprConvert = match x with | TDSwitch(inpExpr, csl, dfltOpt, m) -> let acc = - match dfltOpt, stripTyEqns cenv.g dtreeRetTy with - | Some d, _ -> ConvDecisionTreePrim cenv env dtreeRetTy d - | None, TType.TType_app(tyconRef = tyconRef) when tyconRef.CompiledName = "Int32" || tyconRef.CompiledName = "Boolean" -> - E.DecisionTreeSuccess(0, []) - | None, _ -> wfail( "FSharp.Compiler.Service cannot yet return this kind of pattern match", m) + match dfltOpt with + | Some d -> ConvDecisionTreePrim cenv env dtreeRetTy d + | None -> E.DecisionTreeSuccess(0, []) (csl, acc) ||> List.foldBack (ConvDecisionTreeCase (cenv: SymbolEnv) env m inpExpr dtreeRetTy)