Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

perform sourceExpr translation on match-bang expressions #9407

Merged
merged 2 commits into from
Jun 11, 2020
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Jump to
Jump to file
Failed to load files.
Diff view
Diff view
3 changes: 2 additions & 1 deletion src/fsharp/TypeChecker.fs
Expand Up @@ -8571,6 +8571,7 @@ and TcComputationExpression cenv env overallTy mWhole (interpExpr: Expr) builder

// 'match! expr with pats ...' --> build.Bind(e1, (function pats ...))
| SynExpr.MatchBang (spMatch, expr, clauses, m) ->
let matchExpr = mkSourceExpr expr
let mMatch = match spMatch with DebugPointAtBinding mMatch -> mMatch | _ -> m
if isQuery then error(Error(FSComp.SR.tcMatchMayNotBeUsedWithQuery(), mMatch))

Expand All @@ -8581,7 +8582,7 @@ and TcComputationExpression cenv env overallTy mWhole (interpExpr: Expr) builder
let consumeExpr = SynExpr.MatchLambda (false, mMatch, clauses, spMatch, mMatch)

// TODO: consider allowing translation to BindReturn
Some(translatedCtxt (mkSynCall "Bind" mMatch [expr; consumeExpr]))
Some(translatedCtxt (mkSynCall "Bind" mMatch [matchExpr; consumeExpr]))

| SynExpr.TryWith (innerComp, _mTryToWith, clauses, _mWithToLast, mTryToLast, spTry, _spWith) ->
let mTry = match spTry with DebugPointAtTry.Yes m -> m | _ -> mTryToLast
Expand Down
39 changes: 32 additions & 7 deletions tests/fsharp/Compiler/Language/ComputationExpressionTests.fs
Expand Up @@ -7,9 +7,8 @@ open FSharp.Compiler.SourceCodeServices
[<TestFixture>]
module ComputationExpressionTests =

[<Test>]
let ``do-bang can be used with nested CE expressions``() =
let code = """
let ``complex CE with source member and applicatives`` ceUsage =
sprintf """
module Code
type ResultBuilder() =
member __.Return value = Ok value
Expand All @@ -29,10 +28,12 @@ module Result =
| Ok x1res, Ok x2res -> Ok (x1res, x2res)
| Error e, _ -> Error e
| _, Error e -> Error e

let ofChoice c =
match c with
| Choice1Of2 x -> Ok x
| Choice2Of2 x -> Error x

let fold onOk onError r =
match r with
| Ok x -> onOk x
Expand All @@ -49,9 +50,10 @@ module Async =
}

module AsyncResult =
let zip x1 x2 =
let zip x1 x2 =
Async.zip x1 x2
|> Async.map(fun (r1, r2) -> Result.zip r1 r2)

let foldResult onSuccess onError ar =
Async.map (Result.fold onSuccess onError) ar

Expand Down Expand Up @@ -101,7 +103,7 @@ type AsyncResultBuilder() =
compensation: unit -> unit)
: Async<Result<'T, 'TError>> =
async.TryFinally(computation, compensation)

member __.Using
(resource: 'T when 'T :> System.IDisposable,
binder: 'T -> Async<Result<'U, 'TError>>)
Expand All @@ -127,6 +129,7 @@ type AsyncResultBuilder() =

member inline _.Source(result : Async<Result<_,_>>) : Async<Result<_,_>> = result

[<AutoOpen>]
module ARExts =
type AsyncResultBuilder with
/// <summary>
Expand All @@ -151,9 +154,14 @@ module ARExts =
/// Method lets us transform data types into our internal representation.
/// </summary>
member inline __.Source(asyncComputation : Async<_>) : Async<Result<_,_>> = asyncComputation |> Async.map Ok

let asyncResult = AsyncResultBuilder()

%s""" ceUsage

[<Test>]
let ``do-bang can be used with nested CE expressions``() =
let code = ``complex CE with source member and applicatives`` """
asyncResult {
let! something = asyncResult { return 5 }
do! asyncResult {
Expand All @@ -165,4 +173,21 @@ asyncResult {
|> Async.RunSynchronously
|> printfn "%d"
"""
CompilerAssert.Pass code
CompilerAssert.Pass code

[<Test>]
let ``match-bang should apply source transformations to its inputs`` () =
let code = ``complex CE with source member and applicatives`` """
asyncResult {
// if the source transformation is not applied, the match will not work,
// because match! is only defined in terms of let!, and the only
// bind overload provided takes AsyncResult as its input.
match! Ok 5 with
| 5 -> return "ok"
| n -> return! (Error (sprintf "boo %d" n))
}
|> AsyncResult.foldResult id (fun (err: string) -> err)
|> Async.RunSynchronously
|> printfn "%s"
"""
CompilerAssert.Pass code