diff --git a/src/Compiler/Symbols/Exprs.fs b/src/Compiler/Symbols/Exprs.fs index eabc11f3410..6734694d26d 100644 --- a/src/Compiler/Symbols/Exprs.fs +++ b/src/Compiler/Symbols/Exprs.fs @@ -1266,7 +1266,7 @@ module FSharpExprConvert = 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) + | None -> E.DecisionTreeSuccess(0, []) (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 ba862a29ce1..2eb2e1d954a 100644 --- a/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.Tests.fsproj +++ b/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.Tests.fsproj @@ -97,6 +97,7 @@ RangeTests.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)