diff --git a/.fantomasignore b/.fantomasignore index 4830d0af77d..d142916bd16 100644 --- a/.fantomasignore +++ b/.fantomasignore @@ -20,7 +20,6 @@ src/Compiler/Checking/AccessibilityLogic.fs src/Compiler/Checking/AttributeChecking.fs src/Compiler/Checking/AugmentWithHashCompare.fs src/Compiler/Checking/CheckBasics.fs -src/Compiler/Checking/CheckComputationExpressions.fs src/Compiler/Checking/CheckDeclarations.fs src/Compiler/Checking/CheckExpressions.fs src/Compiler/Checking/CheckFormatStrings.fs diff --git a/.git-blame-ignore-revs b/.git-blame-ignore-revs new file mode 100644 index 00000000000..d8110ac0ace --- /dev/null +++ b/.git-blame-ignore-revs @@ -0,0 +1,2 @@ +# Format src/Compiler/Checking/CheckComputationExpressions.fs, https://github.com/dotnet/fsharp/pull/16512 +603a310cdfd9902ec1d29b399377dcc9ac56235b diff --git a/src/Compiler/Checking/CheckComputationExpressions.fs b/src/Compiler/Checking/CheckComputationExpressions.fs index f1900f7a166..7a64721f901 100644 --- a/src/Compiler/Checking/CheckComputationExpressions.fs +++ b/src/Compiler/Checking/CheckComputationExpressions.fs @@ -1,6 +1,6 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. -/// The typechecker. Left-to-right constrained type checking +/// The typechecker. Left-to-right constrained type checking /// with generalization at appropriate points. module internal FSharp.Compiler.CheckComputationExpressions @@ -28,65 +28,89 @@ open FSharp.Compiler.TypedTreeOps type cenv = TcFileState /// Used to flag if this is the first or a sebsequent translation pass through a computation expression -type CompExprTranslationPass = Initial | Subsequent +type CompExprTranslationPass = + | Initial + | Subsequent /// Used to flag if computation expression custom operations are allowed in a given context -type CustomOperationsMode = Allowed | Denied +type CustomOperationsMode = + | Allowed + | Denied -let TryFindIntrinsicOrExtensionMethInfo collectionSettings (cenv: cenv) (env: TcEnv) m ad nm ty = +let TryFindIntrinsicOrExtensionMethInfo collectionSettings (cenv: cenv) (env: TcEnv) m ad nm ty = AllMethInfosOfTypeInScope collectionSettings cenv.infoReader env.NameEnv (Some nm) ad IgnoreOverrides m ty /// Ignores an attribute let IgnoreAttribute _ = None -let (|ExprAsPat|_|) (f: SynExpr) = - match f with - | SingleIdent v1 | SynExprParen(SingleIdent v1, _, _, _) -> Some (mkSynPatVar None v1) - | SynExprParen(SynExpr.Tuple (false, elems, commas, _), _, _, _) -> - let elems = elems |> List.map (|SingleIdent|_|) - if elems |> List.forall (fun x -> x.IsSome) then - Some (SynPat.Tuple(false, (elems |> List.map (fun x -> mkSynPatVar None x.Value)), commas, f.Range)) +let (|ExprAsPat|_|) (f: SynExpr) = + match f with + | SingleIdent v1 + | SynExprParen(SingleIdent v1, _, _, _) -> Some(mkSynPatVar None v1) + | SynExprParen(SynExpr.Tuple(false, elems, commas, _), _, _, _) -> + let elems = elems |> List.map (|SingleIdent|_|) + + if elems |> List.forall (fun x -> x.IsSome) then + Some(SynPat.Tuple(false, (elems |> List.map (fun x -> mkSynPatVar None x.Value)), commas, f.Range)) else None | _ -> None -// For join clauses that join on nullable, we syntactically insert the creation of nullable values on the appropriate side of the condition, +// For join clauses that join on nullable, we syntactically insert the creation of nullable values on the appropriate side of the condition, // then pull the syntax apart again -let (|JoinRelation|_|) cenv env (expr: SynExpr) = +let (|JoinRelation|_|) cenv env (expr: SynExpr) = let m = expr.Range let ad = env.eAccessRights let isOpName opName vref s = - (s = opName) && - match ResolveExprLongIdent cenv.tcSink cenv.nameResolver m ad env.eNameResEnv TypeNameResolutionInfo.Default [ident(opName, m)] None with - | Result (_, Item.Value vref2, []) -> valRefEq cenv.g vref vref2 - | _ -> false + (s = opName) + && match + ResolveExprLongIdent + cenv.tcSink + cenv.nameResolver + m + ad + env.eNameResEnv + TypeNameResolutionInfo.Default + [ ident (opName, m) ] + None + with + | Result(_, Item.Value vref2, []) -> valRefEq cenv.g vref vref2 + | _ -> false + + match expr with + | BinOpExpr(opId, a, b) when isOpName opNameEquals cenv.g.equals_operator_vref opId.idText -> Some(a, b) + + | BinOpExpr(opId, a, b) when isOpName opNameEqualsNullable cenv.g.equals_nullable_operator_vref opId.idText -> - match expr with - | BinOpExpr(opId, a, b) when isOpName opNameEquals cenv.g.equals_operator_vref opId.idText -> Some (a, b) + let a = + SynExpr.App(ExprAtomicFlag.Atomic, false, mkSynLidGet a.Range [ MangledGlobalName; "System" ] "Nullable", a, a.Range) - | BinOpExpr(opId, a, b) when isOpName opNameEqualsNullable cenv.g.equals_nullable_operator_vref opId.idText -> + Some(a, b) - let a = SynExpr.App (ExprAtomicFlag.Atomic, false, mkSynLidGet a.Range [MangledGlobalName;"System"] "Nullable", a, a.Range) - Some (a, b) + | BinOpExpr(opId, a, b) when isOpName opNameNullableEquals cenv.g.nullable_equals_operator_vref opId.idText -> - | BinOpExpr(opId, a, b) when isOpName opNameNullableEquals cenv.g.nullable_equals_operator_vref opId.idText -> + let b = + SynExpr.App(ExprAtomicFlag.Atomic, false, mkSynLidGet b.Range [ MangledGlobalName; "System" ] "Nullable", b, b.Range) - let b = SynExpr.App (ExprAtomicFlag.Atomic, false, mkSynLidGet b.Range [MangledGlobalName;"System"] "Nullable", b, b.Range) - Some (a, b) + Some(a, b) - | BinOpExpr(opId, a, b) when isOpName opNameNullableEqualsNullable cenv.g.nullable_equals_nullable_operator_vref opId.idText -> + | BinOpExpr(opId, a, b) when isOpName opNameNullableEqualsNullable cenv.g.nullable_equals_nullable_operator_vref opId.idText -> - Some (a, b) + Some(a, b) | _ -> None let elimFastIntegerForLoop (spFor, spTo, id, start: SynExpr, dir, finish: SynExpr, innerExpr, m: range) = let mOp = (unionRanges start.Range finish.Range).MakeSynthetic() - let pseudoEnumExpr = - if dir then mkSynInfix mOp start ".." finish - else mkSynTrifix mOp ".. .." start (SynExpr.Const (SynConst.Int32 -1, mOp)) finish - SynExpr.ForEach (spFor, spTo, SeqExprOnly false, true, mkSynPatVar None id, pseudoEnumExpr, innerExpr, m) + + let pseudoEnumExpr = + if dir then + mkSynInfix mOp start ".." finish + else + mkSynTrifix mOp ".. .." start (SynExpr.Const(SynConst.Int32 -1, mOp)) finish + + SynExpr.ForEach(spFor, spTo, SeqExprOnly false, true, mkSynPatVar None id, pseudoEnumExpr, innerExpr, m) /// Check if a computation or sequence expression is syntactically free of 'yield' (though not yield!) let YieldFree (cenv: cenv) expr = @@ -95,30 +119,27 @@ let YieldFree (cenv: cenv) expr = // Implement yield free logic for F# Language including the LanguageFeature.ImplicitYield let rec YieldFree expr = match expr with - | SynExpr.Sequential (expr1=expr1; expr2=expr2) -> - YieldFree expr1 && YieldFree expr2 + | SynExpr.Sequential(expr1 = expr1; expr2 = expr2) -> YieldFree expr1 && YieldFree expr2 - | SynExpr.IfThenElse (thenExpr=thenExpr; elseExpr=elseExprOpt) -> - YieldFree thenExpr && Option.forall YieldFree elseExprOpt + | SynExpr.IfThenElse(thenExpr = thenExpr; elseExpr = elseExprOpt) -> YieldFree thenExpr && Option.forall YieldFree elseExprOpt - | SynExpr.TryWith (tryExpr=body; withCases=clauses) -> - YieldFree body && clauses |> List.forall (fun (SynMatchClause(resultExpr = res)) -> YieldFree res) + | SynExpr.TryWith(tryExpr = body; withCases = clauses) -> + YieldFree body + && clauses |> List.forall (fun (SynMatchClause(resultExpr = res)) -> YieldFree res) - | SynExpr.Match (clauses=clauses) | SynExpr.MatchBang (clauses=clauses) -> - clauses |> List.forall (fun (SynMatchClause(resultExpr = res)) -> YieldFree res) + | SynExpr.Match(clauses = clauses) + | SynExpr.MatchBang(clauses = clauses) -> clauses |> List.forall (fun (SynMatchClause(resultExpr = res)) -> YieldFree res) - | SynExpr.For (doBody=body) - | SynExpr.TryFinally (tryExpr=body) - | SynExpr.LetOrUse (body=body) - | SynExpr.While (doExpr=body) - | SynExpr.WhileBang (doExpr=body) - | SynExpr.ForEach (bodyExpr=body) -> - YieldFree body + | SynExpr.For(doBody = body) + | SynExpr.TryFinally(tryExpr = body) + | SynExpr.LetOrUse(body = body) + | SynExpr.While(doExpr = body) + | SynExpr.WhileBang(doExpr = body) + | SynExpr.ForEach(bodyExpr = body) -> YieldFree body - | SynExpr.LetOrUseBang(body=body) -> - YieldFree body + | SynExpr.LetOrUseBang(body = body) -> YieldFree body - | SynExpr.YieldOrReturn(flags=(true, _)) -> false + | SynExpr.YieldOrReturn(flags = (true, _)) -> false | _ -> true @@ -127,25 +148,23 @@ let YieldFree (cenv: cenv) expr = // Implement yield free logic for F# Language without the LanguageFeature.ImplicitYield let rec YieldFree expr = match expr with - | SynExpr.Sequential (expr1=expr1; expr2=expr2) -> - YieldFree expr1 && YieldFree expr2 + | SynExpr.Sequential(expr1 = expr1; expr2 = expr2) -> YieldFree expr1 && YieldFree expr2 - | SynExpr.IfThenElse (thenExpr=thenExpr; elseExpr=elseExprOpt) -> - YieldFree thenExpr && Option.forall YieldFree elseExprOpt + | SynExpr.IfThenElse(thenExpr = thenExpr; elseExpr = elseExprOpt) -> YieldFree thenExpr && Option.forall YieldFree elseExprOpt - | SynExpr.TryWith (tryExpr=e1; withCases=clauses) -> - YieldFree e1 && clauses |> List.forall (fun (SynMatchClause(resultExpr = res)) -> YieldFree res) + | SynExpr.TryWith(tryExpr = e1; withCases = clauses) -> + YieldFree e1 + && clauses |> List.forall (fun (SynMatchClause(resultExpr = res)) -> YieldFree res) - | SynExpr.Match (clauses=clauses) | SynExpr.MatchBang (clauses=clauses) -> - clauses |> List.forall (fun (SynMatchClause(resultExpr = res)) -> YieldFree res) + | SynExpr.Match(clauses = clauses) + | SynExpr.MatchBang(clauses = clauses) -> clauses |> List.forall (fun (SynMatchClause(resultExpr = res)) -> YieldFree res) - | SynExpr.For (doBody=body) - | SynExpr.TryFinally (tryExpr=body) - | SynExpr.LetOrUse (body=body) - | SynExpr.While (doExpr=body) - | SynExpr.WhileBang (doExpr=body) - | SynExpr.ForEach (bodyExpr=body) -> - YieldFree body + | SynExpr.For(doBody = body) + | SynExpr.TryFinally(tryExpr = body) + | SynExpr.LetOrUse(body = body) + | SynExpr.While(doExpr = body) + | SynExpr.WhileBang(doExpr = body) + | SynExpr.ForEach(bodyExpr = body) -> YieldFree body | SynExpr.LetOrUseBang _ | SynExpr.YieldOrReturnFrom _ @@ -157,44 +176,43 @@ let YieldFree (cenv: cenv) expr = YieldFree expr - /// Determine if a syntactic expression inside 'seq { ... }' or '[...]' counts as a "simple sequence /// of semicolon separated values". For example [1;2;3]. /// 'acceptDeprecated' is true for the '[ ... ]' case, where we allow the syntax '[ if g then t else e ]' but ask it to be parenthesized /// -let (|SimpleSemicolonSequence|_|) cenv acceptDeprecated cexpr = +let (|SimpleSemicolonSequence|_|) cenv acceptDeprecated cexpr = - let IsSimpleSemicolonSequenceElement expr = + let IsSimpleSemicolonSequenceElement expr = match expr with | SynExpr.IfThenElse _ when acceptDeprecated && YieldFree cenv expr -> true | SynExpr.IfThenElse _ - | SynExpr.TryWith _ - | SynExpr.Match _ - | SynExpr.For _ - | SynExpr.ForEach _ - | SynExpr.TryFinally _ - | SynExpr.YieldOrReturnFrom _ - | SynExpr.YieldOrReturn _ - | SynExpr.LetOrUse _ - | SynExpr.Do _ - | SynExpr.MatchBang _ - | SynExpr.LetOrUseBang _ + | SynExpr.TryWith _ + | SynExpr.Match _ + | SynExpr.For _ + | SynExpr.ForEach _ + | SynExpr.TryFinally _ + | SynExpr.YieldOrReturnFrom _ + | SynExpr.YieldOrReturn _ + | SynExpr.LetOrUse _ + | SynExpr.Do _ + | SynExpr.MatchBang _ + | SynExpr.LetOrUseBang _ | SynExpr.While _ | SynExpr.WhileBang _ -> false | _ -> true - let rec TryGetSimpleSemicolonSequenceOfComprehension expr acc = - match expr with - | SynExpr.Sequential (_, true, e1, e2, _) -> - if IsSimpleSemicolonSequenceElement e1 then + let rec TryGetSimpleSemicolonSequenceOfComprehension expr acc = + match expr with + | SynExpr.Sequential(_, true, e1, e2, _) -> + if IsSimpleSemicolonSequenceElement e1 then TryGetSimpleSemicolonSequenceOfComprehension e2 (e1 :: acc) else - None - | _ -> - if IsSimpleSemicolonSequenceElement expr then + None + | _ -> + if IsSimpleSemicolonSequenceElement expr then Some(List.rev (expr :: acc)) - else - None + else + None TryGetSimpleSemicolonSequenceOfComprehension cexpr [] @@ -202,88 +220,106 @@ let RecordNameAndTypeResolutions cenv env tpenv expr = // This function is motivated by cases like // query { for ... join(for x in f(). } // where there is incomplete code in a query, and we are current just dropping a piece of the AST on the floor (above, the bit inside the 'join'). - // + // // The problem with dropping the AST on the floor is that we get no captured resolutions, which means no Intellisense/QuickInfo/ParamHelp. // // We check this AST-fragment, to get resolutions captured. // // This may have effects from typechecking, producing side-effects on the typecheck environment. - suppressErrorReporting (fun () -> + suppressErrorReporting (fun () -> try - ignore(TcExprOfUnknownType cenv env tpenv expr) + ignore (TcExprOfUnknownType cenv env tpenv expr) with _ -> ()) /// Used for all computation expressions except sequence expressions -let TcComputationExpression (cenv: cenv) env (overallTy: OverallTy) tpenv (mWhole, interpExpr: Expr, builderTy, comp: SynExpr) = +let TcComputationExpression (cenv: cenv) env (overallTy: OverallTy) tpenv (mWhole, interpExpr: Expr, builderTy, comp: SynExpr) = let overallTy = overallTy.Commit - + let g = cenv.g let ad = env.eAccessRights let mkSynDelay2 (e: SynExpr) = mkSynDelay (e.Range.MakeSynthetic()) e - + let builderValName = CompilerGeneratedName "builder" let mBuilderVal = interpExpr.Range - + // Give bespoke error messages for the FSharp.Core "query" builder - let isQuery = - match stripDebugPoints interpExpr with + let isQuery = + match stripDebugPoints interpExpr with // An unparameterized custom builder, e.g., `query`, `async`. - | Expr.Val (vref, _, m) + | Expr.Val(vref, _, m) // A parameterized custom builder, e.g., `builder<…>`, `builder ()`. - | Expr.App (funcExpr = Expr.Val (vref, _, m)) -> - let item = Item.CustomBuilder (vref.DisplayName, vref) + | Expr.App(funcExpr = Expr.Val(vref, _, m)) -> + let item = Item.CustomBuilder(vref.DisplayName, vref) CallNameResolutionSink cenv.tcSink (m, env.NameEnv, item, emptyTyparInst, ItemOccurence.Use, env.eAccessRights) - valRefEq cenv.g vref cenv.g.query_value_vref + valRefEq cenv.g vref cenv.g.query_value_vref | _ -> false /// Make a builder.Method(...) call - let mkSynCall nm (m: range) args = + let mkSynCall nm (m: range) args = let m = m.MakeSynthetic() // Mark as synthetic so the language service won't pick it up. - let args = - match args with - | [] -> SynExpr.Const (SynConst.Unit, m) - | [arg] -> SynExpr.Paren (SynExpr.Paren (arg, range0, None, m), range0, None, m) - | args -> SynExpr.Paren (SynExpr.Tuple (false, args, [], m), range0, None, m) - + + let args = + match args with + | [] -> SynExpr.Const(SynConst.Unit, m) + | [ arg ] -> SynExpr.Paren(SynExpr.Paren(arg, range0, None, m), range0, None, m) + | args -> SynExpr.Paren(SynExpr.Tuple(false, args, [], m), range0, None, m) + let builderVal = mkSynIdGet m builderValName - mkSynApp1 (SynExpr.DotGet (builderVal, range0, SynLongIdent([mkSynId m nm], [], [None]), m)) args m + mkSynApp1 (SynExpr.DotGet(builderVal, range0, SynLongIdent([ mkSynId m nm ], [], [ None ]), m)) args m - let hasMethInfo nm = TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mBuilderVal ad nm builderTy |> isNil |> not + let hasMethInfo nm = + TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mBuilderVal ad nm builderTy + |> isNil + |> not - let sourceMethInfo = TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mBuilderVal ad "Source" builderTy + let sourceMethInfo = + TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mBuilderVal ad "Source" builderTy // Optionally wrap sources of "let!", "yield!", "use!" in "query.Source" - let mkSourceExpr callExpr = - match sourceMethInfo with + let mkSourceExpr callExpr = + match sourceMethInfo with | [] -> callExpr - | _ -> mkSynCall "Source" callExpr.Range [callExpr] + | _ -> mkSynCall "Source" callExpr.Range [ callExpr ] - let mkSourceExprConditional isFromSource callExpr = + let mkSourceExprConditional isFromSource callExpr = if isFromSource then mkSourceExpr callExpr else callExpr /// Decide if the builder is an auto-quote builder let isAutoQuote = hasMethInfo "Quote" let customOperationMethods = - AllMethInfosOfTypeInScope ResultCollectionSettings.AllResults cenv.infoReader env.NameEnv None ad IgnoreOverrides mBuilderVal builderTy + AllMethInfosOfTypeInScope + ResultCollectionSettings.AllResults + cenv.infoReader + env.NameEnv + None + ad + IgnoreOverrides + mBuilderVal + builderTy |> List.choose (fun methInfo -> - if not (IsMethInfoAccessible cenv.amap mBuilderVal ad methInfo) then None else + if not (IsMethInfoAccessible cenv.amap mBuilderVal ad methInfo) then + None + else let nameSearch = - TryBindMethInfoAttribute cenv.g mBuilderVal cenv.g.attrib_CustomOperationAttribute methInfo + TryBindMethInfoAttribute + cenv.g + mBuilderVal + cenv.g.attrib_CustomOperationAttribute + methInfo IgnoreAttribute // We do not respect this attribute for IL methods (fun attr -> // NOTE: right now, we support of custom operations with spaces in them ([]) // In the parameterless CustomOperationAttribute - we use the method name, and also allow it to be ````-quoted (member _.``foo bar`` _ = ...) match attr with // Empty string and parameterless constructor - we use the method name - | Attrib(_, _, [ AttribStringArg "" ], _, _, _, _) // Empty string as parameter - | Attrib(_, _, [ ], _, _, _, _) -> // No parameters, same as empty string for compat reasons. + | Attrib(unnamedArgs = [ AttribStringArg "" ]) // Empty string as parameter + | Attrib(unnamedArgs = []) -> // No parameters, same as empty string for compat reasons. Some methInfo.LogicalName // Use the specified name - | Attrib(_, _, [ AttribStringArg msg ], _, _, _, _) -> - Some msg + | Attrib(unnamedArgs = [ AttribStringArg msg ]) -> Some msg | _ -> None) IgnoreAttribute // We do not respect this attribute for provided methods @@ -291,34 +327,55 @@ let TcComputationExpression (cenv: cenv) env (overallTy: OverallTy) tpenv (mWhol | None -> None | Some nm -> let joinConditionWord = - TryBindMethInfoAttribute cenv.g mBuilderVal cenv.g.attrib_CustomOperationAttribute methInfo + TryBindMethInfoAttribute + cenv.g + mBuilderVal + cenv.g.attrib_CustomOperationAttribute + methInfo IgnoreAttribute // We do not respect this attribute for IL methods - (function Attrib(_, _, _, ExtractAttribNamedArg "JoinConditionWord" (AttribStringArg s), _, _, _) -> Some s | _ -> None) + (function + | Attrib(propVal = ExtractAttribNamedArg "JoinConditionWord" (AttribStringArg s)) -> Some s + | _ -> None) IgnoreAttribute // We do not respect this attribute for provided methods - let flagSearch (propName: string) = - TryBindMethInfoAttribute cenv.g mBuilderVal cenv.g.attrib_CustomOperationAttribute methInfo + let flagSearch (propName: string) = + TryBindMethInfoAttribute + cenv.g + mBuilderVal + cenv.g.attrib_CustomOperationAttribute + methInfo IgnoreAttribute // We do not respect this attribute for IL methods - (function Attrib(_, _, _, ExtractAttribNamedArg propName (AttribBoolArg b), _, _, _) -> Some b | _ -> None) + (function + | Attrib(propVal = ExtractAttribNamedArg propName (AttribBoolArg b)) -> Some b + | _ -> None) IgnoreAttribute // We do not respect this attribute for provided methods - let maintainsVarSpaceUsingBind = defaultArg (flagSearch "MaintainsVariableSpaceUsingBind") false + let maintainsVarSpaceUsingBind = + defaultArg (flagSearch "MaintainsVariableSpaceUsingBind") false + let maintainsVarSpace = defaultArg (flagSearch "MaintainsVariableSpace") false let allowInto = defaultArg (flagSearch "AllowIntoPattern") false let isLikeZip = defaultArg (flagSearch "IsLikeZip") false let isLikeJoin = defaultArg (flagSearch "IsLikeJoin") false let isLikeGroupJoin = defaultArg (flagSearch "IsLikeGroupJoin") false - Some (nm, maintainsVarSpaceUsingBind, maintainsVarSpace, allowInto, isLikeZip, isLikeJoin, isLikeGroupJoin, joinConditionWord, methInfo)) - - let customOperationMethodsIndexedByKeyword = + Some( + nm, + maintainsVarSpaceUsingBind, + maintainsVarSpace, + allowInto, + isLikeZip, + isLikeJoin, + isLikeGroupJoin, + joinConditionWord, + methInfo + )) + + let customOperationMethodsIndexedByKeyword = if cenv.g.langVersion.SupportsFeature LanguageFeature.OverloadsForCustomOperations then customOperationMethods |> Seq.groupBy (fun (nm, _, _, _, _, _, _, _, _) -> nm) - |> Seq.map (fun (nm, group) -> - (nm, - group - |> Seq.toList)) + |> Seq.map (fun (nm, group) -> (nm, group |> Seq.toList)) else customOperationMethods |> Seq.groupBy (fun (nm, _, _, _, _, _, _, _, _) -> nm) @@ -326,14 +383,11 @@ let TcComputationExpression (cenv: cenv) env (overallTy: OverallTy) tpenv (mWhol |> dict // Check for duplicates by method name (keywords and method names must be 1:1) - let customOperationMethodsIndexedByMethodName = + let customOperationMethodsIndexedByMethodName = if cenv.g.langVersion.SupportsFeature LanguageFeature.OverloadsForCustomOperations then customOperationMethods |> Seq.groupBy (fun (_, _, _, _, _, _, _, _, methInfo) -> methInfo.LogicalName) - |> Seq.map (fun (nm, group) -> - (nm, - group - |> Seq.toList)) + |> Seq.map (fun (nm, group) -> (nm, group |> Seq.toList)) else customOperationMethods |> Seq.groupBy (fun (_, _, _, _, _, _, _, _, methInfo) -> methInfo.LogicalName) @@ -344,1189 +398,2003 @@ let TcComputationExpression (cenv: cenv) env (overallTy: OverallTy) tpenv (mWhol let tryGetDataForCustomOperation (nm: Ident) = let isOpDataCountAllowed opDatas = match opDatas with - | [_] -> true + | [ _ ] -> true | _ :: _ -> cenv.g.langVersion.SupportsFeature LanguageFeature.OverloadsForCustomOperations | _ -> false - match customOperationMethodsIndexedByKeyword.TryGetValue nm.idText with - | true, opDatas when isOpDataCountAllowed opDatas -> + match customOperationMethodsIndexedByKeyword.TryGetValue nm.idText with + | true, opDatas when isOpDataCountAllowed opDatas -> for opData in opDatas do - let opName, maintainsVarSpaceUsingBind, maintainsVarSpace, _allowInto, isLikeZip, isLikeJoin, isLikeGroupJoin, _joinConditionWord, methInfo = opData - if (maintainsVarSpaceUsingBind && maintainsVarSpace) || (isLikeZip && isLikeJoin) || (isLikeZip && isLikeGroupJoin) || (isLikeJoin && isLikeGroupJoin) then - errorR(Error(FSComp.SR.tcCustomOperationInvalid opName, nm.idRange)) + let (opName, + maintainsVarSpaceUsingBind, + maintainsVarSpace, + _allowInto, + isLikeZip, + isLikeJoin, + isLikeGroupJoin, + _joinConditionWord, + methInfo) = + opData + + if + (maintainsVarSpaceUsingBind && maintainsVarSpace) + || (isLikeZip && isLikeJoin) + || (isLikeZip && isLikeGroupJoin) + || (isLikeJoin && isLikeGroupJoin) + then + errorR (Error(FSComp.SR.tcCustomOperationInvalid opName, nm.idRange)) + if not (cenv.g.langVersion.SupportsFeature LanguageFeature.OverloadsForCustomOperations) then - match customOperationMethodsIndexedByMethodName.TryGetValue methInfo.LogicalName with - | true, [_] -> () - | _ -> errorR(Error(FSComp.SR.tcCustomOperationMayNotBeOverloaded nm.idText, nm.idRange)) + match customOperationMethodsIndexedByMethodName.TryGetValue methInfo.LogicalName with + | true, [ _ ] -> () + | _ -> errorR (Error(FSComp.SR.tcCustomOperationMayNotBeOverloaded nm.idText, nm.idRange)) + Some opDatas - | true, opData :: _ -> errorR(Error(FSComp.SR.tcCustomOperationMayNotBeOverloaded nm.idText, nm.idRange)); Some [opData] + | true, opData :: _ -> + errorR (Error(FSComp.SR.tcCustomOperationMayNotBeOverloaded nm.idText, nm.idRange)) + Some [ opData ] | _ -> None /// Decide if the identifier represents a use of a custom query operator - let hasCustomOperations () = if isNil customOperationMethods then CustomOperationsMode.Denied else CustomOperationsMode.Allowed + let hasCustomOperations () = + if isNil customOperationMethods then + CustomOperationsMode.Denied + else + CustomOperationsMode.Allowed - let isCustomOperation nm = tryGetDataForCustomOperation nm |> Option.isSome + let isCustomOperation nm = + tryGetDataForCustomOperation nm |> Option.isSome - let customOperationCheckValidity m f opDatas = + let customOperationCheckValidity m f opDatas = let vs = opDatas |> List.map f let v0 = vs[0] - let opName, _maintainsVarSpaceUsingBind, _maintainsVarSpace, _allowInto, _isLikeZip, _isLikeJoin, _isLikeGroupJoin, _joinConditionWord, _methInfo = opDatas[0] - if not (List.allEqual vs) then - errorR(Error(FSComp.SR.tcCustomOperationInvalid opName, m)) + + let (opName, + _maintainsVarSpaceUsingBind, + _maintainsVarSpace, + _allowInto, + _isLikeZip, + _isLikeJoin, + _isLikeGroupJoin, + _joinConditionWord, + _methInfo) = + opDatas[0] + + if not (List.allEqual vs) then + errorR (Error(FSComp.SR.tcCustomOperationInvalid opName, m)) + v0 // Check for the MaintainsVariableSpace on custom operation - let customOperationMaintainsVarSpace (nm: Ident) = - match tryGetDataForCustomOperation nm with + let customOperationMaintainsVarSpace (nm: Ident) = + match tryGetDataForCustomOperation nm with | None -> false | Some opDatas -> - opDatas |> customOperationCheckValidity nm.idRange (fun (_nm, _maintainsVarSpaceUsingBind, maintainsVarSpace, _allowInto, _isLikeZip, _isLikeJoin, _isLikeGroupJoin, _joinConditionWord, _methInfo) -> maintainsVarSpace) - - let customOperationMaintainsVarSpaceUsingBind (nm: Ident) = - match tryGetDataForCustomOperation nm with + opDatas + |> customOperationCheckValidity + nm.idRange + (fun + (_nm, + _maintainsVarSpaceUsingBind, + maintainsVarSpace, + _allowInto, + _isLikeZip, + _isLikeJoin, + _isLikeGroupJoin, + _joinConditionWord, + _methInfo) -> maintainsVarSpace) + + let customOperationMaintainsVarSpaceUsingBind (nm: Ident) = + match tryGetDataForCustomOperation nm with | None -> false | Some opDatas -> - opDatas |> customOperationCheckValidity nm.idRange (fun (_nm, maintainsVarSpaceUsingBind, _maintainsVarSpace, _allowInto, _isLikeZip, _isLikeJoin, _isLikeGroupJoin, _joinConditionWord, _methInfo) -> maintainsVarSpaceUsingBind) - - let customOperationIsLikeZip (nm: Ident) = - match tryGetDataForCustomOperation nm with + opDatas + |> customOperationCheckValidity + nm.idRange + (fun + (_nm, + maintainsVarSpaceUsingBind, + _maintainsVarSpace, + _allowInto, + _isLikeZip, + _isLikeJoin, + _isLikeGroupJoin, + _joinConditionWord, + _methInfo) -> maintainsVarSpaceUsingBind) + + let customOperationIsLikeZip (nm: Ident) = + match tryGetDataForCustomOperation nm with | None -> false | Some opDatas -> - opDatas |> customOperationCheckValidity nm.idRange (fun (_nm, _maintainsVarSpaceUsingBind, _maintainsVarSpace, _allowInto, isLikeZip, _isLikeJoin, _isLikeGroupJoin, _joinConditionWord, _methInfo) -> isLikeZip) - - let customOperationIsLikeJoin (nm: Ident) = - match tryGetDataForCustomOperation nm with + opDatas + |> customOperationCheckValidity + nm.idRange + (fun + (_nm, + _maintainsVarSpaceUsingBind, + _maintainsVarSpace, + _allowInto, + isLikeZip, + _isLikeJoin, + _isLikeGroupJoin, + _joinConditionWord, + _methInfo) -> isLikeZip) + + let customOperationIsLikeJoin (nm: Ident) = + match tryGetDataForCustomOperation nm with | None -> false | Some opDatas -> - opDatas |> customOperationCheckValidity nm.idRange (fun (_nm, _maintainsVarSpaceUsingBind, _maintainsVarSpace, _allowInto, _isLikeZip, isLikeJoin, _isLikeGroupJoin, _joinConditionWord, _methInfo) -> isLikeJoin) - - let customOperationIsLikeGroupJoin (nm: Ident) = - match tryGetDataForCustomOperation nm with + opDatas + |> customOperationCheckValidity + nm.idRange + (fun + (_nm, + _maintainsVarSpaceUsingBind, + _maintainsVarSpace, + _allowInto, + _isLikeZip, + isLikeJoin, + _isLikeGroupJoin, + _joinConditionWord, + _methInfo) -> isLikeJoin) + + let customOperationIsLikeGroupJoin (nm: Ident) = + match tryGetDataForCustomOperation nm with | None -> false | Some opDatas -> - opDatas |> customOperationCheckValidity nm.idRange (fun (_nm, _maintainsVarSpaceUsingBind, _maintainsVarSpace, _allowInto, _isLikeZip, _isLikeJoin, isLikeGroupJoin, _joinConditionWord, _methInfo) -> isLikeGroupJoin) - - let customOperationJoinConditionWord (nm: Ident) = - match tryGetDataForCustomOperation nm with + opDatas + |> customOperationCheckValidity + nm.idRange + (fun + (_nm, + _maintainsVarSpaceUsingBind, + _maintainsVarSpace, + _allowInto, + _isLikeZip, + _isLikeJoin, + isLikeGroupJoin, + _joinConditionWord, + _methInfo) -> isLikeGroupJoin) + + let customOperationJoinConditionWord (nm: Ident) = + match tryGetDataForCustomOperation nm with | Some opDatas -> - opDatas |> customOperationCheckValidity nm.idRange (fun (_nm, _maintainsVarSpaceUsingBind, _maintainsVarSpace, _allowInto, _isLikeZip, _isLikeJoin, _isLikeGroupJoin, joinConditionWord, _methInfo) -> joinConditionWord) - |> function None -> "on" | Some v -> v - | _ -> "on" - - let customOperationAllowsInto (nm: Ident) = - match tryGetDataForCustomOperation nm with + opDatas + |> customOperationCheckValidity + nm.idRange + (fun + (_nm, + _maintainsVarSpaceUsingBind, + _maintainsVarSpace, + _allowInto, + _isLikeZip, + _isLikeJoin, + _isLikeGroupJoin, + joinConditionWord, + _methInfo) -> joinConditionWord) + |> function + | None -> "on" + | Some v -> v + | _ -> "on" + + let customOperationAllowsInto (nm: Ident) = + match tryGetDataForCustomOperation nm with | None -> false | Some opDatas -> - opDatas |> customOperationCheckValidity nm.idRange (fun (_nm, _maintainsVarSpaceUsingBind, _maintainsVarSpace, allowInto, _isLikeZip, _isLikeJoin, _isLikeGroupJoin, _joinConditionWord, _methInfo) -> allowInto) - - let customOpUsageText nm = + opDatas + |> customOperationCheckValidity + nm.idRange + (fun + (_nm, + _maintainsVarSpaceUsingBind, + _maintainsVarSpace, + allowInto, + _isLikeZip, + _isLikeJoin, + _isLikeGroupJoin, + _joinConditionWord, + _methInfo) -> allowInto) + + let customOpUsageText nm = match tryGetDataForCustomOperation nm with - | Some ((_nm, _maintainsVarSpaceUsingBind, _maintainsVarSpace, _allowInto, isLikeZip, isLikeJoin, isLikeGroupJoin, _joinConditionWord, _methInfo) :: _) -> + | Some((_nm, + _maintainsVarSpaceUsingBind, + _maintainsVarSpace, + _allowInto, + isLikeZip, + isLikeJoin, + isLikeGroupJoin, + _joinConditionWord, + _methInfo) :: _) -> if isLikeGroupJoin then - Some (FSComp.SR.customOperationTextLikeGroupJoin(nm.idText, customOperationJoinConditionWord nm, customOperationJoinConditionWord nm)) + Some( + FSComp.SR.customOperationTextLikeGroupJoin ( + nm.idText, + customOperationJoinConditionWord nm, + customOperationJoinConditionWord nm + ) + ) elif isLikeJoin then - Some (FSComp.SR.customOperationTextLikeJoin(nm.idText, customOperationJoinConditionWord nm, customOperationJoinConditionWord nm)) + Some( + FSComp.SR.customOperationTextLikeJoin ( + nm.idText, + customOperationJoinConditionWord nm, + customOperationJoinConditionWord nm + ) + ) elif isLikeZip then - Some (FSComp.SR.customOperationTextLikeZip(nm.idText)) + Some(FSComp.SR.customOperationTextLikeZip (nm.idText)) else None - | _ -> None + | _ -> None /// Inside the 'query { ... }' use a modified name environment that contains fake 'CustomOperation' entries /// for all custom operations. This adds them to the completion lists and prevents them being used as values inside /// the query. - let env = - if List.isEmpty customOperationMethods then env else - { env with - eNameResEnv = - (env.eNameResEnv, customOperationMethods) - ||> Seq.fold (fun nenv (nm, _, _, _, _, _, _, _, methInfo) -> - AddFakeNameToNameEnv nm nenv (Item.CustomOperation (nm, (fun () -> customOpUsageText (ident (nm, mBuilderVal))), Some methInfo))) } + let env = + if List.isEmpty customOperationMethods then + env + else + { env with + eNameResEnv = + (env.eNameResEnv, customOperationMethods) + ||> Seq.fold (fun nenv (nm, _, _, _, _, _, _, _, methInfo) -> + AddFakeNameToNameEnv + nm + nenv + (Item.CustomOperation(nm, (fun () -> customOpUsageText (ident (nm, mBuilderVal))), Some methInfo))) + } // Environment is needed for completions CallEnvSink cenv.tcSink (comp.Range, env.NameEnv, ad) - let tryGetArgAttribsForCustomOperator (nm: Ident) = - match tryGetDataForCustomOperation nm with - | Some argInfos -> - argInfos - |> List.map (fun (_nm, __maintainsVarSpaceUsingBind, _maintainsVarSpace, _allowInto, _isLikeZip, _isLikeJoin, _isLikeGroupJoin, _joinConditionWord, methInfo) -> - match methInfo.GetParamAttribs(cenv.amap, mWhole) with - | [curriedArgInfo] -> Some curriedArgInfo // one for the actual argument group - | _ -> None) + let tryGetArgAttribsForCustomOperator (nm: Ident) = + match tryGetDataForCustomOperation nm with + | Some argInfos -> + argInfos + |> List.map + (fun + (_nm, + __maintainsVarSpaceUsingBind, + _maintainsVarSpace, + _allowInto, + _isLikeZip, + _isLikeJoin, + _isLikeGroupJoin, + _joinConditionWord, + methInfo) -> + match methInfo.GetParamAttribs(cenv.amap, mWhole) with + | [ curriedArgInfo ] -> Some curriedArgInfo // one for the actual argument group + | _ -> None) |> Some | _ -> None - let tryGetArgInfosForCustomOperator (nm: Ident) = - match tryGetDataForCustomOperation nm with - | Some argInfos -> - argInfos - |> List.map (fun (_nm, __maintainsVarSpaceUsingBind, _maintainsVarSpace, _allowInto, _isLikeZip, _isLikeJoin, _isLikeGroupJoin, _joinConditionWord, methInfo) -> - match methInfo with - | FSMeth(_, _, vref, _) -> - match ArgInfosOfMember cenv.g vref with - | [curriedArgInfo] -> Some curriedArgInfo - | _ -> None - | _ -> None) + let tryGetArgInfosForCustomOperator (nm: Ident) = + match tryGetDataForCustomOperation nm with + | Some argInfos -> + argInfos + |> List.map + (fun + (_nm, + __maintainsVarSpaceUsingBind, + _maintainsVarSpace, + _allowInto, + _isLikeZip, + _isLikeJoin, + _isLikeGroupJoin, + _joinConditionWord, + methInfo) -> + match methInfo with + | FSMeth(_, _, vref, _) -> + match ArgInfosOfMember cenv.g vref with + | [ curriedArgInfo ] -> Some curriedArgInfo + | _ -> None + | _ -> None) |> Some | _ -> None - let tryExpectedArgCountForCustomOperator (nm: Ident) = - match tryGetArgAttribsForCustomOperator nm with + let tryExpectedArgCountForCustomOperator (nm: Ident) = + match tryGetArgAttribsForCustomOperator nm with | None -> None - | Some argInfosForOverloads -> - let nums = argInfosForOverloads |> List.map (function None -> -1 | Some argInfos -> List.length argInfos) + | Some argInfosForOverloads -> + let nums = + argInfosForOverloads + |> List.map (function + | None -> -1 + | Some argInfos -> List.length argInfos) // Prior to 'OverloadsForCustomOperations' we count exact arguments. // // With 'OverloadsForCustomOperations' we don't compute an exact expected argument count // if any arguments are optional, out or ParamArray. - let isSpecial = + let isSpecial = if cenv.g.langVersion.SupportsFeature LanguageFeature.OverloadsForCustomOperations then - argInfosForOverloads |> List.exists (fun info -> - match info with + argInfosForOverloads + |> List.exists (fun info -> + match info with | None -> false - | Some args -> - args |> List.exists (fun (ParamAttribs(isParamArrayArg, _isInArg, isOutArg, optArgInfo, _callerInfo, _reflArgInfo)) -> isParamArrayArg || isOutArg || optArgInfo.IsOptional)) + | Some args -> + args + |> List.exists + (fun (ParamAttribs(isParamArrayArg, _isInArg, isOutArg, optArgInfo, _callerInfo, _reflArgInfo)) -> + isParamArrayArg || isOutArg || optArgInfo.IsOptional)) else false - if not isSpecial && nums |> List.forall (fun v -> v >= 0 && v = nums[0]) then - Some (max (nums[0] - 1) 0) // drop the computation context argument + if not isSpecial && nums |> List.forall (fun v -> v >= 0 && v = nums[0]) then + Some(max (nums[0] - 1) 0) // drop the computation context argument else None // Check for the [] attribute on an argument position - let isCustomOperationProjectionParameter i (nm: Ident) = + let isCustomOperationProjectionParameter i (nm: Ident) = match tryGetArgInfosForCustomOperator nm with | None -> false | Some argInfosForOverloads -> - let vs = - argInfosForOverloads |> List.map (function + let vs = + argInfosForOverloads + |> List.map (function | None -> false - | Some argInfos -> - i < argInfos.Length && - let _, argInfo = List.item i argInfos - HasFSharpAttribute cenv.g cenv.g.attrib_ProjectionParameterAttribute argInfo.Attribs) - if List.allEqual vs then vs[0] - else + | Some argInfos -> + i < argInfos.Length + && let _, argInfo = List.item i argInfos in + HasFSharpAttribute cenv.g cenv.g.attrib_ProjectionParameterAttribute argInfo.Attribs) + + if List.allEqual vs then + vs[0] + else let opDatas = (tryGetDataForCustomOperation nm).Value let opName, _, _, _, _, _, _, _j, _ = opDatas[0] - errorR(Error(FSComp.SR.tcCustomOperationInvalid opName, nm.idRange)) + errorR (Error(FSComp.SR.tcCustomOperationInvalid opName, nm.idRange)) false - let (|ForEachThen|_|) synExpr = - match synExpr with - | SynExpr.ForEach (_spFor, _spIn, SeqExprOnly false, isFromSource, pat1, expr1, SynExpr.Sequential (_, true, clause, rest, _), _) -> - Some (isFromSource, pat1, expr1, clause, rest) + let (|ForEachThen|_|) synExpr = + match synExpr with + | SynExpr.ForEach(_spFor, _spIn, SeqExprOnly false, isFromSource, pat1, expr1, SynExpr.Sequential(_, true, clause, rest, _), _) -> + Some(isFromSource, pat1, expr1, clause, rest) | _ -> None - let (|CustomOpId|_|) predicate synExpr = - match synExpr with + let (|CustomOpId|_|) predicate synExpr = + match synExpr with | SingleIdent nm when isCustomOperation nm && predicate nm -> Some nm | _ -> None // e1 in e2 ('in' is parsed as 'JOIN_IN') - let (|InExpr|_|) synExpr = - match synExpr with - | SynExpr.JoinIn (e1, _, e2, mApp) -> Some (e1, e2, mApp) + let (|InExpr|_|) synExpr = + match synExpr with + | SynExpr.JoinIn(e1, _, e2, mApp) -> Some(e1, e2, mApp) | _ -> None // e1 on e2 (note: 'on' is the 'JoinConditionWord') - let (|OnExpr|_|) nm synExpr = - match tryGetDataForCustomOperation nm with + let (|OnExpr|_|) nm synExpr = + match tryGetDataForCustomOperation nm with | None -> None - | Some _ -> - match synExpr with - | SynExpr.App (_, _, SynExpr.App (_, _, e1, SingleIdent opName, _), e2, _) when opName.idText = customOperationJoinConditionWord nm -> - let item = Item.CustomOperation (opName.idText, (fun () -> None), None) + | Some _ -> + match synExpr with + | SynExpr.App(funcExpr = SynExpr.App(funcExpr = e1; argExpr = SingleIdent opName); argExpr = e2) when + opName.idText = customOperationJoinConditionWord nm + -> + let item = Item.CustomOperation(opName.idText, (fun () -> None), None) CallNameResolutionSink cenv.tcSink (opName.idRange, env.NameEnv, item, emptyTyparInst, ItemOccurence.Use, env.AccessRights) - Some (e1, e2) + Some(e1, e2) | _ -> None // e1 into e2 - let (|IntoSuffix|_|) (e: SynExpr) = - match e with - | SynExpr.App (_, _, SynExpr.App (_, _, x, SingleIdent nm2, _), ExprAsPat intoPat, _) when nm2.idText = CustomOperations.Into -> - Some (x, nm2.idRange, intoPat) - | _ -> - None + let (|IntoSuffix|_|) (e: SynExpr) = + match e with + | SynExpr.App(funcExpr = SynExpr.App(funcExpr = x; argExpr = SingleIdent nm2); argExpr = ExprAsPat intoPat) when + nm2.idText = CustomOperations.Into + -> + Some(x, nm2.idRange, intoPat) + | _ -> None - let arbPat (m: range) = mkSynPatVar None (mkSynId (m.MakeSynthetic()) "_missingVar") + let arbPat (m: range) = + mkSynPatVar None (mkSynId (m.MakeSynthetic()) "_missingVar") - let MatchIntoSuffixOrRecover alreadyGivenError (nm: Ident) synExpr = - match synExpr with - | IntoSuffix (x, intoWordRange, intoPat) -> + let MatchIntoSuffixOrRecover alreadyGivenError (nm: Ident) synExpr = + match synExpr with + | IntoSuffix(x, intoWordRange, intoPat) -> // record the "into" as a custom operation for colorization - let item = Item.CustomOperation ("into", (fun () -> None), None) + let item = Item.CustomOperation("into", (fun () -> None), None) CallNameResolutionSink cenv.tcSink (intoWordRange, env.NameEnv, item, emptyTyparInst, ItemOccurence.Use, env.eAccessRights) (x, intoPat, alreadyGivenError) - | _ -> - if not alreadyGivenError then - errorR(Error(FSComp.SR.tcOperatorIncorrectSyntax(nm.idText, Option.get (customOpUsageText nm)), nm.idRange)) + | _ -> + if not alreadyGivenError then + errorR (Error(FSComp.SR.tcOperatorIncorrectSyntax (nm.idText, Option.get (customOpUsageText nm)), nm.idRange)) + (synExpr, arbPat synExpr.Range, true) - let MatchOnExprOrRecover alreadyGivenError nm (onExpr: SynExpr) = - match onExpr with - | OnExpr nm (innerSource, SynExprParen(keySelectors, _, _, _)) -> - (innerSource, keySelectors) - | _ -> - if not alreadyGivenError then - suppressErrorReporting (fun () -> TcExprOfUnknownType cenv env tpenv onExpr) |> ignore - errorR(Error(FSComp.SR.tcOperatorIncorrectSyntax(nm.idText, Option.get (customOpUsageText nm)), nm.idRange)) - (arbExpr("_innerSource", onExpr.Range), mkSynBifix onExpr.Range "=" (arbExpr("_keySelectors", onExpr.Range)) (arbExpr("_keySelector2", onExpr.Range))) - - let JoinOrGroupJoinOp detector synExpr = - match synExpr with - | SynExpr.App (_, _, CustomOpId detector nm, ExprAsPat innerSourcePat, mJoinCore) -> - Some(nm, innerSourcePat, mJoinCore, false) + let MatchOnExprOrRecover alreadyGivenError nm (onExpr: SynExpr) = + match onExpr with + | OnExpr nm (innerSource, SynExprParen(keySelectors, _, _, _)) -> (innerSource, keySelectors) + | _ -> + if not alreadyGivenError then + suppressErrorReporting (fun () -> TcExprOfUnknownType cenv env tpenv onExpr) + |> ignore + + errorR (Error(FSComp.SR.tcOperatorIncorrectSyntax (nm.idText, Option.get (customOpUsageText nm)), nm.idRange)) + + (arbExpr ("_innerSource", onExpr.Range), + mkSynBifix onExpr.Range "=" (arbExpr ("_keySelectors", onExpr.Range)) (arbExpr ("_keySelector2", onExpr.Range))) + + let JoinOrGroupJoinOp detector synExpr = + match synExpr with + | SynExpr.App(_, _, CustomOpId detector nm, ExprAsPat innerSourcePat, mJoinCore) -> Some(nm, innerSourcePat, mJoinCore, false) // join with bad pattern (gives error on "join" and continues) - | SynExpr.App (_, _, CustomOpId detector nm, _innerSourcePatExpr, mJoinCore) -> - errorR(Error(FSComp.SR.tcBinaryOperatorRequiresVariable(nm.idText, Option.get (customOpUsageText nm)), nm.idRange)) + | SynExpr.App(_, _, CustomOpId detector nm, _innerSourcePatExpr, mJoinCore) -> + errorR (Error(FSComp.SR.tcBinaryOperatorRequiresVariable (nm.idText, Option.get (customOpUsageText nm)), nm.idRange)) Some(nm, arbPat mJoinCore, mJoinCore, true) // join (without anything after - gives error on "join" and continues) - | CustomOpId detector nm -> - errorR(Error(FSComp.SR.tcBinaryOperatorRequiresVariable(nm.idText, Option.get (customOpUsageText nm)), nm.idRange)) + | CustomOpId detector nm -> + errorR (Error(FSComp.SR.tcBinaryOperatorRequiresVariable (nm.idText, Option.get (customOpUsageText nm)), nm.idRange)) Some(nm, arbPat synExpr.Range, synExpr.Range, true) - | _ -> - None - // JoinOrGroupJoinOp customOperationIsLikeJoin + | _ -> None + // JoinOrGroupJoinOp customOperationIsLikeJoin - let (|JoinOp|_|) synExpr = JoinOrGroupJoinOp customOperationIsLikeJoin synExpr + let (|JoinOp|_|) synExpr = + JoinOrGroupJoinOp customOperationIsLikeJoin synExpr - let (|GroupJoinOp|_|) synExpr = JoinOrGroupJoinOp customOperationIsLikeGroupJoin synExpr + let (|GroupJoinOp|_|) synExpr = + JoinOrGroupJoinOp customOperationIsLikeGroupJoin synExpr - let arbKeySelectors m = mkSynBifix m "=" (arbExpr("_keySelectors", m)) (arbExpr("_keySelector2", m)) + let arbKeySelectors m = + mkSynBifix m "=" (arbExpr ("_keySelectors", m)) (arbExpr ("_keySelector2", m)) - let (|JoinExpr|_|) synExpr = - match synExpr with - | InExpr (JoinOp(nm, innerSourcePat, _, alreadyGivenError), onExpr, mJoinCore) -> + let (|JoinExpr|_|) synExpr = + match synExpr with + | InExpr(JoinOp(nm, innerSourcePat, _, alreadyGivenError), onExpr, mJoinCore) -> let innerSource, keySelectors = MatchOnExprOrRecover alreadyGivenError nm onExpr Some(nm, innerSourcePat, innerSource, keySelectors, mJoinCore) - | JoinOp (nm, innerSourcePat, mJoinCore, alreadyGivenError) -> - if alreadyGivenError then - errorR(Error(FSComp.SR.tcOperatorRequiresIn(nm.idText, Option.get (customOpUsageText nm)), nm.idRange)) - Some (nm, innerSourcePat, arbExpr("_innerSource", synExpr.Range), arbKeySelectors synExpr.Range, mJoinCore) + | JoinOp(nm, innerSourcePat, mJoinCore, alreadyGivenError) -> + if alreadyGivenError then + errorR (Error(FSComp.SR.tcOperatorRequiresIn (nm.idText, Option.get (customOpUsageText nm)), nm.idRange)) + + Some(nm, innerSourcePat, arbExpr ("_innerSource", synExpr.Range), arbKeySelectors synExpr.Range, mJoinCore) | _ -> None - let (|GroupJoinExpr|_|) synExpr = - match synExpr with - | InExpr (GroupJoinOp (nm, innerSourcePat, _, alreadyGivenError), intoExpr, mGroupJoinCore) -> - let onExpr, intoPat, alreadyGivenError = MatchIntoSuffixOrRecover alreadyGivenError nm intoExpr - let innerSource, keySelectors = MatchOnExprOrRecover alreadyGivenError nm onExpr - Some (nm, innerSourcePat, innerSource, keySelectors, intoPat, mGroupJoinCore) - | GroupJoinOp (nm, innerSourcePat, mGroupJoinCore, alreadyGivenError) -> - if alreadyGivenError then - errorR(Error(FSComp.SR.tcOperatorRequiresIn(nm.idText, Option.get (customOpUsageText nm)), nm.idRange)) - Some (nm, innerSourcePat, arbExpr("_innerSource", synExpr.Range), arbKeySelectors synExpr.Range, arbPat synExpr.Range, mGroupJoinCore) - | _ -> - None + let (|GroupJoinExpr|_|) synExpr = + match synExpr with + | InExpr(GroupJoinOp(nm, innerSourcePat, _, alreadyGivenError), intoExpr, mGroupJoinCore) -> + let onExpr, intoPat, alreadyGivenError = + MatchIntoSuffixOrRecover alreadyGivenError nm intoExpr + let innerSource, keySelectors = MatchOnExprOrRecover alreadyGivenError nm onExpr + Some(nm, innerSourcePat, innerSource, keySelectors, intoPat, mGroupJoinCore) + | GroupJoinOp(nm, innerSourcePat, mGroupJoinCore, alreadyGivenError) -> + if alreadyGivenError then + errorR (Error(FSComp.SR.tcOperatorRequiresIn (nm.idText, Option.get (customOpUsageText nm)), nm.idRange)) + + Some( + nm, + innerSourcePat, + arbExpr ("_innerSource", synExpr.Range), + arbKeySelectors synExpr.Range, + arbPat synExpr.Range, + mGroupJoinCore + ) + | _ -> None - let (|JoinOrGroupJoinOrZipClause|_|) synExpr = + let (|JoinOrGroupJoinOrZipClause|_|) synExpr = - match synExpr with + match synExpr with // join innerSourcePat in innerSource on (keySelector1 = keySelector2) - | JoinExpr (nm, innerSourcePat, innerSource, keySelectors, mJoinCore) -> + | JoinExpr(nm, innerSourcePat, innerSource, keySelectors, mJoinCore) -> Some(nm, innerSourcePat, innerSource, Some keySelectors, None, mJoinCore) // groupJoin innerSourcePat in innerSource on (keySelector1 = keySelector2) into intoPat - | GroupJoinExpr (nm, innerSourcePat, innerSource, keySelectors, intoPat, mGroupJoinCore) -> + | GroupJoinExpr(nm, innerSourcePat, innerSource, keySelectors, intoPat, mGroupJoinCore) -> Some(nm, innerSourcePat, innerSource, Some keySelectors, Some intoPat, mGroupJoinCore) - // zip intoPat in secondSource - | InExpr (SynExpr.App (_, _, CustomOpId customOperationIsLikeZip nm, ExprAsPat secondSourcePat, _), secondSource, mZipCore) -> + // zip intoPat in secondSource + | InExpr(SynExpr.App(_, _, CustomOpId customOperationIsLikeZip nm, ExprAsPat secondSourcePat, _), secondSource, mZipCore) -> Some(nm, secondSourcePat, secondSource, None, None, mZipCore) // zip (without secondSource or in - gives error) - | CustomOpId customOperationIsLikeZip nm -> - errorR(Error(FSComp.SR.tcOperatorIncorrectSyntax(nm.idText, Option.get (customOpUsageText nm)), nm.idRange)) - Some(nm, arbPat synExpr.Range, arbExpr("_secondSource", synExpr.Range), None, None, synExpr.Range) + | CustomOpId customOperationIsLikeZip nm -> + errorR (Error(FSComp.SR.tcOperatorIncorrectSyntax (nm.idText, Option.get (customOpUsageText nm)), nm.idRange)) + Some(nm, arbPat synExpr.Range, arbExpr ("_secondSource", synExpr.Range), None, None, synExpr.Range) // zip secondSource (without in - gives error) - | SynExpr.App (_, _, CustomOpId customOperationIsLikeZip nm, ExprAsPat secondSourcePat, mZipCore) -> - errorR(Error(FSComp.SR.tcOperatorIncorrectSyntax(nm.idText, Option.get (customOpUsageText nm)), mZipCore)) - Some(nm, secondSourcePat, arbExpr("_innerSource", synExpr.Range), None, None, mZipCore) + | SynExpr.App(_, _, CustomOpId customOperationIsLikeZip nm, ExprAsPat secondSourcePat, mZipCore) -> + errorR (Error(FSComp.SR.tcOperatorIncorrectSyntax (nm.idText, Option.get (customOpUsageText nm)), mZipCore)) + Some(nm, secondSourcePat, arbExpr ("_innerSource", synExpr.Range), None, None, mZipCore) - | _ -> - None + | _ -> None - let (|ForEachThenJoinOrGroupJoinOrZipClause|_|) strict synExpr = - match synExpr with - | ForEachThen (isFromSource, firstSourcePat, firstSource, JoinOrGroupJoinOrZipClause(nm, secondSourcePat, secondSource, keySelectorsOpt, pat3opt, mOpCore), innerComp) - when - (let _firstSourceSimplePats, later1 = - use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink - SimplePatsOfPat cenv.synArgNameGenerator firstSourcePat - Option.isNone later1) -> - Some (isFromSource, firstSourcePat, firstSource, nm, secondSourcePat, secondSource, keySelectorsOpt, pat3opt, mOpCore, innerComp) - - | JoinOrGroupJoinOrZipClause(nm, pat2, expr2, expr3, pat3opt, mOpCore) when strict -> - errorR(Error(FSComp.SR.tcBinaryOperatorRequiresBody(nm.idText, Option.get (customOpUsageText nm)), nm.idRange)) - Some (true, arbPat synExpr.Range, arbExpr("_outerSource", synExpr.Range), nm, pat2, expr2, expr3, pat3opt, mOpCore, arbExpr("_innerComp", synExpr.Range)) - - | _ -> - None + let (|ForEachThenJoinOrGroupJoinOrZipClause|_|) strict synExpr = + match synExpr with + | ForEachThen(isFromSource, + firstSourcePat, + firstSource, + JoinOrGroupJoinOrZipClause(nm, secondSourcePat, secondSource, keySelectorsOpt, pat3opt, mOpCore), + innerComp) when + (let _firstSourceSimplePats, later1 = + use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink + SimplePatsOfPat cenv.synArgNameGenerator firstSourcePat + + Option.isNone later1) + -> + Some(isFromSource, firstSourcePat, firstSource, nm, secondSourcePat, secondSource, keySelectorsOpt, pat3opt, mOpCore, innerComp) + + | JoinOrGroupJoinOrZipClause(nm, pat2, expr2, expr3, pat3opt, mOpCore) when strict -> + errorR (Error(FSComp.SR.tcBinaryOperatorRequiresBody (nm.idText, Option.get (customOpUsageText nm)), nm.idRange)) + + Some( + true, + arbPat synExpr.Range, + arbExpr ("_outerSource", synExpr.Range), + nm, + pat2, + expr2, + expr3, + pat3opt, + mOpCore, + arbExpr ("_innerComp", synExpr.Range) + ) + + | _ -> None - let (|StripApps|) e = - let rec strip e = - match e with - | SynExpr.FromParseError (SynExpr.App (_, _, f, arg, _), _) - | SynExpr.App (_, _, f, arg, _) -> - let g, acc = strip f - g, (arg :: acc) + let (|StripApps|) e = + let rec strip e = + match e with + | SynExpr.FromParseError(SynExpr.App(funcExpr = f; argExpr = arg), _) + | SynExpr.App(funcExpr = f; argExpr = arg) -> + let g, acc = strip f + g, (arg :: acc) | _ -> e, [] + let g, acc = strip e g, List.rev acc - let (|OptionalIntoSuffix|) e = - match e with - | IntoSuffix (body, intoWordRange, intoInfo) -> (body, Some (intoWordRange, intoInfo)) + let (|OptionalIntoSuffix|) e = + match e with + | IntoSuffix(body, intoWordRange, intoInfo) -> (body, Some(intoWordRange, intoInfo)) | body -> (body, None) - let (|CustomOperationClause|_|) e = - match e with - | OptionalIntoSuffix(StripApps(SingleIdent nm, _) as core, intoOpt) when isCustomOperation nm -> + let (|CustomOperationClause|_|) e = + match e with + | OptionalIntoSuffix(StripApps(SingleIdent nm, _) as core, intoOpt) when isCustomOperation nm -> // Now we know we have a custom operation, commit the name resolution - let intoInfoOpt = - match intoOpt with - | Some (intoWordRange, intoInfo) -> - let item = Item.CustomOperation ("into", (fun () -> None), None) - CallNameResolutionSink cenv.tcSink (intoWordRange, env.NameEnv, item, emptyTyparInst, ItemOccurence.Use, env.eAccessRights) + let intoInfoOpt = + match intoOpt with + | Some(intoWordRange, intoInfo) -> + let item = Item.CustomOperation("into", (fun () -> None), None) + + CallNameResolutionSink + cenv.tcSink + (intoWordRange, env.NameEnv, item, emptyTyparInst, ItemOccurence.Use, env.eAccessRights) + Some intoInfo | None -> None - Some (nm, Option.get (tryGetDataForCustomOperation nm), core, core.Range, intoInfoOpt) + Some(nm, Option.get (tryGetDataForCustomOperation nm), core, core.Range, intoInfoOpt) | _ -> None - let mkSynLambda p e m = SynExpr.Lambda (false, false, p, e, None, m, SynExprLambdaTrivia.Zero) + let mkSynLambda p e m = + SynExpr.Lambda(false, false, p, e, None, m, SynExprLambdaTrivia.Zero) - let mkExprForVarSpace m (patvs: Val list) = - match patvs with - | [] -> SynExpr.Const (SynConst.Unit, m) - | [v] -> SynExpr.Ident v.Id - | vs -> SynExpr.Tuple (false, (vs |> List.map (fun v -> SynExpr.Ident(v.Id))), [], m) + let mkExprForVarSpace m (patvs: Val list) = + match patvs with + | [] -> SynExpr.Const(SynConst.Unit, m) + | [ v ] -> SynExpr.Ident v.Id + | vs -> SynExpr.Tuple(false, (vs |> List.map (fun v -> SynExpr.Ident(v.Id))), [], m) - let mkSimplePatForVarSpace m (patvs: Val list) = - let spats = - match patvs with + let mkSimplePatForVarSpace m (patvs: Val list) = + let spats = + match patvs with | [] -> [] - | [v] -> [mkSynSimplePatVar false v.Id] + | [ v ] -> [ mkSynSimplePatVar false v.Id ] | vs -> vs |> List.map (fun v -> mkSynSimplePatVar false v.Id) - SynSimplePats.SimplePats (spats, [], m) - let mkPatForVarSpace m (patvs: Val list) = - match patvs with - | [] -> SynPat.Const (SynConst.Unit, m) - | [v] -> mkSynPatVar None v.Id + SynSimplePats.SimplePats(spats, [], m) + + let mkPatForVarSpace m (patvs: Val list) = + match patvs with + | [] -> SynPat.Const(SynConst.Unit, m) + | [ v ] -> mkSynPatVar None v.Id | vs -> SynPat.Tuple(false, (vs |> List.map (fun x -> mkSynPatVar None x.Id)), [], m) - let (|OptionalSequential|) e = - match e with - | SynExpr.Sequential (_sp, true, dataComp1, dataComp2, _) -> (dataComp1, Some dataComp2) + let (|OptionalSequential|) e = + match e with + | SynExpr.Sequential(_sp, true, dataComp1, dataComp2, _) -> (dataComp1, Some dataComp2) | _ -> (e, None) // "cexpr; cexpr" is treated as builder.Combine(cexpr1, cexpr1) // This is not pretty - we have to decide which range markers we use for the calls to Combine and Delay // NOTE: we should probably suppress these sequence points altogether - let rangeForCombine innerComp1 = + let rangeForCombine innerComp1 = let m = - match innerComp1 with - | SynExpr.IfThenElse (trivia={ IfToThenRange = mIfToThen }) -> mIfToThen - | SynExpr.Match (matchDebugPoint=DebugPointAtBinding.Yes mMatch) -> mMatch - | SynExpr.TryWith (trivia={ TryKeyword = mTry }) -> mTry - | SynExpr.TryFinally (trivia={ TryKeyword = mTry }) -> mTry - | SynExpr.For (forDebugPoint=DebugPointAtFor.Yes mBind) -> mBind - | SynExpr.ForEach (forDebugPoint=DebugPointAtFor.Yes mBind) -> mBind - | SynExpr.While (whileDebugPoint=DebugPointAtWhile.Yes mWhile) -> mWhile + match innerComp1 with + | SynExpr.IfThenElse(trivia = { IfToThenRange = mIfToThen }) -> mIfToThen + | SynExpr.Match(matchDebugPoint = DebugPointAtBinding.Yes mMatch) -> mMatch + | SynExpr.TryWith(trivia = { TryKeyword = mTry }) -> mTry + | SynExpr.TryFinally(trivia = { TryKeyword = mTry }) -> mTry + | SynExpr.For(forDebugPoint = DebugPointAtFor.Yes mBind) -> mBind + | SynExpr.ForEach(forDebugPoint = DebugPointAtFor.Yes mBind) -> mBind + | SynExpr.While(whileDebugPoint = DebugPointAtWhile.Yes mWhile) -> mWhile | _ -> innerComp1.Range m.NoteSourceConstruct(NotedSourceConstruct.Combine) // Check for 'where x > y', 'select x, y' and other mis-applications of infix operators, give a good error message, and return a flag - let checkForBinaryApp comp = - match comp with - | StripApps(SingleIdent nm, [StripApps(SingleIdent nm2, args); arg2]) when - IsLogicalInfixOpName nm.idText && - (match tryExpectedArgCountForCustomOperator nm2 with Some n -> n > 0 | _ -> false) && - not (List.isEmpty args) -> - let estimatedRangeOfIntendedLeftAndRightArguments = unionRanges (List.last args).Range arg2.Range - errorR(Error(FSComp.SR.tcUnrecognizedQueryBinaryOperator(), estimatedRangeOfIntendedLeftAndRightArguments)) + let checkForBinaryApp comp = + match comp with + | StripApps(SingleIdent nm, [ StripApps(SingleIdent nm2, args); arg2 ]) when + IsLogicalInfixOpName nm.idText + && (match tryExpectedArgCountForCustomOperator nm2 with + | Some n -> n > 0 + | _ -> false) + && not (List.isEmpty args) + -> + let estimatedRangeOfIntendedLeftAndRightArguments = + unionRanges (List.last args).Range arg2.Range + + errorR (Error(FSComp.SR.tcUnrecognizedQueryBinaryOperator (), estimatedRangeOfIntendedLeftAndRightArguments)) true - | SynExpr.Tuple (false, StripApps(SingleIdent nm2, args) :: _, _, m) when - (match tryExpectedArgCountForCustomOperator nm2 with Some n -> n > 0 | _ -> false) && - not (List.isEmpty args) -> - let estimatedRangeOfIntendedLeftAndRightArguments = unionRanges (List.last args).Range m.EndRange - errorR(Error(FSComp.SR.tcUnrecognizedQueryBinaryOperator(), estimatedRangeOfIntendedLeftAndRightArguments)) + | SynExpr.Tuple(false, StripApps(SingleIdent nm2, args) :: _, _, m) when + (match tryExpectedArgCountForCustomOperator nm2 with + | Some n -> n > 0 + | _ -> false) + && not (List.isEmpty args) + -> + let estimatedRangeOfIntendedLeftAndRightArguments = + unionRanges (List.last args).Range m.EndRange + + errorR (Error(FSComp.SR.tcUnrecognizedQueryBinaryOperator (), estimatedRangeOfIntendedLeftAndRightArguments)) true - | _ -> - false - - let addVarsToVarSpace (varSpace: LazyWithContext) f = - LazyWithContext.Create - ((fun m -> - let (patvs: Val list, env) = varSpace.Force m - let vs, envinner = f m env - let patvs = List.append patvs (vs |> List.filter (fun v -> not (patvs |> List.exists (fun v2 -> v.LogicalName = v2.LogicalName)))) - patvs, envinner), - id) + | _ -> false + + let addVarsToVarSpace (varSpace: LazyWithContext) f = + LazyWithContext.Create( + (fun m -> + let (patvs: Val list, env) = varSpace.Force m + let vs, envinner = f m env + + let patvs = + List.append + patvs + (vs + |> List.filter (fun v -> not (patvs |> List.exists (fun v2 -> v.LogicalName = v2.LogicalName)))) + + patvs, envinner), + id + ) // Flag that a debug point should get emitted prior to both the evaluation of 'rhsExpr' and the call to Using let addBindDebugPoint spBind e = match spBind with - | DebugPointAtBinding.Yes m -> - SynExpr.DebugPoint(DebugPointAtLeafExpr.Yes m, false, e) + | DebugPointAtBinding.Yes m -> SynExpr.DebugPoint(DebugPointAtLeafExpr.Yes m, false, e) | _ -> e - let emptyVarSpace = LazyWithContext.NotLazy ([], env) + let emptyVarSpace = LazyWithContext.NotLazy([], env) // If there are no 'yield' in the computation expression, and the builder supports 'Yield', // then allow the type-directed rule interpreting non-unit-typed expressions in statement // positions as 'yield'. 'yield!' may be present in the computation expression. let enableImplicitYield = cenv.g.langVersion.SupportsFeature LanguageFeature.ImplicitYield - && (hasMethInfo "Yield" && hasMethInfo "Combine" && hasMethInfo "Delay" && YieldFree cenv comp) - - // q - a flag indicating if custom operators are allowed. They are not allowed inside try/with, try/finally, if/then/else etc. - // varSpace - a lazy data structure indicating the variables bound so far in the overall computation - // comp - the computation expression being analyzed - // translatedCtxt - represents the translation of the context in which the computation expression 'comp' occurs, up to a - // hole to be filled by (part of) the results of translating 'comp'. - let rec tryTrans firstTry q varSpace comp translatedCtxt = + && (hasMethInfo "Yield" + && hasMethInfo "Combine" + && hasMethInfo "Delay" + && YieldFree cenv comp) + + /// + /// Try translate the syntax sugar + /// + /// + /// a flag indicating if custom operators are allowed. They are not allowed inside try/with, try/finally, if/then/else etc. + /// a lazy data structure indicating the variables bound so far in the overall computation + /// the computation expression being analyzed + /// represents the translation of the context in which the computation expression 'comp' occurs, + /// up to a hole to be filled by (part of) the results of translating 'comp'. + let rec tryTrans + (firstTry: CompExprTranslationPass) + (q: CustomOperationsMode) + (varSpace: LazyWithContext<(Val list * TcEnv), range>) + (comp: SynExpr) + (translatedCtxt: SynExpr -> SynExpr) + : SynExpr option = // Guard the stack for deeply nested computation expressions - cenv.stackGuard.Guard <| fun () -> - - match comp with - - // for firstSourcePat in firstSource do - // join secondSourcePat in expr2 on (expr3 = expr4) - // ... - // --> - // join expr1 expr2 (fun firstSourcePat -> expr3) (fun secondSourcePat -> expr4) (fun firstSourcePat secondSourcePat -> ...) - - // for firstSourcePat in firstSource do - // groupJoin secondSourcePat in expr2 on (expr3 = expr4) into groupPat - // ... - // --> - // groupJoin expr1 expr2 (fun firstSourcePat -> expr3) (fun secondSourcePat -> expr4) (fun firstSourcePat groupPat -> ...) - - // for firstSourcePat in firstSource do - // zip secondSource into secondSourcePat - // ... - // --> - // zip expr1 expr2 (fun pat1 pat3 -> ...) - | ForEachThenJoinOrGroupJoinOrZipClause true (isFromSource, firstSourcePat, firstSource, nm, secondSourcePat, secondSource, keySelectorsOpt, secondResultPatOpt, mOpCore, innerComp) -> - - if q = CustomOperationsMode.Denied then error(Error(FSComp.SR.tcCustomOperationMayNotBeUsedHere(), nm.idRange)) - let firstSource = mkSourceExprConditional isFromSource firstSource - let secondSource = mkSourceExpr secondSource - - // Add the variables to the variable space, on demand - let varSpaceWithFirstVars = - addVarsToVarSpace varSpace (fun _mCustomOp env -> - use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink - let _, _, vspecs, envinner, _ = TcMatchPattern cenv (NewInferenceType g) env tpenv firstSourcePat None - vspecs, envinner) - - let varSpaceWithSecondVars = - addVarsToVarSpace varSpaceWithFirstVars (fun _mCustomOp env -> - use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink - let _, _, vspecs, envinner, _ = TcMatchPattern cenv (NewInferenceType g) env tpenv secondSourcePat None - vspecs, envinner) - - let varSpaceWithGroupJoinVars = - match secondResultPatOpt with - | Some pat3 -> - addVarsToVarSpace varSpaceWithFirstVars (fun _mCustomOp env -> + cenv.stackGuard.Guard + <| fun () -> + + match comp with + + // for firstSourcePat in firstSource do + // join secondSourcePat in expr2 on (expr3 = expr4) + // ... + // --> + // join expr1 expr2 (fun firstSourcePat -> expr3) (fun secondSourcePat -> expr4) (fun firstSourcePat secondSourcePat -> ...) + + // for firstSourcePat in firstSource do + // groupJoin secondSourcePat in expr2 on (expr3 = expr4) into groupPat + // ... + // --> + // groupJoin expr1 expr2 (fun firstSourcePat -> expr3) (fun secondSourcePat -> expr4) (fun firstSourcePat groupPat -> ...) + + // for firstSourcePat in firstSource do + // zip secondSource into secondSourcePat + // ... + // --> + // zip expr1 expr2 (fun pat1 pat3 -> ...) + | ForEachThenJoinOrGroupJoinOrZipClause true (isFromSource, + firstSourcePat, + firstSource, + nm, + secondSourcePat, + secondSource, + keySelectorsOpt, + secondResultPatOpt, + mOpCore, + innerComp) -> + + if q = CustomOperationsMode.Denied then + error (Error(FSComp.SR.tcCustomOperationMayNotBeUsedHere (), nm.idRange)) + + let firstSource = mkSourceExprConditional isFromSource firstSource + let secondSource = mkSourceExpr secondSource + + // Add the variables to the variable space, on demand + let varSpaceWithFirstVars = + addVarsToVarSpace varSpace (fun _mCustomOp env -> use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink - let _, _, vspecs, envinner, _ = TcMatchPattern cenv (NewInferenceType g) env tpenv pat3 None - vspecs, envinner) - | None -> varSpace - let firstSourceSimplePats, later1 = SimplePatsOfPat cenv.synArgNameGenerator firstSourcePat - let secondSourceSimplePats, later2 = SimplePatsOfPat cenv.synArgNameGenerator secondSourcePat + let _, _, vspecs, envinner, _ = + TcMatchPattern cenv (NewInferenceType g) env tpenv firstSourcePat None - if Option.isSome later1 then errorR (Error (FSComp.SR.tcJoinMustUseSimplePattern(nm.idText), firstSourcePat.Range)) - if Option.isSome later2 then errorR (Error (FSComp.SR.tcJoinMustUseSimplePattern(nm.idText), secondSourcePat.Range)) + vspecs, envinner) - // check 'join' or 'groupJoin' or 'zip' is permitted for this builder - match tryGetDataForCustomOperation nm with - | None -> error(Error(FSComp.SR.tcMissingCustomOperation(nm.idText), nm.idRange)) - | Some opDatas -> - let opName, _, _, _, _, _, _, _, methInfo = opDatas[0] + let varSpaceWithSecondVars = + addVarsToVarSpace varSpaceWithFirstVars (fun _mCustomOp env -> + use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink - // Record the resolution of the custom operation for posterity - let item = Item.CustomOperation (opName, (fun () -> customOpUsageText nm), Some methInfo) + let _, _, vspecs, envinner, _ = + TcMatchPattern cenv (NewInferenceType g) env tpenv secondSourcePat None - // FUTURE: consider whether we can do better than emptyTyparInst here, in order to display instantiations - // of type variables in the quick info provided in the IDE. - CallNameResolutionSink cenv.tcSink (nm.idRange, env.NameEnv, item, emptyTyparInst, ItemOccurence.Use, env.eAccessRights) + vspecs, envinner) - let mkJoinExpr keySelector1 keySelector2 innerPat e = - let mSynthetic = mOpCore.MakeSynthetic() - mkSynCall methInfo.DisplayName mOpCore - [ firstSource - secondSource - mkSynLambda firstSourceSimplePats keySelector1 mSynthetic - mkSynLambda secondSourceSimplePats keySelector2 mSynthetic - mkSynLambda firstSourceSimplePats (mkSynLambda innerPat e mSynthetic) mSynthetic ] - - let mkZipExpr e = - let mSynthetic = mOpCore.MakeSynthetic() - mkSynCall methInfo.DisplayName mOpCore - [ firstSource - secondSource - mkSynLambda firstSourceSimplePats (mkSynLambda secondSourceSimplePats e mSynthetic) mSynthetic ] - - // wraps given expression into sequence with result produced by arbExpr so result will look like: - // l; SynExpr.ArbitraryAfterError (...) - // this allows to handle cases like 'on (a > b)' // '>' is not permitted as correct join relation - // after wrapping a and b can still be typechecked (so we'll have correct completion inside 'on' part) - // but presence of SynExpr.ArbitraryAfterError allows to avoid errors about incompatible types in cases like - // query { - // for a in [1] do - // join b in [""] on (a > b) - // } - // if we typecheck raw 'a' and 'b' then we'll end up with 2 errors: - // 1. incorrect join relation - // 2. incompatible types: int and string - // with SynExpr.ArbitraryAfterError we have only first one - let wrapInArbErrSequence l caption = - SynExpr.Sequential (DebugPointAtSequential.SuppressNeither, true, l, (arbExpr(caption, l.Range.EndRange)), l.Range) - - let mkOverallExprGivenVarSpaceExpr, varSpaceInner = - - let isNullableOp opId = - match ConvertValLogicalNameToDisplayNameCore opId with - | "?=" | "=?" | "?=?" -> true - | _ -> false - - match secondResultPatOpt, keySelectorsOpt with - // groupJoin - | Some secondResultPat, Some relExpr when customOperationIsLikeGroupJoin nm -> - let secondResultSimplePats, later3 = SimplePatsOfPat cenv.synArgNameGenerator secondResultPat - if Option.isSome later3 then errorR (Error (FSComp.SR.tcJoinMustUseSimplePattern(nm.idText), secondResultPat.Range)) - match relExpr with - | JoinRelation cenv env (keySelector1, keySelector2) -> - mkJoinExpr keySelector1 keySelector2 secondResultSimplePats, varSpaceWithGroupJoinVars - | BinOpExpr (opId, l, r) -> - if isNullableOp opId.idText then - // When we cannot resolve NullableOps, recommend the relevant namespace to be added - errorR(Error(FSComp.SR.cannotResolveNullableOperators(ConvertValLogicalNameToDisplayNameCore opId.idText), relExpr.Range)) - else - errorR(Error(FSComp.SR.tcInvalidRelationInJoin(nm.idText), relExpr.Range)) - let l = wrapInArbErrSequence l "_keySelector1" - let r = wrapInArbErrSequence r "_keySelector2" - // this is not correct JoinRelation but it is still binary operation - // we've already reported error now we can use operands of binary operation as join components - mkJoinExpr l r secondResultSimplePats, varSpaceWithGroupJoinVars - | _ -> - errorR(Error(FSComp.SR.tcInvalidRelationInJoin(nm.idText), relExpr.Range)) - // since the shape of relExpr doesn't match our expectations (JoinRelation) - // then we assume that this is l.h.s. of the join relation - // so typechecker will treat relExpr as body of outerKeySelector lambda parameter in GroupJoin method - mkJoinExpr relExpr (arbExpr("_keySelector2", relExpr.Range)) secondResultSimplePats, varSpaceWithGroupJoinVars - - | None, Some relExpr when customOperationIsLikeJoin nm -> - match relExpr with - | JoinRelation cenv env (keySelector1, keySelector2) -> - mkJoinExpr keySelector1 keySelector2 secondSourceSimplePats, varSpaceWithSecondVars - | BinOpExpr (opId, l, r) -> - if isNullableOp opId.idText then - // When we cannot resolve NullableOps, recommend the relevant namespace to be added - errorR(Error(FSComp.SR.cannotResolveNullableOperators(ConvertValLogicalNameToDisplayNameCore opId.idText), relExpr.Range)) - else - errorR(Error(FSComp.SR.tcInvalidRelationInJoin(nm.idText), relExpr.Range)) - // this is not correct JoinRelation but it is still binary operation - // we've already reported error now we can use operands of binary operation as join components - let l = wrapInArbErrSequence l "_keySelector1" - let r = wrapInArbErrSequence r "_keySelector2" - mkJoinExpr l r secondSourceSimplePats, varSpaceWithGroupJoinVars - | _ -> - errorR(Error(FSComp.SR.tcInvalidRelationInJoin(nm.idText), relExpr.Range)) - // since the shape of relExpr doesn't match our expectations (JoinRelation) - // then we assume that this is l.h.s. of the join relation - // so typechecker will treat relExpr as body of outerKeySelector lambda parameter in Join method - mkJoinExpr relExpr (arbExpr("_keySelector2", relExpr.Range)) secondSourceSimplePats, varSpaceWithGroupJoinVars - - | None, None when customOperationIsLikeZip nm -> - mkZipExpr, varSpaceWithSecondVars - - | _ -> - assert false - failwith "unreachable" - - - // Case from C# spec: A query expression with a join clause with an into followed by something other than a select clause - // Case from C# spec: A query expression with a join clause without an into followed by something other than a select clause - let valsInner, _env = varSpaceInner.Force mOpCore - let varSpaceExpr = mkExprForVarSpace mOpCore valsInner - let varSpacePat = mkPatForVarSpace mOpCore valsInner - let joinExpr = mkOverallExprGivenVarSpaceExpr varSpaceExpr - let consumingExpr = SynExpr.ForEach (DebugPointAtFor.No, DebugPointAtInOrTo.No, SeqExprOnly false, false, varSpacePat, joinExpr, innerComp, mOpCore) - Some (trans CompExprTranslationPass.Initial q varSpaceInner consumingExpr translatedCtxt) - - | SynExpr.ForEach (spFor, spIn, SeqExprOnly _seqExprOnly, isFromSource, pat, sourceExpr, innerComp, _mEntireForEach) -> - let sourceExpr = - match RewriteRangeExpr sourceExpr with - | Some e -> e - | None -> sourceExpr - let wrappedSourceExpr = mkSourceExprConditional isFromSource sourceExpr + let varSpaceWithGroupJoinVars = + match secondResultPatOpt with + | Some pat3 -> + addVarsToVarSpace varSpaceWithFirstVars (fun _mCustomOp env -> + use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink - let mFor = - match spFor with - | DebugPointAtFor.Yes m -> m.NoteSourceConstruct(NotedSourceConstruct.For) - | DebugPointAtFor.No -> pat.Range + let _, _, vspecs, envinner, _ = + TcMatchPattern cenv (NewInferenceType g) env tpenv pat3 None - // For computation expressions, 'in' or 'to' is hit on each MoveNext. - // To support this a named debug point for the "in" keyword is available to inlined code. - match spIn with - | DebugPointAtInOrTo.Yes mIn -> - cenv.namedDebugPointsForInlinedCode[{Range=mFor; Name="ForLoop.InOrToKeyword"}] <- mIn - | _ -> () + vspecs, envinner) + | None -> varSpace + + let firstSourceSimplePats, later1 = + SimplePatsOfPat cenv.synArgNameGenerator firstSourcePat + + let secondSourceSimplePats, later2 = + SimplePatsOfPat cenv.synArgNameGenerator secondSourcePat + + if Option.isSome later1 then + errorR (Error(FSComp.SR.tcJoinMustUseSimplePattern (nm.idText), firstSourcePat.Range)) + + if Option.isSome later2 then + errorR (Error(FSComp.SR.tcJoinMustUseSimplePattern (nm.idText), secondSourcePat.Range)) + + // check 'join' or 'groupJoin' or 'zip' is permitted for this builder + match tryGetDataForCustomOperation nm with + | None -> error (Error(FSComp.SR.tcMissingCustomOperation (nm.idText), nm.idRange)) + | Some opDatas -> + let opName, _, _, _, _, _, _, _, methInfo = opDatas[0] + + // Record the resolution of the custom operation for posterity + let item = + Item.CustomOperation(opName, (fun () -> customOpUsageText nm), Some methInfo) + + // FUTURE: consider whether we can do better than emptyTyparInst here, in order to display instantiations + // of type variables in the quick info provided in the IDE. + CallNameResolutionSink cenv.tcSink (nm.idRange, env.NameEnv, item, emptyTyparInst, ItemOccurence.Use, env.eAccessRights) + + let mkJoinExpr keySelector1 keySelector2 innerPat e = + let mSynthetic = mOpCore.MakeSynthetic() + + mkSynCall + methInfo.DisplayName + mOpCore + [ + firstSource + secondSource + mkSynLambda firstSourceSimplePats keySelector1 mSynthetic + mkSynLambda secondSourceSimplePats keySelector2 mSynthetic + mkSynLambda firstSourceSimplePats (mkSynLambda innerPat e mSynthetic) mSynthetic + ] + + let mkZipExpr e = + let mSynthetic = mOpCore.MakeSynthetic() + + mkSynCall + methInfo.DisplayName + mOpCore + [ + firstSource + secondSource + mkSynLambda firstSourceSimplePats (mkSynLambda secondSourceSimplePats e mSynthetic) mSynthetic + ] + + // wraps given expression into sequence with result produced by arbExpr so result will look like: + // l; SynExpr.ArbitraryAfterError (...) + // this allows to handle cases like 'on (a > b)' // '>' is not permitted as correct join relation + // after wrapping a and b can still be typechecked (so we'll have correct completion inside 'on' part) + // but presence of SynExpr.ArbitraryAfterError allows to avoid errors about incompatible types in cases like + // query { + // for a in [1] do + // join b in [""] on (a > b) + // } + // if we typecheck raw 'a' and 'b' then we'll end up with 2 errors: + // 1. incorrect join relation + // 2. incompatible types: int and string + // with SynExpr.ArbitraryAfterError we have only first one + let wrapInArbErrSequence l caption = + SynExpr.Sequential(DebugPointAtSequential.SuppressNeither, true, l, (arbExpr (caption, l.Range.EndRange)), l.Range) + + let mkOverallExprGivenVarSpaceExpr, varSpaceInner = + + let isNullableOp opId = + match ConvertValLogicalNameToDisplayNameCore opId with + | "?=" + | "=?" + | "?=?" -> true + | _ -> false + + match secondResultPatOpt, keySelectorsOpt with + // groupJoin + | Some secondResultPat, Some relExpr when customOperationIsLikeGroupJoin nm -> + let secondResultSimplePats, later3 = + SimplePatsOfPat cenv.synArgNameGenerator secondResultPat + + if Option.isSome later3 then + errorR (Error(FSComp.SR.tcJoinMustUseSimplePattern (nm.idText), secondResultPat.Range)) + + match relExpr with + | JoinRelation cenv env (keySelector1, keySelector2) -> + mkJoinExpr keySelector1 keySelector2 secondResultSimplePats, varSpaceWithGroupJoinVars + | BinOpExpr(opId, l, r) -> + if isNullableOp opId.idText then + // When we cannot resolve NullableOps, recommend the relevant namespace to be added + errorR ( + Error( + FSComp.SR.cannotResolveNullableOperators (ConvertValLogicalNameToDisplayNameCore opId.idText), + relExpr.Range + ) + ) + else + errorR (Error(FSComp.SR.tcInvalidRelationInJoin (nm.idText), relExpr.Range)) + + let l = wrapInArbErrSequence l "_keySelector1" + let r = wrapInArbErrSequence r "_keySelector2" + // this is not correct JoinRelation but it is still binary operation + // we've already reported error now we can use operands of binary operation as join components + mkJoinExpr l r secondResultSimplePats, varSpaceWithGroupJoinVars + | _ -> + errorR (Error(FSComp.SR.tcInvalidRelationInJoin (nm.idText), relExpr.Range)) + // since the shape of relExpr doesn't match our expectations (JoinRelation) + // then we assume that this is l.h.s. of the join relation + // so typechecker will treat relExpr as body of outerKeySelector lambda parameter in GroupJoin method + mkJoinExpr relExpr (arbExpr ("_keySelector2", relExpr.Range)) secondResultSimplePats, + varSpaceWithGroupJoinVars + + | None, Some relExpr when customOperationIsLikeJoin nm -> + match relExpr with + | JoinRelation cenv env (keySelector1, keySelector2) -> + mkJoinExpr keySelector1 keySelector2 secondSourceSimplePats, varSpaceWithSecondVars + | BinOpExpr(opId, l, r) -> + if isNullableOp opId.idText then + // When we cannot resolve NullableOps, recommend the relevant namespace to be added + errorR ( + Error( + FSComp.SR.cannotResolveNullableOperators (ConvertValLogicalNameToDisplayNameCore opId.idText), + relExpr.Range + ) + ) + else + errorR (Error(FSComp.SR.tcInvalidRelationInJoin (nm.idText), relExpr.Range)) + // this is not correct JoinRelation but it is still binary operation + // we've already reported error now we can use operands of binary operation as join components + let l = wrapInArbErrSequence l "_keySelector1" + let r = wrapInArbErrSequence r "_keySelector2" + mkJoinExpr l r secondSourceSimplePats, varSpaceWithGroupJoinVars + | _ -> + errorR (Error(FSComp.SR.tcInvalidRelationInJoin (nm.idText), relExpr.Range)) + // since the shape of relExpr doesn't match our expectations (JoinRelation) + // then we assume that this is l.h.s. of the join relation + // so typechecker will treat relExpr as body of outerKeySelector lambda parameter in Join method + mkJoinExpr relExpr (arbExpr ("_keySelector2", relExpr.Range)) secondSourceSimplePats, + varSpaceWithGroupJoinVars + + | None, None when customOperationIsLikeZip nm -> mkZipExpr, varSpaceWithSecondVars + + | _ -> + assert false + failwith "unreachable" + + // Case from C# spec: A query expression with a join clause with an into followed by something other than a select clause + // Case from C# spec: A query expression with a join clause without an into followed by something other than a select clause + let valsInner, _env = varSpaceInner.Force mOpCore + let varSpaceExpr = mkExprForVarSpace mOpCore valsInner + let varSpacePat = mkPatForVarSpace mOpCore valsInner + let joinExpr = mkOverallExprGivenVarSpaceExpr varSpaceExpr + + let consumingExpr = + SynExpr.ForEach( + DebugPointAtFor.No, + DebugPointAtInOrTo.No, + SeqExprOnly false, + false, + varSpacePat, + joinExpr, + innerComp, + mOpCore + ) + + Some(trans CompExprTranslationPass.Initial q varSpaceInner consumingExpr translatedCtxt) + + | SynExpr.ForEach(spFor, spIn, SeqExprOnly _seqExprOnly, isFromSource, pat, sourceExpr, innerComp, _mEntireForEach) -> + let sourceExpr = + match RewriteRangeExpr sourceExpr with + | Some e -> e + | None -> sourceExpr + + let wrappedSourceExpr = mkSourceExprConditional isFromSource sourceExpr + + let mFor = + match spFor with + | DebugPointAtFor.Yes m -> m.NoteSourceConstruct(NotedSourceConstruct.For) + | DebugPointAtFor.No -> pat.Range + + // For computation expressions, 'in' or 'to' is hit on each MoveNext. + // To support this a named debug point for the "in" keyword is available to inlined code. + match spIn with + | DebugPointAtInOrTo.Yes mIn -> + cenv.namedDebugPointsForInlinedCode[{ + Range = mFor + Name = "ForLoop.InOrToKeyword" + }] <- mIn + | _ -> () + + let mPat = pat.Range + + if + isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mFor ad "For" builderTy) + then + error (Error(FSComp.SR.tcRequireBuilderMethod ("For"), mFor)) - let mPat = pat.Range + // Add the variables to the query variable space, on demand + let varSpace = + addVarsToVarSpace varSpace (fun _mCustomOp env -> + use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink - if isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mFor ad "For" builderTy) then - error(Error(FSComp.SR.tcRequireBuilderMethod("For"), mFor)) + let _, _, vspecs, envinner, _ = + TcMatchPattern cenv (NewInferenceType g) env tpenv pat None - // Add the variables to the query variable space, on demand - let varSpace = - addVarsToVarSpace varSpace (fun _mCustomOp env -> - use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink - let _, _, vspecs, envinner, _ = TcMatchPattern cenv (NewInferenceType g) env tpenv pat None - vspecs, envinner) + vspecs, envinner) - Some (trans CompExprTranslationPass.Initial q varSpace innerComp - (fun innerCompR -> + Some( + trans CompExprTranslationPass.Initial q varSpace innerComp (fun innerCompR -> - let forCall = - mkSynCall "For" mFor [wrappedSourceExpr; SynExpr.MatchLambda (false, mPat, [SynMatchClause(pat, None, innerCompR, mPat, DebugPointAtTarget.Yes, SynMatchClauseTrivia.Zero)], DebugPointAtBinding.NoneAtInvisible, mFor) ] + let forCall = + mkSynCall + "For" + mFor + [ + wrappedSourceExpr + SynExpr.MatchLambda( + false, + mPat, + [ + SynMatchClause(pat, None, innerCompR, mPat, DebugPointAtTarget.Yes, SynMatchClauseTrivia.Zero) + ], + DebugPointAtBinding.NoneAtInvisible, + mFor + ) + ] let forCall = match spFor with - | DebugPointAtFor.Yes _ -> - SynExpr.DebugPoint(DebugPointAtLeafExpr.Yes mFor, false, forCall) + | DebugPointAtFor.Yes _ -> SynExpr.DebugPoint(DebugPointAtLeafExpr.Yes mFor, false, forCall) | DebugPointAtFor.No -> forCall - translatedCtxt forCall)) - - | SynExpr.For (forDebugPoint=spFor; toDebugPoint=spTo; ident=id; identBody=start; direction=dir; toBody=finish; doBody=innerComp; range=m) -> - let mFor = match spFor with DebugPointAtFor.Yes m -> m.NoteSourceConstruct(NotedSourceConstruct.For) | _ -> m - - if isQuery then errorR(Error(FSComp.SR.tcNoIntegerForLoopInQuery(), mFor)) - - let reduced = elimFastIntegerForLoop (spFor, spTo, id, start, dir, finish, innerComp, m) - Some (trans CompExprTranslationPass.Initial q varSpace reduced translatedCtxt ) - - | SynExpr.While (spWhile, guardExpr, innerComp, _) -> - let mGuard = guardExpr.Range - let mWhile = match spWhile with DebugPointAtWhile.Yes m -> m.NoteSourceConstruct(NotedSourceConstruct.While) | _ -> mGuard - - if isQuery then error(Error(FSComp.SR.tcNoWhileInQuery(), mWhile)) + translatedCtxt forCall) + ) + + | SynExpr.For( + forDebugPoint = spFor + toDebugPoint = spTo + ident = id + identBody = start + direction = dir + toBody = finish + doBody = innerComp + range = m) -> + let mFor = + match spFor with + | DebugPointAtFor.Yes m -> m.NoteSourceConstruct(NotedSourceConstruct.For) + | _ -> m + + if isQuery then + errorR (Error(FSComp.SR.tcNoIntegerForLoopInQuery (), mFor)) + + let reduced = + elimFastIntegerForLoop (spFor, spTo, id, start, dir, finish, innerComp, m) + + Some(trans CompExprTranslationPass.Initial q varSpace reduced translatedCtxt) + + | SynExpr.While(spWhile, guardExpr, innerComp, _) -> + let mGuard = guardExpr.Range + + let mWhile = + match spWhile with + | DebugPointAtWhile.Yes m -> m.NoteSourceConstruct(NotedSourceConstruct.While) + | _ -> mGuard + + if isQuery then + error (Error(FSComp.SR.tcNoWhileInQuery (), mWhile)) + + if + isNil ( + TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mWhile ad "While" builderTy + ) + then + error (Error(FSComp.SR.tcRequireBuilderMethod ("While"), mWhile)) + + if + isNil ( + TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mWhile ad "Delay" builderTy + ) + then + error (Error(FSComp.SR.tcRequireBuilderMethod ("Delay"), mWhile)) + + // 'while' is hit just before each time the guard is called + let guardExpr = + match spWhile with + | DebugPointAtWhile.Yes _ -> SynExpr.DebugPoint(DebugPointAtLeafExpr.Yes mWhile, false, guardExpr) + | DebugPointAtWhile.No -> guardExpr + + Some( + trans CompExprTranslationPass.Initial q varSpace innerComp (fun holeFill -> + translatedCtxt ( + mkSynCall + "While" + mWhile + [ + mkSynDelay2 guardExpr + mkSynCall "Delay" mWhile [ mkSynDelay innerComp.Range holeFill ] + ] + )) + ) + + | SynExpr.WhileBang(spWhile, guardExpr, innerComp, mOrig) -> + let mGuard = guardExpr.Range + + let mWhile = + match spWhile with + | DebugPointAtWhile.Yes m -> m.NoteSourceConstruct(NotedSourceConstruct.While) + | _ -> mGuard + + let mGuard = mGuard.MakeSynthetic() + + // 'while!' is hit just before each time the guard is called + let guardExpr = + match spWhile with + | DebugPointAtWhile.Yes _ -> SynExpr.DebugPoint(DebugPointAtLeafExpr.Yes mWhile, false, guardExpr) + | DebugPointAtWhile.No -> guardExpr + + let rewrittenWhileExpr = + let idFirst = mkSynId mGuard (CompilerGeneratedName "first") + let patFirst = mkSynPatVar None idFirst + + let body = + let idCond = mkSynId mGuard (CompilerGeneratedName "cond") + let patCond = mkSynPatVar None idCond + + let condBinding = + mkSynBinding + (Xml.PreXmlDoc.Empty, patCond) + (None, + false, + true, + mGuard, + DebugPointAtBinding.NoneAtSticky, + None, + SynExpr.Ident idFirst, + mGuard, + [], + [], + None, + SynBindingTrivia.Zero) + + let setCondExpr = SynExpr.Set(SynExpr.Ident idCond, SynExpr.Ident idFirst, mGuard) + + let bindCondExpr = + SynExpr.LetOrUseBang( + DebugPointAtBinding.NoneAtSticky, + false, + true, + patFirst, + guardExpr, + [], + setCondExpr, + mGuard, + SynExprLetOrUseBangTrivia.Zero + ) + + let whileExpr = + SynExpr.While( + DebugPointAtWhile.No, + SynExpr.Ident idCond, + SynExpr.Sequential(DebugPointAtSequential.SuppressBoth, true, innerComp, bindCondExpr, mWhile), + mOrig + ) + + SynExpr.LetOrUse(false, false, [ condBinding ], whileExpr, mGuard, SynExprLetOrUseTrivia.Zero) + + SynExpr.LetOrUseBang( + DebugPointAtBinding.NoneAtSticky, + false, + true, + patFirst, + guardExpr, + [], + body, + mGuard, + SynExprLetOrUseBangTrivia.Zero + ) + + tryTrans CompExprTranslationPass.Initial q varSpace rewrittenWhileExpr translatedCtxt + + | SynExpr.TryFinally(innerComp, unwindExpr, _mTryToLast, spTry, spFinally, trivia) -> + + let mTry = + match spTry with + | DebugPointAtTry.Yes m -> m.NoteSourceConstruct(NotedSourceConstruct.Try) + | _ -> trivia.TryKeyword + + let mFinally = + match spFinally with + | DebugPointAtFinally.Yes m -> m.NoteSourceConstruct(NotedSourceConstruct.Finally) + | _ -> trivia.FinallyKeyword + + // Put down a debug point for the 'finally' + let unwindExpr2 = + match spFinally with + | DebugPointAtFinally.Yes _ -> SynExpr.DebugPoint(DebugPointAtLeafExpr.Yes mFinally, true, unwindExpr) + | DebugPointAtFinally.No -> unwindExpr + + if isQuery then + error (Error(FSComp.SR.tcNoTryFinallyInQuery (), mTry)) + + if + isNil ( + TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mTry ad "TryFinally" builderTy + ) + then + error (Error(FSComp.SR.tcRequireBuilderMethod ("TryFinally"), mTry)) + + if + isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mTry ad "Delay" builderTy) + then + error (Error(FSComp.SR.tcRequireBuilderMethod ("Delay"), mTry)) + + let innerExpr = transNoQueryOps innerComp + + let innerExpr = + match spTry with + | DebugPointAtTry.Yes _ -> SynExpr.DebugPoint(DebugPointAtLeafExpr.Yes mTry, true, innerExpr) + | _ -> innerExpr + + Some( + translatedCtxt ( + mkSynCall + "TryFinally" + mTry + [ + mkSynCall "Delay" mTry [ mkSynDelay innerComp.Range innerExpr ] + mkSynDelay2 unwindExpr2 + ] + ) + ) + + | SynExpr.Paren(range = m) -> error (Error(FSComp.SR.tcConstructIsAmbiguousInComputationExpression (), m)) + + // In some cases the node produced by `mkSynCall "Zero" m []` may be discarded in the case + // of implicit yields - for example "list { 1; 2 }" when each expression checks as an implicit yield. + // If it is not discarded, the syntax node will later be checked and the existence/non-existence of the Zero method + // will be checked/reported appropriately (though the error message won't mention computation expressions + // like our other error messages for missing methods). + | SynExpr.ImplicitZero m -> + if + (not enableImplicitYield) + && isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env m ad "Zero" builderTy) + then + error (Error(FSComp.SR.tcRequireBuilderMethod ("Zero"), m)) + + Some(translatedCtxt (mkSynCall "Zero" m [])) + + | OptionalSequential(JoinOrGroupJoinOrZipClause(_, _, _, _, _, mClause), _) when firstTry = CompExprTranslationPass.Initial -> + + // 'join' clauses preceded by 'let' and other constructs get processed by repackaging with a 'for' loop. + let patvs, _env = varSpace.Force comp.Range + let varSpaceExpr = mkExprForVarSpace mClause patvs + let varSpacePat = mkPatForVarSpace mClause patvs + + let dataCompPrior = + translatedCtxt (transNoQueryOps (SynExpr.YieldOrReturn((true, false), varSpaceExpr, mClause))) + + // Rebind using for ... + let rebind = + SynExpr.ForEach( + DebugPointAtFor.No, + DebugPointAtInOrTo.No, + SeqExprOnly false, + false, + varSpacePat, + dataCompPrior, + comp, + comp.Range + ) + + // Retry with the 'for' loop packaging. Set firstTry=false just in case 'join' processing fails + tryTrans CompExprTranslationPass.Subsequent q varSpace rebind id + + | OptionalSequential(CustomOperationClause(nm, _, opExpr, mClause, _), _) -> + + if q = CustomOperationsMode.Denied then + error (Error(FSComp.SR.tcCustomOperationMayNotBeUsedHere (), opExpr.Range)) + + let patvs, _env = varSpace.Force comp.Range + let varSpaceExpr = mkExprForVarSpace mClause patvs + + let dataCompPriorToOp = + let isYield = not (customOperationMaintainsVarSpaceUsingBind nm) + translatedCtxt (transNoQueryOps (SynExpr.YieldOrReturn((isYield, false), varSpaceExpr, mClause))) + + // Now run the consumeCustomOpClauses + Some(consumeCustomOpClauses q varSpace dataCompPriorToOp comp false mClause) + + | SynExpr.Sequential(sp, true, innerComp1, innerComp2, m) -> + + // Check for 'where x > y' and other mis-applications of infix operators. If detected, give a good error message, and just ignore innerComp1 + if isQuery && checkForBinaryApp innerComp1 then + Some(trans CompExprTranslationPass.Initial q varSpace innerComp2 translatedCtxt) - if isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mWhile ad "While" builderTy) then - error(Error(FSComp.SR.tcRequireBuilderMethod("While"), mWhile)) - - if isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mWhile ad "Delay" builderTy) then - error(Error(FSComp.SR.tcRequireBuilderMethod("Delay"), mWhile)) - - // 'while' is hit just before each time the guard is called - let guardExpr = - match spWhile with - | DebugPointAtWhile.Yes _ -> - SynExpr.DebugPoint(DebugPointAtLeafExpr.Yes mWhile, false, guardExpr) - | DebugPointAtWhile.No -> guardExpr - - Some(trans CompExprTranslationPass.Initial q varSpace innerComp (fun holeFill -> - translatedCtxt - (mkSynCall "While" mWhile - [ mkSynDelay2 guardExpr; - mkSynCall "Delay" mWhile [mkSynDelay innerComp.Range holeFill]])) ) - - | SynExpr.WhileBang (spWhile, guardExpr, innerComp, mOrig) -> - let mGuard = guardExpr.Range - let mWhile = match spWhile with DebugPointAtWhile.Yes m -> m.NoteSourceConstruct(NotedSourceConstruct.While) | _ -> mGuard - let mGuard = mGuard.MakeSynthetic() - - // 'while!' is hit just before each time the guard is called - let guardExpr = - match spWhile with - | DebugPointAtWhile.Yes _ -> - SynExpr.DebugPoint(DebugPointAtLeafExpr.Yes mWhile, false, guardExpr) - | DebugPointAtWhile.No -> guardExpr - - let rewrittenWhileExpr = - let idFirst = mkSynId mGuard (CompilerGeneratedName "first") - let patFirst = mkSynPatVar None idFirst - - let body = - let idCond = mkSynId mGuard (CompilerGeneratedName "cond") - let patCond = mkSynPatVar None idCond - let condBinding = mkSynBinding (Xml.PreXmlDoc.Empty, patCond) (None, false, true, mGuard, DebugPointAtBinding.NoneAtSticky, None, SynExpr.Ident idFirst, mGuard, [], [], None, SynBindingTrivia.Zero) - let setCondExpr = SynExpr.Set (SynExpr.Ident idCond, SynExpr.Ident idFirst, mGuard) - let bindCondExpr = SynExpr.LetOrUseBang (DebugPointAtBinding.NoneAtSticky, false, true, patFirst, guardExpr, [], setCondExpr, mGuard, SynExprLetOrUseBangTrivia.Zero) - - let whileExpr = SynExpr.While (DebugPointAtWhile.No, SynExpr.Ident idCond, SynExpr.Sequential (DebugPointAtSequential.SuppressBoth, true, innerComp, bindCondExpr, mWhile), mOrig) - SynExpr.LetOrUse (false, false, [ condBinding ], whileExpr, mGuard, SynExprLetOrUseTrivia.Zero) - - SynExpr.LetOrUseBang (DebugPointAtBinding.NoneAtSticky, false, true, patFirst, guardExpr, [], body, mGuard, SynExprLetOrUseBangTrivia.Zero) - - tryTrans CompExprTranslationPass.Initial q varSpace rewrittenWhileExpr translatedCtxt - - | SynExpr.TryFinally (innerComp, unwindExpr, _mTryToLast, spTry, spFinally, trivia) -> - - let mTry = match spTry with DebugPointAtTry.Yes m -> m.NoteSourceConstruct(NotedSourceConstruct.Try) | _ -> trivia.TryKeyword - let mFinally = match spFinally with DebugPointAtFinally.Yes m -> m.NoteSourceConstruct(NotedSourceConstruct.Finally) | _ -> trivia.FinallyKeyword - - // Put down a debug point for the 'finally' - let unwindExpr2 = - match spFinally with - | DebugPointAtFinally.Yes _ -> - SynExpr.DebugPoint(DebugPointAtLeafExpr.Yes mFinally, true, unwindExpr) - | DebugPointAtFinally.No -> unwindExpr - - if isQuery then error(Error(FSComp.SR.tcNoTryFinallyInQuery(), mTry)) - - if isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mTry ad "TryFinally" builderTy) then - error(Error(FSComp.SR.tcRequireBuilderMethod("TryFinally"), mTry)) - - if isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mTry ad "Delay" builderTy) then - error(Error(FSComp.SR.tcRequireBuilderMethod("Delay"), mTry)) - - let innerExpr = transNoQueryOps innerComp - - let innerExpr = - match spTry with - | DebugPointAtTry.Yes _ -> - SynExpr.DebugPoint(DebugPointAtLeafExpr.Yes mTry, true, innerExpr) - | _ -> innerExpr - - Some (translatedCtxt - (mkSynCall "TryFinally" mTry [ - mkSynCall "Delay" mTry [mkSynDelay innerComp.Range innerExpr] - mkSynDelay2 unwindExpr2])) - - | SynExpr.Paren (_, _, _, m) -> - error(Error(FSComp.SR.tcConstructIsAmbiguousInComputationExpression(), m)) - - // In some cases the node produced by `mkSynCall "Zero" m []` may be discarded in the case - // of implicit yields - for example "list { 1; 2 }" when each expression checks as an implicit yield. - // If it is not discarded, the syntax node will later be checked and the existence/non-existence of the Zero method - // will be checked/reported appropriately (though the error message won't mention computation expressions - // like our other error messages for missing methods). - | SynExpr.ImplicitZero m -> - if (not enableImplicitYield) && - isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env m ad "Zero" builderTy) then error(Error(FSComp.SR.tcRequireBuilderMethod("Zero"), m)) - Some (translatedCtxt (mkSynCall "Zero" m [])) - - | OptionalSequential (JoinOrGroupJoinOrZipClause (_, _, _, _, _, mClause), _) - when firstTry = CompExprTranslationPass.Initial -> - - // 'join' clauses preceded by 'let' and other constructs get processed by repackaging with a 'for' loop. - let patvs, _env = varSpace.Force comp.Range - let varSpaceExpr = mkExprForVarSpace mClause patvs - let varSpacePat = mkPatForVarSpace mClause patvs - - let dataCompPrior = - translatedCtxt (transNoQueryOps (SynExpr.YieldOrReturn ((true, false), varSpaceExpr, mClause))) - - // Rebind using for ... - let rebind = - SynExpr.ForEach (DebugPointAtFor.No, DebugPointAtInOrTo.No, SeqExprOnly false, false, varSpacePat, dataCompPrior, comp, comp.Range) - - // Retry with the 'for' loop packaging. Set firstTry=false just in case 'join' processing fails - tryTrans CompExprTranslationPass.Subsequent q varSpace rebind id + else + if isQuery && not (innerComp1.IsArbExprAndThusAlreadyReportedError) then + match innerComp1 with + | SynExpr.JoinIn _ -> () // an error will be reported later when we process innerComp1 as a sequential + | _ -> errorR (Error(FSComp.SR.tcUnrecognizedQueryOperator (), innerComp1.RangeOfFirstPortion)) + + match tryTrans CompExprTranslationPass.Initial CustomOperationsMode.Denied varSpace innerComp1 id with + | Some c -> + // "cexpr; cexpr" is treated as builder.Combine(cexpr1, cexpr1) + let m1 = rangeForCombine innerComp1 + + if + isNil ( + TryFindIntrinsicOrExtensionMethInfo + ResultCollectionSettings.AtMostOneResult + cenv + env + m + ad + "Combine" + builderTy + ) + then + error (Error(FSComp.SR.tcRequireBuilderMethod ("Combine"), m)) + + if + isNil ( + TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env m ad "Delay" builderTy + ) + then + error (Error(FSComp.SR.tcRequireBuilderMethod ("Delay"), m)) + + let combineCall = + mkSynCall + "Combine" + m1 + [ + c + mkSynCall "Delay" m1 [ mkSynDelay innerComp2.Range (transNoQueryOps innerComp2) ] + ] + + Some(translatedCtxt combineCall) + + | None -> + // "do! expr; cexpr" is treated as { let! () = expr in cexpr } + match innerComp1 with + | SynExpr.DoBang(rhsExpr, m) -> + let sp = + match sp with + | DebugPointAtSequential.SuppressExpr -> DebugPointAtBinding.NoneAtDo + | DebugPointAtSequential.SuppressBoth -> DebugPointAtBinding.NoneAtDo + | DebugPointAtSequential.SuppressStmt -> DebugPointAtBinding.Yes m + | DebugPointAtSequential.SuppressNeither -> DebugPointAtBinding.Yes m + + Some( + trans + CompExprTranslationPass.Initial + q + varSpace + (SynExpr.LetOrUseBang( + sp, + false, + true, + SynPat.Const(SynConst.Unit, rhsExpr.Range), + rhsExpr, + [], + innerComp2, + m, + SynExprLetOrUseBangTrivia.Zero + )) + translatedCtxt + ) + + // "expr; cexpr" is treated as sequential execution + | _ -> + Some( + trans CompExprTranslationPass.Initial q varSpace innerComp2 (fun holeFill -> + let fillExpr = + if enableImplicitYield then + // When implicit yields are enabled, then if the 'innerComp1' checks as type + // 'unit' we interpret the expression as a sequential, and when it doesn't + // have type 'unit' we interpret it as a 'Yield + Combine'. + let combineExpr = + let m1 = rangeForCombine innerComp1 + let implicitYieldExpr = mkSynCall "Yield" comp.Range [ innerComp1 ] + + mkSynCall + "Combine" + m1 + [ + implicitYieldExpr + mkSynCall "Delay" m1 [ mkSynDelay holeFill.Range holeFill ] + ] + + SynExpr.SequentialOrImplicitYield(sp, innerComp1, holeFill, combineExpr, m) + else + SynExpr.Sequential(sp, true, innerComp1, holeFill, m) + + translatedCtxt fillExpr) + ) + + | SynExpr.IfThenElse(guardExpr, thenComp, elseCompOpt, spIfToThen, isRecovery, mIfToEndOfElseBranch, trivia) -> + match elseCompOpt with + | Some elseComp -> + if isQuery then + error (Error(FSComp.SR.tcIfThenElseMayNotBeUsedWithinQueries (), trivia.IfToThenRange)) + + Some( + translatedCtxt ( + SynExpr.IfThenElse( + guardExpr, + transNoQueryOps thenComp, + Some(transNoQueryOps elseComp), + spIfToThen, + isRecovery, + mIfToEndOfElseBranch, + trivia + ) + ) + ) + | None -> + let elseComp = + if + isNil ( + TryFindIntrinsicOrExtensionMethInfo + ResultCollectionSettings.AtMostOneResult + cenv + env + trivia.IfToThenRange + ad + "Zero" + builderTy + ) + then + error (Error(FSComp.SR.tcRequireBuilderMethod ("Zero"), trivia.IfToThenRange)) + + mkSynCall "Zero" trivia.IfToThenRange [] + + Some( + trans CompExprTranslationPass.Initial q varSpace thenComp (fun holeFill -> + translatedCtxt ( + SynExpr.IfThenElse( + guardExpr, + holeFill, + Some elseComp, + spIfToThen, + isRecovery, + mIfToEndOfElseBranch, + trivia + ) + )) + ) + + // 'let binds in expr' + | SynExpr.LetOrUse(isRec, false, binds, innerComp, m, trivia) -> + + // For 'query' check immediately + if isQuery then + match (List.map (BindingNormalization.NormalizeBinding ValOrMemberBinding cenv env) binds) with + | [ NormalizedBinding(_, SynBindingKind.Normal, false, false, _, _, _, _, _, _, _, _) ] when not isRec -> () + | normalizedBindings -> + let failAt m = + error (Error(FSComp.SR.tcNonSimpleLetBindingInQuery (), m)) + + match normalizedBindings with + | NormalizedBinding(mBinding = mBinding) :: _ -> failAt mBinding + | _ -> failAt m - | OptionalSequential (CustomOperationClause (nm, _, opExpr, mClause, _), _) -> + // Add the variables to the query variable space, on demand + let varSpace = + addVarsToVarSpace varSpace (fun mQueryOp env -> + // Normalize the bindings before detecting the bound variables + match (List.map (BindingNormalization.NormalizeBinding ValOrMemberBinding cenv env) binds) with + | [ NormalizedBinding(kind = SynBindingKind.Normal; mustInline = false; isMutable = false; pat = pat) ] -> + // successful case + use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink - if q = CustomOperationsMode.Denied then error(Error(FSComp.SR.tcCustomOperationMayNotBeUsedHere(), opExpr.Range)) + let _, _, vspecs, envinner, _ = + TcMatchPattern cenv (NewInferenceType g) env tpenv pat None + + vspecs, envinner + | _ -> + // error case + error (Error(FSComp.SR.tcCustomOperationMayNotBeUsedInConjunctionWithNonSimpleLetBindings (), mQueryOp))) + + Some( + trans CompExprTranslationPass.Initial q varSpace innerComp (fun holeFill -> + translatedCtxt (SynExpr.LetOrUse(isRec, false, binds, holeFill, m, trivia))) + ) + + // 'use x = expr in expr' + | SynExpr.LetOrUse( + isUse = true + bindings = [ SynBinding(kind = SynBindingKind.Normal; headPat = pat; expr = rhsExpr; debugPoint = spBind) ] + body = innerComp) -> + let mBind = + match spBind with + | DebugPointAtBinding.Yes m -> m + | _ -> rhsExpr.Range + + if isQuery then + error (Error(FSComp.SR.tcUseMayNotBeUsedInQueries (), mBind)) + + let innerCompRange = innerComp.Range + + let consumeExpr = + SynExpr.MatchLambda( + false, + innerCompRange, + [ + SynMatchClause( + pat, + None, + transNoQueryOps innerComp, + innerCompRange, + DebugPointAtTarget.Yes, + SynMatchClauseTrivia.Zero + ) + ], + DebugPointAtBinding.NoneAtInvisible, + innerCompRange + ) + + if + isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mBind ad "Using" builderTy) + then + error (Error(FSComp.SR.tcRequireBuilderMethod ("Using"), mBind)) + + Some( + translatedCtxt (mkSynCall "Using" mBind [ rhsExpr; consumeExpr ]) + |> addBindDebugPoint spBind + ) + + // 'let! pat = expr in expr' + // --> build.Bind(e1, (fun _argN -> match _argN with pat -> expr)) + // or + // --> build.BindReturn(e1, (fun _argN -> match _argN with pat -> expr-without-return)) + | SynExpr.LetOrUseBang( + bindDebugPoint = spBind + isUse = false + isFromSource = isFromSource + pat = pat + rhs = rhsExpr + andBangs = [] + body = innerComp) -> + + let mBind = + match spBind with + | DebugPointAtBinding.Yes m -> m + | _ -> rhsExpr.Range + + if isQuery then + error (Error(FSComp.SR.tcBindMayNotBeUsedInQueries (), mBind)) - let patvs, _env = varSpace.Force comp.Range - let varSpaceExpr = mkExprForVarSpace mClause patvs - - let dataCompPriorToOp = - let isYield = not (customOperationMaintainsVarSpaceUsingBind nm) - translatedCtxt (transNoQueryOps (SynExpr.YieldOrReturn ((isYield, false), varSpaceExpr, mClause))) - - // Now run the consumeCustomOpClauses - Some (consumeCustomOpClauses q varSpace dataCompPriorToOp comp false mClause) - - | SynExpr.Sequential (sp, true, innerComp1, innerComp2, m) -> - - // Check for 'where x > y' and other mis-applications of infix operators. If detected, give a good error message, and just ignore innerComp1 - if isQuery && checkForBinaryApp innerComp1 then - Some (trans CompExprTranslationPass.Initial q varSpace innerComp2 translatedCtxt) - - else - - if isQuery && not(innerComp1.IsArbExprAndThusAlreadyReportedError) then - match innerComp1 with - | SynExpr.JoinIn _ -> () // an error will be reported later when we process innerComp1 as a sequential - | _ -> errorR(Error(FSComp.SR.tcUnrecognizedQueryOperator(), innerComp1.RangeOfFirstPortion)) - - match tryTrans CompExprTranslationPass.Initial CustomOperationsMode.Denied varSpace innerComp1 id with - | Some c -> - // "cexpr; cexpr" is treated as builder.Combine(cexpr1, cexpr1) - let m1 = rangeForCombine innerComp1 - - if isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env m ad "Combine" builderTy) then - error(Error(FSComp.SR.tcRequireBuilderMethod("Combine"), m)) - - if isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env m ad "Delay" builderTy) then - error(Error(FSComp.SR.tcRequireBuilderMethod("Delay"), m)) - - let combineCall = mkSynCall "Combine" m1 [c; mkSynCall "Delay" m1 [mkSynDelay innerComp2.Range (transNoQueryOps innerComp2)]] - - Some (translatedCtxt combineCall) - - | None -> - // "do! expr; cexpr" is treated as { let! () = expr in cexpr } - match innerComp1 with - | SynExpr.DoBang (rhsExpr, m) -> - let sp = - match sp with - | DebugPointAtSequential.SuppressExpr -> DebugPointAtBinding.NoneAtDo - | DebugPointAtSequential.SuppressBoth -> DebugPointAtBinding.NoneAtDo - | DebugPointAtSequential.SuppressStmt -> DebugPointAtBinding.Yes m - | DebugPointAtSequential.SuppressNeither -> DebugPointAtBinding.Yes m - Some(trans CompExprTranslationPass.Initial q varSpace (SynExpr.LetOrUseBang (sp, false, true, SynPat.Const(SynConst.Unit, rhsExpr.Range), rhsExpr, [], innerComp2, m, SynExprLetOrUseBangTrivia.Zero)) translatedCtxt) - - // "expr; cexpr" is treated as sequential execution - | _ -> - Some (trans CompExprTranslationPass.Initial q varSpace innerComp2 (fun holeFill -> - let fillExpr = - if enableImplicitYield then - // When implicit yields are enabled, then if the 'innerComp1' checks as type - // 'unit' we interpret the expression as a sequential, and when it doesn't - // have type 'unit' we interpret it as a 'Yield + Combine'. - let combineExpr = - let m1 = rangeForCombine innerComp1 - let implicitYieldExpr = mkSynCall "Yield" comp.Range [innerComp1] - mkSynCall "Combine" m1 [implicitYieldExpr; mkSynCall "Delay" m1 [mkSynDelay holeFill.Range holeFill]] - SynExpr.SequentialOrImplicitYield(sp, innerComp1, holeFill, combineExpr, m) - else - SynExpr.Sequential(sp, true, innerComp1, holeFill, m) - translatedCtxt fillExpr)) - - | SynExpr.IfThenElse (guardExpr, thenComp, elseCompOpt, spIfToThen, isRecovery, mIfToEndOfElseBranch, trivia) -> - match elseCompOpt with - | Some elseComp -> - if isQuery then error(Error(FSComp.SR.tcIfThenElseMayNotBeUsedWithinQueries(), trivia.IfToThenRange)) - Some (translatedCtxt (SynExpr.IfThenElse (guardExpr, transNoQueryOps thenComp, Some(transNoQueryOps elseComp), spIfToThen, isRecovery, mIfToEndOfElseBranch, trivia))) - | None -> - let elseComp = - if isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env trivia.IfToThenRange ad "Zero" builderTy) then - error(Error(FSComp.SR.tcRequireBuilderMethod("Zero"), trivia.IfToThenRange)) - mkSynCall "Zero" trivia.IfToThenRange [] - Some (trans CompExprTranslationPass.Initial q varSpace thenComp (fun holeFill -> translatedCtxt (SynExpr.IfThenElse (guardExpr, holeFill, Some elseComp, spIfToThen, isRecovery, mIfToEndOfElseBranch, trivia)))) - - // 'let binds in expr' - | SynExpr.LetOrUse (isRec, false, binds, innerComp, m, trivia) -> - - // For 'query' check immediately - if isQuery then - match (List.map (BindingNormalization.NormalizeBinding ValOrMemberBinding cenv env) binds) with - | [NormalizedBinding(_, SynBindingKind.Normal, false, false, _, _, _, _, _, _, _, _)] when not isRec -> - () - | normalizedBindings -> - let failAt m = error(Error(FSComp.SR.tcNonSimpleLetBindingInQuery(), m)) - match normalizedBindings with - | NormalizedBinding(_, _, _, _, _, _, _, _, _, _, mBinding, _) :: _ -> failAt mBinding - | _ -> failAt m - - // Add the variables to the query variable space, on demand - let varSpace = - addVarsToVarSpace varSpace (fun mQueryOp env -> - // Normalize the bindings before detecting the bound variables - match (List.map (BindingNormalization.NormalizeBinding ValOrMemberBinding cenv env) binds) with - | [NormalizedBinding(_vis, SynBindingKind.Normal, false, false, _, _, _, _, pat, _, _, _)] -> - // successful case + // Add the variables to the query variable space, on demand + let varSpace = + addVarsToVarSpace varSpace (fun _mCustomOp env -> use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink - let _, _, vspecs, envinner, _ = TcMatchPattern cenv (NewInferenceType g) env tpenv pat None - vspecs, envinner - | _ -> - // error case - error(Error(FSComp.SR.tcCustomOperationMayNotBeUsedInConjunctionWithNonSimpleLetBindings(), mQueryOp))) - Some (trans CompExprTranslationPass.Initial q varSpace innerComp (fun holeFill -> translatedCtxt (SynExpr.LetOrUse (isRec, false, binds, holeFill, m, trivia)))) + let _, _, vspecs, envinner, _ = + TcMatchPattern cenv (NewInferenceType g) env tpenv pat None - // 'use x = expr in expr' - | SynExpr.LetOrUse (isUse=true; bindings=[SynBinding (kind=SynBindingKind.Normal; headPat=pat; expr=rhsExpr; debugPoint=spBind)]; body=innerComp) -> - let mBind = match spBind with DebugPointAtBinding.Yes m -> m | _ -> rhsExpr.Range - if isQuery then error(Error(FSComp.SR.tcUseMayNotBeUsedInQueries(), mBind)) - let innerCompRange = innerComp.Range - let consumeExpr = SynExpr.MatchLambda(false, innerCompRange, [SynMatchClause(pat, None, transNoQueryOps innerComp, innerCompRange, DebugPointAtTarget.Yes, SynMatchClauseTrivia.Zero)], DebugPointAtBinding.NoneAtInvisible, innerCompRange) - - if isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mBind ad "Using" builderTy) then - error(Error(FSComp.SR.tcRequireBuilderMethod("Using"), mBind)) - - Some (translatedCtxt (mkSynCall "Using" mBind [rhsExpr; consumeExpr ]) |> addBindDebugPoint spBind) - - // 'let! pat = expr in expr' - // --> build.Bind(e1, (fun _argN -> match _argN with pat -> expr)) - // or - // --> build.BindReturn(e1, (fun _argN -> match _argN with pat -> expr-without-return)) - | SynExpr.LetOrUseBang (bindDebugPoint=spBind; isUse=false; isFromSource=isFromSource; pat=pat; rhs=rhsExpr; andBangs=[]; body=innerComp) -> - - let mBind = match spBind with DebugPointAtBinding.Yes m -> m | _ -> rhsExpr.Range - if isQuery then error(Error(FSComp.SR.tcBindMayNotBeUsedInQueries(), mBind)) - - // Add the variables to the query variable space, on demand - let varSpace = - addVarsToVarSpace varSpace (fun _mCustomOp env -> - use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink - let _, _, vspecs, envinner, _ = TcMatchPattern cenv (NewInferenceType g) env tpenv pat None vspecs, envinner) - let rhsExpr = mkSourceExprConditional isFromSource rhsExpr - Some (transBind q varSpace mBind (addBindDebugPoint spBind) "Bind" [rhsExpr] pat innerComp translatedCtxt) - - // 'use! pat = e1 in e2' --> build.Bind(e1, (function _argN -> match _argN with pat -> build.Using(x, (fun _argN -> match _argN with pat -> e2)))) - | SynExpr.LetOrUseBang (bindDebugPoint=spBind; isUse=true; isFromSource=isFromSource; pat=SynPat.Named (ident=SynIdent(id,_); isThisVal=false) as pat; rhs=rhsExpr; andBangs=[]; body=innerComp) - | SynExpr.LetOrUseBang (bindDebugPoint=spBind; isUse=true; isFromSource=isFromSource; pat=SynPat.LongIdent (longDotId=SynLongIdent([id], _, _)) as pat; rhs=rhsExpr; andBangs=[]; body=innerComp) -> - - let mBind = match spBind with DebugPointAtBinding.Yes m -> m | _ -> rhsExpr.Range - if isQuery then error(Error(FSComp.SR.tcBindMayNotBeUsedInQueries(), mBind)) - - if isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mBind ad "Using" builderTy) then - error(Error(FSComp.SR.tcRequireBuilderMethod("Using"), mBind)) - if isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mBind ad "Bind" builderTy) then - error(Error(FSComp.SR.tcRequireBuilderMethod("Bind"), mBind)) - - let bindExpr = - let consumeExpr = SynExpr.MatchLambda(false, mBind, [SynMatchClause(pat, None, transNoQueryOps innerComp, innerComp.Range, DebugPointAtTarget.Yes, SynMatchClauseTrivia.Zero)], DebugPointAtBinding.NoneAtInvisible, mBind) - let consumeExpr = mkSynCall "Using" mBind [SynExpr.Ident id; consumeExpr ] - let consumeExpr = SynExpr.MatchLambda(false, mBind, [SynMatchClause(pat, None, consumeExpr, id.idRange, DebugPointAtTarget.No, SynMatchClauseTrivia.Zero)], DebugPointAtBinding.NoneAtInvisible, mBind) let rhsExpr = mkSourceExprConditional isFromSource rhsExpr - mkSynCall "Bind" mBind [rhsExpr; consumeExpr] - |> addBindDebugPoint spBind + Some(transBind q varSpace mBind (addBindDebugPoint spBind) "Bind" [ rhsExpr ] pat innerComp translatedCtxt) + + // 'use! pat = e1 in e2' --> build.Bind(e1, (function _argN -> match _argN with pat -> build.Using(x, (fun _argN -> match _argN with pat -> e2)))) + | SynExpr.LetOrUseBang( + bindDebugPoint = spBind + isUse = true + isFromSource = isFromSource + pat = SynPat.Named(ident = SynIdent(id, _); isThisVal = false) as pat + rhs = rhsExpr + andBangs = [] + body = innerComp) + | SynExpr.LetOrUseBang( + bindDebugPoint = spBind + isUse = true + isFromSource = isFromSource + pat = SynPat.LongIdent(longDotId = SynLongIdent(id = [ id ])) as pat + rhs = rhsExpr + andBangs = [] + body = innerComp) -> + + let mBind = + match spBind with + | DebugPointAtBinding.Yes m -> m + | _ -> rhsExpr.Range + + if isQuery then + error (Error(FSComp.SR.tcBindMayNotBeUsedInQueries (), mBind)) + + if + isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mBind ad "Using" builderTy) + then + error (Error(FSComp.SR.tcRequireBuilderMethod ("Using"), mBind)) + + if + isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mBind ad "Bind" builderTy) + then + error (Error(FSComp.SR.tcRequireBuilderMethod ("Bind"), mBind)) + + let bindExpr = + let consumeExpr = + SynExpr.MatchLambda( + false, + mBind, + [ + SynMatchClause( + pat, + None, + transNoQueryOps innerComp, + innerComp.Range, + DebugPointAtTarget.Yes, + SynMatchClauseTrivia.Zero + ) + ], + DebugPointAtBinding.NoneAtInvisible, + mBind + ) + + let consumeExpr = mkSynCall "Using" mBind [ SynExpr.Ident id; consumeExpr ] + + let consumeExpr = + SynExpr.MatchLambda( + false, + mBind, + [ + SynMatchClause(pat, None, consumeExpr, id.idRange, DebugPointAtTarget.No, SynMatchClauseTrivia.Zero) + ], + DebugPointAtBinding.NoneAtInvisible, + mBind + ) + + let rhsExpr = mkSourceExprConditional isFromSource rhsExpr + mkSynCall "Bind" mBind [ rhsExpr; consumeExpr ] |> addBindDebugPoint spBind + + Some(translatedCtxt bindExpr) + + // 'use! pat = e1 ... in e2' where 'pat' is not a simple name --> error + | SynExpr.LetOrUseBang(isUse = true; pat = pat; andBangs = andBangs) -> + if isNil andBangs then + error (Error(FSComp.SR.tcInvalidUseBangBinding (), pat.Range)) + else + error (Error(FSComp.SR.tcInvalidUseBangBindingNoAndBangs (), comp.Range)) + + // 'let! pat1 = expr1 and! pat2 = expr2 in ...' --> + // build.BindN(expr1, expr2, ...) + // or + // build.BindNReturn(expr1, expr2, ...) + // or + // build.Bind(build.MergeSources(expr1, expr2), ...) + | SynExpr.LetOrUseBang( + bindDebugPoint = spBind + isUse = false + isFromSource = isFromSource + pat = letPat + rhs = letRhsExpr + andBangs = andBangBindings + body = innerComp + range = letBindRange) -> + if not (cenv.g.langVersion.SupportsFeature LanguageFeature.AndBang) then + error (Error(FSComp.SR.tcAndBangNotSupported (), comp.Range)) + + if isQuery then + error (Error(FSComp.SR.tcBindMayNotBeUsedInQueries (), letBindRange)) + + let mBind = + match spBind with + | DebugPointAtBinding.Yes m -> m + | _ -> letRhsExpr.Range + + let sources = + (letRhsExpr + :: [ for SynExprAndBang(body = andExpr) in andBangBindings -> andExpr ]) + |> List.map (mkSourceExprConditional isFromSource) + + let pats = + letPat :: [ for SynExprAndBang(pat = andPat) in andBangBindings -> andPat ] + + let sourcesRange = sources |> List.map (fun e -> e.Range) |> List.reduce unionRanges + + let numSources = sources.Length + let bindReturnNName = "Bind" + string numSources + "Return" + let bindNName = "Bind" + string numSources + + // Check if this is a Bind2Return etc. + let hasBindReturnN = + not ( + isNil ( + TryFindIntrinsicOrExtensionMethInfo + ResultCollectionSettings.AtMostOneResult + cenv + env + mBind + ad + bindReturnNName + builderTy + ) + ) + + if hasBindReturnN && Option.isSome (convertSimpleReturnToExpr varSpace innerComp) then + let consumePat = SynPat.Tuple(false, pats, [], letPat.Range) - Some(translatedCtxt bindExpr) + // Add the variables to the query variable space, on demand + let varSpace = + addVarsToVarSpace varSpace (fun _mCustomOp env -> + use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink - // 'use! pat = e1 ... in e2' where 'pat' is not a simple name --> error - | SynExpr.LetOrUseBang (isUse=true; pat=pat; andBangs=andBangs) -> - if isNil andBangs then - error(Error(FSComp.SR.tcInvalidUseBangBinding(), pat.Range)) - else - error(Error(FSComp.SR.tcInvalidUseBangBindingNoAndBangs(), comp.Range)) - - // 'let! pat1 = expr1 and! pat2 = expr2 in ...' --> - // build.BindN(expr1, expr2, ...) - // or - // build.BindNReturn(expr1, expr2, ...) - // or - // build.Bind(build.MergeSources(expr1, expr2), ...) - | SynExpr.LetOrUseBang(bindDebugPoint=spBind; isUse=false; isFromSource=isFromSource; pat=letPat; rhs=letRhsExpr; andBangs=andBangBindings; body=innerComp; range=letBindRange) -> - if not (cenv.g.langVersion.SupportsFeature LanguageFeature.AndBang) then - error(Error(FSComp.SR.tcAndBangNotSupported(), comp.Range)) - - if isQuery then - error(Error(FSComp.SR.tcBindMayNotBeUsedInQueries(), letBindRange)) - - let mBind = match spBind with DebugPointAtBinding.Yes m -> m | _ -> letRhsExpr.Range - let sources = (letRhsExpr :: [for SynExprAndBang(body=andExpr) in andBangBindings -> andExpr ]) |> List.map (mkSourceExprConditional isFromSource) - let pats = letPat :: [for SynExprAndBang(pat = andPat) in andBangBindings -> andPat ] - let sourcesRange = sources |> List.map (fun e -> e.Range) |> List.reduce unionRanges - - let numSources = sources.Length - let bindReturnNName = "Bind"+string numSources+"Return" - let bindNName = "Bind"+string numSources - - // Check if this is a Bind2Return etc. - let hasBindReturnN = not (isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mBind ad bindReturnNName builderTy)) - if hasBindReturnN && Option.isSome (convertSimpleReturnToExpr varSpace innerComp) then - let consumePat = SynPat.Tuple(false, pats, [], letPat.Range) + let _, _, vspecs, envinner, _ = + TcMatchPattern cenv (NewInferenceType g) env tpenv consumePat None - // Add the variables to the query variable space, on demand - let varSpace = - addVarsToVarSpace varSpace (fun _mCustomOp env -> - use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink - let _, _, vspecs, envinner, _ = TcMatchPattern cenv (NewInferenceType g) env tpenv consumePat None vspecs, envinner) - Some (transBind q varSpace mBind (addBindDebugPoint spBind) bindNName sources consumePat innerComp translatedCtxt) - - else + Some(transBind q varSpace mBind (addBindDebugPoint spBind) bindNName sources consumePat innerComp translatedCtxt) - // Check if this is a Bind2 etc. - let hasBindN = not (isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mBind ad bindNName builderTy)) - if hasBindN then - let consumePat = SynPat.Tuple(false, pats, [], letPat.Range) + else - // Add the variables to the query variable space, on demand - let varSpace = - addVarsToVarSpace varSpace (fun _mCustomOp env -> + // Check if this is a Bind2 etc. + let hasBindN = + not ( + isNil ( + TryFindIntrinsicOrExtensionMethInfo + ResultCollectionSettings.AtMostOneResult + cenv + env + mBind + ad + bindNName + builderTy + ) + ) + + if hasBindN then + let consumePat = SynPat.Tuple(false, pats, [], letPat.Range) + + // Add the variables to the query variable space, on demand + let varSpace = + addVarsToVarSpace varSpace (fun _mCustomOp env -> use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink - let _, _, vspecs, envinner, _ = TcMatchPattern cenv (NewInferenceType g) env tpenv consumePat None - vspecs, envinner) - Some (transBind q varSpace mBind (addBindDebugPoint spBind) bindNName sources consumePat innerComp translatedCtxt) - else + let _, _, vspecs, envinner, _ = + TcMatchPattern cenv (NewInferenceType g) env tpenv consumePat None - // Look for the maximum supported MergeSources, MergeSources3, ... - let mkMergeSourcesName n = if n = 2 then "MergeSources" else "MergeSources"+(string n) + vspecs, envinner) - let maxMergeSources = - let rec loop (n: int) = - let mergeSourcesName = mkMergeSourcesName n - if isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mBind ad mergeSourcesName builderTy) then - (n-1) - else - loop (n+1) - loop 2 + Some(transBind q varSpace mBind (addBindDebugPoint spBind) bindNName sources consumePat innerComp translatedCtxt) + else - if maxMergeSources = 1 then error(Error(FSComp.SR.tcRequireMergeSourcesOrBindN(bindNName), mBind)) + // Look for the maximum supported MergeSources, MergeSources3, ... + let mkMergeSourcesName n = + if n = 2 then + "MergeSources" + else + "MergeSources" + (string n) + + let maxMergeSources = + let rec loop (n: int) = + let mergeSourcesName = mkMergeSourcesName n + + if + isNil ( + TryFindIntrinsicOrExtensionMethInfo + ResultCollectionSettings.AtMostOneResult + cenv + env + mBind + ad + mergeSourcesName + builderTy + ) + then + (n - 1) + else + loop (n + 1) + + loop 2 + + if maxMergeSources = 1 then + error (Error(FSComp.SR.tcRequireMergeSourcesOrBindN (bindNName), mBind)) + + let rec mergeSources (sourcesAndPats: (SynExpr * SynPat) list) = + let numSourcesAndPats = sourcesAndPats.Length + assert (numSourcesAndPats <> 0) + + if numSourcesAndPats = 1 then + sourcesAndPats[0] + + elif numSourcesAndPats <= maxMergeSources then + + // Call MergeSources2(e1, e2), MergeSources3(e1, e2, e3) etc + let mergeSourcesName = mkMergeSourcesName numSourcesAndPats + + if + isNil ( + TryFindIntrinsicOrExtensionMethInfo + ResultCollectionSettings.AtMostOneResult + cenv + env + mBind + ad + mergeSourcesName + builderTy + ) + then + error (Error(FSComp.SR.tcRequireMergeSourcesOrBindN (bindNName), mBind)) + + let source = mkSynCall mergeSourcesName sourcesRange (List.map fst sourcesAndPats) + let pat = SynPat.Tuple(false, List.map snd sourcesAndPats, [], letPat.Range) + source, pat - let rec mergeSources (sourcesAndPats: (SynExpr * SynPat) list) = - let numSourcesAndPats = sourcesAndPats.Length - assert (numSourcesAndPats <> 0) - if numSourcesAndPats = 1 then - sourcesAndPats[0] + else - elif numSourcesAndPats <= maxMergeSources then + // Call MergeSourcesMax(e1, e2, e3, e4, (...)) + let nowSourcesAndPats, laterSourcesAndPats = + List.splitAt (maxMergeSources - 1) sourcesAndPats - // Call MergeSources2(e1, e2), MergeSources3(e1, e2, e3) etc - let mergeSourcesName = mkMergeSourcesName numSourcesAndPats + let mergeSourcesName = mkMergeSourcesName maxMergeSources - if isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mBind ad mergeSourcesName builderTy) then - error(Error(FSComp.SR.tcRequireMergeSourcesOrBindN(bindNName), mBind)) + if + isNil ( + TryFindIntrinsicOrExtensionMethInfo + ResultCollectionSettings.AtMostOneResult + cenv + env + mBind + ad + mergeSourcesName + builderTy + ) + then + error (Error(FSComp.SR.tcRequireMergeSourcesOrBindN (bindNName), mBind)) - let source = mkSynCall mergeSourcesName sourcesRange (List.map fst sourcesAndPats) - let pat = SynPat.Tuple(false, List.map snd sourcesAndPats, [], letPat.Range) - source, pat + let laterSource, laterPat = mergeSources laterSourcesAndPats - else + let source = + mkSynCall mergeSourcesName sourcesRange (List.map fst nowSourcesAndPats @ [ laterSource ]) - // Call MergeSourcesMax(e1, e2, e3, e4, (...)) - let nowSourcesAndPats, laterSourcesAndPats = List.splitAt (maxMergeSources - 1) sourcesAndPats - let mergeSourcesName = mkMergeSourcesName maxMergeSources + let pat = + SynPat.Tuple(false, List.map snd nowSourcesAndPats @ [ laterPat ], [], letPat.Range) - if isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mBind ad mergeSourcesName builderTy) then - error(Error(FSComp.SR.tcRequireMergeSourcesOrBindN(bindNName), mBind)) + source, pat - let laterSource, laterPat = mergeSources laterSourcesAndPats - let source = mkSynCall mergeSourcesName sourcesRange (List.map fst nowSourcesAndPats @ [laterSource]) - let pat = SynPat.Tuple(false, List.map snd nowSourcesAndPats @ [laterPat], [], letPat.Range) - source, pat + let mergedSources, consumePat = mergeSources (List.zip sources pats) - let mergedSources, consumePat = mergeSources (List.zip sources pats) - - // Add the variables to the query variable space, on demand - let varSpace = - addVarsToVarSpace varSpace (fun _mCustomOp env -> + // Add the variables to the query variable space, on demand + let varSpace = + addVarsToVarSpace varSpace (fun _mCustomOp env -> use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink - let _, _, vspecs, envinner, _ = TcMatchPattern cenv (NewInferenceType g) env tpenv consumePat None - vspecs, envinner) - - // Build the 'Bind' call - Some (transBind q varSpace mBind (addBindDebugPoint spBind) "Bind" [mergedSources] consumePat innerComp translatedCtxt) - - | SynExpr.Match (spMatch, expr, clauses, m, trivia) -> - if isQuery then error(Error(FSComp.SR.tcMatchMayNotBeUsedWithQuery(), trivia.MatchKeyword)) - let clauses = clauses |> List.map (fun (SynMatchClause(pat, cond, innerComp, patm, sp, trivia)) -> SynMatchClause(pat, cond, transNoQueryOps innerComp, patm, sp, trivia)) - Some(translatedCtxt (SynExpr.Match (spMatch, expr, clauses, m, trivia))) - - // 'match! expr with pats ...' --> build.Bind(e1, (function pats ...)) - // FUTURE: consider allowing translation to BindReturn - | SynExpr.MatchBang (spMatch, expr, clauses, _m, trivia) -> - let inputExpr = mkSourceExpr expr - if isQuery then error(Error(FSComp.SR.tcMatchMayNotBeUsedWithQuery(), trivia.MatchBangKeyword)) - - if isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env trivia.MatchBangKeyword ad "Bind" builderTy) then - error(Error(FSComp.SR.tcRequireBuilderMethod("Bind"), trivia.MatchBangKeyword)) - let clauses = clauses |> List.map (fun (SynMatchClause(pat, cond, innerComp, patm, sp, trivia)) -> SynMatchClause(pat, cond, transNoQueryOps innerComp, patm, sp, trivia)) - let consumeExpr = SynExpr.MatchLambda (false, trivia.MatchBangKeyword, clauses, DebugPointAtBinding.NoneAtInvisible, trivia.MatchBangKeyword) + let _, _, vspecs, envinner, _ = + TcMatchPattern cenv (NewInferenceType g) env tpenv consumePat None - let callExpr = - mkSynCall "Bind" trivia.MatchBangKeyword [inputExpr; consumeExpr] - |> addBindDebugPoint spMatch - - Some(translatedCtxt callExpr) + vspecs, envinner) - | SynExpr.TryWith (innerComp, clauses, mTryToLast, spTry, spWith, trivia) -> - let mTry = match spTry with DebugPointAtTry.Yes _ -> trivia.TryKeyword.NoteSourceConstruct(NotedSourceConstruct.Try) | _ -> trivia.TryKeyword - let spWith2 = match spWith with DebugPointAtWith.Yes _ -> DebugPointAtBinding.Yes trivia.WithKeyword | _ -> DebugPointAtBinding.NoneAtInvisible - - if isQuery then error(Error(FSComp.SR.tcTryWithMayNotBeUsedInQueries(), mTry)) + // Build the 'Bind' call + Some( + transBind + q + varSpace + mBind + (addBindDebugPoint spBind) + "Bind" + [ mergedSources ] + consumePat + innerComp + translatedCtxt + ) + + | SynExpr.Match(spMatch, expr, clauses, m, trivia) -> + if isQuery then + error (Error(FSComp.SR.tcMatchMayNotBeUsedWithQuery (), trivia.MatchKeyword)) + + let clauses = + clauses + |> List.map (fun (SynMatchClause(pat, cond, innerComp, patm, sp, trivia)) -> + SynMatchClause(pat, cond, transNoQueryOps innerComp, patm, sp, trivia)) + + Some(translatedCtxt (SynExpr.Match(spMatch, expr, clauses, m, trivia))) + + // 'match! expr with pats ...' --> build.Bind(e1, (function pats ...)) + // FUTURE: consider allowing translation to BindReturn + | SynExpr.MatchBang(spMatch, expr, clauses, _m, trivia) -> + let inputExpr = mkSourceExpr expr + + if isQuery then + error (Error(FSComp.SR.tcMatchMayNotBeUsedWithQuery (), trivia.MatchBangKeyword)) + + if + isNil ( + TryFindIntrinsicOrExtensionMethInfo + ResultCollectionSettings.AtMostOneResult + cenv + env + trivia.MatchBangKeyword + ad + "Bind" + builderTy + ) + then + error (Error(FSComp.SR.tcRequireBuilderMethod ("Bind"), trivia.MatchBangKeyword)) + + let clauses = + clauses + |> List.map (fun (SynMatchClause(pat, cond, innerComp, patm, sp, trivia)) -> + SynMatchClause(pat, cond, transNoQueryOps innerComp, patm, sp, trivia)) + + let consumeExpr = + SynExpr.MatchLambda( + false, + trivia.MatchBangKeyword, + clauses, + DebugPointAtBinding.NoneAtInvisible, + trivia.MatchBangKeyword + ) + + let callExpr = + mkSynCall "Bind" trivia.MatchBangKeyword [ inputExpr; consumeExpr ] + |> addBindDebugPoint spMatch + + Some(translatedCtxt callExpr) + + | SynExpr.TryWith(innerComp, clauses, mTryToLast, spTry, spWith, trivia) -> + let mTry = + match spTry with + | DebugPointAtTry.Yes _ -> trivia.TryKeyword.NoteSourceConstruct(NotedSourceConstruct.Try) + | _ -> trivia.TryKeyword + + let spWith2 = + match spWith with + | DebugPointAtWith.Yes _ -> DebugPointAtBinding.Yes trivia.WithKeyword + | _ -> DebugPointAtBinding.NoneAtInvisible + + if isQuery then + error (Error(FSComp.SR.tcTryWithMayNotBeUsedInQueries (), mTry)) + + let clauses = + clauses + |> List.map (fun (SynMatchClause(pat, cond, clauseComp, patm, sp, trivia)) -> + SynMatchClause(pat, cond, transNoQueryOps clauseComp, patm, sp, trivia)) + + let consumeExpr = + SynExpr.MatchLambda(true, mTryToLast, clauses, spWith2, mTryToLast) + + if + isNil ( + TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mTry ad "TryWith" builderTy + ) + then + error (Error(FSComp.SR.tcRequireBuilderMethod ("TryWith"), mTry)) + + if + isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mTry ad "Delay" builderTy) + then + error (Error(FSComp.SR.tcRequireBuilderMethod ("Delay"), mTry)) + + let innerExpr = transNoQueryOps innerComp + + let innerExpr = + match spTry with + | DebugPointAtTry.Yes _ -> SynExpr.DebugPoint(DebugPointAtLeafExpr.Yes mTry, true, innerExpr) + | _ -> innerExpr + + let callExpr = + mkSynCall "TryWith" mTry [ mkSynCall "Delay" mTry [ mkSynDelay2 innerExpr ]; consumeExpr ] + + Some(translatedCtxt callExpr) + + | SynExpr.YieldOrReturnFrom((true, _), synYieldExpr, m) -> + let yieldFromExpr = mkSourceExpr synYieldExpr + + if + isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env m ad "YieldFrom" builderTy) + then + error (Error(FSComp.SR.tcRequireBuilderMethod ("YieldFrom"), m)) + + let yieldFromCall = mkSynCall "YieldFrom" m [ yieldFromExpr ] + + let yieldFromCall = + if IsControlFlowExpression synYieldExpr then + yieldFromCall + else + SynExpr.DebugPoint(DebugPointAtLeafExpr.Yes m, false, yieldFromCall) - let clauses = clauses |> List.map (fun (SynMatchClause(pat, cond, clauseComp, patm, sp, trivia)) -> SynMatchClause(pat, cond, transNoQueryOps clauseComp, patm, sp, trivia)) - let consumeExpr = SynExpr.MatchLambda(true, mTryToLast, clauses, spWith2, mTryToLast) + Some(translatedCtxt yieldFromCall) - if isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mTry ad "TryWith" builderTy) then - error(Error(FSComp.SR.tcRequireBuilderMethod("TryWith"), mTry)) + | SynExpr.YieldOrReturnFrom((false, _), synReturnExpr, m) -> + let returnFromExpr = mkSourceExpr synReturnExpr - if isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mTry ad "Delay" builderTy) then - error(Error(FSComp.SR.tcRequireBuilderMethod("Delay"), mTry)) + if isQuery then + error (Error(FSComp.SR.tcReturnMayNotBeUsedInQueries (), m)) - let innerExpr = transNoQueryOps innerComp + if + isNil ( + TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env m ad "ReturnFrom" builderTy + ) + then + error (Error(FSComp.SR.tcRequireBuilderMethod ("ReturnFrom"), m)) - let innerExpr = - match spTry with - | DebugPointAtTry.Yes _ -> - SynExpr.DebugPoint(DebugPointAtLeafExpr.Yes mTry, true, innerExpr) - | _ -> innerExpr - - let callExpr = - mkSynCall "TryWith" mTry [ - mkSynCall "Delay" mTry [mkSynDelay2 innerExpr] - consumeExpr - ] - - Some(translatedCtxt callExpr) - - | SynExpr.YieldOrReturnFrom ((true, _), synYieldExpr, m) -> - let yieldFromExpr = mkSourceExpr synYieldExpr - if isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env m ad "YieldFrom" builderTy) then - error(Error(FSComp.SR.tcRequireBuilderMethod("YieldFrom"), m)) - - let yieldFromCall = mkSynCall "YieldFrom" m [yieldFromExpr] - - let yieldFromCall = - if IsControlFlowExpression synYieldExpr then - yieldFromCall - else - SynExpr.DebugPoint(DebugPointAtLeafExpr.Yes m, false, yieldFromCall) + let returnFromCall = mkSynCall "ReturnFrom" m [ returnFromExpr ] - Some (translatedCtxt yieldFromCall) - - | SynExpr.YieldOrReturnFrom ((false, _), synReturnExpr, m) -> - let returnFromExpr = mkSourceExpr synReturnExpr - if isQuery then error(Error(FSComp.SR.tcReturnMayNotBeUsedInQueries(), m)) - - if isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env m ad "ReturnFrom" builderTy) then - error(Error(FSComp.SR.tcRequireBuilderMethod("ReturnFrom"), m)) + let returnFromCall = + if IsControlFlowExpression synReturnExpr then + returnFromCall + else + SynExpr.DebugPoint(DebugPointAtLeafExpr.Yes m, false, returnFromCall) - let returnFromCall = mkSynCall "ReturnFrom" m [returnFromExpr] + Some(translatedCtxt returnFromCall) - let returnFromCall = - if IsControlFlowExpression synReturnExpr then - returnFromCall - else - SynExpr.DebugPoint(DebugPointAtLeafExpr.Yes m, false, returnFromCall) + | SynExpr.YieldOrReturn((isYield, _), synYieldOrReturnExpr, m) -> + let methName = (if isYield then "Yield" else "Return") - Some (translatedCtxt returnFromCall) + if isQuery && not isYield then + error (Error(FSComp.SR.tcReturnMayNotBeUsedInQueries (), m)) - | SynExpr.YieldOrReturn ((isYield, _), synYieldOrReturnExpr, m) -> - let methName = (if isYield then "Yield" else "Return") - if isQuery && not isYield then error(Error(FSComp.SR.tcReturnMayNotBeUsedInQueries(), m)) + if + isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env m ad methName builderTy) + then + error (Error(FSComp.SR.tcRequireBuilderMethod (methName), m)) - if isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env m ad methName builderTy) then - error(Error(FSComp.SR.tcRequireBuilderMethod(methName), m)) + let yieldOrReturnCall = mkSynCall methName m [ synYieldOrReturnExpr ] - let yieldOrReturnCall = mkSynCall methName m [synYieldOrReturnExpr] - - let yieldOrReturnCall = - if IsControlFlowExpression synYieldOrReturnExpr then - yieldOrReturnCall - else - SynExpr.DebugPoint(DebugPointAtLeafExpr.Yes m, false, yieldOrReturnCall) + let yieldOrReturnCall = + if IsControlFlowExpression synYieldOrReturnExpr then + yieldOrReturnCall + else + SynExpr.DebugPoint(DebugPointAtLeafExpr.Yes m, false, yieldOrReturnCall) - Some(translatedCtxt yieldOrReturnCall) + Some(translatedCtxt yieldOrReturnCall) - | _ -> None + | _ -> None and consumeCustomOpClauses q (varSpace: LazyWithContext<_, _>) dataCompPrior compClausesExpr lastUsesBind mClause = @@ -1536,10 +2404,10 @@ let TcComputationExpression (cenv: cenv) env (overallTy: OverallTy) tpenv (mWhol let varSpaceSimplePat = mkSimplePatForVarSpace mClause patvs let varSpacePat = mkPatForVarSpace mClause patvs - match compClausesExpr with - + match compClausesExpr with + // Detect one custom operation... This clause will always match at least once... - | OptionalSequential (CustomOperationClause (nm, opDatas, opExpr, mClause, optionalIntoPat), optionalCont) -> + | OptionalSequential(CustomOperationClause(nm, opDatas, opExpr, mClause, optionalIntoPat), optionalCont) -> let opName, _, _, _, _, _, _, _, methInfo = opDatas[0] let isLikeZip = customOperationIsLikeZip nm @@ -1547,16 +2415,18 @@ let TcComputationExpression (cenv: cenv) env (overallTy: OverallTy) tpenv (mWhol let isLikeGroupJoin = customOperationIsLikeZip nm // Record the resolution of the custom operation for posterity - let item = Item.CustomOperation (opName, (fun () -> customOpUsageText nm), Some methInfo) + let item = + Item.CustomOperation(opName, (fun () -> customOpUsageText nm), Some methInfo) // FUTURE: consider whether we can do better than emptyTyparInst here, in order to display instantiations // of type variables in the quick info provided in the IDE. CallNameResolutionSink cenv.tcSink (nm.idRange, env.NameEnv, item, emptyTyparInst, ItemOccurence.Use, env.eAccessRights) if isLikeZip || isLikeJoin || isLikeGroupJoin then - errorR(Error(FSComp.SR.tcBinaryOperatorRequiresBody(nm.idText, Option.get (customOpUsageText nm)), nm.idRange)) - match optionalCont with - | None -> + errorR (Error(FSComp.SR.tcBinaryOperatorRequiresBody (nm.idText, Option.get (customOpUsageText nm)), nm.idRange)) + + match optionalCont with + | None -> // we are about to drop the 'opExpr' AST on the floor. we've already reported an error. attempt to get name resolutions before dropping it RecordNameAndTypeResolutions cenv env tpenv opExpr dataCompPrior @@ -1568,217 +2438,346 @@ let TcComputationExpression (cenv: cenv) env (overallTy: OverallTy) tpenv (mWhol let expectedArgCount = tryExpectedArgCountForCustomOperator nm - let dataCompAfterOp = - match opExpr with + let dataCompAfterOp = + match opExpr with | StripApps(SingleIdent nm, args) -> let argCountsMatch = match expectedArgCount with | Some n -> n = args.Length | None -> cenv.g.langVersion.SupportsFeature LanguageFeature.OverloadsForCustomOperations + if argCountsMatch then // Check for the [] attribute on each argument position - let args = args |> List.mapi (fun i arg -> - if isCustomOperationProjectionParameter (i+1) nm then - SynExpr.Lambda (false, false, varSpaceSimplePat, arg, None, arg.Range.MakeSynthetic(), SynExprLambdaTrivia.Zero) - else arg) + let args = + args + |> List.mapi (fun i arg -> + if isCustomOperationProjectionParameter (i + 1) nm then + SynExpr.Lambda( + false, + false, + varSpaceSimplePat, + arg, + None, + arg.Range.MakeSynthetic(), + SynExprLambdaTrivia.Zero + ) + else + arg) + mkSynCall methInfo.DisplayName mClause (dataCompPrior :: args) - else + else let expectedArgCount = defaultArg expectedArgCount 0 - errorR(Error(FSComp.SR.tcCustomOperationHasIncorrectArgCount(nm.idText, expectedArgCount, args.Length), nm.idRange)) - mkSynCall methInfo.DisplayName mClause ([ dataCompPrior ] @ List.init expectedArgCount (fun i -> arbExpr("_arg" + string i, mClause))) + + errorR ( + Error( + FSComp.SR.tcCustomOperationHasIncorrectArgCount (nm.idText, expectedArgCount, args.Length), + nm.idRange + ) + ) + + mkSynCall + methInfo.DisplayName + mClause + ([ dataCompPrior ] + @ List.init expectedArgCount (fun i -> arbExpr ("_arg" + string i, mClause))) | _ -> failwith "unreachable" - match optionalCont with - | None -> - match optionalIntoPat with - | Some intoPat -> errorR(Error(FSComp.SR.tcIntoNeedsRestOfQuery(), intoPat.Range)) + match optionalCont with + | None -> + match optionalIntoPat with + | Some intoPat -> errorR (Error(FSComp.SR.tcIntoNeedsRestOfQuery (), intoPat.Range)) | None -> () + dataCompAfterOp - | Some contExpr -> - - // select a.Name into name; ... - // distinct into d; ... - // - // Rebind the into pattern and process the rest of the clauses - match optionalIntoPat with - | Some intoPat -> - if not (customOperationAllowsInto nm) then - error(Error(FSComp.SR.tcOperatorDoesntAcceptInto(nm.idText), intoPat.Range)) - - // Rebind using either for ... or let!.... - let rebind = - if maintainsVarSpaceUsingBind then - SynExpr.LetOrUseBang (DebugPointAtBinding.NoneAtLet, false, false, intoPat, dataCompAfterOp, [], contExpr, intoPat.Range, SynExprLetOrUseBangTrivia.Zero) - else - SynExpr.ForEach (DebugPointAtFor.No, DebugPointAtInOrTo.No, SeqExprOnly false, false, intoPat, dataCompAfterOp, contExpr, intoPat.Range) - - trans CompExprTranslationPass.Initial q emptyVarSpace rebind id - - // select a.Name; ... - // distinct; ... - // - // Process the rest of the clauses - | None -> - if maintainsVarSpace || maintainsVarSpaceUsingBind then - consumeCustomOpClauses q varSpace dataCompAfterOp contExpr maintainsVarSpaceUsingBind mClause + | Some contExpr -> + + // select a.Name into name; ... + // distinct into d; ... + // + // Rebind the into pattern and process the rest of the clauses + match optionalIntoPat with + | Some intoPat -> + if not (customOperationAllowsInto nm) then + error (Error(FSComp.SR.tcOperatorDoesntAcceptInto (nm.idText), intoPat.Range)) + + // Rebind using either for ... or let!.... + let rebind = + if maintainsVarSpaceUsingBind then + SynExpr.LetOrUseBang( + DebugPointAtBinding.NoneAtLet, + false, + false, + intoPat, + dataCompAfterOp, + [], + contExpr, + intoPat.Range, + SynExprLetOrUseBangTrivia.Zero + ) else - consumeCustomOpClauses q emptyVarSpace dataCompAfterOp contExpr false mClause + SynExpr.ForEach( + DebugPointAtFor.No, + DebugPointAtInOrTo.No, + SeqExprOnly false, + false, + intoPat, + dataCompAfterOp, + contExpr, + intoPat.Range + ) + + trans CompExprTranslationPass.Initial q emptyVarSpace rebind id + + // select a.Name; ... + // distinct; ... + // + // Process the rest of the clauses + | None -> + if maintainsVarSpace || maintainsVarSpaceUsingBind then + consumeCustomOpClauses q varSpace dataCompAfterOp contExpr maintainsVarSpaceUsingBind mClause + else + consumeCustomOpClauses q emptyVarSpace dataCompAfterOp contExpr false mClause - // No more custom operator clauses in compClausesExpr, but there may be clauses like join, yield etc. + // No more custom operator clauses in compClausesExpr, but there may be clauses like join, yield etc. // Bind/iterate the dataCompPrior and use compClausesExpr as the body. - | _ -> + | _ -> // Rebind using either for ... or let!.... - let rebind = - if lastUsesBind then - SynExpr.LetOrUseBang (DebugPointAtBinding.NoneAtLet, false, false, varSpacePat, dataCompPrior, [], compClausesExpr, compClausesExpr.Range, SynExprLetOrUseBangTrivia.Zero) - else - SynExpr.ForEach (DebugPointAtFor.No, DebugPointAtInOrTo.No, SeqExprOnly false, false, varSpacePat, dataCompPrior, compClausesExpr, compClausesExpr.Range) - + let rebind = + if lastUsesBind then + SynExpr.LetOrUseBang( + DebugPointAtBinding.NoneAtLet, + false, + false, + varSpacePat, + dataCompPrior, + [], + compClausesExpr, + compClausesExpr.Range, + SynExprLetOrUseBangTrivia.Zero + ) + else + SynExpr.ForEach( + DebugPointAtFor.No, + DebugPointAtInOrTo.No, + SeqExprOnly false, + false, + varSpacePat, + dataCompPrior, + compClausesExpr, + compClausesExpr.Range + ) + trans CompExprTranslationPass.Initial q varSpace rebind id and transNoQueryOps comp = trans CompExprTranslationPass.Initial CustomOperationsMode.Denied emptyVarSpace comp id - and trans firstTry q varSpace comp translatedCtxt = - match tryTrans firstTry q varSpace comp translatedCtxt with + and trans firstTry q varSpace comp translatedCtxt = + match tryTrans firstTry q varSpace comp translatedCtxt with | Some e -> e - | None -> + | None -> // This only occurs in final position in a sequence - match comp with + match comp with // "do! expr;" in final position is treated as { let! () = expr in return () } when Return is provided (and no Zero with Default attribute is available) or as { let! () = expr in zero } otherwise - | SynExpr.DoBang (rhsExpr, m) -> + | SynExpr.DoBang(rhsExpr, m) -> let mUnit = rhsExpr.Range let rhsExpr = mkSourceExpr rhsExpr - if isQuery then error(Error(FSComp.SR.tcBindMayNotBeUsedInQueries(), m)) + + if isQuery then + error (Error(FSComp.SR.tcBindMayNotBeUsedInQueries (), m)) + let bodyExpr = - if isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env m ad "Return" builderTy) then + if + isNil ( + TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env m ad "Return" builderTy + ) + then SynExpr.ImplicitZero m else - match TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env m ad "Zero" builderTy with + match + TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env m ad "Zero" builderTy + with | minfo :: _ when MethInfoHasAttribute cenv.g m cenv.g.attrib_DefaultValueAttribute minfo -> SynExpr.ImplicitZero m - | _ -> SynExpr.YieldOrReturn ((false, true), SynExpr.Const (SynConst.Unit, m), m) - let letBangBind = SynExpr.LetOrUseBang (DebugPointAtBinding.NoneAtDo, false, false, SynPat.Const(SynConst.Unit, mUnit), rhsExpr, [], bodyExpr, m, SynExprLetOrUseBangTrivia.Zero) + | _ -> SynExpr.YieldOrReturn((false, true), SynExpr.Const(SynConst.Unit, m), m) + + let letBangBind = + SynExpr.LetOrUseBang( + DebugPointAtBinding.NoneAtDo, + false, + false, + SynPat.Const(SynConst.Unit, mUnit), + rhsExpr, + [], + bodyExpr, + m, + SynExprLetOrUseBangTrivia.Zero + ) + trans CompExprTranslationPass.Initial q varSpace letBangBind translatedCtxt // "expr;" in final position is treated as { expr; zero } // Suppress the sequence point on the "zero" - | _ -> + | _ -> // Check for 'where x > y' and other mis-applications of infix operators. If detected, give a good error message, and just ignore comp - if isQuery && checkForBinaryApp comp then + if isQuery && checkForBinaryApp comp then trans CompExprTranslationPass.Initial q varSpace (SynExpr.ImplicitZero comp.Range) translatedCtxt else - if isQuery && not comp.IsArbExprAndThusAlreadyReportedError then - match comp with + if isQuery && not comp.IsArbExprAndThusAlreadyReportedError then + match comp with | SynExpr.JoinIn _ -> () // an error will be reported later when we process innerComp1 as a sequential - | _ -> errorR(Error(FSComp.SR.tcUnrecognizedQueryOperator(), comp.RangeOfFirstPortion)) + | _ -> errorR (Error(FSComp.SR.tcUnrecognizedQueryOperator (), comp.RangeOfFirstPortion)) + trans CompExprTranslationPass.Initial q varSpace (SynExpr.ImplicitZero comp.Range) (fun holeFill -> - let fillExpr = - if enableImplicitYield then - let implicitYieldExpr = mkSynCall "Yield" comp.Range [comp] - SynExpr.SequentialOrImplicitYield(DebugPointAtSequential.SuppressExpr, comp, holeFill, implicitYieldExpr, comp.Range) + let fillExpr = + if enableImplicitYield then + let implicitYieldExpr = mkSynCall "Yield" comp.Range [ comp ] + + SynExpr.SequentialOrImplicitYield( + DebugPointAtSequential.SuppressExpr, + comp, + holeFill, + implicitYieldExpr, + comp.Range + ) else SynExpr.Sequential(DebugPointAtSequential.SuppressExpr, true, comp, holeFill, comp.Range) - translatedCtxt fillExpr) - and transBind q varSpace bindRange addBindDebugPoint bindName bindArgs (consumePat: SynPat) (innerComp: SynExpr) translatedCtxt = + translatedCtxt fillExpr) + + and transBind q varSpace bindRange addBindDebugPoint bindName bindArgs (consumePat: SynPat) (innerComp: SynExpr) translatedCtxt = let innerRange = innerComp.Range - - let innerCompReturn = + + let innerCompReturn = if cenv.g.langVersion.SupportsFeature LanguageFeature.AndBang then convertSimpleReturnToExpr varSpace innerComp - else None + else + None + + match innerCompReturn with + | Some(innerExpr, customOpInfo) when + (let bindName = bindName + "Return" - match innerCompReturn with - | Some (innerExpr, customOpInfo) when - (let bindName = bindName + "Return" - not (isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env bindRange ad bindName builderTy))) -> + not ( + isNil ( + TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env bindRange ad bindName builderTy + ) + )) + -> let bindName = bindName + "Return" - + // Build the `BindReturn` call let dataCompPriorToOp = - let consumeExpr = SynExpr.MatchLambda(false, consumePat.Range, [SynMatchClause(consumePat, None, innerExpr, innerRange, DebugPointAtTarget.Yes, SynMatchClauseTrivia.Zero)], DebugPointAtBinding.NoneAtInvisible, innerRange) - translatedCtxt (mkSynCall bindName bindRange (bindArgs @ [consumeExpr])) - - match customOpInfo with + let consumeExpr = + SynExpr.MatchLambda( + false, + consumePat.Range, + [ + SynMatchClause(consumePat, None, innerExpr, innerRange, DebugPointAtTarget.Yes, SynMatchClauseTrivia.Zero) + ], + DebugPointAtBinding.NoneAtInvisible, + innerRange + ) + + translatedCtxt (mkSynCall bindName bindRange (bindArgs @ [ consumeExpr ])) + + match customOpInfo with | None -> dataCompPriorToOp - | Some (innerComp, mClause) -> + | Some(innerComp, mClause) -> // If the `BindReturn` was forced by a custom operation, continue to process the clauses of the CustomOp consumeCustomOpClauses q varSpace dataCompPriorToOp innerComp false mClause - | _ -> + | _ -> - if isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env bindRange ad bindName builderTy) then - error(Error(FSComp.SR.tcRequireBuilderMethod(bindName), bindRange)) + if + isNil ( + TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env bindRange ad bindName builderTy + ) + then + error (Error(FSComp.SR.tcRequireBuilderMethod (bindName), bindRange)) // Build the `Bind` call trans CompExprTranslationPass.Initial q varSpace innerComp (fun holeFill -> - let consumeExpr = SynExpr.MatchLambda(false, consumePat.Range, [SynMatchClause(consumePat, None, holeFill, innerRange, DebugPointAtTarget.Yes, SynMatchClauseTrivia.Zero)], DebugPointAtBinding.NoneAtInvisible, innerRange) - let bindCall = mkSynCall bindName bindRange (bindArgs @ [consumeExpr]) + let consumeExpr = + SynExpr.MatchLambda( + false, + consumePat.Range, + [ + SynMatchClause(consumePat, None, holeFill, innerRange, DebugPointAtTarget.Yes, SynMatchClauseTrivia.Zero) + ], + DebugPointAtBinding.NoneAtInvisible, + innerRange + ) + + let bindCall = mkSynCall bindName bindRange (bindArgs @ [ consumeExpr ]) translatedCtxt (bindCall |> addBindDebugPoint)) /// This function is for desugaring into .Bind{N}Return calls if possible /// The outer option indicates if .BindReturn is possible. When it returns None, .BindReturn cannot be used /// The inner option indicates if a custom operation is involved inside and convertSimpleReturnToExpr varSpace innerComp = - match innerComp with - | SynExpr.YieldOrReturn ((false, _), returnExpr, m) -> + match innerComp with + | SynExpr.YieldOrReturn((false, _), returnExpr, m) -> let returnExpr = SynExpr.DebugPoint(DebugPointAtLeafExpr.Yes m, false, returnExpr) - Some (returnExpr, None) + Some(returnExpr, None) - | SynExpr.Match (spMatch, expr, clauses, m, trivia) -> - let clauses = - clauses |> List.map (fun (SynMatchClause(pat, cond, innerComp2, patm, sp, trivia)) -> + | SynExpr.Match(spMatch, expr, clauses, m, trivia) -> + let clauses = + clauses + |> List.map (fun (SynMatchClause(pat, cond, innerComp2, patm, sp, trivia)) -> match convertSimpleReturnToExpr varSpace innerComp2 with | None -> None // failure - | Some (_, Some _) -> None // custom op on branch = failure - | Some (innerExpr2, None) -> Some (SynMatchClause(pat, cond, innerExpr2, patm, sp, trivia))) + | Some(_, Some _) -> None // custom op on branch = failure + | Some(innerExpr2, None) -> Some(SynMatchClause(pat, cond, innerExpr2, patm, sp, trivia))) + if clauses |> List.forall Option.isSome then - Some (SynExpr.Match (spMatch, expr, (clauses |> List.map Option.get), m, trivia), None) + Some(SynExpr.Match(spMatch, expr, (clauses |> List.map Option.get), m, trivia), None) else None - | SynExpr.IfThenElse (guardExpr, thenComp, elseCompOpt, spIfToThen, isRecovery, mIfToEndOfElseBranch, trivia) -> + | SynExpr.IfThenElse(guardExpr, thenComp, elseCompOpt, spIfToThen, isRecovery, mIfToEndOfElseBranch, trivia) -> match convertSimpleReturnToExpr varSpace thenComp with | None -> None - | Some (_, Some _) -> None - | Some (thenExpr, None) -> - let elseExprOptOpt = - match elseCompOpt with - // When we are missing an 'else' part alltogether in case of 'if cond then return exp', we fallback from BindReturn into regular Bind+Return - | None -> None - | Some elseComp -> - match convertSimpleReturnToExpr varSpace elseComp with - | None -> None // failure - | Some (_, Some _) -> None // custom op on branch = failure - | Some (elseExpr, None) -> Some (Some elseExpr) - match elseExprOptOpt with - | None -> None - | Some elseExprOpt -> Some (SynExpr.IfThenElse (guardExpr, thenExpr, elseExprOpt, spIfToThen, isRecovery, mIfToEndOfElseBranch, trivia), None) + | Some(_, Some _) -> None + | Some(thenExpr, None) -> + let elseExprOptOpt = + match elseCompOpt with + // When we are missing an 'else' part alltogether in case of 'if cond then return exp', we fallback from BindReturn into regular Bind+Return + | None -> None + | Some elseComp -> + match convertSimpleReturnToExpr varSpace elseComp with + | None -> None // failure + | Some(_, Some _) -> None // custom op on branch = failure + | Some(elseExpr, None) -> Some(Some elseExpr) + + match elseExprOptOpt with + | None -> None + | Some elseExprOpt -> + Some(SynExpr.IfThenElse(guardExpr, thenExpr, elseExprOpt, spIfToThen, isRecovery, mIfToEndOfElseBranch, trivia), None) - | SynExpr.LetOrUse (isRec, false, binds, innerComp, m, trivia) -> + | SynExpr.LetOrUse(isRec, false, binds, innerComp, m, trivia) -> match convertSimpleReturnToExpr varSpace innerComp with | None -> None - | Some (_, Some _) -> None - | Some (innerExpr, None) -> Some (SynExpr.LetOrUse (isRec, false, binds, innerExpr, m, trivia), None) + | Some(_, Some _) -> None + | Some(innerExpr, None) -> Some(SynExpr.LetOrUse(isRec, false, binds, innerExpr, m, trivia), None) - | OptionalSequential (CustomOperationClause (nm, _, _, mClause, _), _) when customOperationMaintainsVarSpaceUsingBind nm -> + | OptionalSequential(CustomOperationClause(nm, _, _, mClause, _), _) when customOperationMaintainsVarSpaceUsingBind nm -> let patvs, _env = varSpace.Force comp.Range let varSpaceExpr = mkExprForVarSpace mClause patvs - - Some (varSpaceExpr, Some (innerComp, mClause)) - | SynExpr.Sequential (sp, true, innerComp1, innerComp2, m) -> + Some(varSpaceExpr, Some(innerComp, mClause)) + + | SynExpr.Sequential(sp, true, innerComp1, innerComp2, m) -> // Check the first part isn't a computation expression construct if isSimpleExpr innerComp1 then // Check the second part is a simple return match convertSimpleReturnToExpr varSpace innerComp2 with | None -> None - | Some (innerExpr2, optionalCont) -> Some (SynExpr.Sequential (sp, true, innerComp1, innerExpr2, m), optionalCont) + | Some(innerExpr2, optionalCont) -> Some(SynExpr.Sequential(sp, true, innerComp1, innerExpr2, m), optionalCont) else None @@ -1787,7 +2786,7 @@ let TcComputationExpression (cenv: cenv) env (overallTy: OverallTy) tpenv (mWhol /// Check if an expression has no computation expression constructs and isSimpleExpr comp = - match comp with + match comp with | ForEachThenJoinOrGroupJoinOrZipClause false _ -> false | SynExpr.ForEach _ -> false | SynExpr.For _ -> false @@ -1795,61 +2794,85 @@ let TcComputationExpression (cenv: cenv) env (overallTy: OverallTy) tpenv (mWhol | SynExpr.WhileBang _ -> false | SynExpr.TryFinally _ -> false | SynExpr.ImplicitZero _ -> false - | OptionalSequential (JoinOrGroupJoinOrZipClause _, _) -> false - | OptionalSequential (CustomOperationClause _, _) -> false - | SynExpr.Sequential (_, _, innerComp1, innerComp2, _) -> isSimpleExpr innerComp1 && isSimpleExpr innerComp2 - | SynExpr.IfThenElse (thenExpr=thenComp; elseExpr=elseCompOpt) -> - isSimpleExpr thenComp && (match elseCompOpt with None -> true | Some c -> isSimpleExpr c) - | SynExpr.LetOrUse (body=innerComp) -> isSimpleExpr innerComp + | OptionalSequential(JoinOrGroupJoinOrZipClause _, _) -> false + | OptionalSequential(CustomOperationClause _, _) -> false + | SynExpr.Sequential(_, _, innerComp1, innerComp2, _) -> isSimpleExpr innerComp1 && isSimpleExpr innerComp2 + | SynExpr.IfThenElse(thenExpr = thenComp; elseExpr = elseCompOpt) -> + isSimpleExpr thenComp + && (match elseCompOpt with + | None -> true + | Some c -> isSimpleExpr c) + | SynExpr.LetOrUse(body = innerComp) -> isSimpleExpr innerComp | SynExpr.LetOrUseBang _ -> false - | SynExpr.Match (clauses=clauses) -> - clauses |> List.forall (fun (SynMatchClause(resultExpr = innerComp)) -> isSimpleExpr innerComp) + | SynExpr.Match(clauses = clauses) -> + clauses + |> List.forall (fun (SynMatchClause(resultExpr = innerComp)) -> isSimpleExpr innerComp) | SynExpr.MatchBang _ -> false - | SynExpr.TryWith (tryExpr=innerComp; withCases=clauses) -> - isSimpleExpr innerComp && - clauses |> List.forall (fun (SynMatchClause(resultExpr = clauseComp)) -> isSimpleExpr clauseComp) + | SynExpr.TryWith(tryExpr = innerComp; withCases = clauses) -> + isSimpleExpr innerComp + && clauses + |> List.forall (fun (SynMatchClause(resultExpr = clauseComp)) -> isSimpleExpr clauseComp) | SynExpr.YieldOrReturnFrom _ -> false | SynExpr.YieldOrReturn _ -> false | SynExpr.DoBang _ -> false | _ -> true - let basicSynExpr = - trans CompExprTranslationPass.Initial (hasCustomOperations ()) (LazyWithContext.NotLazy ([], env)) comp id + let basicSynExpr = + trans CompExprTranslationPass.Initial (hasCustomOperations ()) (LazyWithContext.NotLazy([], env)) comp id - let mDelayOrQuoteOrRun = mBuilderVal.NoteSourceConstruct(NotedSourceConstruct.DelayOrQuoteOrRun).MakeSynthetic() + let mDelayOrQuoteOrRun = + mBuilderVal + .NoteSourceConstruct(NotedSourceConstruct.DelayOrQuoteOrRun) + .MakeSynthetic() // Add a call to 'Delay' if the method is present - let delayedExpr = - match TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mBuilderVal ad "Delay" builderTy with + let delayedExpr = + match TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mBuilderVal ad "Delay" builderTy with | [] -> basicSynExpr - | _ -> - mkSynCall "Delay" mDelayOrQuoteOrRun [(mkSynDelay2 basicSynExpr)] + | _ -> mkSynCall "Delay" mDelayOrQuoteOrRun [ (mkSynDelay2 basicSynExpr) ] // Add a call to 'Quote' if the method is present - let quotedSynExpr = - if isAutoQuote then - SynExpr.Quote (mkSynIdGet mDelayOrQuoteOrRun (CompileOpName "<@ @>"), false, delayedExpr, true, mWhole) - else delayedExpr - + let quotedSynExpr = + if isAutoQuote then + SynExpr.Quote(mkSynIdGet mDelayOrQuoteOrRun (CompileOpName "<@ @>"), false, delayedExpr, true, mWhole) + else + delayedExpr + // Add a call to 'Run' if the method is present - let runExpr = - match TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mBuilderVal ad "Run" builderTy with + let runExpr = + match TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mBuilderVal ad "Run" builderTy with | [] -> quotedSynExpr - | _ -> mkSynCall "Run" mDelayOrQuoteOrRun [quotedSynExpr] - - let lambdaExpr = - SynExpr.Lambda (false, false, SynSimplePats.SimplePats ([mkSynSimplePatVar false (mkSynId mBuilderVal builderValName)], [], mBuilderVal), runExpr, None, mBuilderVal, SynExprLambdaTrivia.Zero) + | _ -> mkSynCall "Run" mDelayOrQuoteOrRun [ quotedSynExpr ] + + let lambdaExpr = + SynExpr.Lambda( + false, + false, + SynSimplePats.SimplePats([ mkSynSimplePatVar false (mkSynId mBuilderVal builderValName) ], [], mBuilderVal), + runExpr, + None, + mBuilderVal, + SynExprLambdaTrivia.Zero + ) let env = match comp with - | SynExpr.YieldOrReturn ((true, _), _, _) -> { env with eContextInfo = ContextInfo.YieldInComputationExpression } - | SynExpr.YieldOrReturn ((_, true), _, _) -> { env with eContextInfo = ContextInfo.ReturnInComputationExpression } + | SynExpr.YieldOrReturn(flags = (true, _)) -> + { env with + eContextInfo = ContextInfo.YieldInComputationExpression + } + | SynExpr.YieldOrReturn(flags = (_, true)) -> + { env with + eContextInfo = ContextInfo.ReturnInComputationExpression + } | _ -> env - let lambdaExpr, tpenv = TcExpr cenv (MustEqual (mkFunTy g builderTy overallTy)) env tpenv lambdaExpr + let lambdaExpr, tpenv = + TcExpr cenv (MustEqual(mkFunTy g builderTy overallTy)) env tpenv lambdaExpr // beta-var-reduce to bind the builder using a 'let' binding - let coreExpr = mkApps cenv.g ((lambdaExpr, tyOfExpr cenv.g lambdaExpr), [], [interpExpr], mBuilderVal) + let coreExpr = + mkApps cenv.g ((lambdaExpr, tyOfExpr cenv.g lambdaExpr), [], [ interpExpr ], mBuilderVal) coreExpr, tpenv @@ -1858,13 +2881,16 @@ let mkSeqEmpty (cenv: cenv) env m genTy = let g = cenv.g let genResultTy = NewInferenceType g UnifyTypes cenv env m genTy (mkSeqTy g genResultTy) - mkCallSeqEmpty g m genResultTy + mkCallSeqEmpty g m genResultTy let mkSeqCollect (cenv: cenv) env m enumElemTy genTy lam enumExpr = let g = cenv.g let genResultTy = NewInferenceType g UnifyTypes cenv env m genTy (mkSeqTy cenv.g genResultTy) - let enumExpr = mkCoerceIfNeeded cenv.g (mkSeqTy cenv.g enumElemTy) (tyOfExpr cenv.g enumExpr) enumExpr + + let enumExpr = + mkCoerceIfNeeded cenv.g (mkSeqTy cenv.g enumElemTy) (tyOfExpr cenv.g enumExpr) enumExpr + mkCallSeqCollect cenv.g m enumElemTy genResultTy lam enumExpr let mkSeqUsing (cenv: cenv) (env: TcEnv) m resourceTy genTy resourceExpr lam = @@ -1872,58 +2898,83 @@ let mkSeqUsing (cenv: cenv) (env: TcEnv) m resourceTy genTy resourceExpr lam = AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m NoTrace cenv.g.system_IDisposable_ty resourceTy let genResultTy = NewInferenceType g UnifyTypes cenv env m genTy (mkSeqTy cenv.g genResultTy) - mkCallSeqUsing cenv.g m resourceTy genResultTy resourceExpr lam + mkCallSeqUsing cenv.g m resourceTy genResultTy resourceExpr lam let mkSeqDelay (cenv: cenv) env m genTy lam = let g = cenv.g let genResultTy = NewInferenceType g UnifyTypes cenv env m genTy (mkSeqTy cenv.g genResultTy) - mkCallSeqDelay cenv.g m genResultTy (mkUnitDelayLambda cenv.g m lam) + mkCallSeqDelay cenv.g m genResultTy (mkUnitDelayLambda cenv.g m lam) let mkSeqAppend (cenv: cenv) env m genTy e1 e2 = let g = cenv.g let genResultTy = NewInferenceType g UnifyTypes cenv env m genTy (mkSeqTy cenv.g genResultTy) - let e1 = mkCoerceIfNeeded cenv.g (mkSeqTy cenv.g genResultTy) (tyOfExpr cenv.g e1) e1 - let e2 = mkCoerceIfNeeded cenv.g (mkSeqTy cenv.g genResultTy) (tyOfExpr cenv.g e2) e2 - mkCallSeqAppend cenv.g m genResultTy e1 e2 + + let e1 = + mkCoerceIfNeeded cenv.g (mkSeqTy cenv.g genResultTy) (tyOfExpr cenv.g e1) e1 + + let e2 = + mkCoerceIfNeeded cenv.g (mkSeqTy cenv.g genResultTy) (tyOfExpr cenv.g e2) e2 + + mkCallSeqAppend cenv.g m genResultTy e1 e2 let mkSeqFromFunctions (cenv: cenv) env m genTy e1 e2 = let g = cenv.g let genResultTy = NewInferenceType g UnifyTypes cenv env m genTy (mkSeqTy cenv.g genResultTy) - let e2 = mkCoerceIfNeeded cenv.g (mkSeqTy cenv.g genResultTy) (tyOfExpr cenv.g e2) e2 - mkCallSeqGenerated cenv.g m genResultTy e1 e2 + + let e2 = + mkCoerceIfNeeded cenv.g (mkSeqTy cenv.g genResultTy) (tyOfExpr cenv.g e2) e2 + + mkCallSeqGenerated cenv.g m genResultTy e1 e2 let mkSeqFinally (cenv: cenv) env m genTy e1 e2 = let g = cenv.g let genResultTy = NewInferenceType g UnifyTypes cenv env m genTy (mkSeqTy cenv.g genResultTy) - let e1 = mkCoerceIfNeeded cenv.g (mkSeqTy cenv.g genResultTy) (tyOfExpr cenv.g e1) e1 - mkCallSeqFinally cenv.g m genResultTy e1 e2 + + let e1 = + mkCoerceIfNeeded cenv.g (mkSeqTy cenv.g genResultTy) (tyOfExpr cenv.g e1) e1 + + mkCallSeqFinally cenv.g m genResultTy e1 e2 let mkSeqTryWith (cenv: cenv) env m genTy origSeq exnFilter exnHandler = let g = cenv.g let genResultTy = NewInferenceType g UnifyTypes cenv env m genTy (mkSeqTy cenv.g genResultTy) - let origSeq = mkCoerceIfNeeded cenv.g (mkSeqTy cenv.g genResultTy) (tyOfExpr cenv.g origSeq) origSeq - mkCallSeqTryWith cenv.g m genResultTy origSeq exnFilter exnHandler -let mkSeqExprMatchClauses (pat, vspecs) innerExpr = - [MatchClause(pat, None, TTarget(vspecs, innerExpr, None), pat.Range) ] + let origSeq = + mkCoerceIfNeeded cenv.g (mkSeqTy cenv.g genResultTy) (tyOfExpr cenv.g origSeq) origSeq + + mkCallSeqTryWith cenv.g m genResultTy origSeq exnFilter exnHandler + +let mkSeqExprMatchClauses (pat, vspecs) innerExpr = + [ MatchClause(pat, None, TTarget(vspecs, innerExpr, None), pat.Range) ] -let compileSeqExprMatchClauses (cenv: cenv) env inputExprMark (pat: Pattern, vspecs) innerExpr inputExprOpt bindPatTy genInnerTy = +let compileSeqExprMatchClauses (cenv: cenv) env inputExprMark (pat: Pattern, vspecs) innerExpr inputExprOpt bindPatTy genInnerTy = let patMark = pat.Range - let tclauses = mkSeqExprMatchClauses (pat, vspecs) innerExpr - CompilePatternForMatchClauses cenv env inputExprMark patMark false ThrowIncompleteMatchException inputExprOpt bindPatTy genInnerTy tclauses + let tclauses = mkSeqExprMatchClauses (pat, vspecs) innerExpr + + CompilePatternForMatchClauses + cenv + env + inputExprMark + patMark + false + ThrowIncompleteMatchException + inputExprOpt + bindPatTy + genInnerTy + tclauses /// This case is used for computation expressions which are sequence expressions. Technically the code path is different because it /// typechecks rather than doing a shallow syntactic translation, and generates calls into the Seq.* library -/// and helpers rather than to the builder methods (there is actually no builder for 'seq' in the library). -/// These are later detected by state machine compilation. +/// and helpers rather than to the builder methods (there is actually no builder for 'seq' in the library). +/// These are later detected by state machine compilation. /// /// Also "ienumerable extraction" is performed on arguments to "for". -let TcSequenceExpression (cenv: cenv) env tpenv comp (overallTy: OverallTy) m = +let TcSequenceExpression (cenv: cenv) env tpenv comp (overallTy: OverallTy) m = let g = cenv.g let genEnumElemTy = NewInferenceType g @@ -1933,68 +2984,94 @@ let TcSequenceExpression (cenv: cenv) env tpenv comp (overallTy: OverallTy) m = let flex = not (isTyparTy cenv.g genEnumElemTy) // If there are no 'yield' in the computation expression then allow the type-directed rule - // interpreting non-unit-typed expressions in statement positions as 'yield'. 'yield!' may be + // interpreting non-unit-typed expressions in statement positions as 'yield'. 'yield!' may be // present in the computation expression. let enableImplicitYield = cenv.g.langVersion.SupportsFeature LanguageFeature.ImplicitYield && (YieldFree cenv comp) - let mkSeqDelayedExpr m (coreExpr: Expr) = + let mkSeqDelayedExpr m (coreExpr: Expr) = let overallTy = tyOfExpr cenv.g coreExpr mkSeqDelay cenv env m overallTy coreExpr let rec tryTcSequenceExprBody env genOuterTy tpenv comp = - match comp with - | SynExpr.ForEach (spFor, spIn, SeqExprOnly _seqExprOnly, _isFromSource, pat, pseudoEnumExpr, innerComp, _m) -> + match comp with + | SynExpr.ForEach(spFor, spIn, SeqExprOnly _seqExprOnly, _isFromSource, pat, pseudoEnumExpr, innerComp, _m) -> let pseudoEnumExpr = match RewriteRangeExpr pseudoEnumExpr with | Some e -> e | None -> pseudoEnumExpr - // This expression is not checked with the knowledge it is an IEnumerable, since we permit other enumerable types with GetEnumerator/MoveNext methods, as does C# - let pseudoEnumExpr, arbitraryTy, tpenv = TcExprOfUnknownType cenv env tpenv pseudoEnumExpr - let enumExpr, enumElemTy = ConvertArbitraryExprToEnumerable cenv arbitraryTy env pseudoEnumExpr - let patR, _, vspecs, envinner, tpenv = TcMatchPattern cenv enumElemTy env tpenv pat None + // This expression is not checked with the knowledge it is an IEnumerable, since we permit other enumerable types with GetEnumerator/MoveNext methods, as does C# + let pseudoEnumExpr, arbitraryTy, tpenv = + TcExprOfUnknownType cenv env tpenv pseudoEnumExpr + + let enumExpr, enumElemTy = + ConvertArbitraryExprToEnumerable cenv arbitraryTy env pseudoEnumExpr + + let patR, _, vspecs, envinner, tpenv = + TcMatchPattern cenv enumElemTy env tpenv pat None + let innerExpr, tpenv = let envinner = { envinner with eIsControlFlow = true } tcSequenceExprBody envinner genOuterTy tpenv innerComp - + let enumExprRange = enumExpr.Range // We attach the debug point to the lambda expression so we can fetch it out again in LowerComputedListOrArraySeqExpr - let mFor = match spFor with DebugPointAtFor.Yes m -> m.NoteSourceConstruct(NotedSourceConstruct.For) | _ -> enumExprRange + let mFor = + match spFor with + | DebugPointAtFor.Yes m -> m.NoteSourceConstruct(NotedSourceConstruct.For) + | _ -> enumExprRange // We attach the debug point to the lambda expression so we can fetch it out again in LowerComputedListOrArraySeqExpr - let mIn = match spIn with DebugPointAtInOrTo.Yes m -> m.NoteSourceConstruct(NotedSourceConstruct.InOrTo) | _ -> pat.Range + let mIn = + match spIn with + | DebugPointAtInOrTo.Yes m -> m.NoteSourceConstruct(NotedSourceConstruct.InOrTo) + | _ -> pat.Range - match patR, vspecs, innerExpr with + match patR, vspecs, innerExpr with // Legacy peephole optimization: // "seq { .. for x in e1 -> e2 .. }" == "e1 |> Seq.map (fun x -> e2)" // "seq { .. for x in e1 do yield e2 .. }" == "e1 |> Seq.map (fun x -> e2)" // // This transformation is visible in quotations and thus needs to remain. - | (TPat_as (TPat_wild _, PatternValBinding (v, _), _), - [_], - DebugPoints(Expr.App (Expr.Val (vref, _, _), _, [genEnumElemTy], [yieldExpr], _mYield), recreate)) - when valRefEq cenv.g vref cenv.g.seq_singleton_vref -> + | (TPat_as(TPat_wild _, PatternValBinding(v, _), _), + [ _ ], + DebugPoints(Expr.App(Expr.Val(vref, _, _), _, [ genEnumElemTy ], [ yieldExpr ], _mYield), recreate)) when + valRefEq cenv.g vref cenv.g.seq_singleton_vref + -> // The debug point mFor is attached to the 'map' // The debug point mIn is attached to the lambda - // Note: the 'yield' part of the debug point for 'yield expr' is currently lost in debug points. + // Note: the 'yield' part of the debug point for 'yield expr' is currently lost in debug points. let lam = mkLambda mIn v (recreate yieldExpr, genEnumElemTy) - let enumExpr = mkCoerceIfNeeded cenv.g (mkSeqTy cenv.g enumElemTy) (tyOfExpr cenv.g enumExpr) enumExpr + + let enumExpr = + mkCoerceIfNeeded cenv.g (mkSeqTy cenv.g enumElemTy) (tyOfExpr cenv.g enumExpr) enumExpr + Some(mkCallSeqMap cenv.g mFor enumElemTy genEnumElemTy lam enumExpr, tpenv) - | _ -> + | _ -> // The debug point mFor is attached to the 'collect' // The debug point mIn is attached to the lambda - let matchv, matchExpr = compileSeqExprMatchClauses cenv env enumExprRange (patR, vspecs) innerExpr None enumElemTy genOuterTy + let matchv, matchExpr = + compileSeqExprMatchClauses cenv env enumExprRange (patR, vspecs) innerExpr None enumElemTy genOuterTy + let lam = mkLambda mIn matchv (matchExpr, tyOfExpr cenv.g matchExpr) Some(mkSeqCollect cenv env mFor enumElemTy genOuterTy lam enumExpr, tpenv) - | SynExpr.For (forDebugPoint=spFor; toDebugPoint=spTo; ident=id; identBody=start; direction=dir; toBody=finish; doBody=innerComp; range=m) -> + | SynExpr.For( + forDebugPoint = spFor + toDebugPoint = spTo + ident = id + identBody = start + direction = dir + toBody = finish + doBody = innerComp + range = m) -> Some(tcSequenceExprBody env genOuterTy tpenv (elimFastIntegerForLoop (spFor, spTo, id, start, dir, finish, innerComp, m))) - | SynExpr.While (spWhile, guardExpr, innerComp, _m) -> + | SynExpr.While(spWhile, guardExpr, innerComp, _m) -> let guardExpr, tpenv = let env = { env with eIsControlFlow = false } TcExpr cenv (MustEqual cenv.g.bool_ty) env tpenv guardExpr @@ -2002,10 +3079,10 @@ let TcSequenceExpression (cenv: cenv) env tpenv comp (overallTy: OverallTy) m = let innerExpr, tpenv = let env = { env with eIsControlFlow = true } tcSequenceExprBody env genOuterTy tpenv innerComp - + let guardExprMark = guardExpr.Range let guardLambdaExpr = mkUnitDelayLambda cenv.g guardExprMark guardExpr - + // We attach the debug point to the lambda expression so we can fetch it out again in LowerComputedListOrArraySeqExpr let mWhile = match spWhile with @@ -2015,78 +3092,105 @@ let TcSequenceExpression (cenv: cenv) env tpenv comp (overallTy: OverallTy) m = let innerDelayedExpr = mkSeqDelayedExpr mWhile innerExpr Some(mkSeqFromFunctions cenv env guardExprMark genOuterTy guardLambdaExpr innerDelayedExpr, tpenv) - | SynExpr.TryFinally (innerComp, unwindExpr, mTryToLast, spTry, spFinally, trivia) -> + | SynExpr.TryFinally(innerComp, unwindExpr, mTryToLast, spTry, spFinally, trivia) -> let env = { env with eIsControlFlow = true } let innerExpr, tpenv = tcSequenceExprBody env genOuterTy tpenv innerComp let unwindExpr, tpenv = TcExpr cenv (MustEqual cenv.g.unit_ty) env tpenv unwindExpr - + // We attach the debug points to the lambda expressions so we can fetch it out again in LowerComputedListOrArraySeqExpr - let mTry = - match spTry with + let mTry = + match spTry with | DebugPointAtTry.Yes m -> m.NoteSourceConstruct(NotedSourceConstruct.Try) | _ -> trivia.TryKeyword - let mFinally = - match spFinally with + let mFinally = + match spFinally with | DebugPointAtFinally.Yes m -> m.NoteSourceConstruct(NotedSourceConstruct.Finally) | _ -> trivia.FinallyKeyword let innerExpr = mkSeqDelayedExpr mTry innerExpr let unwindExpr = mkUnitDelayLambda cenv.g mFinally unwindExpr - + Some(mkSeqFinally cenv env mTryToLast genOuterTy innerExpr unwindExpr, tpenv) - | SynExpr.Paren (_, _, _, m) when not (cenv.g.langVersion.SupportsFeature LanguageFeature.ImplicitYield)-> - error(Error(FSComp.SR.tcConstructIsAmbiguousInSequenceExpression(), m)) + | SynExpr.Paren(range = m) when not (cenv.g.langVersion.SupportsFeature LanguageFeature.ImplicitYield) -> + error (Error(FSComp.SR.tcConstructIsAmbiguousInSequenceExpression (), m)) - | SynExpr.ImplicitZero m -> - Some(mkSeqEmpty cenv env m genOuterTy, tpenv ) + | SynExpr.ImplicitZero m -> Some(mkSeqEmpty cenv env m genOuterTy, tpenv) - | SynExpr.DoBang (_rhsExpr, m) -> - error(Error(FSComp.SR.tcDoBangIllegalInSequenceExpression(), m)) + | SynExpr.DoBang(_rhsExpr, m) -> error (Error(FSComp.SR.tcDoBangIllegalInSequenceExpression (), m)) - | SynExpr.Sequential (sp, true, innerComp1, innerComp2, m) -> - let env1 = { env with eIsControlFlow = (match sp with DebugPointAtSequential.SuppressNeither | DebugPointAtSequential.SuppressExpr -> true | _ -> false) } + | SynExpr.Sequential(sp, true, innerComp1, innerComp2, m) -> + let env1 = + { env with + eIsControlFlow = + (match sp with + | DebugPointAtSequential.SuppressNeither + | DebugPointAtSequential.SuppressExpr -> true + | _ -> false) + } - let res, tpenv = tcSequenceExprBodyAsSequenceOrStatement env1 genOuterTy tpenv innerComp1 + let res, tpenv = + tcSequenceExprBodyAsSequenceOrStatement env1 genOuterTy tpenv innerComp1 - let env2 = { env with eIsControlFlow = (match sp with DebugPointAtSequential.SuppressNeither | DebugPointAtSequential.SuppressStmt -> true | _ -> false) } + let env2 = + { env with + eIsControlFlow = + (match sp with + | DebugPointAtSequential.SuppressNeither + | DebugPointAtSequential.SuppressStmt -> true + | _ -> false) + } // "expr; cexpr" is treated as sequential execution // "cexpr; cexpr" is treated as append - match res with - | Choice1Of2 innerExpr1 -> + match res with + | Choice1Of2 innerExpr1 -> let innerExpr2, tpenv = tcSequenceExprBody env2 genOuterTy tpenv innerComp2 let innerExpr2 = mkSeqDelayedExpr innerExpr2.Range innerExpr2 Some(mkSeqAppend cenv env innerComp1.Range genOuterTy innerExpr1 innerExpr2, tpenv) - | Choice2Of2 stmt1 -> + | Choice2Of2 stmt1 -> let innerExpr2, tpenv = tcSequenceExprBody env2 genOuterTy tpenv innerComp2 Some(Expr.Sequential(stmt1, innerExpr2, NormalSeq, m), tpenv) - | SynExpr.IfThenElse (guardExpr, thenComp, elseCompOpt, spIfToThen, _isRecovery, mIfToEndOfElseBranch, trivia) -> + | SynExpr.IfThenElse(guardExpr, thenComp, elseCompOpt, spIfToThen, _isRecovery, mIfToEndOfElseBranch, trivia) -> let guardExpr', tpenv = TcExpr cenv (MustEqual cenv.g.bool_ty) env tpenv guardExpr let env = { env with eIsControlFlow = true } let thenExpr, tpenv = tcSequenceExprBody env genOuterTy tpenv thenComp - let elseComp = (match elseCompOpt with Some c -> c | None -> SynExpr.ImplicitZero trivia.IfToThenRange) + + let elseComp = + (match elseCompOpt with + | Some c -> c + | None -> SynExpr.ImplicitZero trivia.IfToThenRange) + let elseExpr, tpenv = tcSequenceExprBody env genOuterTy tpenv elseComp Some(mkCond spIfToThen mIfToEndOfElseBranch genOuterTy guardExpr' thenExpr elseExpr, tpenv) // 'let x = expr in expr' - | SynExpr.LetOrUse (isUse=false (* not a 'use' binding *)) -> - TcLinearExprs - (fun overallTy envinner tpenv e -> tcSequenceExprBody envinner overallTy.Commit tpenv e) - cenv env overallTy - tpenv + | SynExpr.LetOrUse(isUse = false) -> + TcLinearExprs + (fun overallTy envinner tpenv e -> tcSequenceExprBody envinner overallTy.Commit tpenv e) + cenv + env + overallTy + tpenv true - comp - id |> Some + comp + id + |> Some // 'use x = expr in expr' - | SynExpr.LetOrUse (isUse=true; bindings=[SynBinding (kind=SynBindingKind.Normal; headPat=pat; expr=rhsExpr; debugPoint=spBind)]; body=innerComp; range=wholeExprMark) -> + | SynExpr.LetOrUse( + isUse = true + bindings = [ SynBinding(kind = SynBindingKind.Normal; headPat = pat; expr = rhsExpr; debugPoint = spBind) ] + body = innerComp + range = wholeExprMark) -> let bindPatTy = NewInferenceType g let inputExprTy = NewInferenceType g - let pat', _, vspecs, envinner, tpenv = TcMatchPattern cenv bindPatTy env tpenv pat None + + let pat', _, vspecs, envinner, tpenv = + TcMatchPattern cenv bindPatTy env tpenv pat None UnifyTypes cenv env m inputExprTy bindPatTy @@ -2098,84 +3202,117 @@ let TcSequenceExpression (cenv: cenv) env tpenv comp (overallTy: OverallTy) m = let envinner = { envinner with eIsControlFlow = true } tcSequenceExprBody envinner genOuterTy tpenv innerComp - let mBind = - match spBind with + let mBind = + match spBind with | DebugPointAtBinding.Yes m -> m.NoteSourceConstruct(NotedSourceConstruct.Binding) | _ -> inputExpr.Range let inputExprMark = inputExpr.Range - let matchv, matchExpr = compileSeqExprMatchClauses cenv envinner inputExprMark (pat', vspecs) innerExpr (Some inputExpr) bindPatTy genOuterTy + let matchv, matchExpr = + compileSeqExprMatchClauses cenv envinner inputExprMark (pat', vspecs) innerExpr (Some inputExpr) bindPatTy genOuterTy let consumeExpr = mkLambda mBind matchv (matchExpr, genOuterTy) // The 'mBind' is attached to the lambda Some(mkSeqUsing cenv env wholeExprMark bindPatTy genOuterTy inputExpr consumeExpr, tpenv) - | SynExpr.LetOrUseBang (range=m) -> - error(Error(FSComp.SR.tcUseForInSequenceExpression(), m)) + | SynExpr.LetOrUseBang(range = m) -> error (Error(FSComp.SR.tcUseForInSequenceExpression (), m)) - | SynExpr.Match (spMatch, expr, clauses, _m, _trivia) -> + | SynExpr.Match(spMatch, expr, clauses, _m, _trivia) -> let inputExpr, inputTy, tpenv = TcExprOfUnknownType cenv env tpenv expr - let tclauses, tpenv = - (tpenv, clauses) ||> List.mapFold (fun tpenv (SynMatchClause(pat, cond, innerComp, _, sp, _)) -> - let patR, condR, vspecs, envinner, tpenv = TcMatchPattern cenv inputTy env tpenv pat cond - let envinner = - match sp with - | DebugPointAtTarget.Yes -> { envinner with eIsControlFlow = true } - | DebugPointAtTarget.No -> envinner - let innerExpr, tpenv = tcSequenceExprBody envinner genOuterTy tpenv innerComp - MatchClause(patR, condR, TTarget(vspecs, innerExpr, None), patR.Range), tpenv) + let tclauses, tpenv = + (tpenv, clauses) + ||> List.mapFold (fun tpenv (SynMatchClause(pat, cond, innerComp, _, sp, _)) -> + let patR, condR, vspecs, envinner, tpenv = + TcMatchPattern cenv inputTy env tpenv pat cond + + let envinner = + match sp with + | DebugPointAtTarget.Yes -> { envinner with eIsControlFlow = true } + | DebugPointAtTarget.No -> envinner + + let innerExpr, tpenv = tcSequenceExprBody envinner genOuterTy tpenv innerComp + MatchClause(patR, condR, TTarget(vspecs, innerExpr, None), patR.Range), tpenv) let inputExprTy = tyOfExpr cenv.g inputExpr let inputExprMark = inputExpr.Range - let matchv, matchExpr = CompilePatternForMatchClauses cenv env inputExprMark inputExprMark true ThrowIncompleteMatchException (Some inputExpr) inputExprTy genOuterTy tclauses + + let matchv, matchExpr = + CompilePatternForMatchClauses + cenv + env + inputExprMark + inputExprMark + true + ThrowIncompleteMatchException + (Some inputExpr) + inputExprTy + genOuterTy + tclauses Some(mkLet spMatch inputExprMark matchv inputExpr matchExpr, tpenv) - | SynExpr.TryWith (innerTry,withList,mTryToWith,_spTry,_spWith,trivia) -> - if not(g.langVersion.SupportsFeature(LanguageFeature.TryWithInSeqExpression)) then - error(Error(FSComp.SR.tcTryIllegalInSequenceExpression(), mTryToWith)) + | SynExpr.TryWith(innerTry, withList, mTryToWith, _spTry, _spWith, trivia) -> + if not (g.langVersion.SupportsFeature(LanguageFeature.TryWithInSeqExpression)) then + error (Error(FSComp.SR.tcTryIllegalInSequenceExpression (), mTryToWith)) let env = { env with eIsControlFlow = true } - let tryExpr, tpenv = - let inner,tpenv = tcSequenceExprBody env genOuterTy tpenv innerTry + + let tryExpr, tpenv = + let inner, tpenv = tcSequenceExprBody env genOuterTy tpenv innerTry mkSeqDelayedExpr mTryToWith inner, tpenv // Compile the pattern twice, once as a filter with all succeeding targets returning "1", and once as a proper catch block. - let clauses, tpenv = - (tpenv, withList) ||> List.mapFold (fun tpenv (SynMatchClause(pat, cond, innerComp, m, sp, _)) -> - let patR, condR, vspecs, envinner, tpenv = TcMatchPattern cenv g.exn_ty env tpenv pat cond + let clauses, tpenv = + (tpenv, withList) + ||> List.mapFold (fun tpenv (SynMatchClause(pat, cond, innerComp, m, sp, _)) -> + let patR, condR, vspecs, envinner, tpenv = + TcMatchPattern cenv g.exn_ty env tpenv pat cond + let envinner = match sp with | DebugPointAtTarget.Yes -> { envinner with eIsControlFlow = true } | DebugPointAtTarget.No -> envinner + let matchBody, tpenv = tcSequenceExprBody envinner genOuterTy tpenv innerComp - let handlerClause = MatchClause(patR, condR, TTarget(vspecs, matchBody, None), patR.Range) - let filterClause = MatchClause(patR, condR, TTarget([], Expr.Const(Const.Int32 1,m,g.int_ty), None), patR.Range) - (handlerClause,filterClause), tpenv) + + let handlerClause = + MatchClause(patR, condR, TTarget(vspecs, matchBody, None), patR.Range) + + let filterClause = + MatchClause(patR, condR, TTarget([], Expr.Const(Const.Int32 1, m, g.int_ty), None), patR.Range) + + (handlerClause, filterClause), tpenv) let handlers, filterClauses = List.unzip clauses let withRange = trivia.WithToEndRange - let v1, filterExpr = CompilePatternForMatchClauses cenv env withRange withRange true FailFilter None g.exn_ty g.int_ty filterClauses - let v2, handlerExpr = CompilePatternForMatchClauses cenv env withRange withRange true FailFilter None g.exn_ty genOuterTy handlers + + let v1, filterExpr = + CompilePatternForMatchClauses cenv env withRange withRange true FailFilter None g.exn_ty g.int_ty filterClauses + + let v2, handlerExpr = + CompilePatternForMatchClauses cenv env withRange withRange true FailFilter None g.exn_ty genOuterTy handlers let filterLambda = mkLambda filterExpr.Range v1 (filterExpr, genOuterTy) let handlerLambda = mkLambda handlerExpr.Range v2 (handlerExpr, genOuterTy) - let combinatorExpr = mkSeqTryWith cenv env mTryToWith genOuterTy tryExpr filterLambda handlerLambda - Some (combinatorExpr,tpenv) + let combinatorExpr = + mkSeqTryWith cenv env mTryToWith genOuterTy tryExpr filterLambda handlerLambda + + Some(combinatorExpr, tpenv) - | SynExpr.YieldOrReturnFrom ((isYield, _), synYieldExpr, m) -> + | SynExpr.YieldOrReturnFrom((isYield, _), synYieldExpr, m) -> let env = { env with eIsControlFlow = false } let resultExpr, genExprTy, tpenv = TcExprOfUnknownType cenv env tpenv synYieldExpr - if not isYield then errorR(Error(FSComp.SR.tcUseYieldBangForMultipleResults(), m)) + if not isYield then + errorR (Error(FSComp.SR.tcUseYieldBangForMultipleResults (), m)) AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m NoTrace genOuterTy genExprTy - let resultExpr = mkCoerceExpr(resultExpr, genOuterTy, m, genExprTy) + let resultExpr = mkCoerceExpr (resultExpr, genOuterTy, m, genExprTy) let resultExpr = if IsControlFlowExpression synYieldExpr then @@ -2185,11 +3322,12 @@ let TcSequenceExpression (cenv: cenv) env tpenv comp (overallTy: OverallTy) m = Some(resultExpr, tpenv) - | SynExpr.YieldOrReturn ((isYield, _), synYieldExpr, m) -> + | SynExpr.YieldOrReturn((isYield, _), synYieldExpr, m) -> let env = { env with eIsControlFlow = false } let genResultTy = NewInferenceType g - if not isYield then errorR(Error(FSComp.SR.tcSeqResultsUseYield(), m)) + if not isYield then + errorR (Error(FSComp.SR.tcSeqResultsUseYield (), m)) UnifyTypes cenv env m genOuterTy (mkSeqTy cenv.g genResultTy) @@ -2203,30 +3341,34 @@ let TcSequenceExpression (cenv: cenv) env tpenv comp (overallTy: OverallTy) m = else mkDebugPoint m resultExpr - Some(resultExpr, tpenv ) + Some(resultExpr, tpenv) | _ -> None - + and tcSequenceExprBody env (genOuterTy: TType) tpenv comp = - let res, tpenv = tcSequenceExprBodyAsSequenceOrStatement env genOuterTy tpenv comp - match res with - | Choice1Of2 expr -> - expr, tpenv - | Choice2Of2 stmt -> + let res, tpenv = tcSequenceExprBodyAsSequenceOrStatement env genOuterTy tpenv comp + + match res with + | Choice1Of2 expr -> expr, tpenv + | Choice2Of2 stmt -> let m = comp.Range let resExpr = Expr.Sequential(stmt, mkSeqEmpty cenv env m genOuterTy, NormalSeq, m) resExpr, tpenv and tcSequenceExprBodyAsSequenceOrStatement env genOuterTy tpenv comp = - match tryTcSequenceExprBody env genOuterTy tpenv comp with - | Some (expr, tpenv) -> Choice1Of2 expr, tpenv - | None -> + match tryTcSequenceExprBody env genOuterTy tpenv comp with + | Some(expr, tpenv) -> Choice1Of2 expr, tpenv + | None -> - let env = { env with eContextInfo = ContextInfo.SequenceExpression genOuterTy } + let env = + { env with + eContextInfo = ContextInfo.SequenceExpression genOuterTy + } if enableImplicitYield then let hasTypeUnit, expr, tpenv = TryTcStmt cenv env tpenv comp - if hasTypeUnit then + + if hasTypeUnit then Choice2Of2 expr, tpenv else let genResultTy = NewInferenceType g @@ -2235,7 +3377,10 @@ let TcSequenceExpression (cenv: cenv) env tpenv comp (overallTy: OverallTy) m = let expr, tpenv = TcExprFlex cenv flex true genResultTy env tpenv comp let exprTy = tyOfExpr cenv.g expr AddCxTypeMustSubsumeType env.eContextInfo env.DisplayEnv cenv.css mExpr NoTrace genResultTy exprTy - let resExpr = mkCallSeqSingleton cenv.g mExpr genResultTy (mkCoerceExpr(expr, genResultTy, mExpr, exprTy)) + + let resExpr = + mkCallSeqSingleton cenv.g mExpr genResultTy (mkCoerceExpr (expr, genResultTy, mExpr, exprTy)) + Choice1Of2 resExpr, tpenv else let stmt, tpenv = TcStmtThatCantBeCtorBody cenv env tpenv comp @@ -2247,32 +3392,32 @@ let TcSequenceExpression (cenv: cenv) env tpenv comp (overallTy: OverallTy) m = let TcSequenceExpressionEntry (cenv: cenv) env (overallTy: OverallTy) tpenv (hasBuilder, comp) m = match RewriteRangeExpr comp with - | Some replacementExpr -> - TcExpr cenv overallTy env tpenv replacementExpr + | Some replacementExpr -> TcExpr cenv overallTy env tpenv replacementExpr | None -> - let implicitYieldEnabled = cenv.g.langVersion.SupportsFeature LanguageFeature.ImplicitYield + let implicitYieldEnabled = + cenv.g.langVersion.SupportsFeature LanguageFeature.ImplicitYield - let validateObjectSequenceOrRecordExpression = not implicitYieldEnabled + let validateObjectSequenceOrRecordExpression = not implicitYieldEnabled - match comp with - | SynExpr.New _ -> - try - TcExprUndelayed cenv overallTy env tpenv comp |> ignore - with RecoverableException e -> - errorRecovery e m - errorR(Error(FSComp.SR.tcInvalidObjectExpressionSyntaxForm(), m)) - | SimpleSemicolonSequence cenv false _ when validateObjectSequenceOrRecordExpression -> - errorR(Error(FSComp.SR.tcInvalidObjectSequenceOrRecordExpression(), m)) - | _ -> - () - - if not hasBuilder && not cenv.g.compilingFSharpCore then - error(Error(FSComp.SR.tcInvalidSequenceExpressionSyntaxForm(), m)) - - TcSequenceExpression cenv env tpenv comp overallTy m - -let TcArrayOrListComputedExpression (cenv: cenv) env (overallTy: OverallTy) tpenv (isArray, comp) m = + match comp with + | SynExpr.New _ -> + try + TcExprUndelayed cenv overallTy env tpenv comp |> ignore + with RecoverableException e -> + errorRecovery e m + + errorR (Error(FSComp.SR.tcInvalidObjectExpressionSyntaxForm (), m)) + | SimpleSemicolonSequence cenv false _ when validateObjectSequenceOrRecordExpression -> + errorR (Error(FSComp.SR.tcInvalidObjectSequenceOrRecordExpression (), m)) + | _ -> () + + if not hasBuilder && not cenv.g.compilingFSharpCore then + error (Error(FSComp.SR.tcInvalidSequenceExpressionSyntaxForm (), m)) + + TcSequenceExpression cenv env tpenv comp overallTy m + +let TcArrayOrListComputedExpression (cenv: cenv) env (overallTy: OverallTy) tpenv (isArray, comp) m = let g = cenv.g // The syntax '[ n .. m ]' and '[ n .. step .. m ]' is not really part of array or list syntax. @@ -2280,7 +3425,7 @@ let TcArrayOrListComputedExpression (cenv: cenv) env (overallTy: OverallTy) tpen // // The elaborated form of '[ n .. m ]' is 'List.ofSeq (seq (op_Range n m))' and this shouldn't change match RewriteRangeExpr comp with - | Some replacementExpr -> + | Some replacementExpr -> let genCollElemTy = NewInferenceType g let genCollTy = (if isArray then mkArrayType else mkListTy) cenv.g genCollElemTy @@ -2291,87 +3436,131 @@ let TcArrayOrListComputedExpression (cenv: cenv) env (overallTy: OverallTy) tpen let expr, tpenv = TcExpr cenv (MustEqual exprTy) env tpenv replacementExpr - let expr = - if cenv.g.compilingFSharpCore then - expr - else + let expr = + if cenv.g.compilingFSharpCore then + expr + else // We add a call to 'seq ... ' to make sure sequence expression compilation gets applied to the contents of the // comprehension. But don't do this in FSharp.Core.dll since 'seq' may not yet be defined. mkCallSeq cenv.g m genCollElemTy expr - - let expr = mkCoerceExpr(expr, exprTy, expr.Range, overallTy.Commit) - let expr = - if isArray then + let expr = mkCoerceExpr (expr, exprTy, expr.Range, overallTy.Commit) + + let expr = + if isArray then mkCallSeqToArray cenv.g m genCollElemTy expr - else + else mkCallSeqToList cenv.g m genCollElemTy expr + expr, tpenv | None -> - // LanguageFeatures.ImplicitYield do not require this validation - let implicitYieldEnabled = cenv.g.langVersion.SupportsFeature LanguageFeature.ImplicitYield - let validateExpressionWithIfRequiresParenthesis = not implicitYieldEnabled - let acceptDeprecatedIfThenExpression = not implicitYieldEnabled + // LanguageFeatures.ImplicitYield do not require this validation + let implicitYieldEnabled = + cenv.g.langVersion.SupportsFeature LanguageFeature.ImplicitYield + + let validateExpressionWithIfRequiresParenthesis = not implicitYieldEnabled + let acceptDeprecatedIfThenExpression = not implicitYieldEnabled - match comp with - | SimpleSemicolonSequence cenv acceptDeprecatedIfThenExpression elems -> match comp with - | SimpleSemicolonSequence cenv false _ -> () - | _ when validateExpressionWithIfRequiresParenthesis -> errorR(Deprecated(FSComp.SR.tcExpressionWithIfRequiresParenthesis(), m)) - | _ -> () + | SimpleSemicolonSequence cenv acceptDeprecatedIfThenExpression elems -> + match comp with + | SimpleSemicolonSequence cenv false _ -> () + | _ when validateExpressionWithIfRequiresParenthesis -> + errorR (Deprecated(FSComp.SR.tcExpressionWithIfRequiresParenthesis (), m)) + | _ -> () - let replacementExpr = - if isArray then - // This are to improve parsing/processing speed for parser tables by converting to an array blob ASAP - let nelems = elems.Length - if nelems > 0 && List.forall (function SynExpr.Const (SynConst.UInt16 _, _) -> true | _ -> false) elems - then SynExpr.Const (SynConst.UInt16s (Array.ofList (List.map (function SynExpr.Const (SynConst.UInt16 x, _) -> x | _ -> failwith "unreachable") elems)), m) - elif nelems > 0 && List.forall (function SynExpr.Const (SynConst.Byte _, _) -> true | _ -> false) elems - then SynExpr.Const (SynConst.Bytes (Array.ofList (List.map (function SynExpr.Const (SynConst.Byte x, _) -> x | _ -> failwith "unreachable") elems), SynByteStringKind.Regular, m), m) - else SynExpr.ArrayOrList (isArray, elems, m) - else - if cenv.g.langVersion.SupportsFeature(LanguageFeature.ReallyLongLists) then - SynExpr.ArrayOrList (isArray, elems, m) - else - if elems.Length > 500 then - error(Error(FSComp.SR.tcListLiteralMaxSize(), m)) - SynExpr.ArrayOrList (isArray, elems, m) + let replacementExpr = + if isArray then + // This are to improve parsing/processing speed for parser tables by converting to an array blob ASAP + let nelems = elems.Length + + if + nelems > 0 + && List.forall + (function + | SynExpr.Const(SynConst.UInt16 _, _) -> true + | _ -> false) + elems + then + SynExpr.Const( + SynConst.UInt16s( + Array.ofList ( + List.map + (function + | SynExpr.Const(SynConst.UInt16 x, _) -> x + | _ -> failwith "unreachable") + elems + ) + ), + m + ) + elif + nelems > 0 + && List.forall + (function + | SynExpr.Const(SynConst.Byte _, _) -> true + | _ -> false) + elems + then + SynExpr.Const( + SynConst.Bytes( + Array.ofList ( + List.map + (function + | SynExpr.Const(SynConst.Byte x, _) -> x + | _ -> failwith "unreachable") + elems + ), + SynByteStringKind.Regular, + m + ), + m + ) + else + SynExpr.ArrayOrList(isArray, elems, m) + else if cenv.g.langVersion.SupportsFeature(LanguageFeature.ReallyLongLists) then + SynExpr.ArrayOrList(isArray, elems, m) + else + if elems.Length > 500 then + error (Error(FSComp.SR.tcListLiteralMaxSize (), m)) - TcExprUndelayed cenv overallTy env tpenv replacementExpr - | _ -> + SynExpr.ArrayOrList(isArray, elems, m) - let genCollElemTy = NewInferenceType g + TcExprUndelayed cenv overallTy env tpenv replacementExpr + | _ -> - let genCollTy = (if isArray then mkArrayType else mkListTy) cenv.g genCollElemTy + let genCollElemTy = NewInferenceType g - // Propagating type directed conversion, e.g. for - // let x : seq = [ yield 1; if true then yield 2 ] - TcPropagatingExprLeafThenConvert cenv overallTy genCollTy env (* canAdhoc *) m (fun () -> - - let exprTy = mkSeqTy cenv.g genCollElemTy + let genCollTy = (if isArray then mkArrayType else mkListTy) cenv.g genCollElemTy - // Check the comprehension - let expr, tpenv = TcSequenceExpression cenv env tpenv comp (MustEqual exprTy) m + // Propagating type directed conversion, e.g. for + // let x : seq = [ yield 1; if true then yield 2 ] + TcPropagatingExprLeafThenConvert cenv overallTy genCollTy env (* canAdhoc *) m (fun () -> - let expr = mkCoerceIfNeeded cenv.g exprTy (tyOfExpr cenv.g expr) expr + let exprTy = mkSeqTy cenv.g genCollElemTy - let expr = - if cenv.g.compilingFSharpCore then - //warning(Error(FSComp.SR.fslibUsingComputedListOrArray(), expr.Range)) - expr - else - // We add a call to 'seq ... ' to make sure sequence expression compilation gets applied to the contents of the - // comprehension. But don't do this in FSharp.Core.dll since 'seq' may not yet be defined. - mkCallSeq cenv.g m genCollElemTy expr - - let expr = mkCoerceExpr(expr, exprTy, expr.Range, overallTy.Commit) + // Check the comprehension + let expr, tpenv = TcSequenceExpression cenv env tpenv comp (MustEqual exprTy) m - let expr = - if isArray then - mkCallSeqToArray cenv.g m genCollElemTy expr - else - mkCallSeqToList cenv.g m genCollElemTy expr - - expr, tpenv) + let expr = mkCoerceIfNeeded cenv.g exprTy (tyOfExpr cenv.g expr) expr + + let expr = + if cenv.g.compilingFSharpCore then + //warning(Error(FSComp.SR.fslibUsingComputedListOrArray(), expr.Range)) + expr + else + // We add a call to 'seq ... ' to make sure sequence expression compilation gets applied to the contents of the + // comprehension. But don't do this in FSharp.Core.dll since 'seq' may not yet be defined. + mkCallSeq cenv.g m genCollElemTy expr + + let expr = mkCoerceExpr (expr, exprTy, expr.Range, overallTy.Commit) + + let expr = + if isArray then + mkCallSeqToArray cenv.g m genCollElemTy expr + else + mkCallSeqToList cenv.g m genCollElemTy expr + + expr, tpenv)