diff --git a/src/Compiler/Checking/Expressions/CheckComputationExpressions.fs b/src/Compiler/Checking/Expressions/CheckComputationExpressions.fs index 55ed6c9761d..2b66af3eea9 100644 --- a/src/Compiler/Checking/Expressions/CheckComputationExpressions.fs +++ b/src/Compiler/Checking/Expressions/CheckComputationExpressions.fs @@ -24,6 +24,7 @@ open FSharp.Compiler.Text open FSharp.Compiler.Text.Range open FSharp.Compiler.TypedTree open FSharp.Compiler.TypedTreeOps +open System.Collections.Generic type cenv = TcFileState @@ -39,88 +40,44 @@ type CustomOperationsMode = | Allowed | Denied +[] +type ComputationExpressionContext<'a> = + { + cenv: TcFileState + env: TcEnv + tpenv: UnscopedTyparEnv + customOperationMethodsIndexedByKeyword: + IDictionary * MethInfo>> + customOperationMethodsIndexedByMethodName: + IDictionary * MethInfo>> + sourceMethInfo: 'a list + builderValName: string + ad: AccessorDomain + builderTy: TType + isQuery: bool + enableImplicitYield: bool + origComp: SynExpr + mWhole: range + emptyVarSpace: LazyWithContext * TcEnv, range> + } + let inline 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 inline IgnoreAttribute _ = None -[] -let (|ExprAsPat|_|) (f: SynExpr) = - match f with - | SingleIdent v1 - | SynExprParen(SingleIdent v1, _, _, _) -> ValueSome(mkSynPatVar None v1) - | SynExprParen(SynExpr.Tuple(false, elems, commas, _), _, _, _) -> - let elems = elems |> List.map (|SingleIdent|_|) - - if elems |> List.forall (fun x -> x.IsSome) then - ValueSome(SynPat.Tuple(false, (elems |> List.map (fun x -> mkSynPatVar None x.Value)), commas, f.Range)) - else - ValueNone - | _ -> ValueNone - -// 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 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 - - match expr with - | BinOpExpr(opId, a, b) when isOpName opNameEquals cenv.g.equals_operator_vref opId.idText -> ValueSome(a, b) - - | BinOpExpr(opId, a, b) when isOpName opNameEqualsNullable cenv.g.equals_nullable_operator_vref opId.idText -> - - let a = - SynExpr.App(ExprAtomicFlag.Atomic, false, mkSynLidGet a.Range [ MangledGlobalName; "System" ] "Nullable", a, a.Range) - - ValueSome(a, b) - - | 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) - - ValueSome(a, b) - - | BinOpExpr(opId, a, b) when isOpName opNameNullableEqualsNullable cenv.g.nullable_equals_nullable_operator_vref opId.idText -> - - ValueSome(a, b) - - | _ -> ValueNone +let inline arbPat (m: range) = + mkSynPatVar None (mkSynId (m.MakeSynthetic()) "_missingVar") -let (|ForEachThen|_|) synExpr = - match synExpr with - | SynExpr.ForEach(_spFor, - _spIn, - SeqExprOnly false, - isFromSource, - pat1, - expr1, - SynExpr.Sequential(isTrueSeq = true; expr1 = clause; expr2 = rest), - _) -> Some(isFromSource, pat1, expr1, clause, rest) - | _ -> None +let inline arbKeySelectors m = + mkSynBifix m "=" (arbExpr ("_keySelectors", m)) (arbExpr ("_keySelector2", m)) -let (|CustomOpId|_|) isCustomOperation predicate synExpr = - match synExpr with - | SingleIdent nm when isCustomOperation nm && predicate nm -> Some nm - | _ -> None +// Flag that a debug point should get emitted prior to both the evaluation of 'rhsExpr' and the call to Using +let inline addBindDebugPoint spBind e = + match spBind with + | DebugPointAtBinding.Yes m -> SynExpr.DebugPoint(DebugPointAtLeafExpr.Yes m, false, e) + | _ -> e let inline mkSynDelay2 (e: SynExpr) = mkSynDelay (e.Range.MakeSynthetic()) e @@ -149,40 +106,37 @@ let mkSourceExprConditional isFromSource callExpr sourceMethInfo builderValName else callExpr -let hasMethInfo nm cenv env mBuilderVal ad builderTy = - match TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mBuilderVal ad nm builderTy with - | [] -> false - | _ -> true - -/// Used for all computation expressions except sequence expressions -let TcComputationExpression (cenv: TcFileState) env (overallTy: OverallTy) tpenv (mWhole, interpExpr: Expr, builderTy, comp: SynExpr) = - let overallTy = overallTy.Commit +let inline mkSynLambda p e m = + SynExpr.Lambda(false, false, p, e, None, m, SynExprLambdaTrivia.Zero) - let g = cenv.g - let ad = env.eAccessRights +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 builderValName = CompilerGeneratedName "builder" - let mBuilderVal = interpExpr.Range +let mkSimplePatForVarSpace m (patvs: Val list) = + let spats = + match patvs with + | [] -> [] + | [ v ] -> [ mkSynSimplePatVar false v.Id ] + | vs -> vs |> List.map (fun v -> mkSynSimplePatVar false v.Id) - // Give bespoke error messages for the FSharp.Core "query" builder - let isQuery = - match stripDebugPoints interpExpr with - // An unparameterized custom builder, e.g., `query`, `async`. - | Expr.Val(vref, _, m) - // A parameterized custom builder, e.g., `builder<…>`, `builder ()`. - | Expr.App(funcExpr = Expr.Val(vref, _, m)) when not vref.IsMember || vref.IsConstructor -> - 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 - | _ -> false + SynSimplePats.SimplePats(spats, [], m) - let sourceMethInfo = - TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mBuilderVal ad "Source" builderTy +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) - /// Decide if the builder is an auto-quote builder - let isAutoQuote = hasMethInfo "Quote" cenv env mBuilderVal ad builderTy +let hasMethInfo nm cenv env mBuilderVal ad builderTy = + match TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mBuilderVal ad nm builderTy with + | [] -> false + | _ -> true - let customOperationMethods = +let getCustomOperationMethods (cenv: TcFileState) (env: TcEnv) ad mBuilderVal builderTy = + let allMethInfos = AllMethInfosOfTypeInScope ResultCollectionSettings.AllResults cenv.infoReader @@ -192,10 +146,10 @@ let TcComputationExpression (cenv: TcFileState) env (overallTy: OverallTy) tpenv IgnoreOverrides mBuilderVal builderTy - |> List.choose (fun methInfo -> - if not (IsMethInfoAccessible cenv.amap mBuilderVal ad methInfo) then - None - else + + [ + for methInfo in allMethInfos do + if IsMethInfoAccessible cenv.amap mBuilderVal ad methInfo then let nameSearch = TryBindMethInfoAttribute cenv.g @@ -217,7 +171,7 @@ let TcComputationExpression (cenv: TcFileState) env (overallTy: OverallTy) tpenv IgnoreAttribute // We do not respect this attribute for provided methods match nameSearch with - | None -> None + | None -> () | Some nm -> let joinConditionWord = TryBindMethInfoAttribute @@ -252,1596 +206,1854 @@ let TcComputationExpression (cenv: TcFileState) env (overallTy: OverallTy) tpenv let isLikeJoin = defaultArg (flagSearch "IsLikeJoin") false let isLikeGroupJoin = defaultArg (flagSearch "IsLikeGroupJoin") false - Some( - nm, - maintainsVarSpaceUsingBind, - maintainsVarSpace, - allowInto, - isLikeZip, - isLikeJoin, - isLikeGroupJoin, - joinConditionWord, - methInfo - )) + nm, + maintainsVarSpaceUsingBind, + maintainsVarSpace, + allowInto, + isLikeZip, + isLikeJoin, + isLikeGroupJoin, + joinConditionWord, + methInfo + ] + +/// Decide if the identifier represents a use of a custom query operator +let tryGetDataForCustomOperation (nm: Ident) ceenv = + let isOpDataCountAllowed opDatas = + match opDatas with + | [ _ ] -> true + | _ :: _ -> ceenv.cenv.g.langVersion.SupportsFeature LanguageFeature.OverloadsForCustomOperations + | _ -> false - 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)) - else - customOperationMethods - |> Seq.groupBy (fun (nm, _, _, _, _, _, _, _, _) -> nm) - |> Seq.map (fun (nm, g) -> (nm, Seq.toList g)) - |> dict + match ceenv.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 - // Check for duplicates by method name (keywords and method names must be 1:1) - 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)) - else - customOperationMethods - |> Seq.groupBy (fun (_, _, _, _, _, _, _, _, methInfo) -> methInfo.LogicalName) - |> Seq.map (fun (nm, g) -> (nm, Seq.toList g)) - |> dict + if + (maintainsVarSpaceUsingBind && maintainsVarSpace) + || (isLikeZip && isLikeJoin) + || (isLikeZip && isLikeGroupJoin) + || (isLikeJoin && isLikeGroupJoin) + then + errorR (Error(FSComp.SR.tcCustomOperationInvalid opName, nm.idRange)) - /// Decide if the identifier represents a use of a custom query operator - let tryGetDataForCustomOperation (nm: Ident) = - let isOpDataCountAllowed opDatas = - match opDatas with - | [ _ ] -> true - | _ :: _ -> cenv.g.langVersion.SupportsFeature LanguageFeature.OverloadsForCustomOperations - | _ -> false - - 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)) - - 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)) - - Some opDatas - | true, opData :: _ -> - errorR (Error(FSComp.SR.tcCustomOperationMayNotBeOverloaded nm.idText, nm.idRange)) - Some [ opData ] - | _ -> None + if not (ceenv.cenv.g.langVersion.SupportsFeature LanguageFeature.OverloadsForCustomOperations) then + match ceenv.customOperationMethodsIndexedByMethodName.TryGetValue methInfo.LogicalName with + | true, [ _ ] -> () + | _ -> errorR (Error(FSComp.SR.tcCustomOperationMayNotBeOverloaded nm.idText, nm.idRange)) - /// Decide if the identifier represents a use of a custom query operator - let hasCustomOperations () = - if isNil customOperationMethods then - CustomOperationsMode.Denied - else - CustomOperationsMode.Allowed - - let isCustomOperation nm = - tryGetDataForCustomOperation nm |> Option.isSome - - 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)) - - v0 - - // Check for the MaintainsVariableSpace on custom operation - 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 - | 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 - | 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 - | 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 - | 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 - | 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 - | None -> false - | Some opDatas -> - 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) :: _) -> - if isLikeGroupJoin then - Some( - FSComp.SR.customOperationTextLikeGroupJoin ( - nm.idText, - customOperationJoinConditionWord nm, - customOperationJoinConditionWord nm - ) + Some opDatas + | true, opData :: _ -> + errorR (Error(FSComp.SR.tcCustomOperationMayNotBeOverloaded nm.idText, nm.idRange)) + Some [ opData ] + | _ -> None + +let isCustomOperation ceenv nm = + tryGetDataForCustomOperation nm ceenv |> Option.isSome + +let customOperationCheckValidity m f opDatas = + let vs = List.map f opDatas + 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)) + + v0 + +// Check for the MaintainsVariableSpace on custom operation +let customOperationMaintainsVarSpace ceenv (nm: Ident) = + match tryGetDataForCustomOperation nm ceenv with + | None -> false + | Some opDatas -> + opDatas + |> customOperationCheckValidity + nm.idRange + (fun + (_nm, + _maintainsVarSpaceUsingBind, + maintainsVarSpace, + _allowInto, + _isLikeZip, + _isLikeJoin, + _isLikeGroupJoin, + _joinConditionWord, + _methInfo) -> maintainsVarSpace) + +let customOperationMaintainsVarSpaceUsingBind ceenv (nm: Ident) = + match tryGetDataForCustomOperation nm ceenv with + | None -> false + | Some opDatas -> + opDatas + |> customOperationCheckValidity + nm.idRange + (fun + (_nm, + maintainsVarSpaceUsingBind, + _maintainsVarSpace, + _allowInto, + _isLikeZip, + _isLikeJoin, + _isLikeGroupJoin, + _joinConditionWord, + _methInfo) -> maintainsVarSpaceUsingBind) + +let customOperationIsLikeZip ceenv (nm: Ident) = + match tryGetDataForCustomOperation nm ceenv with + | None -> false + | Some opDatas -> + opDatas + |> customOperationCheckValidity + nm.idRange + (fun + (_nm, + _maintainsVarSpaceUsingBind, + _maintainsVarSpace, + _allowInto, + isLikeZip, + _isLikeJoin, + _isLikeGroupJoin, + _joinConditionWord, + _methInfo) -> isLikeZip) + +let customOperationIsLikeJoin ceenv (nm: Ident) = + match tryGetDataForCustomOperation nm ceenv with + | None -> false + | Some opDatas -> + opDatas + |> customOperationCheckValidity + nm.idRange + (fun + (_nm, + _maintainsVarSpaceUsingBind, + _maintainsVarSpace, + _allowInto, + _isLikeZip, + isLikeJoin, + _isLikeGroupJoin, + _joinConditionWord, + _methInfo) -> isLikeJoin) + +let customOperationIsLikeGroupJoin ceenv (nm: Ident) = + match tryGetDataForCustomOperation nm ceenv with + | None -> false + | Some opDatas -> + opDatas + |> customOperationCheckValidity + nm.idRange + (fun + (_nm, + _maintainsVarSpaceUsingBind, + _maintainsVarSpace, + _allowInto, + _isLikeZip, + _isLikeJoin, + isLikeGroupJoin, + _joinConditionWord, + _methInfo) -> isLikeGroupJoin) + +let customOperationJoinConditionWord ceenv (nm: Ident) = + match tryGetDataForCustomOperation nm ceenv 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 ceenv (nm: Ident) = + match tryGetDataForCustomOperation nm ceenv with + | None -> false + | Some opDatas -> + opDatas + |> customOperationCheckValidity + nm.idRange + (fun + (_nm, + _maintainsVarSpaceUsingBind, + _maintainsVarSpace, + allowInto, + _isLikeZip, + _isLikeJoin, + _isLikeGroupJoin, + _joinConditionWord, + _methInfo) -> allowInto) + +let customOpUsageText ceenv nm = + match tryGetDataForCustomOperation nm ceenv with + | Some((_nm, + _maintainsVarSpaceUsingBind, + _maintainsVarSpace, + _allowInto, + isLikeZip, + isLikeJoin, + isLikeGroupJoin, + _joinConditionWord, + _methInfo) :: _) -> + if isLikeGroupJoin then + Some( + FSComp.SR.customOperationTextLikeGroupJoin ( + nm.idText, + customOperationJoinConditionWord ceenv nm, + customOperationJoinConditionWord ceenv nm ) - elif isLikeJoin then - Some( - FSComp.SR.customOperationTextLikeJoin ( - nm.idText, - customOperationJoinConditionWord nm, - customOperationJoinConditionWord nm - ) + ) + elif isLikeJoin then + Some( + FSComp.SR.customOperationTextLikeJoin ( + nm.idText, + customOperationJoinConditionWord ceenv nm, + customOperationJoinConditionWord ceenv nm ) - elif isLikeZip then - Some(FSComp.SR.customOperationTextLikeZip (nm.idText)) - else - 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 + ) + elif isLikeZip then + Some(FSComp.SR.customOperationTextLikeZip (nm.idText)) 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) - |> 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) - |> Some - | _ -> None + None + | _ -> None - 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) - - // 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 = - if cenv.g.langVersion.SupportsFeature LanguageFeature.OverloadsForCustomOperations then - 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)) - else - false +let tryGetArgAttribsForCustomOperator ceenv (nm: Ident) = + match tryGetDataForCustomOperation nm ceenv with + | Some argInfos -> + argInfos + |> List.map + (fun + (_nm, + __maintainsVarSpaceUsingBind, + _maintainsVarSpace, + _allowInto, + _isLikeZip, + _isLikeJoin, + _isLikeGroupJoin, + _joinConditionWord, + methInfo) -> + match methInfo.GetParamAttribs(ceenv.cenv.amap, ceenv.mWhole) with + | [ curriedArgInfo ] -> Some curriedArgInfo // one for the actual argument group + | _ -> None) + |> Some + | _ -> None - 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 +let tryGetArgInfosForCustomOperator ceenv (nm: Ident) = + match tryGetDataForCustomOperation nm ceenv with + | Some argInfos -> + argInfos + |> List.map + (fun + (_nm, + __maintainsVarSpaceUsingBind, + _maintainsVarSpace, + _allowInto, + _isLikeZip, + _isLikeJoin, + _isLikeGroupJoin, + _joinConditionWord, + methInfo) -> + match methInfo with + | FSMeth(_, _, vref, _) -> + match ArgInfosOfMember ceenv.cenv.g vref with + | [ curriedArgInfo ] -> Some curriedArgInfo + | _ -> None + | _ -> None) + |> Some + | _ -> None - // Check for the [] attribute on an argument position - let isCustomOperationProjectionParameter i (nm: Ident) = - match tryGetArgInfosForCustomOperator nm with - | None -> false - | Some argInfosForOverloads -> - let vs = +let tryExpectedArgCountForCustomOperator ceenv (nm: Ident) = + match tryGetArgAttribsForCustomOperator ceenv nm with + | None -> None + | 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 = + if ceenv.cenv.g.langVersion.SupportsFeature LanguageFeature.OverloadsForCustomOperations then argInfosForOverloads - |> List.map (function + |> List.exists (fun info -> + match info with | None -> false - | 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] + | Some args -> + args + |> List.exists (fun (ParamAttribs(isParamArrayArg, _isInArg, isOutArg, optArgInfo, _callerInfo, _reflArgInfo)) -> + isParamArrayArg || isOutArg || optArgInfo.IsOptional)) else - let opDatas = (tryGetDataForCustomOperation nm).Value - let opName, _, _, _, _, _, _, _j, _ = opDatas[0] - errorR (Error(FSComp.SR.tcCustomOperationInvalid opName, nm.idRange)) false - // e1 in e2 ('in' is parsed as 'JOIN_IN') - let (|InExpr|_|) synExpr = - match synExpr with - | SynExpr.JoinIn(e1, _, e2, mApp) -> Some(e1, e2, mApp) - | _ -> None + 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 - // e1 on e2 (note: 'on' is the 'JoinConditionWord') - let (|OnExpr|_|) nm synExpr = - match tryGetDataForCustomOperation nm with - | 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) - | _ -> None - - // e1 into e2 - 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 +// Check for the [] attribute on an argument position +let isCustomOperationProjectionParameter ceenv i (nm: Ident) = + match tryGetArgInfosForCustomOperator ceenv nm with + | None -> false + | Some argInfosForOverloads -> + let vs = + argInfosForOverloads + |> List.map (function + | None -> false + | Some argInfos -> + i < argInfos.Length + && let _, argInfo = List.item i argInfos in + HasFSharpAttribute ceenv.cenv.g ceenv.cenv.g.attrib_ProjectionParameterAttribute argInfo.Attribs) + + if List.allEqual vs then + vs[0] + else + let opDatas = (tryGetDataForCustomOperation nm ceenv).Value - let arbPat (m: range) = - mkSynPatVar None (mkSynId (m.MakeSynthetic()) "_missingVar") + let opName, _, _, _, _, _, _, _j, _ = opDatas[0] + errorR (Error(FSComp.SR.tcCustomOperationInvalid opName, nm.idRange)) + false - 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) - 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)) - - (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 isCustomOperation detector nm, ExprAsPat innerSourcePat, mJoinCore) -> - Some(nm, innerSourcePat, mJoinCore, false) - // join with bad pattern (gives error on "join" and continues) - | SynExpr.App(_, _, CustomOpId isCustomOperation 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 isCustomOperation 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 +[] +let (|ExprAsPat|_|) (f: SynExpr) = + match f with + | SingleIdent v1 + | SynExprParen(SingleIdent v1, _, _, _) -> ValueSome(mkSynPatVar None v1) + | SynExprParen(SynExpr.Tuple(false, elems, commas, _), _, _, _) -> + let elems = elems |> List.map (|SingleIdent|_|) - let (|JoinOp|_|) synExpr = - JoinOrGroupJoinOp customOperationIsLikeJoin synExpr + if elems |> List.forall (fun x -> x.IsSome) then + ValueSome(SynPat.Tuple(false, (elems |> List.map (fun x -> mkSynPatVar None x.Value)), commas, f.Range)) + else + ValueNone + | _ -> ValueNone - let (|GroupJoinOp|_|) synExpr = - JoinOrGroupJoinOp customOperationIsLikeGroupJoin synExpr +// 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|_|) ceenv (expr: SynExpr) = + let m = expr.Range + let ad = ceenv.env.eAccessRights - let arbKeySelectors m = - mkSynBifix m "=" (arbExpr ("_keySelectors", m)) (arbExpr ("_keySelector2", m)) + let isOpName opName vref s = + (s = opName) + && match + ResolveExprLongIdent + ceenv.cenv.tcSink + ceenv.cenv.nameResolver + m + ad + ceenv.env.eNameResEnv + TypeNameResolutionInfo.Default + [ ident (opName, m) ] + None + with + | Result(_, Item.Value vref2, []) -> valRefEq ceenv.cenv.g vref vref2 + | _ -> false - 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) - | _ -> None + match expr with + | BinOpExpr(opId, a, b) when isOpName opNameEquals ceenv.cenv.g.equals_operator_vref opId.idText -> ValueSome(a, b) - let (|GroupJoinExpr|_|) synExpr = - match synExpr with - | InExpr(GroupJoinOp(nm, innerSourcePat, _, alreadyGivenError), intoExpr, mGroupJoinCore) -> - let onExpr, intoPat, alreadyGivenError = - MatchIntoSuffixOrRecover alreadyGivenError nm intoExpr + | BinOpExpr(opId, a, b) when isOpName opNameEqualsNullable ceenv.cenv.g.equals_nullable_operator_vref opId.idText -> - 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)) + let a = + SynExpr.App(ExprAtomicFlag.Atomic, false, mkSynLidGet a.Range [ MangledGlobalName; "System" ] "Nullable", a, a.Range) - Some( - nm, - innerSourcePat, - arbExpr ("_innerSource", synExpr.Range), - arbKeySelectors synExpr.Range, - arbPat synExpr.Range, - mGroupJoinCore - ) - | _ -> None + ValueSome(a, b) - let (|JoinOrGroupJoinOrZipClause|_|) synExpr = + | BinOpExpr(opId, a, b) when isOpName opNameNullableEquals ceenv.cenv.g.nullable_equals_operator_vref opId.idText -> - match synExpr with - // join innerSourcePat in innerSource on (keySelector1 = keySelector2) - | JoinExpr(nm, innerSourcePat, innerSource, keySelectors, mJoinCore) -> - Some(nm, innerSourcePat, innerSource, Some keySelectors, None, mJoinCore) + let b = + SynExpr.App(ExprAtomicFlag.Atomic, false, mkSynLidGet b.Range [ MangledGlobalName; "System" ] "Nullable", b, b.Range) - // groupJoin innerSourcePat in innerSource on (keySelector1 = keySelector2) into intoPat - | GroupJoinExpr(nm, innerSourcePat, innerSource, keySelectors, intoPat, mGroupJoinCore) -> - Some(nm, innerSourcePat, innerSource, Some keySelectors, Some intoPat, mGroupJoinCore) + ValueSome(a, b) - // zip intoPat in secondSource - | InExpr(SynExpr.App(_, _, CustomOpId isCustomOperation customOperationIsLikeZip nm, ExprAsPat secondSourcePat, _), - secondSource, - mZipCore) -> Some(nm, secondSourcePat, secondSource, None, None, mZipCore) + | BinOpExpr(opId, a, b) when isOpName opNameNullableEqualsNullable ceenv.cenv.g.nullable_equals_nullable_operator_vref opId.idText -> - // zip (without secondSource or in - gives error) - | CustomOpId isCustomOperation 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) + ValueSome(a, b) - // zip secondSource (without in - gives error) - | SynExpr.App(_, _, CustomOpId isCustomOperation 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) + | _ -> ValueNone - | _ -> None +let (|ForEachThen|_|) synExpr = + match synExpr with + | SynExpr.ForEach(_spFor, + _spIn, + SeqExprOnly false, + isFromSource, + pat1, + expr1, + SynExpr.Sequential(isTrueSeq = true; expr1 = clause; expr2 = rest), + _) -> Some(isFromSource, pat1, expr1, clause, rest) + | _ -> None + +let (|CustomOpId|_|) isCustomOperation 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) + | _ -> None - let (|ForEachThenJoinOrGroupJoinOrZipClause|_|) strict synExpr = +// e1 on e2 (note: 'on' is the 'JoinConditionWord') +let (|OnExpr|_|) ceenv nm synExpr = + match tryGetDataForCustomOperation nm ceenv with + | None -> None + | Some _ -> 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) + | SynExpr.App(funcExpr = SynExpr.App(funcExpr = e1; argExpr = SingleIdent opName); argExpr = e2) when + opName.idText = customOperationJoinConditionWord ceenv nm -> - Some(isFromSource, firstSourcePat, firstSource, nm, secondSourcePat, secondSource, keySelectorsOpt, pat3opt, mOpCore, innerComp) + let item = Item.CustomOperation(opName.idText, (fun () -> None), None) - | 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) - ) + CallNameResolutionSink + ceenv.cenv.tcSink + (opName.idRange, ceenv.env.NameEnv, item, emptyTyparInst, ItemOccurence.Use, ceenv.env.AccessRights) + Some(e1, e2) | _ -> None - 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, [] +// e1 into e2 +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 g, acc = strip e - g, List.rev acc +let JoinOrGroupJoinOp ceenv detector synExpr = + match synExpr with + | SynExpr.App(_, _, CustomOpId (isCustomOperation ceenv) detector nm, ExprAsPat innerSourcePat, mJoinCore) -> + Some(nm, innerSourcePat, mJoinCore, false) + // join with bad pattern (gives error on "join" and continues) + | SynExpr.App(_, _, CustomOpId (isCustomOperation ceenv) detector nm, _innerSourcePatExpr, mJoinCore) -> + errorR (Error(FSComp.SR.tcBinaryOperatorRequiresVariable (nm.idText, Option.get (customOpUsageText ceenv nm)), nm.idRange)) + + Some(nm, arbPat mJoinCore, mJoinCore, true) + // join (without anything after - gives error on "join" and continues) + | CustomOpId (isCustomOperation ceenv) detector nm -> + errorR (Error(FSComp.SR.tcBinaryOperatorRequiresVariable (nm.idText, Option.get (customOpUsageText ceenv nm)), nm.idRange)) + + Some(nm, arbPat synExpr.Range, synExpr.Range, true) + | _ -> None +// JoinOrGroupJoinOp customOperationIsLikeJoin - let (|OptionalIntoSuffix|) e = - match e with - | IntoSuffix(body, intoWordRange, intoInfo) -> (body, Some(intoWordRange, intoInfo)) - | body -> (body, None) +let (|JoinOp|_|) ceenv synExpr = + JoinOrGroupJoinOp ceenv (customOperationIsLikeJoin ceenv) synExpr - 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) +let (|GroupJoinOp|_|) ceenv synExpr = + JoinOrGroupJoinOp ceenv (customOperationIsLikeGroupJoin ceenv) synExpr - CallNameResolutionSink - cenv.tcSink - (intoWordRange, env.NameEnv, item, emptyTyparInst, ItemOccurence.Use, env.eAccessRights) +let MatchIntoSuffixOrRecover ceenv 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) - Some intoInfo - | None -> None + CallNameResolutionSink + ceenv.cenv.tcSink + (intoWordRange, ceenv.env.NameEnv, item, emptyTyparInst, ItemOccurence.Use, ceenv.env.eAccessRights) - Some(nm, Option.get (tryGetDataForCustomOperation nm), core, core.Range, intoInfoOpt) - | _ -> None + (x, intoPat, alreadyGivenError) + | _ -> + if not alreadyGivenError then + errorR (Error(FSComp.SR.tcOperatorIncorrectSyntax (nm.idText, Option.get (customOpUsageText ceenv nm)), nm.idRange)) - let mkSynLambda p e m = - SynExpr.Lambda(false, false, p, e, None, m, SynExprLambdaTrivia.Zero) + (synExpr, arbPat synExpr.Range, true) - 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 MatchOnExprOrRecover ceenv alreadyGivenError nm (onExpr: SynExpr) = + match onExpr with + | OnExpr ceenv nm (innerSource, SynExprParen(keySelectors, _, _, _)) -> (innerSource, keySelectors) + | _ -> + if not alreadyGivenError then + suppressErrorReporting (fun () -> TcExprOfUnknownType ceenv.cenv ceenv.env ceenv.tpenv onExpr) + |> ignore - let mkSimplePatForVarSpace m (patvs: Val list) = - let spats = - match patvs with - | [] -> [] - | [ v ] -> [ mkSynSimplePatVar false v.Id ] - | vs -> vs |> List.map (fun v -> mkSynSimplePatVar false v.Id) + errorR (Error(FSComp.SR.tcOperatorIncorrectSyntax (nm.idText, Option.get (customOpUsageText ceenv nm)), nm.idRange)) - SynSimplePats.SimplePats(spats, [], m) + (arbExpr ("_innerSource", onExpr.Range), + mkSynBifix onExpr.Range "=" (arbExpr ("_keySelectors", onExpr.Range)) (arbExpr ("_keySelector2", onExpr.Range))) - 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 (|JoinExpr|_|) (ceenv: ComputationExpressionContext<'a>) synExpr = + match synExpr with + | InExpr(JoinOp ceenv (nm, innerSourcePat, _, alreadyGivenError), onExpr, mJoinCore) -> + let innerSource, keySelectors = + MatchOnExprOrRecover ceenv alreadyGivenError nm onExpr - let (|OptionalSequential|) e = - match e with - | SynExpr.Sequential(debugPoint = _sp; isTrueSeq = true; expr1 = dataComp1; expr2 = 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 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 - | _ -> 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)) - 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 + Some(nm, innerSourcePat, innerSource, keySelectors, mJoinCore) + | JoinOp ceenv (nm, innerSourcePat, mJoinCore, alreadyGivenError) -> + if alreadyGivenError then + errorR (Error(FSComp.SR.tcOperatorRequiresIn (nm.idText, Option.get (customOpUsageText ceenv nm)), nm.idRange)) - errorR (Error(FSComp.SR.tcUnrecognizedQueryBinaryOperator (), estimatedRangeOfIntendedLeftAndRightArguments)) - true - | _ -> false + Some(nm, innerSourcePat, arbExpr ("_innerSource", synExpr.Range), arbKeySelectors synExpr.Range, mJoinCore) + | _ -> None - let addVarsToVarSpace (varSpace: LazyWithContext) f = - LazyWithContext.Create( - (fun m -> - let (patvs: Val list, env) = varSpace.Force m - let vs, envinner = f m env +let (|GroupJoinExpr|_|) ceenv synExpr = + match synExpr with + | InExpr(GroupJoinOp ceenv (nm, innerSourcePat, _, alreadyGivenError), intoExpr, mGroupJoinCore) -> + let onExpr, intoPat, alreadyGivenError = + MatchIntoSuffixOrRecover ceenv alreadyGivenError nm intoExpr + + let innerSource, keySelectors = + MatchOnExprOrRecover ceenv alreadyGivenError nm onExpr + + Some(nm, innerSourcePat, innerSource, keySelectors, intoPat, mGroupJoinCore) + | GroupJoinOp ceenv (nm, innerSourcePat, mGroupJoinCore, alreadyGivenError) -> + if alreadyGivenError then + errorR (Error(FSComp.SR.tcOperatorRequiresIn (nm.idText, Option.get (customOpUsageText ceenv nm)), nm.idRange)) + + Some( + nm, + innerSourcePat, + arbExpr ("_innerSource", synExpr.Range), + arbKeySelectors synExpr.Range, + arbPat synExpr.Range, + mGroupJoinCore + ) + | _ -> None - let patvs = - List.append - patvs - (vs - |> List.filter (fun v -> not (patvs |> List.exists (fun v2 -> v.LogicalName = v2.LogicalName)))) +let (|JoinOrGroupJoinOrZipClause|_|) (ceenv: ComputationExpressionContext<'a>) synExpr = - patvs, envinner), - id - ) + match synExpr with + // join innerSourcePat in innerSource on (keySelector1 = keySelector2) + | JoinExpr ceenv (nm, innerSourcePat, innerSource, keySelectors, mJoinCore) -> + Some(nm, innerSourcePat, innerSource, Some keySelectors, None, mJoinCore) - // 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) - | _ -> e + // groupJoin innerSourcePat in innerSource on (keySelector1 = keySelector2) into intoPat + | GroupJoinExpr ceenv (nm, innerSourcePat, innerSource, keySelectors, intoPat, mGroupJoinCore) -> + Some(nm, innerSourcePat, innerSource, Some keySelectors, Some intoPat, mGroupJoinCore) - let emptyVarSpace = LazyWithContext.NotLazy([], env) + // zip intoPat in secondSource + | InExpr(SynExpr.App(_, _, CustomOpId (isCustomOperation ceenv) (customOperationIsLikeZip ceenv) nm, ExprAsPat secondSourcePat, _), + secondSource, + mZipCore) -> Some(nm, secondSourcePat, secondSource, None, None, mZipCore) - // 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" cenv env mBuilderVal ad builderTy - && hasMethInfo "Combine" cenv env mBuilderVal ad builderTy - && hasMethInfo "Delay" cenv env mBuilderVal ad builderTy - && YieldFree cenv comp) + // zip (without secondSource or in - gives error) + | CustomOpId (isCustomOperation ceenv) (customOperationIsLikeZip ceenv) nm -> + errorR (Error(FSComp.SR.tcOperatorIncorrectSyntax (nm.idText, Option.get (customOpUsageText ceenv nm)), nm.idRange)) - let origComp = comp + Some(nm, arbPat synExpr.Range, arbExpr ("_secondSource", synExpr.Range), None, None, synExpr.Range) - /// - /// 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 () -> + // zip secondSource (without in - gives error) + | SynExpr.App(_, _, CustomOpId (isCustomOperation ceenv) (customOperationIsLikeZip ceenv) nm, ExprAsPat secondSourcePat, mZipCore) -> + errorR (Error(FSComp.SR.tcOperatorIncorrectSyntax (nm.idText, Option.get (customOpUsageText ceenv nm)), mZipCore)) - match comp with + Some(nm, secondSourcePat, arbExpr ("_innerSource", synExpr.Range), None, None, mZipCore) - // 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) -> - match q with - | CustomOperationsMode.Denied -> error (Error(FSComp.SR.tcCustomOperationMayNotBeUsedHere (), nm.idRange)) - | CustomOperationsMode.Allowed -> - - let firstSource = - mkSourceExprConditional isFromSource firstSource sourceMethInfo builderValName - - let secondSource = mkSourceExpr secondSource sourceMethInfo builderValName - - // Add the variables to the variable space, on demand - let varSpaceWithFirstVars = - addVarsToVarSpace varSpace (fun _mCustomOp env -> - use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink + | _ -> None - let _, _, vspecs, envinner, _ = - TcMatchPattern cenv (NewInferenceType g) env tpenv firstSourcePat None +let (|ForEachThenJoinOrGroupJoinOrZipClause|_|) (ceenv: ComputationExpressionContext<'a>) strict synExpr = + match synExpr with + | ForEachThen(isFromSource, + firstSourcePat, + firstSource, + JoinOrGroupJoinOrZipClause ceenv (nm, secondSourcePat, secondSource, keySelectorsOpt, pat3opt, mOpCore), + innerComp) when + (let _firstSourceSimplePats, later1 = + use _holder = TemporarilySuspendReportingTypecheckResultsToSink ceenv.cenv.tcSink + SimplePatsOfPat ceenv.cenv.synArgNameGenerator firstSourcePat + + Option.isNone later1) + -> + Some(isFromSource, firstSourcePat, firstSource, nm, secondSourcePat, secondSource, keySelectorsOpt, pat3opt, mOpCore, innerComp) + + | JoinOrGroupJoinOrZipClause ceenv (nm, pat2, expr2, expr3, pat3opt, mOpCore) when strict -> + errorR (Error(FSComp.SR.tcBinaryOperatorRequiresBody (nm.idText, Option.get (customOpUsageText ceenv nm)), nm.idRange)) + + Some( + true, + arbPat synExpr.Range, + arbExpr ("_outerSource", synExpr.Range), + nm, + pat2, + expr2, + expr3, + pat3opt, + mOpCore, + arbExpr ("_innerComp", synExpr.Range) + ) - vspecs, envinner) + | _ -> None - let varSpaceWithSecondVars = - addVarsToVarSpace varSpaceWithFirstVars (fun _mCustomOp env -> - use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink +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)) + | body -> (body, None) + +let (|CustomOperationClause|_|) ceenv e = + match e with + | OptionalIntoSuffix(StripApps(SingleIdent nm, _) as core, intoOpt) when isCustomOperation ceenv 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 + ceenv.cenv.tcSink + (intoWordRange, ceenv.env.NameEnv, item, emptyTyparInst, ItemOccurence.Use, ceenv.env.eAccessRights) + + Some intoInfo + | None -> None - let _, _, vspecs, envinner, _ = - TcMatchPattern cenv (NewInferenceType g) env tpenv secondSourcePat None + Some(nm, Option.get (tryGetDataForCustomOperation nm ceenv), core, core.Range, intoInfoOpt) + | _ -> None - vspecs, envinner) +let (|OptionalSequential|) e = + match e with + | SynExpr.Sequential(debugPoint = _sp; isTrueSeq = true; expr1 = dataComp1; expr2 = 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 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 + | _ -> 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 ceenv comp = + match comp with + | StripApps(SingleIdent nm, [ StripApps(SingleIdent nm2, args); arg2 ]) when + IsLogicalInfixOpName nm.idText + && (match tryExpectedArgCountForCustomOperator ceenv 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 ceenv 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 inline 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 + ) + +/// +/// Try translate the syntax sugar +/// +/// Computation expression context (carrying caches, environments, ranges, etc) +/// Flag if it's inital check +/// 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 TryTranslateComputationExpression + (ceenv: ComputationExpressionContext<'a>) + (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 + + let cenv = ceenv.cenv + + cenv.stackGuard.Guard + <| fun () -> - let varSpaceWithGroupJoinVars = - match secondResultPatOpt with - | Some pat3 -> - addVarsToVarSpace varSpaceWithFirstVars (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 - - 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, - SynExprSequentialTrivia.Zero - ) + match comp with - 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 + // 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 ceenv true (isFromSource, + firstSourcePat, + firstSource, + nm, + secondSourcePat, + secondSource, + keySelectorsOpt, + secondResultPatOpt, + mOpCore, + innerComp) -> + match q with + | CustomOperationsMode.Denied -> error (Error(FSComp.SR.tcCustomOperationMayNotBeUsedHere (), nm.idRange)) + | CustomOperationsMode.Allowed -> + + let firstSource = + mkSourceExprConditional isFromSource firstSource ceenv.sourceMethInfo ceenv.builderValName + + let secondSource = + mkSourceExpr secondSource ceenv.sourceMethInfo ceenv.builderValName + + // Add the variables to the variable space, on demand + let varSpaceWithFirstVars = + addVarsToVarSpace varSpace (fun _mCustomOp env -> + use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink - | None, None when customOperationIsLikeZip nm -> mkZipExpr, varSpaceWithSecondVars + let _, _, vspecs, envinner, _ = + TcMatchPattern cenv (NewInferenceType cenv.g) env ceenv.tpenv firstSourcePat None - | _ -> - assert false - failwith "unreachable" + vspecs, envinner) - // 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 builderValName + let varSpaceWithSecondVars = + addVarsToVarSpace varSpaceWithFirstVars (fun _mCustomOp env -> + use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink - let consumingExpr = - SynExpr.ForEach( - DebugPointAtFor.No, - DebugPointAtInOrTo.No, - SeqExprOnly false, - false, - varSpacePat, - joinExpr, - innerComp, - mOpCore - ) + let _, _, vspecs, envinner, _ = + TcMatchPattern cenv (NewInferenceType cenv.g) env ceenv.tpenv secondSourcePat None - Some(trans CompExprTranslationPass.Initial q varSpaceInner consumingExpr translatedCtxt) + vspecs, envinner) - | SynExpr.ForEach(spFor, spIn, SeqExprOnly _seqExprOnly, isFromSource, pat, sourceExpr, innerComp, _mEntireForEach) -> - let sourceExpr = - match RewriteRangeExpr sourceExpr with - | Some e -> e - | None -> sourceExpr + let varSpaceWithGroupJoinVars = + match secondResultPatOpt with + | Some pat3 -> + addVarsToVarSpace varSpaceWithFirstVars (fun _mCustomOp env -> + use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink - let wrappedSourceExpr = - mkSourceExprConditional isFromSource sourceExpr sourceMethInfo builderValName + let _, _, vspecs, envinner, _ = + TcMatchPattern cenv (NewInferenceType cenv.g) env ceenv.tpenv pat3 None - let mFor = - match spFor with - | DebugPointAtFor.Yes m -> m.NoteSourceConstruct(NotedSourceConstruct.For) - | DebugPointAtFor.No -> pat.Range + vspecs, envinner) + | None -> varSpace - // 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 firstSourceSimplePats, later1 = + SimplePatsOfPat cenv.synArgNameGenerator firstSourcePat - let mPat = pat.Range + let secondSourceSimplePats, later2 = + SimplePatsOfPat cenv.synArgNameGenerator secondSourcePat - if - isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mFor ad "For" builderTy) - then - error (Error(FSComp.SR.tcRequireBuilderMethod ("For"), mFor)) + if Option.isSome later1 then + errorR (Error(FSComp.SR.tcJoinMustUseSimplePattern (nm.idText), firstSourcePat.Range)) - // Add the variables to the query variable space, on demand - let varSpace = - addVarsToVarSpace varSpace (fun _mCustomOp env -> - use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink + if Option.isSome later2 then + errorR (Error(FSComp.SR.tcJoinMustUseSimplePattern (nm.idText), secondSourcePat.Range)) - let _, _, vspecs, envinner, _ = - TcMatchPattern cenv (NewInferenceType g) env tpenv pat None + // check 'join' or 'groupJoin' or 'zip' is permitted for this builder + match tryGetDataForCustomOperation nm ceenv with + | None -> error (Error(FSComp.SR.tcMissingCustomOperation (nm.idText), nm.idRange)) + | Some opDatas -> + let opName, _, _, _, _, _, _, _, methInfo = opDatas[0] - vspecs, envinner) + // Record the resolution of the custom operation for posterity + let item = + Item.CustomOperation(opName, (fun () -> customOpUsageText ceenv nm), Some methInfo) - 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 - ) - ] - builderValName + // 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, ceenv.env.NameEnv, item, emptyTyparInst, ItemOccurence.Use, ceenv.env.eAccessRights) - let forCall = - match spFor with - | DebugPointAtFor.Yes _ -> SynExpr.DebugPoint(DebugPointAtLeafExpr.Yes mFor, false, forCall) - | DebugPointAtFor.No -> forCall + let mkJoinExpr keySelector1 keySelector2 innerPat e = + let mSynthetic = mOpCore.MakeSynthetic() - translatedCtxt forCall) - ) + mkSynCall + methInfo.DisplayName + mOpCore + [ + firstSource + secondSource + mkSynLambda firstSourceSimplePats keySelector1 mSynthetic + mkSynLambda secondSourceSimplePats keySelector2 mSynthetic + mkSynLambda firstSourceSimplePats (mkSynLambda innerPat e mSynthetic) mSynthetic + ] - | 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 + let mkZipExpr e = + let mSynthetic = mOpCore.MakeSynthetic() - if isQuery then - errorR (Error(FSComp.SR.tcNoIntegerForLoopInQuery (), mFor)) + mkSynCall + methInfo.DisplayName + mOpCore + [ + firstSource + secondSource + mkSynLambda firstSourceSimplePats (mkSynLambda secondSourceSimplePats e mSynthetic) mSynthetic + ] - let reduced = - elimFastIntegerForLoop (spFor, spTo, id, start, dir, finish, innerComp, m) + // 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, + SynExprSequentialTrivia.Zero + ) - Some(trans CompExprTranslationPass.Initial q varSpace reduced translatedCtxt) + let mkOverallExprGivenVarSpaceExpr, varSpaceInner = + + let isNullableOp opId = + match ConvertValLogicalNameToDisplayNameCore opId with + | "?=" + | "=?" + | "?=?" -> true + | _ -> false + + match secondResultPatOpt, keySelectorsOpt with + // groupJoin + | Some secondResultPat, Some relExpr when customOperationIsLikeGroupJoin ceenv 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 ceenv (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)) - | SynExpr.While(spWhile, guardExpr, innerComp, _) -> - let mGuard = guardExpr.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 ceenv nm -> + match relExpr with + | JoinRelation ceenv (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 - let mWhile = - match spWhile with - | DebugPointAtWhile.Yes m -> m.NoteSourceConstruct(NotedSourceConstruct.While) - | _ -> mGuard + | None, None when customOperationIsLikeZip ceenv nm -> mkZipExpr, varSpaceWithSecondVars - if isQuery then - error (Error(FSComp.SR.tcNoWhileInQuery (), mWhile)) + | _ -> + 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 ceenv.builderValName + + let consumingExpr = + SynExpr.ForEach( + DebugPointAtFor.No, + DebugPointAtInOrTo.No, + SeqExprOnly false, + false, + varSpacePat, + joinExpr, + innerComp, + mOpCore + ) - if - isNil ( - TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mWhile ad "While" builderTy - ) - then - error (Error(FSComp.SR.tcRequireBuilderMethod ("While"), mWhile)) + Some(TranslateComputationExpression ceenv CompExprTranslationPass.Initial q varSpaceInner consumingExpr translatedCtxt) - if - isNil ( - TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mWhile ad "Delay" builderTy - ) - then - error (Error(FSComp.SR.tcRequireBuilderMethod ("Delay"), mWhile)) + | SynExpr.ForEach(spFor, spIn, SeqExprOnly _seqExprOnly, isFromSource, pat, sourceExpr, innerComp, _mEntireForEach) -> + let sourceExpr = + match RewriteRangeExpr sourceExpr with + | Some e -> e + | None -> sourceExpr - // '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 wrappedSourceExpr = + mkSourceExprConditional isFromSource sourceExpr ceenv.sourceMethInfo ceenv.builderValName - Some( - trans CompExprTranslationPass.Initial q varSpace innerComp (fun holeFill -> - translatedCtxt ( - mkSynCall - "While" - mWhile - [ - mkSynDelay2 guardExpr - mkSynCall "Delay" mWhile [ mkSynDelay innerComp.Range holeFill ] builderValName - ] - builderValName - )) - ) + let mFor = + match spFor with + | DebugPointAtFor.Yes m -> m.NoteSourceConstruct(NotedSourceConstruct.For) + | DebugPointAtFor.No -> pat.Range - | 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 - ) + // 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 whileExpr = - SynExpr.While( - DebugPointAtWhile.No, - SynExpr.Ident idCond, - SynExpr.Sequential( - DebugPointAtSequential.SuppressBoth, - true, - innerComp, - bindCondExpr, - mWhile, - SynExprSequentialTrivia.Zero - ), - mOrig - ) + let mPat = pat.Range - SynExpr.LetOrUse(false, false, [ condBinding ], whileExpr, mGuard, SynExprLetOrUseTrivia.Zero) + if + isNil ( + TryFindIntrinsicOrExtensionMethInfo + ResultCollectionSettings.AtMostOneResult + cenv + ceenv.env + mFor + ceenv.ad + "For" + ceenv.builderTy + ) + then + error (Error(FSComp.SR.tcRequireBuilderMethod ("For"), mFor)) - SynExpr.LetOrUseBang( - DebugPointAtBinding.NoneAtSticky, - false, - true, - patFirst, - guardExpr, - [], - body, - mGuard, - SynExprLetOrUseBangTrivia.Zero - ) + // Add the variables to the query variable space, on demand + let varSpace = + addVarsToVarSpace varSpace (fun _mCustomOp env -> + use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink - tryTrans CompExprTranslationPass.Initial q varSpace rewrittenWhileExpr translatedCtxt + let _, _, vspecs, envinner, _ = + TcMatchPattern cenv (NewInferenceType cenv.g) env ceenv.tpenv pat None - | SynExpr.TryFinally(innerComp, unwindExpr, _mTryToLast, spTry, spFinally, trivia) -> + vspecs, envinner) - let mTry = - match spTry with - | DebugPointAtTry.Yes m -> m.NoteSourceConstruct(NotedSourceConstruct.Try) - | _ -> trivia.TryKeyword + Some( + TranslateComputationExpression ceenv CompExprTranslationPass.Initial q varSpace innerComp (fun innerCompR -> - let mFinally = - match spFinally with - | DebugPointAtFinally.Yes m -> m.NoteSourceConstruct(NotedSourceConstruct.Finally) - | _ -> trivia.FinallyKeyword + let forCall = + mkSynCall + "For" + mFor + [ + wrappedSourceExpr + SynExpr.MatchLambda( + false, + mPat, + [ + SynMatchClause(pat, None, innerCompR, mPat, DebugPointAtTarget.Yes, SynMatchClauseTrivia.Zero) + ], + DebugPointAtBinding.NoneAtInvisible, + mFor + ) + ] + ceenv.builderValName - // 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 + let forCall = + match spFor with + | DebugPointAtFor.Yes _ -> SynExpr.DebugPoint(DebugPointAtLeafExpr.Yes mFor, false, forCall) + | DebugPointAtFor.No -> forCall - if isQuery then - error (Error(FSComp.SR.tcNoTryFinallyInQuery (), mTry)) + translatedCtxt forCall) + ) - if - isNil ( - TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mTry ad "TryFinally" builderTy - ) - then - error (Error(FSComp.SR.tcRequireBuilderMethod ("TryFinally"), mTry)) + | 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 ceenv.isQuery then + errorR (Error(FSComp.SR.tcNoIntegerForLoopInQuery (), mFor)) + + let reduced = + elimFastIntegerForLoop (spFor, spTo, id, start, dir, finish, innerComp, m) + + Some(TranslateComputationExpression ceenv 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 ceenv.isQuery then + error (Error(FSComp.SR.tcNoWhileInQuery (), mWhile)) - if - isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mTry ad "Delay" builderTy) - then - error (Error(FSComp.SR.tcRequireBuilderMethod ("Delay"), mTry)) + if + isNil ( + TryFindIntrinsicOrExtensionMethInfo + ResultCollectionSettings.AtMostOneResult + cenv + ceenv.env + mWhile + ceenv.ad + "While" + ceenv.builderTy + ) + then + error (Error(FSComp.SR.tcRequireBuilderMethod ("While"), mWhile)) - let innerExpr = transNoQueryOps innerComp + if + isNil ( + TryFindIntrinsicOrExtensionMethInfo + ResultCollectionSettings.AtMostOneResult + cenv + ceenv.env + mWhile + ceenv.ad + "Delay" + ceenv.builderTy + ) + then + error (Error(FSComp.SR.tcRequireBuilderMethod ("Delay"), mWhile)) - let innerExpr = - match spTry with - | DebugPointAtTry.Yes _ -> SynExpr.DebugPoint(DebugPointAtLeafExpr.Yes mTry, true, innerExpr) - | _ -> innerExpr + // '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( + Some( + TranslateComputationExpression ceenv CompExprTranslationPass.Initial q varSpace innerComp (fun holeFill -> translatedCtxt ( mkSynCall - "TryFinally" - mTry + "While" + mWhile [ - mkSynCall "Delay" mTry [ mkSynDelay innerComp.Range innerExpr ] builderValName - mkSynDelay2 unwindExpr2 + mkSynDelay2 guardExpr + mkSynCall "Delay" mWhile [ mkSynDelay innerComp.Range holeFill ] ceenv.builderValName ] - builderValName - ) + ceenv.builderValName + )) + ) + + | 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, + SynExprSequentialTrivia.Zero + ), + mOrig + ) + + SynExpr.LetOrUse(false, false, [ condBinding ], whileExpr, mGuard, SynExprLetOrUseTrivia.Zero) + + SynExpr.LetOrUseBang( + DebugPointAtBinding.NoneAtSticky, + false, + true, + patFirst, + guardExpr, + [], + body, + mGuard, + SynExprLetOrUseBangTrivia.Zero ) - | 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 - match origComp with - // builder { } - // - // The compiler inserts a dummy () in CheckExpressions.fs for - // empty-bodied computation expressions. In this case, the user - // has not actually written any "control construct" in the body, - // and so we use a more specific error message for clarity. - | SynExpr.Const(SynConst.Unit, mUnit) when - g.langVersion.SupportsFeature LanguageFeature.EmptyBodiedComputationExpressions - && Range.equals mUnit range0 - -> - error (Error(FSComp.SR.tcEmptyBodyRequiresBuilderZeroMethod (), mWhole)) - | _ -> error (Error(FSComp.SR.tcRequireBuilderMethod ("Zero"), m)) - - Some(translatedCtxt (mkSynCall "Zero" m [] builderValName)) - - | 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 + TryTranslateComputationExpression ceenv CompExprTranslationPass.Initial q varSpace rewrittenWhileExpr translatedCtxt - let dataCompPrior = - translatedCtxt (transNoQueryOps (SynExpr.YieldOrReturn((true, false), varSpaceExpr, mClause))) + | SynExpr.TryFinally(innerComp, unwindExpr, _mTryToLast, spTry, spFinally, trivia) -> - // Rebind using for ... - let rebind = - SynExpr.ForEach( - DebugPointAtFor.No, - DebugPointAtInOrTo.No, - SeqExprOnly false, - false, - varSpacePat, - dataCompPrior, - comp, - comp.Range - ) + let mTry = + match spTry with + | DebugPointAtTry.Yes m -> m.NoteSourceConstruct(NotedSourceConstruct.Try) + | _ -> trivia.TryKeyword - // Retry with the 'for' loop packaging. Set firstTry=false just in case 'join' processing fails - tryTrans CompExprTranslationPass.Subsequent q varSpace rebind id + let mFinally = + match spFinally with + | DebugPointAtFinally.Yes m -> m.NoteSourceConstruct(NotedSourceConstruct.Finally) + | _ -> trivia.FinallyKeyword - | OptionalSequential(CustomOperationClause(nm, _, opExpr, mClause, _), _) -> + // 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 - match q with - | CustomOperationsMode.Denied -> error (Error(FSComp.SR.tcCustomOperationMayNotBeUsedHere (), opExpr.Range)) - | CustomOperationsMode.Allowed -> - let patvs, _env = varSpace.Force comp.Range - let varSpaceExpr = mkExprForVarSpace mClause patvs + if ceenv.isQuery then + error (Error(FSComp.SR.tcNoTryFinallyInQuery (), mTry)) - let dataCompPriorToOp = - let isYield = not (customOperationMaintainsVarSpaceUsingBind nm) - translatedCtxt (transNoQueryOps (SynExpr.YieldOrReturn((isYield, false), varSpaceExpr, mClause))) + if + isNil ( + TryFindIntrinsicOrExtensionMethInfo + ResultCollectionSettings.AtMostOneResult + cenv + ceenv.env + mTry + ceenv.ad + "TryFinally" + ceenv.builderTy + ) + then + error (Error(FSComp.SR.tcRequireBuilderMethod ("TryFinally"), mTry)) - // Now run the consumeCustomOpClauses - Some(consumeCustomOpClauses q varSpace dataCompPriorToOp comp false mClause) + if + isNil ( + TryFindIntrinsicOrExtensionMethInfo + ResultCollectionSettings.AtMostOneResult + cenv + ceenv.env + mTry + ceenv.ad + "Delay" + ceenv.builderTy + ) + then + error (Error(FSComp.SR.tcRequireBuilderMethod ("Delay"), mTry)) - | SynExpr.Sequential(sp, true, innerComp1, innerComp2, m, _) -> + let innerExpr = TranslateComputationExpressionNoQueryOps ceenv innerComp - // 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) + let innerExpr = + match spTry with + | DebugPointAtTry.Yes _ -> SynExpr.DebugPoint(DebugPointAtLeafExpr.Yes mTry, true, innerExpr) + | _ -> innerExpr - else + Some( + translatedCtxt ( + mkSynCall + "TryFinally" + mTry + [ + mkSynCall "Delay" mTry [ mkSynDelay innerComp.Range innerExpr ] ceenv.builderValName + mkSynDelay2 unwindExpr2 + ] + ceenv.builderValName + ) + ) - 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)) + | SynExpr.Paren(range = m) -> error (Error(FSComp.SR.tcConstructIsAmbiguousInComputationExpression (), m)) - if - isNil ( - TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env m ad "Delay" builderTy - ) - then - error (Error(FSComp.SR.tcRequireBuilderMethod ("Delay"), 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 ceenv.enableImplicitYield) + && isNil ( + TryFindIntrinsicOrExtensionMethInfo + ResultCollectionSettings.AtMostOneResult + cenv + ceenv.env + m + ceenv.ad + "Zero" + ceenv.builderTy + ) + then + match ceenv.origComp with + // builder { } + // + // The compiler inserts a dummy () in CheckExpressions.fs for + // empty-bodied computation expressions. In this case, the user + // has not actually written any "control construct" in the body, + // and so we use a more specific error message for clarity. + | SynExpr.Const(SynConst.Unit, mUnit) when + cenv.g.langVersion.SupportsFeature LanguageFeature.EmptyBodiedComputationExpressions + && Range.equals mUnit range0 + -> + error (Error(FSComp.SR.tcEmptyBodyRequiresBuilderZeroMethod (), ceenv.mWhole)) + | _ -> error (Error(FSComp.SR.tcRequireBuilderMethod ("Zero"), m)) + + Some(translatedCtxt (mkSynCall "Zero" m [] ceenv.builderValName)) + + | OptionalSequential(JoinOrGroupJoinOrZipClause ceenv (_, _, _, _, _, 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 combineCall = - mkSynCall - "Combine" - m1 - [ - c - mkSynCall "Delay" m1 [ mkSynDelay innerComp2.Range (transNoQueryOps innerComp2) ] builderValName - ] - builderValName - - 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 - ) + let dataCompPrior = + translatedCtxt ( + TranslateComputationExpressionNoQueryOps ceenv (SynExpr.YieldOrReturn((true, false), varSpaceExpr, mClause)) + ) - // "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 ] builderValName - - mkSynCall - "Combine" - m1 - [ - implicitYieldExpr - mkSynCall "Delay" m1 [ mkSynDelay holeFill.Range holeFill ] builderValName - ] - builderValName - - SynExpr.SequentialOrImplicitYield(sp, innerComp1, holeFill, combineExpr, m) - else - SynExpr.Sequential(sp, true, innerComp1, holeFill, m, SynExprSequentialTrivia.Zero) - - translatedCtxt fillExpr) - ) + // Rebind using for ... + let rebind = + SynExpr.ForEach( + DebugPointAtFor.No, + DebugPointAtInOrTo.No, + SeqExprOnly false, + false, + varSpacePat, + dataCompPrior, + comp, + comp.Range + ) - | SynExpr.IfThenElse(guardExpr, thenComp, elseCompOpt, spIfToThen, isRecovery, mIfToEndOfElseBranch, trivia) -> - match elseCompOpt with - | Some elseComp -> - if isQuery then - error (Error(FSComp.SR.tcIfThenElseMayNotBeUsedWithinQueries (), trivia.IfToThenRange)) + // Retry with the 'for' loop packaging. Set firstTry=false just in case 'join' processing fails + TryTranslateComputationExpression ceenv CompExprTranslationPass.Subsequent q varSpace rebind id - 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)) + | OptionalSequential(CustomOperationClause ceenv (nm, _, opExpr, mClause, _), _) -> + + match q with + | CustomOperationsMode.Denied -> error (Error(FSComp.SR.tcCustomOperationMayNotBeUsedHere (), opExpr.Range)) + | CustomOperationsMode.Allowed -> + let patvs, _env = varSpace.Force comp.Range + let varSpaceExpr = mkExprForVarSpace mClause patvs - mkSynCall "Zero" trivia.IfToThenRange [] builderValName + let dataCompPriorToOp = + let isYield = not (customOperationMaintainsVarSpaceUsingBind ceenv nm) - Some( - trans CompExprTranslationPass.Initial q varSpace thenComp (fun holeFill -> - translatedCtxt ( - SynExpr.IfThenElse( - guardExpr, - holeFill, - Some elseComp, - spIfToThen, - isRecovery, - mIfToEndOfElseBranch, - trivia - ) - )) + translatedCtxt ( + TranslateComputationExpressionNoQueryOps ceenv (SynExpr.YieldOrReturn((isYield, false), varSpaceExpr, mClause)) ) - // 'let binds in expr' - | SynExpr.LetOrUse(isRec, false, binds, innerComp, m, trivia) -> + // Now run the consumeCustomOpClauses + Some(ConsumeCustomOpClauses ceenv comp q varSpace dataCompPriorToOp comp false mClause) - // 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)) + | SynExpr.Sequential(sp, true, innerComp1, innerComp2, m, _) -> - match normalizedBindings with - | NormalizedBinding(mBinding = mBinding) :: _ -> failAt mBinding - | _ -> failAt 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 ceenv.isQuery && checkForBinaryApp ceenv innerComp1 then + Some(TranslateComputationExpression ceenv CompExprTranslationPass.Initial q varSpace innerComp2 translatedCtxt) - // 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; shouldInline = false; isMutable = false; pat = pat) ] -> - // successful case - use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink + else - let _, _, vspecs, envinner, _ = - TcMatchPattern cenv (NewInferenceType g) env tpenv pat None + if ceenv.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 + TryTranslateComputationExpression + ceenv + 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 + ceenv.env + m + ceenv.ad + "Combine" + ceenv.builderTy + ) + then + error (Error(FSComp.SR.tcRequireBuilderMethod ("Combine"), m)) - vspecs, envinner - | _ -> - // error case - error (Error(FSComp.SR.tcCustomOperationMayNotBeUsedInConjunctionWithNonSimpleLetBindings (), mQueryOp))) + if + isNil ( + TryFindIntrinsicOrExtensionMethInfo + ResultCollectionSettings.AtMostOneResult + cenv + ceenv.env + m + ceenv.ad + "Delay" + ceenv.builderTy + ) + then + error (Error(FSComp.SR.tcRequireBuilderMethod ("Delay"), m)) - Some( - trans CompExprTranslationPass.Initial q varSpace innerComp (fun holeFill -> - translatedCtxt (SynExpr.LetOrUse(isRec, false, binds, holeFill, m, trivia))) - ) + let combineCall = + mkSynCall + "Combine" + m1 + [ + c + mkSynCall + "Delay" + m1 + [ + mkSynDelay innerComp2.Range (TranslateComputationExpressionNoQueryOps ceenv innerComp2) + ] + ceenv.builderValName + ] + ceenv.builderValName - // '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 + Some(translatedCtxt combineCall) - if isQuery then - error (Error(FSComp.SR.tcUseMayNotBeUsedInQueries (), mBind)) + | 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 - let innerCompRange = innerComp.Range + Some( + TranslateComputationExpression + ceenv + CompExprTranslationPass.Initial + q + varSpace + (SynExpr.LetOrUseBang( + sp, + false, + true, + SynPat.Const(SynConst.Unit, rhsExpr.Range), + rhsExpr, + [], + innerComp2, + m, + SynExprLetOrUseBangTrivia.Zero + )) + translatedCtxt + ) - let consumeExpr = - SynExpr.MatchLambda( + // "expr; cexpr" is treated as sequential execution + | _ -> + Some( + TranslateComputationExpression ceenv CompExprTranslationPass.Initial q varSpace innerComp2 (fun holeFill -> + let fillExpr = + if ceenv.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 ] ceenv.builderValName + + mkSynCall + "Combine" + m1 + [ + implicitYieldExpr + mkSynCall "Delay" m1 [ mkSynDelay holeFill.Range holeFill ] ceenv.builderValName + ] + ceenv.builderValName + + SynExpr.SequentialOrImplicitYield(sp, innerComp1, holeFill, combineExpr, m) + else + SynExpr.Sequential(sp, true, innerComp1, holeFill, m, SynExprSequentialTrivia.Zero) + + translatedCtxt fillExpr) + ) + + | SynExpr.IfThenElse(guardExpr, thenComp, elseCompOpt, spIfToThen, isRecovery, mIfToEndOfElseBranch, trivia) -> + match elseCompOpt with + | Some elseComp -> + if ceenv.isQuery then + error (Error(FSComp.SR.tcIfThenElseMayNotBeUsedWithinQueries (), trivia.IfToThenRange)) + + Some( + translatedCtxt ( + SynExpr.IfThenElse( + guardExpr, + TranslateComputationExpressionNoQueryOps ceenv thenComp, + Some(TranslateComputationExpressionNoQueryOps ceenv elseComp), + spIfToThen, + isRecovery, + mIfToEndOfElseBranch, + trivia + ) + ) + ) + | None -> + let elseComp = + if + isNil ( + TryFindIntrinsicOrExtensionMethInfo + ResultCollectionSettings.AtMostOneResult + cenv + ceenv.env + trivia.IfToThenRange + ceenv.ad + "Zero" + ceenv.builderTy + ) + then + error (Error(FSComp.SR.tcRequireBuilderMethod ("Zero"), trivia.IfToThenRange)) + + mkSynCall "Zero" trivia.IfToThenRange [] ceenv.builderValName + + Some( + TranslateComputationExpression ceenv 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 ceenv.isQuery then + match (List.map (BindingNormalization.NormalizeBinding ValOrMemberBinding cenv ceenv.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 + + // 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; shouldInline = false; isMutable = false; pat = pat) ] -> + // successful case + use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink + + let _, _, vspecs, envinner, _ = + TcMatchPattern cenv (NewInferenceType cenv.g) env ceenv.tpenv pat None + + vspecs, envinner + | _ -> + // error case + error (Error(FSComp.SR.tcCustomOperationMayNotBeUsedInConjunctionWithNonSimpleLetBindings (), mQueryOp))) + + Some( + TranslateComputationExpression ceenv 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 ceenv.isQuery then + error (Error(FSComp.SR.tcUseMayNotBeUsedInQueries (), mBind)) + + let innerCompRange = innerComp.Range + + let consumeExpr = + SynExpr.MatchLambda( + false, + innerCompRange, + [ + SynMatchClause( + pat, + None, + TranslateComputationExpressionNoQueryOps ceenv innerComp, + innerCompRange, + DebugPointAtTarget.Yes, + SynMatchClauseTrivia.Zero + ) + ], + DebugPointAtBinding.NoneAtInvisible, + innerCompRange + ) + + if + isNil ( + TryFindIntrinsicOrExtensionMethInfo + ResultCollectionSettings.AtMostOneResult + cenv + ceenv.env + mBind + ceenv.ad + "Using" + ceenv.builderTy + ) + then + error (Error(FSComp.SR.tcRequireBuilderMethod ("Using"), mBind)) + + Some( + translatedCtxt (mkSynCall "Using" mBind [ rhsExpr; consumeExpr ] ceenv.builderValName) + |> 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 ceenv.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 cenv.g) env ceenv.tpenv pat None + + vspecs, envinner) + + let rhsExpr = + mkSourceExprConditional isFromSource rhsExpr ceenv.sourceMethInfo ceenv.builderValName + + Some( + TranslateComputationExpressionBind + ceenv + comp + 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 ceenv.isQuery then + error (Error(FSComp.SR.tcBindMayNotBeUsedInQueries (), mBind)) + + if + isNil ( + TryFindIntrinsicOrExtensionMethInfo + ResultCollectionSettings.AtMostOneResult + cenv + ceenv.env + mBind + ceenv.ad + "Using" + ceenv.builderTy + ) + then + error (Error(FSComp.SR.tcRequireBuilderMethod ("Using"), mBind)) + + if + isNil ( + TryFindIntrinsicOrExtensionMethInfo + ResultCollectionSettings.AtMostOneResult + cenv + ceenv.env + mBind + ceenv.ad + "Bind" + ceenv.builderTy + ) + then + error (Error(FSComp.SR.tcRequireBuilderMethod ("Bind"), mBind)) + + let bindExpr = + let consumeExpr = + SynExpr.MatchLambda( false, - innerCompRange, + mBind, [ SynMatchClause( pat, None, - transNoQueryOps innerComp, - innerCompRange, + TranslateComputationExpressionNoQueryOps ceenv innerComp, + innerComp.Range, DebugPointAtTarget.Yes, SynMatchClauseTrivia.Zero ) ], DebugPointAtBinding.NoneAtInvisible, - innerCompRange + mBind ) - if - isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mBind ad "Using" builderTy) - then - error (Error(FSComp.SR.tcRequireBuilderMethod ("Using"), mBind)) + let consumeExpr = + mkSynCall "Using" mBind [ SynExpr.Ident id; consumeExpr ] ceenv.builderValName - Some( - translatedCtxt (mkSynCall "Using" mBind [ rhsExpr; consumeExpr ] builderValName) - |> addBindDebugPoint spBind + let consumeExpr = + SynExpr.MatchLambda( + false, + mBind, + [ + SynMatchClause(pat, None, consumeExpr, id.idRange, DebugPointAtTarget.No, SynMatchClauseTrivia.Zero) + ], + DebugPointAtBinding.NoneAtInvisible, + mBind + ) + + let rhsExpr = + mkSourceExprConditional isFromSource rhsExpr ceenv.sourceMethInfo ceenv.builderValName + + mkSynCall "Bind" mBind [ rhsExpr; consumeExpr ] ceenv.builderValName + |> 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 ceenv.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 (fun expr -> mkSourceExprConditional isFromSource expr ceenv.sourceMethInfo ceenv.builderValName) + + 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 + ceenv.env + mBind + ceenv.ad + bindReturnNName + ceenv.builderTy + ) ) - // '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)) + if + hasBindReturnN + && Option.isSome (convertSimpleReturnToExpr ceenv comp varSpace innerComp) + then + let consumePat = SynPat.Tuple(false, pats, [], letPat.Range) // Add the variables to the query variable space, on demand let varSpace = @@ -1849,155 +2061,43 @@ let TcComputationExpression (cenv: TcFileState) env (overallTy: OverallTy) tpenv use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink let _, _, vspecs, envinner, _ = - TcMatchPattern cenv (NewInferenceType g) env tpenv pat None + TcMatchPattern cenv (NewInferenceType cenv.g) env ceenv.tpenv consumePat None vspecs, envinner) - let rhsExpr = - mkSourceExprConditional isFromSource rhsExpr sourceMethInfo builderValName - - 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 ] builderValName - - let consumeExpr = - SynExpr.MatchLambda( - false, - mBind, - [ - SynMatchClause(pat, None, consumeExpr, id.idRange, DebugPointAtTarget.No, SynMatchClauseTrivia.Zero) - ], - DebugPointAtBinding.NoneAtInvisible, - mBind - ) - - let rhsExpr = - mkSourceExprConditional isFromSource rhsExpr sourceMethInfo builderValName - - mkSynCall "Bind" mBind [ rhsExpr; consumeExpr ] builderValName - |> addBindDebugPoint spBind + Some( + TranslateComputationExpressionBind + ceenv + comp + q + varSpace + mBind + (addBindDebugPoint spBind) + bindNName + sources + consumePat + innerComp + translatedCtxt + ) - Some(translatedCtxt bindExpr) + else - // '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 (fun expr -> mkSourceExprConditional isFromSource expr sourceMethInfo builderValName) - - 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 = + // Check if this is a Bind2 etc. + let hasBindN = not ( isNil ( TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv - env + ceenv.env mBind - ad - bindReturnNName - builderTy + ceenv.ad + bindNName + ceenv.builderTy ) ) - if hasBindReturnN && Option.isSome (convertSimpleReturnToExpr varSpace innerComp) then + if hasBindN then let consumePat = SynPat.Tuple(false, pats, [], letPat.Range) // Add the variables to the query variable space, on demand @@ -2006,581 +2106,842 @@ let TcComputationExpression (cenv: TcFileState) env (overallTy: OverallTy) tpenv use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink let _, _, vspecs, envinner, _ = - TcMatchPattern cenv (NewInferenceType g) env tpenv consumePat None + TcMatchPattern cenv (NewInferenceType cenv.g) env ceenv.tpenv consumePat None vspecs, envinner) - Some(transBind q varSpace mBind (addBindDebugPoint spBind) bindNName sources consumePat innerComp translatedCtxt) - + Some( + TranslateComputationExpressionBind + ceenv + comp + q + varSpace + mBind + (addBindDebugPoint spBind) + bindNName + sources + consumePat + innerComp + translatedCtxt + ) else - // Check if this is a Bind2 etc. - let hasBindN = - not ( - isNil ( - TryFindIntrinsicOrExtensionMethInfo - ResultCollectionSettings.AtMostOneResult - cenv - env - mBind - ad - bindNName - builderTy - ) - ) + // 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 + ceenv.env + mBind + ceenv.ad + mergeSourcesName + ceenv.builderTy + ) + then + (n - 1) + else + loop (n + 1) - if hasBindN then - let consumePat = SynPat.Tuple(false, pats, [], letPat.Range) + loop 2 - // Add the variables to the query variable space, on demand - let varSpace = - addVarsToVarSpace varSpace (fun _mCustomOp env -> - use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink + if maxMergeSources = 1 then + error (Error(FSComp.SR.tcRequireMergeSourcesOrBindN (bindNName), mBind)) - let _, _, vspecs, envinner, _ = - TcMatchPattern cenv (NewInferenceType g) env tpenv consumePat None + let rec mergeSources (sourcesAndPats: (SynExpr * SynPat) list) = + let numSourcesAndPats = sourcesAndPats.Length + assert (numSourcesAndPats <> 0) - vspecs, envinner) + if numSourcesAndPats = 1 then + sourcesAndPats[0] - Some(transBind q varSpace mBind (addBindDebugPoint spBind) bindNName sources consumePat innerComp translatedCtxt) - else + elif numSourcesAndPats <= maxMergeSources then - // 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) + // Call MergeSources2(e1, e2), MergeSources3(e1, e2, e3) etc + let mergeSourcesName = mkMergeSourcesName numSourcesAndPats - loop 2 + if + isNil ( + TryFindIntrinsicOrExtensionMethInfo + ResultCollectionSettings.AtMostOneResult + cenv + ceenv.env + mBind + ceenv.ad + mergeSourcesName + ceenv.builderTy + ) + then + error (Error(FSComp.SR.tcRequireMergeSourcesOrBindN (bindNName), mBind)) - if maxMergeSources = 1 then - error (Error(FSComp.SR.tcRequireMergeSourcesOrBindN (bindNName), mBind)) + let source = + mkSynCall mergeSourcesName sourcesRange (List.map fst sourcesAndPats) ceenv.builderValName - let rec mergeSources (sourcesAndPats: (SynExpr * SynPat) list) = - let numSourcesAndPats = sourcesAndPats.Length - assert (numSourcesAndPats <> 0) + let pat = SynPat.Tuple(false, List.map snd sourcesAndPats, [], letPat.Range) + source, pat - 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 + ceenv.env + mBind + ceenv.ad + mergeSourcesName + ceenv.builderTy + ) + then + error (Error(FSComp.SR.tcRequireMergeSourcesOrBindN (bindNName), mBind)) - let source = - mkSynCall mergeSourcesName sourcesRange (List.map fst sourcesAndPats) builderValName + let laterSource, laterPat = mergeSources laterSourcesAndPats - let pat = SynPat.Tuple(false, List.map snd sourcesAndPats, [], letPat.Range) - source, pat + let source = + mkSynCall + mergeSourcesName + sourcesRange + (List.map fst nowSourcesAndPats @ [ laterSource ]) + ceenv.builderValName - else + let pat = + SynPat.Tuple(false, List.map snd nowSourcesAndPats @ [ laterPat ], [], letPat.Range) - // Call MergeSourcesMax(e1, e2, e3, e4, (...)) - let nowSourcesAndPats, laterSourcesAndPats = - List.splitAt (maxMergeSources - 1) sourcesAndPats - - let mergeSourcesName = mkMergeSourcesName maxMergeSources - - 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 mergedSources, consumePat = mergeSources (List.zip sources pats) - let source = - mkSynCall - mergeSourcesName - sourcesRange - (List.map fst nowSourcesAndPats @ [ laterSource ]) - builderValName + // Add the variables to the query variable space, on demand + let varSpace = + addVarsToVarSpace varSpace (fun _mCustomOp env -> + use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink - let pat = - SynPat.Tuple(false, List.map snd nowSourcesAndPats @ [ laterPat ], [], letPat.Range) + let _, _, vspecs, envinner, _ = + TcMatchPattern cenv (NewInferenceType cenv.g) env ceenv.tpenv consumePat None - source, pat + vspecs, envinner) - let mergedSources, consumePat = mergeSources (List.zip sources pats) + // Build the 'Bind' call + Some( + TranslateComputationExpressionBind + ceenv + comp + q + varSpace + mBind + (addBindDebugPoint spBind) + "Bind" + [ mergedSources ] + consumePat + innerComp + translatedCtxt + ) - // Add the variables to the query variable space, on demand - let varSpace = - addVarsToVarSpace varSpace (fun _mCustomOp env -> - use _holder = TemporarilySuspendReportingTypecheckResultsToSink cenv.tcSink + | SynExpr.Match(spMatch, expr, clauses, m, trivia) -> + if ceenv.isQuery then + error (Error(FSComp.SR.tcMatchMayNotBeUsedWithQuery (), trivia.MatchKeyword)) - let _, _, vspecs, envinner, _ = - TcMatchPattern cenv (NewInferenceType g) env tpenv consumePat None + let clauses = + clauses + |> List.map (fun (SynMatchClause(pat, cond, innerComp, patm, sp, trivia)) -> + SynMatchClause(pat, cond, TranslateComputationExpressionNoQueryOps ceenv innerComp, patm, sp, trivia)) - vspecs, envinner) + Some(translatedCtxt (SynExpr.Match(spMatch, expr, clauses, m, trivia))) - // Build the 'Bind' call - Some( - transBind - q - varSpace - mBind - (addBindDebugPoint spBind) - "Bind" - [ mergedSources ] - consumePat - innerComp - translatedCtxt - ) + // '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 ceenv.sourceMethInfo ceenv.builderValName - | SynExpr.Match(spMatch, expr, clauses, m, trivia) -> - if isQuery then - error (Error(FSComp.SR.tcMatchMayNotBeUsedWithQuery (), trivia.MatchKeyword)) + if ceenv.isQuery then + error (Error(FSComp.SR.tcMatchMayNotBeUsedWithQuery (), trivia.MatchBangKeyword)) - let clauses = - clauses - |> List.map (fun (SynMatchClause(pat, cond, innerComp, patm, sp, trivia)) -> - SynMatchClause(pat, cond, transNoQueryOps innerComp, patm, sp, trivia)) + if + isNil ( + TryFindIntrinsicOrExtensionMethInfo + ResultCollectionSettings.AtMostOneResult + cenv + ceenv.env + trivia.MatchBangKeyword + ceenv.ad + "Bind" + ceenv.builderTy + ) + then + error (Error(FSComp.SR.tcRequireBuilderMethod ("Bind"), trivia.MatchBangKeyword)) - Some(translatedCtxt (SynExpr.Match(spMatch, expr, clauses, m, trivia))) + let clauses = + clauses + |> List.map (fun (SynMatchClause(pat, cond, innerComp, patm, sp, trivia)) -> + SynMatchClause(pat, cond, TranslateComputationExpressionNoQueryOps ceenv innerComp, patm, sp, 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 sourceMethInfo builderValName + let consumeExpr = + SynExpr.MatchLambda(false, trivia.MatchBangKeyword, clauses, DebugPointAtBinding.NoneAtInvisible, trivia.MatchBangKeyword) - if isQuery then - error (Error(FSComp.SR.tcMatchMayNotBeUsedWithQuery (), trivia.MatchBangKeyword)) + let callExpr = + mkSynCall "Bind" trivia.MatchBangKeyword [ inputExpr; consumeExpr ] ceenv.builderValName + |> addBindDebugPoint spMatch - if - isNil ( - TryFindIntrinsicOrExtensionMethInfo - ResultCollectionSettings.AtMostOneResult - cenv - env - trivia.MatchBangKeyword - ad - "Bind" - builderTy - ) - then - error (Error(FSComp.SR.tcRequireBuilderMethod ("Bind"), trivia.MatchBangKeyword)) + Some(translatedCtxt callExpr) - let clauses = - clauses - |> List.map (fun (SynMatchClause(pat, cond, innerComp, patm, sp, trivia)) -> - SynMatchClause(pat, cond, transNoQueryOps innerComp, patm, sp, trivia)) + | SynExpr.TryWith(innerComp, clauses, mTryToLast, spTry, spWith, trivia) -> + let mTry = + match spTry with + | DebugPointAtTry.Yes _ -> trivia.TryKeyword.NoteSourceConstruct(NotedSourceConstruct.Try) + | _ -> trivia.TryKeyword - let consumeExpr = - SynExpr.MatchLambda( - false, - trivia.MatchBangKeyword, - clauses, - DebugPointAtBinding.NoneAtInvisible, - trivia.MatchBangKeyword - ) + let spWith2 = + match spWith with + | DebugPointAtWith.Yes _ -> DebugPointAtBinding.Yes trivia.WithKeyword + | _ -> DebugPointAtBinding.NoneAtInvisible - let callExpr = - mkSynCall "Bind" trivia.MatchBangKeyword [ inputExpr; consumeExpr ] builderValName - |> addBindDebugPoint spMatch + if ceenv.isQuery then + error (Error(FSComp.SR.tcTryWithMayNotBeUsedInQueries (), mTry)) - Some(translatedCtxt callExpr) + let clauses = + clauses + |> List.map (fun (SynMatchClause(pat, cond, clauseComp, patm, sp, trivia)) -> + SynMatchClause(pat, cond, TranslateComputationExpressionNoQueryOps ceenv clauseComp, patm, sp, trivia)) - | SynExpr.TryWith(innerComp, clauses, mTryToLast, spTry, spWith, trivia) -> - let mTry = - match spTry with - | DebugPointAtTry.Yes _ -> trivia.TryKeyword.NoteSourceConstruct(NotedSourceConstruct.Try) - | _ -> trivia.TryKeyword + let consumeExpr = + SynExpr.MatchLambda(true, mTryToLast, clauses, spWith2, mTryToLast) - let spWith2 = - match spWith with - | DebugPointAtWith.Yes _ -> DebugPointAtBinding.Yes trivia.WithKeyword - | _ -> DebugPointAtBinding.NoneAtInvisible + if + isNil ( + TryFindIntrinsicOrExtensionMethInfo + ResultCollectionSettings.AtMostOneResult + cenv + ceenv.env + mTry + ceenv.ad + "TryWith" + ceenv.builderTy + ) + then + error (Error(FSComp.SR.tcRequireBuilderMethod ("TryWith"), mTry)) - if isQuery then - error (Error(FSComp.SR.tcTryWithMayNotBeUsedInQueries (), mTry)) + if + isNil ( + TryFindIntrinsicOrExtensionMethInfo + ResultCollectionSettings.AtMostOneResult + cenv + ceenv.env + mTry + ceenv.ad + "Delay" + ceenv.builderTy + ) + then + error (Error(FSComp.SR.tcRequireBuilderMethod ("Delay"), mTry)) - let clauses = - clauses - |> List.map (fun (SynMatchClause(pat, cond, clauseComp, patm, sp, trivia)) -> - SynMatchClause(pat, cond, transNoQueryOps clauseComp, patm, sp, trivia)) + let innerExpr = TranslateComputationExpressionNoQueryOps ceenv innerComp - let consumeExpr = - SynExpr.MatchLambda(true, mTryToLast, clauses, spWith2, mTryToLast) + let innerExpr = + match spTry with + | DebugPointAtTry.Yes _ -> SynExpr.DebugPoint(DebugPointAtLeafExpr.Yes mTry, true, innerExpr) + | _ -> innerExpr - if - isNil ( - TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mTry ad "TryWith" builderTy - ) - then - error (Error(FSComp.SR.tcRequireBuilderMethod ("TryWith"), mTry)) + let callExpr = + mkSynCall + "TryWith" + mTry + [ + mkSynCall "Delay" mTry [ mkSynDelay2 innerExpr ] ceenv.builderValName + consumeExpr + ] + ceenv.builderValName - if - isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mTry ad "Delay" builderTy) - then - error (Error(FSComp.SR.tcRequireBuilderMethod ("Delay"), mTry)) + Some(translatedCtxt callExpr) - let innerExpr = transNoQueryOps innerComp + | SynExpr.YieldOrReturnFrom((true, _), synYieldExpr, m) -> + let yieldFromExpr = + mkSourceExpr synYieldExpr ceenv.sourceMethInfo ceenv.builderValName - let innerExpr = - match spTry with - | DebugPointAtTry.Yes _ -> SynExpr.DebugPoint(DebugPointAtLeafExpr.Yes mTry, true, innerExpr) - | _ -> innerExpr + if + isNil ( + TryFindIntrinsicOrExtensionMethInfo + ResultCollectionSettings.AtMostOneResult + cenv + ceenv.env + m + ceenv.ad + "YieldFrom" + ceenv.builderTy + ) + then + error (Error(FSComp.SR.tcRequireBuilderMethod ("YieldFrom"), m)) - let callExpr = - mkSynCall "TryWith" mTry [ mkSynCall "Delay" mTry [ mkSynDelay2 innerExpr ] builderValName; consumeExpr ] builderValName + let yieldFromCall = mkSynCall "YieldFrom" m [ yieldFromExpr ] ceenv.builderValName - Some(translatedCtxt callExpr) + let yieldFromCall = + if IsControlFlowExpression synYieldExpr then + yieldFromCall + else + SynExpr.DebugPoint(DebugPointAtLeafExpr.Yes m, false, yieldFromCall) - | SynExpr.YieldOrReturnFrom((true, _), synYieldExpr, m) -> - let yieldFromExpr = mkSourceExpr synYieldExpr sourceMethInfo builderValName + Some(translatedCtxt yieldFromCall) - if - isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env m ad "YieldFrom" builderTy) - then - error (Error(FSComp.SR.tcRequireBuilderMethod ("YieldFrom"), m)) + | SynExpr.YieldOrReturnFrom((false, _), synReturnExpr, m) -> + let returnFromExpr = + mkSourceExpr synReturnExpr ceenv.sourceMethInfo ceenv.builderValName - let yieldFromCall = mkSynCall "YieldFrom" m [ yieldFromExpr ] builderValName + if ceenv.isQuery then + error (Error(FSComp.SR.tcReturnMayNotBeUsedInQueries (), m)) - let yieldFromCall = - if IsControlFlowExpression synYieldExpr then - yieldFromCall - else - SynExpr.DebugPoint(DebugPointAtLeafExpr.Yes m, false, yieldFromCall) + if + isNil ( + TryFindIntrinsicOrExtensionMethInfo + ResultCollectionSettings.AtMostOneResult + cenv + ceenv.env + m + ceenv.ad + "ReturnFrom" + ceenv.builderTy + ) + then + error (Error(FSComp.SR.tcRequireBuilderMethod ("ReturnFrom"), m)) - Some(translatedCtxt yieldFromCall) + let returnFromCall = + mkSynCall "ReturnFrom" m [ returnFromExpr ] ceenv.builderValName - | SynExpr.YieldOrReturnFrom((false, _), synReturnExpr, m) -> - let returnFromExpr = mkSourceExpr synReturnExpr sourceMethInfo builderValName + let returnFromCall = + if IsControlFlowExpression synReturnExpr then + returnFromCall + else + SynExpr.DebugPoint(DebugPointAtLeafExpr.Yes m, false, returnFromCall) - if isQuery then - error (Error(FSComp.SR.tcReturnMayNotBeUsedInQueries (), m)) + Some(translatedCtxt returnFromCall) - if - isNil ( - TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env m ad "ReturnFrom" builderTy - ) - then - error (Error(FSComp.SR.tcRequireBuilderMethod ("ReturnFrom"), m)) + | SynExpr.YieldOrReturn((isYield, _), synYieldOrReturnExpr, m) -> + let methName = (if isYield then "Yield" else "Return") - let returnFromCall = mkSynCall "ReturnFrom" m [ returnFromExpr ] builderValName + if ceenv.isQuery && not isYield then + error (Error(FSComp.SR.tcReturnMayNotBeUsedInQueries (), m)) - let returnFromCall = - if IsControlFlowExpression synReturnExpr then - returnFromCall - else - SynExpr.DebugPoint(DebugPointAtLeafExpr.Yes m, false, returnFromCall) + if + isNil ( + TryFindIntrinsicOrExtensionMethInfo + ResultCollectionSettings.AtMostOneResult + cenv + ceenv.env + m + ceenv.ad + methName + ceenv.builderTy + ) + then + error (Error(FSComp.SR.tcRequireBuilderMethod (methName), m)) - Some(translatedCtxt returnFromCall) + let yieldOrReturnCall = + mkSynCall methName m [ synYieldOrReturnExpr ] ceenv.builderValName - | SynExpr.YieldOrReturn((isYield, _), synYieldOrReturnExpr, m) -> - let methName = (if isYield then "Yield" else "Return") + let yieldOrReturnCall = + if IsControlFlowExpression synYieldOrReturnExpr then + yieldOrReturnCall + else + SynExpr.DebugPoint(DebugPointAtLeafExpr.Yes m, false, yieldOrReturnCall) - if isQuery && not isYield then - error (Error(FSComp.SR.tcReturnMayNotBeUsedInQueries (), m)) + Some(translatedCtxt yieldOrReturnCall) - if - isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env m ad methName builderTy) - then - error (Error(FSComp.SR.tcRequireBuilderMethod (methName), m)) + | _ -> None - let yieldOrReturnCall = mkSynCall methName m [ synYieldOrReturnExpr ] builderValName +and ConsumeCustomOpClauses + (ceenv: ComputationExpressionContext<'a>) + (comp: SynExpr) + q + (varSpace: LazyWithContext<_, _>) + dataCompPrior + compClausesExpr + lastUsesBind + mClause + = - let yieldOrReturnCall = - if IsControlFlowExpression synYieldOrReturnExpr then - yieldOrReturnCall - else - SynExpr.DebugPoint(DebugPointAtLeafExpr.Yes m, false, yieldOrReturnCall) + // Substitute 'yield ' into the context - Some(translatedCtxt yieldOrReturnCall) + let patvs, _env = varSpace.Force comp.Range + let varSpaceSimplePat = mkSimplePatForVarSpace mClause patvs + let varSpacePat = mkPatForVarSpace mClause patvs - | _ -> None + match compClausesExpr with - and consumeCustomOpClauses q (varSpace: LazyWithContext<_, _>) dataCompPrior compClausesExpr lastUsesBind mClause = + // Detect one custom operation... This clause will always match at least once... + | OptionalSequential(CustomOperationClause ceenv (nm, opDatas, opExpr, mClause, optionalIntoPat), optionalCont) -> - // Substitute 'yield ' into the context + let opName, _, _, _, _, _, _, _, methInfo = opDatas[0] - let patvs, _env = varSpace.Force comp.Range - let varSpaceSimplePat = mkSimplePatForVarSpace mClause patvs - let varSpacePat = mkPatForVarSpace mClause patvs + let isLikeZip = customOperationIsLikeZip ceenv nm - match compClausesExpr with + let isLikeJoin = customOperationIsLikeJoin ceenv nm - // Detect one custom operation... This clause will always match at least once... - | OptionalSequential(CustomOperationClause(nm, opDatas, opExpr, mClause, optionalIntoPat), optionalCont) -> + let isLikeGroupJoin = customOperationIsLikeZip ceenv nm - let opName, _, _, _, _, _, _, _, methInfo = opDatas[0] - let isLikeZip = customOperationIsLikeZip nm - let isLikeJoin = customOperationIsLikeJoin nm - let isLikeGroupJoin = customOperationIsLikeZip nm + // Record the resolution of the custom operation for posterity + let item = + Item.CustomOperation(opName, (fun () -> customOpUsageText ceenv nm), Some methInfo) - // 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 + ceenv.cenv.tcSink + (nm.idRange, ceenv.env.NameEnv, item, emptyTyparInst, ItemOccurence.Use, ceenv.env.eAccessRights) - // 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 ceenv nm)), nm.idRange)) - if isLikeZip || isLikeJoin || isLikeGroupJoin then - 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 ceenv.cenv ceenv.env ceenv.tpenv opExpr + dataCompPrior + | Some contExpr -> ConsumeCustomOpClauses ceenv comp q varSpace dataCompPrior contExpr lastUsesBind mClause + else - 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 - | Some contExpr -> consumeCustomOpClauses q varSpace dataCompPrior contExpr lastUsesBind mClause - else + let maintainsVarSpace = customOperationMaintainsVarSpace ceenv nm - let maintainsVarSpace = customOperationMaintainsVarSpace nm - let maintainsVarSpaceUsingBind = customOperationMaintainsVarSpaceUsingBind nm - - let expectedArgCount = tryExpectedArgCountForCustomOperator nm - - 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 maintainsVarSpaceUsingBind = customOperationMaintainsVarSpaceUsingBind ceenv nm - mkSynCall methInfo.DisplayName mClause (dataCompPrior :: args) builderValName - else - let expectedArgCount = defaultArg expectedArgCount 0 + let expectedArgCount = tryExpectedArgCountForCustomOperator ceenv nm - errorR ( - Error( - FSComp.SR.tcCustomOperationHasIncorrectArgCount (nm.idText, expectedArgCount, args.Length), - nm.idRange - ) + let dataCompAfterOp = + match opExpr with + | StripApps(SingleIdent nm, args) -> + let argCountsMatch = + match expectedArgCount with + | Some n -> n = args.Length + | None -> ceenv.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 ceenv (i + 1) nm then + SynExpr.Lambda( + false, + false, + varSpaceSimplePat, + arg, + None, + arg.Range.MakeSynthetic(), + SynExprLambdaTrivia.Zero + ) + else + arg) + + mkSynCall methInfo.DisplayName mClause (dataCompPrior :: args) ceenv.builderValName + 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))) + ceenv.builderValName + | _ -> failwith "unreachable" + + 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 ceenv 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 ) - mkSynCall - methInfo.DisplayName - mClause - ([ dataCompPrior ] - @ List.init expectedArgCount (fun i -> arbExpr ("_arg" + string i, mClause))) - builderValName - | _ -> failwith "unreachable" + TranslateComputationExpression ceenv CompExprTranslationPass.Initial q ceenv.emptyVarSpace rebind id - match optionalCont with + // select a.Name; ... + // distinct; ... + // + // Process the rest of the clauses | 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 - ) + if maintainsVarSpace || maintainsVarSpaceUsingBind then + ConsumeCustomOpClauses ceenv comp q varSpace dataCompAfterOp contExpr maintainsVarSpaceUsingBind mClause + else + ConsumeCustomOpClauses ceenv comp q ceenv.emptyVarSpace dataCompAfterOp contExpr false mClause + + // 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 + ) - trans CompExprTranslationPass.Initial q emptyVarSpace rebind id + TranslateComputationExpression ceenv CompExprTranslationPass.Initial q varSpace rebind id + +and TranslateComputationExpressionNoQueryOps ceenv comp = + TranslateComputationExpression ceenv CompExprTranslationPass.Initial CustomOperationsMode.Denied ceenv.emptyVarSpace comp id + +and TranslateComputationExpressionBind + (ceenv: ComputationExpressionContext<'a>) + comp + q + varSpace + bindRange + addBindDebugPoint + bindName + (bindArgs: SynExpr list) + (consumePat: SynPat) + (innerComp: SynExpr) + translatedCtxt + = + + let innerRange = innerComp.Range + + let innerCompReturn = + if ceenv.cenv.g.langVersion.SupportsFeature LanguageFeature.AndBang then + convertSimpleReturnToExpr ceenv comp varSpace innerComp + else + None - // 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 + match innerCompReturn with + | Some(innerExpr, customOpInfo) when + (let bindName = bindName + "Return" + + not ( + isNil ( + TryFindIntrinsicOrExtensionMethInfo + ResultCollectionSettings.AtMostOneResult + ceenv.cenv + ceenv.env + bindRange + ceenv.ad + bindName + ceenv.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 + ) - // 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 - ) + translatedCtxt (mkSynCall bindName bindRange (bindArgs @ [ consumeExpr ]) ceenv.builderValName) + + match customOpInfo with + | None -> dataCompPriorToOp + | Some(innerComp, mClause) -> + // If the `BindReturn` was forced by a custom operation, continue to process the clauses of the CustomOp + ConsumeCustomOpClauses ceenv comp q varSpace dataCompPriorToOp innerComp false mClause + + | _ -> + + if + isNil ( + TryFindIntrinsicOrExtensionMethInfo + ResultCollectionSettings.AtMostOneResult + ceenv.cenv + ceenv.env + bindRange + ceenv.ad + bindName + ceenv.builderTy + ) + then + error (Error(FSComp.SR.tcRequireBuilderMethod (bindName), bindRange)) + + // Build the `Bind` call + TranslateComputationExpression ceenv 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 + ) - trans CompExprTranslationPass.Initial q varSpace rebind id + let bindCall = + mkSynCall bindName bindRange (bindArgs @ [ consumeExpr ]) ceenv.builderValName - and transNoQueryOps comp = - trans CompExprTranslationPass.Initial CustomOperationsMode.Denied emptyVarSpace comp id + translatedCtxt (bindCall |> addBindDebugPoint)) - and trans firstTry q varSpace comp translatedCtxt = - cenv.stackGuard.Guard - <| fun () -> - match tryTrans firstTry q varSpace comp translatedCtxt with - | Some e -> e - | None -> - // This only occurs in final position in a sequence - 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) -> - let mUnit = rhsExpr.Range - let rhsExpr = mkSourceExpr rhsExpr sourceMethInfo builderValName - - if isQuery then - error (Error(FSComp.SR.tcBindMayNotBeUsedInQueries (), m)) - - let bodyExpr = - 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 - | 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 - ) +/// 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 (ceenv: ComputationExpressionContext<'a>) comp varSpace innerComp = + match innerComp with + | SynExpr.YieldOrReturn((false, _), returnExpr, m) -> + let returnExpr = SynExpr.DebugPoint(DebugPointAtLeafExpr.Yes m, false, returnExpr) + Some(returnExpr, None) + + | SynExpr.Match(spMatch, expr, clauses, m, trivia) -> + let clauses = + clauses + |> List.map (fun (SynMatchClause(pat, cond, innerComp2, patm, sp, trivia)) -> + match convertSimpleReturnToExpr ceenv comp 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))) + + if clauses |> List.forall Option.isSome then + Some(SynExpr.Match(spMatch, expr, (clauses |> List.map Option.get), m, trivia), None) + else + None + + | SynExpr.IfThenElse(guardExpr, thenComp, elseCompOpt, spIfToThen, isRecovery, mIfToEndOfElseBranch, trivia) -> + match convertSimpleReturnToExpr ceenv comp 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 ceenv comp 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) - trans CompExprTranslationPass.Initial q varSpace letBangBind translatedCtxt + | SynExpr.LetOrUse(isRec, false, binds, innerComp, m, trivia) -> + match convertSimpleReturnToExpr ceenv comp varSpace innerComp with + | None -> None + | Some(_, Some _) -> None + | Some(innerExpr, None) -> Some(SynExpr.LetOrUse(isRec, false, binds, innerExpr, m, trivia), None) + + | OptionalSequential(CustomOperationClause ceenv (nm, _, _, mClause, _), _) when customOperationMaintainsVarSpaceUsingBind ceenv 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, trivia) -> + + // Check the first part isn't a computation expression construct + if (isSimpleExpr ceenv innerComp1) then + // Check the second part is a simple return + match convertSimpleReturnToExpr ceenv comp varSpace innerComp2 with + | None -> None + | Some(innerExpr2, optionalCont) -> Some(SynExpr.Sequential(sp, true, innerComp1, innerExpr2, m, trivia), optionalCont) + else + None + + | _ -> None + +/// Check if an expression has no computation expression constructs +and isSimpleExpr ceenv comp = + + match comp with + | ForEachThenJoinOrGroupJoinOrZipClause ceenv false _ -> false + | SynExpr.ForEach _ -> false + | SynExpr.For _ -> false + | SynExpr.While _ -> false + | SynExpr.WhileBang _ -> false + | SynExpr.TryFinally _ -> false + | SynExpr.ImplicitZero _ -> false + | OptionalSequential(JoinOrGroupJoinOrZipClause ceenv _, _) -> false + | OptionalSequential(CustomOperationClause ceenv _, _) -> false + | SynExpr.Sequential(expr1 = innerComp1; expr2 = innerComp2) -> isSimpleExpr ceenv innerComp1 && isSimpleExpr ceenv innerComp2 + | SynExpr.IfThenElse(thenExpr = thenComp; elseExpr = elseCompOpt) -> + isSimpleExpr ceenv thenComp + && (match elseCompOpt with + | None -> true + | Some c -> isSimpleExpr ceenv c) + | SynExpr.LetOrUse(body = innerComp) -> isSimpleExpr ceenv innerComp + | SynExpr.LetOrUseBang _ -> false + | SynExpr.Match(clauses = clauses) -> + clauses + |> List.forall (fun (SynMatchClause(resultExpr = innerComp)) -> isSimpleExpr ceenv innerComp) + | SynExpr.MatchBang _ -> false + | SynExpr.TryWith(tryExpr = innerComp; withCases = clauses) -> + isSimpleExpr ceenv innerComp + && clauses + |> List.forall (fun (SynMatchClause(resultExpr = clauseComp)) -> isSimpleExpr ceenv clauseComp) + | SynExpr.YieldOrReturnFrom _ -> false + | SynExpr.YieldOrReturn _ -> false + | SynExpr.DoBang _ -> false + | _ -> true - // "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 - trans CompExprTranslationPass.Initial q varSpace (SynExpr.ImplicitZero comp.Range) translatedCtxt +and TranslateComputationExpression (ceenv: ComputationExpressionContext<'a>) firstTry q varSpace comp translatedCtxt = + + ceenv.cenv.stackGuard.Guard + <| fun () -> + match TryTranslateComputationExpression ceenv firstTry q varSpace comp translatedCtxt with + | Some e -> e + | None -> + // This only occurs in final position in a sequence + 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) -> + let mUnit = rhsExpr.Range + let rhsExpr = mkSourceExpr rhsExpr ceenv.sourceMethInfo ceenv.builderValName + + if ceenv.isQuery then + error (Error(FSComp.SR.tcBindMayNotBeUsedInQueries (), m)) + + let bodyExpr = + if + isNil ( + TryFindIntrinsicOrExtensionMethInfo + ResultCollectionSettings.AtMostOneResult + ceenv.cenv + ceenv.env + m + ceenv.ad + "Return" + ceenv.builderTy + ) + then + SynExpr.ImplicitZero m else - 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)) + match + TryFindIntrinsicOrExtensionMethInfo + ResultCollectionSettings.AtMostOneResult + ceenv.cenv + ceenv.env + m + ceenv.ad + "Zero" + ceenv.builderTy + with + | minfo :: _ when MethInfoHasAttribute ceenv.cenv.g m ceenv.cenv.g.attrib_DefaultValueAttribute minfo -> + SynExpr.ImplicitZero m + | _ -> SynExpr.YieldOrReturn((false, true), SynExpr.Const(SynConst.Unit, m), m) - trans CompExprTranslationPass.Initial q varSpace (SynExpr.ImplicitZero comp.Range) (fun holeFill -> + let letBangBind = + SynExpr.LetOrUseBang( + DebugPointAtBinding.NoneAtDo, + false, + false, + SynPat.Const(SynConst.Unit, mUnit), + rhsExpr, + [], + bodyExpr, + m, + SynExprLetOrUseBangTrivia.Zero + ) + + TranslateComputationExpression ceenv 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 ceenv.isQuery && checkForBinaryApp ceenv comp then + TranslateComputationExpression + ceenv + CompExprTranslationPass.Initial + q + varSpace + (SynExpr.ImplicitZero comp.Range) + translatedCtxt + else + if ceenv.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)) + + TranslateComputationExpression + ceenv + CompExprTranslationPass.Initial + q + varSpace + (SynExpr.ImplicitZero comp.Range) + (fun holeFill -> let fillExpr = - if enableImplicitYield then - let implicitYieldExpr = mkSynCall "Yield" comp.Range [ comp ] builderValName + if ceenv.enableImplicitYield then + let implicitYieldExpr = mkSynCall "Yield" comp.Range [ comp ] ceenv.builderValName SynExpr.SequentialOrImplicitYield( DebugPointAtSequential.SuppressExpr, @@ -2601,192 +2962,119 @@ let TcComputationExpression (cenv: TcFileState) env (overallTy: OverallTy) tpenv translatedCtxt fillExpr) - and transBind - q - varSpace - bindRange - addBindDebugPoint - bindName - (bindArgs: SynExpr list) - (consumePat: SynPat) - (innerComp: SynExpr) - translatedCtxt - = - - let innerRange = innerComp.Range - - let innerCompReturn = - if cenv.g.langVersion.SupportsFeature LanguageFeature.AndBang then - convertSimpleReturnToExpr varSpace innerComp - else - None - - match innerCompReturn with - | Some(innerExpr, customOpInfo) when - (let bindName = bindName + "Return" - - 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 ]) builderValName) - - match customOpInfo with - | None -> dataCompPriorToOp - | 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)) - - // 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 - ) +/// Used for all computation expressions except sequence expressions +let TcComputationExpression (cenv: TcFileState) env (overallTy: OverallTy) tpenv (mWhole, interpExpr: Expr, builderTy, comp: SynExpr) = + let overallTy = overallTy.Commit - let bindCall = - mkSynCall bindName bindRange (bindArgs @ [ consumeExpr ]) builderValName + let ad = env.eAccessRights - translatedCtxt (bindCall |> addBindDebugPoint)) + let builderValName = CompilerGeneratedName "builder" + let mBuilderVal = interpExpr.Range - /// 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) -> - let returnExpr = SynExpr.DebugPoint(DebugPointAtLeafExpr.Yes m, false, returnExpr) - Some(returnExpr, None) + // Give bespoke error messages for the FSharp.Core "query" builder + let isQuery = + match stripDebugPoints interpExpr with + // An unparameterized custom builder, e.g., `query`, `async`. + | Expr.Val(vref, _, m) + // A parameterized custom builder, e.g., `builder<…>`, `builder ()`. + | Expr.App(funcExpr = Expr.Val(vref, _, m)) when not vref.IsMember || vref.IsConstructor -> + 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 + | _ -> false - | 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))) + let sourceMethInfo = + TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env mBuilderVal ad "Source" builderTy - if clauses |> List.forall Option.isSome then - Some(SynExpr.Match(spMatch, expr, (clauses |> List.map Option.get), m, trivia), None) - else - None + /// Decide if the builder is an auto-quote builder + let isAutoQuote = hasMethInfo "Quote" cenv env mBuilderVal ad builderTy - | 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) + let customOperationMethods = + getCustomOperationMethods cenv env ad mBuilderVal builderTy - | 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) + /// Decide if the identifier represents a use of a custom query operator + let hasCustomOperations = + match customOperationMethods with + | [] -> CustomOperationsMode.Denied + | _ -> CustomOperationsMode.Allowed - | OptionalSequential(CustomOperationClause(nm, _, _, mClause, _), _) when customOperationMaintainsVarSpaceUsingBind nm -> + let customOperationMethodsIndexedByKeyword = + if cenv.g.langVersion.SupportsFeature LanguageFeature.OverloadsForCustomOperations then + customOperationMethods + |> Seq.groupBy (fun (nm, _, _, _, _, _, _, _, _) -> nm) + |> Seq.map (fun (nm, group) -> (nm, Seq.toList group)) + else + customOperationMethods + |> Seq.groupBy (fun (nm, _, _, _, _, _, _, _, _) -> nm) + |> Seq.map (fun (nm, group) -> (nm, Seq.toList group)) + |> dict - let patvs, _env = varSpace.Force comp.Range - let varSpaceExpr = mkExprForVarSpace mClause patvs + // Check for duplicates by method name (keywords and method names must be 1:1) + let customOperationMethodsIndexedByMethodName = + if cenv.g.langVersion.SupportsFeature LanguageFeature.OverloadsForCustomOperations then + customOperationMethods + |> Seq.groupBy (fun (_, _, _, _, _, _, _, _, methInfo) -> methInfo.LogicalName) + |> Seq.map (fun (nm, group) -> (nm, Seq.toList group)) + else + customOperationMethods + |> Seq.groupBy (fun (_, _, _, _, _, _, _, _, methInfo) -> methInfo.LogicalName) + |> Seq.map (fun (nm, group) -> (nm, Seq.toList group)) + |> dict - Some(varSpaceExpr, Some(innerComp, mClause)) + // 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" cenv env mBuilderVal ad builderTy + && hasMethInfo "Combine" cenv env mBuilderVal ad builderTy + && hasMethInfo "Delay" cenv env mBuilderVal ad builderTy + && YieldFree cenv comp) - | SynExpr.Sequential(sp, true, innerComp1, innerComp2, m, trivia) -> + let origComp = comp - // 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, trivia), optionalCont) - else - None + let ceenv = + { + cenv = cenv + env = env + tpenv = tpenv + customOperationMethodsIndexedByKeyword = customOperationMethodsIndexedByKeyword + customOperationMethodsIndexedByMethodName = customOperationMethodsIndexedByMethodName + sourceMethInfo = sourceMethInfo + builderValName = builderValName + ad = ad + builderTy = builderTy + isQuery = isQuery + enableImplicitYield = enableImplicitYield + origComp = origComp + mWhole = mWhole + emptyVarSpace = LazyWithContext.NotLazy([], env) + } - | _ -> 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 ceenv (ident (nm, mBuilderVal))), Some methInfo))) + } - /// Check if an expression has no computation expression constructs - and isSimpleExpr comp = + // Environment is needed for completions + CallEnvSink cenv.tcSink (comp.Range, env.NameEnv, ad) - match comp with - | ForEachThenJoinOrGroupJoinOrZipClause false _ -> false - | SynExpr.ForEach _ -> false - | SynExpr.For _ -> false - | SynExpr.While _ -> false - | SynExpr.WhileBang _ -> false - | SynExpr.TryFinally _ -> false - | SynExpr.ImplicitZero _ -> false - | OptionalSequential(JoinOrGroupJoinOrZipClause _, _) -> false - | OptionalSequential(CustomOperationClause _, _) -> false - | SynExpr.Sequential(expr1 = innerComp1; expr2 = 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.MatchBang _ -> false - | 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 ceenv = { ceenv with env = env } let basicSynExpr = - trans CompExprTranslationPass.Initial (hasCustomOperations ()) (LazyWithContext.NotLazy([], env)) comp id + TranslateComputationExpression ceenv CompExprTranslationPass.Initial hasCustomOperations (LazyWithContext.NotLazy([], env)) comp id let mDelayOrQuoteOrRun = mBuilderVal @@ -2836,7 +3124,7 @@ let TcComputationExpression (cenv: TcFileState) env (overallTy: OverallTy) tpenv | _ -> env let lambdaExpr, tpenv = - TcExpr cenv (MustEqual(mkFunTy g builderTy overallTy)) env tpenv lambdaExpr + TcExpr cenv (MustEqual(mkFunTy cenv.g builderTy overallTy)) env tpenv lambdaExpr // beta-var-reduce to bind the builder using a 'let' binding let coreExpr =