Skip to content

Commit 4cb5ff0

Browse files
DedSec256DedSec256
committed
wip
1 parent cb5d15c commit 4cb5ff0

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
@@ -2004,7 +2011,7 @@ let rec TryTranslateComputationExpression
20042011
|> List.map (fun expr -> mkSourceExprConditional isFromSource expr ceenv.sourceMethInfo ceenv.builderValName)
20052012

20062013
let pats =
2007-
letPat :: [ for SynBinding(headPat = andPat) in andBangBindings -> andPat ]
2014+
letPat :: [ for binding in andBangBindings -> getTypedHeadPattern binding ]
20082015

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

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

Lines changed: 161 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -2031,6 +2031,167 @@ match test() with
20312031
|> compileAndRun
20322032
|> shouldSucceed
20332033

2034+
[<Fact>]
2035+
let ``Preview: let! return type check error 01`` () =
2036+
FSharp """
2037+
module Test
2038+
2039+
open System.Threading.Tasks
2040+
2041+
task {
2042+
let! x: string = Task.FromResult(1)
2043+
()
2044+
}
2045+
|> ignore
2046+
"""
2047+
|> withLangVersionPreview
2048+
|> typecheck
2049+
|> shouldFail
2050+
|> withDiagnostics [
2051+
Error 1, Line 7, Col 10, Line 7, Col 19, "This expression was expected to have type
2052+
'int'
2053+
but here has type
2054+
'string' "
2055+
]
2056+
2057+
[<Fact>]
2058+
let ``Preview: let! return type check error 02`` () =
2059+
FSharp """
2060+
module Test
2061+
2062+
open System.Threading.Tasks
2063+
2064+
task {
2065+
let! (x: string): int = Task.FromResult(1)
2066+
()
2067+
}
2068+
|> ignore
2069+
"""
2070+
|> withLangVersionPreview
2071+
|> typecheck
2072+
|> shouldFail
2073+
|> withDiagnostics [
2074+
Error 1, Line 7, Col 11, Line 7, Col 20, "This expression was expected to have type
2075+
'int'
2076+
but here has type
2077+
'string' "
2078+
]
2079+
2080+
[<Fact>]
2081+
let ``Preview: let! return type check error 03`` () =
2082+
FSharp """
2083+
module Test
2084+
2085+
open System.Threading.Tasks
2086+
2087+
task {
2088+
let! (x: string): int = Task.FromResult("")
2089+
()
2090+
}
2091+
|> ignore
2092+
"""
2093+
|> withLangVersionPreview
2094+
|> typecheck
2095+
|> shouldFail
2096+
|> withDiagnostics [
2097+
Error 1, Line 7, Col 10, Line 7, Col 26, "This expression was expected to have type
2098+
'string'
2099+
but here has type
2100+
'int' "
2101+
]
2102+
2103+
[<Fact>]
2104+
let ``Preview: let!-and! return type check error 01`` () =
2105+
FSharp """
2106+
module Test
2107+
2108+
type MyBuilder() =
2109+
member _.Return(x: int): Result<int, exn> = failwith ""
2110+
member _.Bind(m: Result<int, exn>, f: int -> Result<int, exn>): Result<int, exn> = failwith ""
2111+
member _.Bind2(m1: Result<int, exn>, m2: Result<int, exn>, f: int * int -> Result<int, exn>): Result<int, exn> = failwith ""
2112+
2113+
let builder = MyBuilder()
2114+
2115+
builder {
2116+
let! x: int = Ok 1
2117+
and! y: string = Ok 2
2118+
return 0
2119+
}
2120+
|> ignore
2121+
"""
2122+
|> withLangVersionPreview
2123+
|> typecheck
2124+
|> shouldFail
2125+
|> withDiagnostics [
2126+
Error 1, Line 13, Col 10, Line 13, Col 19, "This expression was expected to have type
2127+
'int'
2128+
but here has type
2129+
'string' ";
2130+
Warning 25, Line 12, Col 10, Line 12, Col 16, "Incomplete pattern matches on this expression."
2131+
]
2132+
2133+
[<Fact>]
2134+
let ``Preview: let!-and! return type check error 02`` () =
2135+
FSharp """
2136+
module Test
2137+
2138+
type MyBuilder() =
2139+
member _.Return(x: int): Result<int, exn> = failwith ""
2140+
member _.Bind(m: Result<int, exn>, f: int -> Result<int, exn>): Result<int, exn> = failwith ""
2141+
member _.Bind2(m1: Result<int, exn>, m2: Result<int, exn>, f: int * int -> Result<int, exn>): Result<int, exn> = failwith ""
2142+
2143+
let builder = MyBuilder()
2144+
2145+
builder {
2146+
let! x: int = Ok 1
2147+
and! (y: string): int = Ok 2
2148+
return 0
2149+
}
2150+
|> ignore
2151+
"""
2152+
|> withLangVersionPreview
2153+
|> typecheck
2154+
|> shouldFail
2155+
|> withDiagnostics [
2156+
Error 1, Line 13, Col 11, Line 13, Col 20, "This expression was expected to have type
2157+
'int'
2158+
but here has type
2159+
'string' "
2160+
]
2161+
2162+
[<Fact>]
2163+
let ``Preview: let!-and! return type check error 03`` () =
2164+
FSharp """
2165+
module Test
2166+
2167+
type MyBuilder() =
2168+
member _.Return(x: int): Result<int, exn> = failwith ""
2169+
member _.Bind(m: Result<int, exn>, f: int -> Result<int, exn>): Result<int, exn> = failwith ""
2170+
member _.Bind2(m1: Result<int, exn>, m2: Result<int, exn>, f: int * int -> Result<int, exn>): Result<int, exn> = failwith ""
2171+
2172+
let builder = MyBuilder()
2173+
2174+
builder {
2175+
let! x: int = Ok 1
2176+
and! (y: int): string = Ok 1
2177+
return 0
2178+
}
2179+
|> ignore
2180+
"""
2181+
|> withLangVersionPreview
2182+
|> typecheck
2183+
|> shouldFail
2184+
|> withDiagnostics [
2185+
Error 1, Line 13, Col 10, Line 13, Col 26, "This expression was expected to have type
2186+
'int'
2187+
but here has type
2188+
'string' "
2189+
Error 1, Line 13, Col 11, Line 13, Col 17, "This expression was expected to have type
2190+
'string'
2191+
but here has type
2192+
'int' "
2193+
]
2194+
20342195
[<Theory; FileInlineData("tailcalls.fsx")>]
20352196
let ``tail call methods work`` compilation =
20362197
compilation

0 commit comments

Comments
 (0)