Skip to content

Commit b12e354

Browse files
DedSec256DedSec256
committed
wip
1 parent b7a3a82 commit b12e354

File tree

2 files changed

+172
-4
lines changed

2 files changed

+172
-4
lines changed

‎src/Compiler/Checking/Expressions/CheckComputationExpressions.fs‎

Lines changed: 11 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -4,7 +4,6 @@
44
/// with generalization at appropriate points.
55
module internal FSharp.Compiler.CheckComputationExpressions
66

7-
open FSharp.Compiler.TcGlobals
87
open Internal.Utilities.Library
98
open FSharp.Compiler.AccessibilityLogic
109
open FSharp.Compiler.AttributeChecking
@@ -854,6 +853,12 @@ let (|OptionalSequential|) e =
854853
| SynExpr.Sequential(debugPoint = _sp; isTrueSeq = true; expr1 = dataComp1; expr2 = dataComp2) -> (dataComp1, Some dataComp2)
855854
| _ -> (e, None)
856855

856+
let private getTypedHeadPattern (SynBinding(headPat = headPattern; returnInfo = returnInfo)) =
857+
match returnInfo with
858+
| None -> headPattern
859+
| Some(SynBindingReturnInfo(typeName = typeName; range = range)) ->
860+
SynPat.Typed(headPattern, typeName, unionRanges headPattern.Range range)
861+
857862
[<return: Struct>]
858863
let (|ExprAsUseBang|_|) expr =
859864
match expr with
@@ -865,7 +870,8 @@ let (|ExprAsUseBang|_|) expr =
865870
body = innerComp
866871
trivia = { LetOrUseKeyword = mBind }) ->
867872
match bindings with
868-
| SynBinding(debugPoint = spBind; headPat = pat; expr = rhsExpr) :: andBangs ->
873+
| SynBinding(debugPoint = spBind; expr = rhsExpr) as binding :: andBangs ->
874+
let pat = getTypedHeadPattern binding
869875
ValueSome(spBind, isFromSource, pat, rhsExpr, andBangs, innerComp, mBind)
870876
| _ -> ValueNone
871877
| _ -> ValueNone
@@ -881,7 +887,8 @@ let (|ExprAsLetBang|_|) expr =
881887
body = innerComp
882888
trivia = { LetOrUseKeyword = mBind }) ->
883889
match bindings with
884-
| SynBinding(debugPoint = spBind; headPat = letPat; expr = letRhsExpr) :: andBangBindings ->
890+
| SynBinding(debugPoint = spBind; expr = letRhsExpr) as binding :: andBangBindings ->
891+
let letPat = getTypedHeadPattern binding
885892
ValueSome(spBind, isFromSource, letPat, letRhsExpr, andBangBindings, innerComp, mBind)
886893
| _ -> ValueNone
887894
| _ -> ValueNone
@@ -2006,7 +2013,7 @@ let rec TryTranslateComputationExpression
20062013
|> List.map (fun expr -> mkSourceExprConditional isFromSource expr ceenv.sourceMethInfo ceenv.builderValName)
20072014

20082015
let pats =
2009-
letPat :: [ for SynBinding(headPat = andPat) in andBangBindings -> andPat ]
2016+
letPat :: [ for binding in andBangBindings -> getTypedHeadPattern binding ]
20102017

20112018
let sourcesRange = sources |> List.map (fun e -> e.Range) |> List.reduce unionRanges
20122019

‎tests/FSharp.Compiler.ComponentTests/Language/ComputationExpressionTests.fs‎

Lines changed: 161 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -2072,6 +2072,167 @@ task {
20722072
Error 1, Line 7, Col 11, Line 7, Col 17, "This expression was expected to have type
20732073
'IDisposable'
20742074
but here has type
2075+
'int' "
2076+
]
2077+
2078+
[<Fact>]
2079+
let ``Preview: let! return type check error 01`` () =
2080+
FSharp """
2081+
module Test
2082+
2083+
open System.Threading.Tasks
2084+
2085+
task {
2086+
let! x: string = Task.FromResult(1)
2087+
()
2088+
}
2089+
|> ignore
2090+
"""
2091+
|> withLangVersionPreview
2092+
|> typecheck
2093+
|> shouldFail
2094+
|> withDiagnostics [
2095+
Error 1, Line 7, Col 10, Line 7, Col 19, "This expression was expected to have type
2096+
'int'
2097+
but here has type
2098+
'string' "
2099+
]
2100+
2101+
[<Fact>]
2102+
let ``Preview: let! return type check error 02`` () =
2103+
FSharp """
2104+
module Test
2105+
2106+
open System.Threading.Tasks
2107+
2108+
task {
2109+
let! (x: string): int = Task.FromResult(1)
2110+
()
2111+
}
2112+
|> ignore
2113+
"""
2114+
|> withLangVersionPreview
2115+
|> typecheck
2116+
|> shouldFail
2117+
|> withDiagnostics [
2118+
Error 1, Line 7, Col 11, Line 7, Col 20, "This expression was expected to have type
2119+
'int'
2120+
but here has type
2121+
'string' "
2122+
]
2123+
2124+
[<Fact>]
2125+
let ``Preview: let! return type check error 03`` () =
2126+
FSharp """
2127+
module Test
2128+
2129+
open System.Threading.Tasks
2130+
2131+
task {
2132+
let! (x: string): int = Task.FromResult("")
2133+
()
2134+
}
2135+
|> ignore
2136+
"""
2137+
|> withLangVersionPreview
2138+
|> typecheck
2139+
|> shouldFail
2140+
|> withDiagnostics [
2141+
Error 1, Line 7, Col 10, Line 7, Col 26, "This expression was expected to have type
2142+
'string'
2143+
but here has type
2144+
'int' "
2145+
]
2146+
2147+
[<Fact>]
2148+
let ``Preview: let!-and! return type check error 01`` () =
2149+
FSharp """
2150+
module Test
2151+
2152+
type MyBuilder() =
2153+
member _.Return(x: int): Result<int, exn> = failwith ""
2154+
member _.Bind(m: Result<int, exn>, f: int -> Result<int, exn>): Result<int, exn> = failwith ""
2155+
member _.Bind2(m1: Result<int, exn>, m2: Result<int, exn>, f: int * int -> Result<int, exn>): Result<int, exn> = failwith ""
2156+
2157+
let builder = MyBuilder()
2158+
2159+
builder {
2160+
let! x: int = Ok 1
2161+
and! y: string = Ok 2
2162+
return 0
2163+
}
2164+
|> ignore
2165+
"""
2166+
|> withLangVersionPreview
2167+
|> typecheck
2168+
|> shouldFail
2169+
|> withDiagnostics [
2170+
Error 1, Line 13, Col 10, Line 13, Col 19, "This expression was expected to have type
2171+
'int'
2172+
but here has type
2173+
'string' ";
2174+
Warning 25, Line 12, Col 10, Line 12, Col 16, "Incomplete pattern matches on this expression."
2175+
]
2176+
2177+
[<Fact>]
2178+
let ``Preview: let!-and! return type check error 02`` () =
2179+
FSharp """
2180+
module Test
2181+
2182+
type MyBuilder() =
2183+
member _.Return(x: int): Result<int, exn> = failwith ""
2184+
member _.Bind(m: Result<int, exn>, f: int -> Result<int, exn>): Result<int, exn> = failwith ""
2185+
member _.Bind2(m1: Result<int, exn>, m2: Result<int, exn>, f: int * int -> Result<int, exn>): Result<int, exn> = failwith ""
2186+
2187+
let builder = MyBuilder()
2188+
2189+
builder {
2190+
let! x: int = Ok 1
2191+
and! (y: string): int = Ok 2
2192+
return 0
2193+
}
2194+
|> ignore
2195+
"""
2196+
|> withLangVersionPreview
2197+
|> typecheck
2198+
|> shouldFail
2199+
|> withDiagnostics [
2200+
Error 1, Line 13, Col 11, Line 13, Col 20, "This expression was expected to have type
2201+
'int'
2202+
but here has type
2203+
'string' "
2204+
]
2205+
2206+
[<Fact>]
2207+
let ``Preview: let!-and! return type check error 03`` () =
2208+
FSharp """
2209+
module Test
2210+
2211+
type MyBuilder() =
2212+
member _.Return(x: int): Result<int, exn> = failwith ""
2213+
member _.Bind(m: Result<int, exn>, f: int -> Result<int, exn>): Result<int, exn> = failwith ""
2214+
member _.Bind2(m1: Result<int, exn>, m2: Result<int, exn>, f: int * int -> Result<int, exn>): Result<int, exn> = failwith ""
2215+
2216+
let builder = MyBuilder()
2217+
2218+
builder {
2219+
let! x: int = Ok 1
2220+
and! (y: int): string = Ok 1
2221+
return 0
2222+
}
2223+
|> ignore
2224+
"""
2225+
|> withLangVersionPreview
2226+
|> typecheck
2227+
|> shouldFail
2228+
|> withDiagnostics [
2229+
Error 1, Line 13, Col 10, Line 13, Col 26, "This expression was expected to have type
2230+
'int'
2231+
but here has type
2232+
'string' "
2233+
Error 1, Line 13, Col 11, Line 13, Col 17, "This expression was expected to have type
2234+
'string'
2235+
but here has type
20752236
'int' "
20762237
]
20772238

0 commit comments

Comments
 (0)