Skip to content

Commit 5ef3492

Browse files
dsymeTIHan
dsyme
authored and
TIHan
committed
add more tests for SRTP resolution (#8318)
* add more tests * two new tests
1 parent b8c748c commit 5ef3492

File tree

8 files changed

+282
-0
lines changed

8 files changed

+282
-0
lines changed

‎tests/fsharp/tests.fs

+15
Original file line numberDiff line numberDiff line change
@@ -2161,6 +2161,12 @@ module TypecheckTests =
21612161
fsc cfg "%s --target:library -o:pos33.dll --warnaserror" cfg.fsc_flags ["pos33.fsi"; "pos33.fs"]
21622162
peverify cfg "pos33.dll"
21632163

2164+
[<Test>]
2165+
let ``sigs pos34`` () =
2166+
let cfg = testConfig "typecheck/sigs"
2167+
fsc cfg "%s --target:library -o:pos34.dll --warnaserror" cfg.fsc_flags ["pos34.fs"]
2168+
peverify cfg "pos34.dll"
2169+
21642170
[<Test>]
21652171
let ``sigs pos23`` () =
21662172
let cfg = testConfig "typecheck/sigs"
@@ -2672,6 +2678,15 @@ module TypecheckTests =
26722678
[<Test>]
26732679
let ``type check neg119`` () = singleNegTest (testConfig "typecheck/sigs") "neg119"
26742680

2681+
[<Test>]
2682+
let ``type check neg120`` () = singleNegTest (testConfig "typecheck/sigs") "neg120"
2683+
2684+
[<Test>]
2685+
let ``type check neg121`` () = singleNegTest (testConfig "typecheck/sigs") "neg121"
2686+
2687+
[<Test>]
2688+
let ``type check neg122`` () = singleNegTest (testConfig "typecheck/sigs") "neg122"
2689+
26752690
[<Test>]
26762691
let ``type check neg_anon_1`` () = singleNegTest (testConfig "typecheck/sigs") "neg_anon_1"
26772692

‎tests/fsharp/typecheck/sigs/neg120.bsl

+27
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,27 @@
1+
2+
neg120.fs(95,18,95,21): typecheck error FS0071: Type constraint mismatch when applying the default type 'obj' for a type inference variable. No overloads match for method 'op_GreaterGreaterEquals'. The available overloads are shown below. Consider adding further type constraints
3+
neg120.fs(95,18,95,21): typecheck error FS0071: Possible overload: 'static member Bind.( >>= ) : source:Id<'T> * f:('T -> Id<'U>) -> Id<'U>'. Type constraint mismatch. The type
4+
'int -> obj'
5+
is not compatible with type
6+
''a -> Id<'b>'
7+
.
8+
neg120.fs(95,18,95,21): typecheck error FS0071: Possible overload: 'static member Bind.( >>= ) : source:Async<'T> * f:('T -> Async<'a1>) -> Async<'a1>'. Type constraint mismatch. The type
9+
'Id<int>'
10+
is not compatible with type
11+
'Async<'a>'
12+
.
13+
neg120.fs(95,18,95,21): typecheck error FS0071: Possible overload: 'static member Bind.( >>= ) : source:'T option * f:('T -> 'U option) -> 'U option'. Type constraint mismatch. The type
14+
'Id<int>'
15+
is not compatible with type
16+
''a option'
17+
.
18+
neg120.fs(95,18,95,21): typecheck error FS0071: Possible overload: 'static member Bind.( >>= ) : source:Task<'T> * f:('T -> Task<'U>) -> Task<'U>'. Type constraint mismatch. The type
19+
'Id<int>'
20+
is not compatible with type
21+
'Task<'a>'
22+
.
23+
neg120.fs(95,18,95,21): typecheck error FS0071: Possible overload: 'static member Bind.( >>= ) : source:Lazy<'T> * f:('T -> Lazy<'U>) -> Lazy<'U>'. Type constraint mismatch. The type
24+
'Id<int>'
25+
is not compatible with type
26+
'Lazy<'a>'
27+
.

‎tests/fsharp/typecheck/sigs/neg120.fs

+97
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,97 @@
1+
module Neg120
2+
3+
// From https://github.com/dotnet/fsharp/issues/4171#issuecomment-528063764
4+
open System.Threading.Tasks
5+
// [<Sealed>]
6+
type Id<'t> (v: 't) =
7+
let value = v
8+
member __.getValue = value
9+
10+
[<RequireQualifiedAccess>]
11+
module Id =
12+
let run (x: Id<_>) = x.getValue
13+
let map f (x: Id<_>) = Id (f x.getValue)
14+
let create x = Id x
15+
16+
17+
type Bind =
18+
static member (>>=) (source: Lazy<'T> , f: 'T -> Lazy<'U> ) = lazy (f source.Value).Value : Lazy<'U>
19+
static member (>>=) (source: Task<'T> , f: 'T -> Task<'U> ) = source.ContinueWith(fun (x: Task<_>) -> f x.Result).Unwrap () : Task<'U>
20+
static member (>>=) (source , f: 'T -> _ ) = Option.bind f source : option<'U>
21+
static member (>>=) (source , f: 'T -> _ ) = async.Bind (source, f)
22+
static member (>>=) (source : Id<_> , f: 'T -> _ ) = f source.getValue : Id<'U>
23+
24+
static member inline Invoke (source: '``Monad<'T>``) (binder: 'T -> '``Monad<'U>``) : '``Monad<'U>`` =
25+
let inline call (_mthd: 'M, input: 'I, _output: 'R, f) = ((^M or ^I or ^R) : (static member (>>=) : _*_ -> _) input, f)
26+
call (Unchecked.defaultof<Bind>, source, Unchecked.defaultof<'``Monad<'U>``>, binder)
27+
28+
let inline (>>=) (x: '``Monad<'T>``) (f: 'T->'``Monad<'U>``) : '``Monad<'U>`` = Bind.Invoke x f
29+
30+
type Return =
31+
static member inline Invoke (x: 'T) : '``Applicative<'T>`` =
32+
let inline call (mthd: ^M, output: ^R) = ((^M or ^R) : (static member Return : _*_ -> _) output, mthd)
33+
call (Unchecked.defaultof<Return>, Unchecked.defaultof<'``Applicative<'T>``>) x
34+
35+
static member Return (_: Lazy<'a> , _: Return ) = fun x -> Lazy<_>.CreateFromValue x : Lazy<'a>
36+
static member Return (_: 'a Task , _: Return ) = fun x -> Task.FromResult x : 'a Task
37+
static member Return (_: option<'a> , _: Return ) = fun x -> Some x : option<'a>
38+
static member Return (_: 'a Async , _: Return ) = fun (x: 'a) -> async.Return x
39+
static member Return (_: 'a Id , _: Return ) = fun (x: 'a) -> Id x
40+
41+
let inline result (x: 'T) : '``Functor<'T>`` = Return.Invoke x
42+
43+
44+
type TypeT<'``monad<'t>``> = TypeT of obj
45+
type Node<'``monad<'t>``,'t> = A | B of 't * TypeT<'``monad<'t>``>
46+
47+
let inline wrap (mit: 'mit) =
48+
let _mnil = (result Unchecked.defaultof<'t> : 'mt) >>= fun (_:'t) -> (result Node<'mt,'t>.A ) : 'mit
49+
TypeT mit : TypeT<'mt>
50+
51+
let inline unwrap (TypeT mit : TypeT<'mt>) =
52+
let _mnil = (result Unchecked.defaultof<'t> : 'mt) >>= fun (_:'t) -> (result Node<'mt,'t>.A ) : 'mit
53+
unbox mit : 'mit
54+
55+
let inline empty () = wrap ((result Node<'mt,'t>.A) : 'mit) : TypeT<'mt>
56+
57+
let inline concat l1 l2 =
58+
let rec loop (l1: TypeT<'mt>) (lst2: TypeT<'mt>) =
59+
let (l1, l2) = unwrap l1, unwrap lst2
60+
TypeT (l1 >>= function A -> l2 | B (x: 't, xs) -> ((result (B (x, loop xs lst2))) : 'mit))
61+
loop l1 l2 : TypeT<'mt>
62+
63+
64+
let inline bind f (source: TypeT<'mt>) : TypeT<'mu> =
65+
// let _mnil = (result Unchecked.defaultof<'t> : 'mt) >>= fun (_: 't) -> (result Unchecked.defaultof<'u>) : 'mu
66+
let rec loop f input =
67+
TypeT (
68+
(unwrap input : 'mit) >>= function
69+
| A -> result <| (A : Node<'mu,'u>) : 'miu
70+
| B (h:'t, t: TypeT<'mt>) ->
71+
let res = concat (f h: TypeT<'mu>) (loop f t)
72+
unwrap res : 'miu)
73+
loop f source : TypeT<'mu>
74+
75+
76+
let inline map (f: 'T->'U) (x: '``Monad<'T>`` ) = Bind.Invoke x (f >> Return.Invoke) : '``Monad<'U>``
77+
78+
79+
let inline unfold (f:'State -> '``M<('T * 'State) option>``) (s:'State) : TypeT<'MT> =
80+
let rec loop f s = f s |> map (function
81+
| Some (a, s) -> B (a, loop f s)
82+
| None -> A) |> wrap
83+
loop f s
84+
85+
let inline create (al: '``Monad<list<'T>>``) : TypeT<'``Monad<'T>``> =
86+
unfold (fun i -> map (fun (lst:list<_>) -> if lst.Length > i then Some (lst.[i], i+1) else None) al) 0
87+
88+
let inline run (lst: TypeT<'MT>) : '``Monad<list<'T>>`` =
89+
let rec loop acc x = unwrap x >>= function
90+
| A -> result (List.rev acc)
91+
| B (x, xs) -> loop (x::acc) xs
92+
loop [] lst
93+
94+
let c0 = create (Id ([1..10]))
95+
let res0 = c0 |> run |> create |> run
96+
97+
// See pos34.fs for the Sealed case that compiles without complaint

‎tests/fsharp/typecheck/sigs/neg121.bsl

+2
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,2 @@
1+
2+
neg121.fs(19,28,19,38): typecheck error FS0071: Type constraint mismatch when applying the default type 'int' for a type inference variable. The type 'int' does not support the operator 'ParseApply' Consider adding further type constraints

‎tests/fsharp/typecheck/sigs/neg121.fs

+19
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,19 @@
1+
module Neg121
2+
3+
// See https://github.com/dotnet/fsharp/pull/3582#issuecomment-399755533, which listed
4+
// this as a test case of interest.
5+
//
6+
// This is to pin down that behaviour doesn't change in the future unless we intend it to.
7+
open System
8+
type System.String with static member inline ParseApply (path:string) (fn: string -> ^b) : ^b = fn ""
9+
type System.Int32 with static member inline ParseApply (path:string) (fn: int -> ^b) : ^b = fn 0
10+
type System.Double with static member inline ParseApply (path:string) (fn: float -> ^b) : ^b = fn 0.
11+
type System.Boolean with static member inline ParseApply (path:string) (fn: bool -> ^b) : ^b = fn true
12+
13+
let inline parser (fmt:PrintfFormat< ^a -> ^b,_,_,^b>) (fn:^a -> ^b) (v:string) : ^b
14+
when ^a : (static member ParseApply: string -> (^a -> ^b) -> ^b) =
15+
(^a : (static member ParseApply: string -> (^a -> ^b) -> ^b)(v,fn))
16+
17+
let inline patternTest (fmt:PrintfFormat< ^a -> Action< ^T>,_,_,Action< ^T>>) (fn:^a -> Action< ^T>) v : Action< ^T> = parser fmt fn v
18+
19+
let parseFn1 = patternTest "adfadf%i" (fun v -> printfn "%i" v; Unchecked.defaultof<Action<unit>> )

‎tests/fsharp/typecheck/sigs/neg122.bsl

+2
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,2 @@
1+
2+
neg122.fs(19,28,19,38): typecheck error FS0001: The type 'string' does not support the operator 'ParseApply'

‎tests/fsharp/typecheck/sigs/neg122.fs

+19
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,19 @@
1+
module Neg122
2+
3+
// See https://github.com/dotnet/fsharp/pull/3582#issuecomment-399755533, which listed
4+
// this as a test case of interest.
5+
//
6+
// This is to pin down that behaviour doesn't change in the future unless we intend it to.
7+
open System
8+
type System.String with static member inline ParseApply (path:string) (fn: string -> ^b) : ^b = fn ""
9+
type System.Int32 with static member inline ParseApply (path:string) (fn: int -> ^b) : ^b = fn 0
10+
type System.Double with static member inline ParseApply (path:string) (fn: float -> ^b) : ^b = fn 0.
11+
type System.Boolean with static member inline ParseApply (path:string) (fn: bool -> ^b) : ^b = fn true
12+
13+
let inline parser (fmt:PrintfFormat< ^a -> ^b,_,_,^b>) (fn:^a -> ^b) (v:string) : ^b
14+
when ^a : (static member ParseApply: string -> (^a -> ^b) -> ^b) =
15+
(^a : (static member ParseApply: string -> (^a -> ^b) -> ^b)(v,fn))
16+
17+
let inline patternTest (fmt:PrintfFormat< ^a -> Action< ^T>,_,_,Action< ^T>>) (fn:^a -> Action< ^T>) v : Action< ^T> = parser fmt fn v
18+
19+
let parseFn2 = patternTest "adf%s245" (fun v -> printfn "%s" v; Unchecked.defaultof<Action<unit>> )

‎tests/fsharp/typecheck/sigs/pos34.fs

+101
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,101 @@
1+
module Pos34
2+
3+
// From https://github.com/dotnet/fsharp/issues/4171#issuecomment-528063764
4+
// This case is where the type gets labelled as Sealed
5+
// This case compiles without complaint
6+
//
7+
// See also neg120.fs
8+
open System.Threading.Tasks
9+
10+
[<Sealed>]
11+
type Id<'t> (v: 't) =
12+
let value = v
13+
member __.getValue = value
14+
15+
[<RequireQualifiedAccess>]
16+
module Id =
17+
let run (x: Id<_>) = x.getValue
18+
let map f (x: Id<_>) = Id (f x.getValue)
19+
let create x = Id x
20+
21+
22+
type Bind =
23+
static member (>>=) (source: Lazy<'T> , f: 'T -> Lazy<'U> ) = lazy (f source.Value).Value : Lazy<'U>
24+
static member (>>=) (source: Task<'T> , f: 'T -> Task<'U> ) = source.ContinueWith(fun (x: Task<_>) -> f x.Result).Unwrap () : Task<'U>
25+
static member (>>=) (source , f: 'T -> _ ) = Option.bind f source : option<'U>
26+
static member (>>=) (source , f: 'T -> _ ) = async.Bind (source, f)
27+
static member (>>=) (source : Id<_> , f: 'T -> _ ) = f source.getValue : Id<'U>
28+
29+
static member inline Invoke (source: '``Monad<'T>``) (binder: 'T -> '``Monad<'U>``) : '``Monad<'U>`` =
30+
let inline call (_mthd: 'M, input: 'I, _output: 'R, f) = ((^M or ^I or ^R) : (static member (>>=) : _*_ -> _) input, f)
31+
call (Unchecked.defaultof<Bind>, source, Unchecked.defaultof<'``Monad<'U>``>, binder)
32+
33+
let inline (>>=) (x: '``Monad<'T>``) (f: 'T->'``Monad<'U>``) : '``Monad<'U>`` = Bind.Invoke x f
34+
35+
type Return =
36+
static member inline Invoke (x: 'T) : '``Applicative<'T>`` =
37+
let inline call (mthd: ^M, output: ^R) = ((^M or ^R) : (static member Return : _*_ -> _) output, mthd)
38+
call (Unchecked.defaultof<Return>, Unchecked.defaultof<'``Applicative<'T>``>) x
39+
40+
static member Return (_: Lazy<'a> , _: Return ) = fun x -> Lazy<_>.CreateFromValue x : Lazy<'a>
41+
static member Return (_: 'a Task , _: Return ) = fun x -> Task.FromResult x : 'a Task
42+
static member Return (_: option<'a> , _: Return ) = fun x -> Some x : option<'a>
43+
static member Return (_: 'a Async , _: Return ) = fun (x: 'a) -> async.Return x
44+
static member Return (_: 'a Id , _: Return ) = fun (x: 'a) -> Id x
45+
46+
let inline result (x: 'T) : '``Functor<'T>`` = Return.Invoke x
47+
48+
49+
type TypeT<'``monad<'t>``> = TypeT of obj
50+
type Node<'``monad<'t>``,'t> = A | B of 't * TypeT<'``monad<'t>``>
51+
52+
let inline wrap (mit: 'mit) =
53+
let _mnil = (result Unchecked.defaultof<'t> : 'mt) >>= fun (_:'t) -> (result Node<'mt,'t>.A ) : 'mit
54+
TypeT mit : TypeT<'mt>
55+
56+
let inline unwrap (TypeT mit : TypeT<'mt>) =
57+
let _mnil = (result Unchecked.defaultof<'t> : 'mt) >>= fun (_:'t) -> (result Node<'mt,'t>.A ) : 'mit
58+
unbox mit : 'mit
59+
60+
let inline empty () = wrap ((result Node<'mt,'t>.A) : 'mit) : TypeT<'mt>
61+
62+
let inline concat l1 l2 =
63+
let rec loop (l1: TypeT<'mt>) (lst2: TypeT<'mt>) =
64+
let (l1, l2) = unwrap l1, unwrap lst2
65+
TypeT (l1 >>= function A -> l2 | B (x: 't, xs) -> ((result (B (x, loop xs lst2))) : 'mit))
66+
loop l1 l2 : TypeT<'mt>
67+
68+
69+
let inline bind f (source: TypeT<'mt>) : TypeT<'mu> =
70+
// let _mnil = (result Unchecked.defaultof<'t> : 'mt) >>= fun (_: 't) -> (result Unchecked.defaultof<'u>) : 'mu
71+
let rec loop f input =
72+
TypeT (
73+
(unwrap input : 'mit) >>= function
74+
| A -> result <| (A : Node<'mu,'u>) : 'miu
75+
| B (h:'t, t: TypeT<'mt>) ->
76+
let res = concat (f h: TypeT<'mu>) (loop f t)
77+
unwrap res : 'miu)
78+
loop f source : TypeT<'mu>
79+
80+
81+
let inline map (f: 'T->'U) (x: '``Monad<'T>`` ) = Bind.Invoke x (f >> Return.Invoke) : '``Monad<'U>``
82+
83+
84+
let inline unfold (f:'State -> '``M<('T * 'State) option>``) (s:'State) : TypeT<'MT> =
85+
let rec loop f s = f s |> map (function
86+
| Some (a, s) -> B (a, loop f s)
87+
| None -> A) |> wrap
88+
loop f s
89+
90+
let inline create (al: '``Monad<list<'T>>``) : TypeT<'``Monad<'T>``> =
91+
unfold (fun i -> map (fun (lst:list<_>) -> if lst.Length > i then Some (lst.[i], i+1) else None) al) 0
92+
93+
let inline run (lst: TypeT<'MT>) : '``Monad<list<'T>>`` =
94+
let rec loop acc x = unwrap x >>= function
95+
| A -> result (List.rev acc)
96+
| B (x, xs) -> loop (x::acc) xs
97+
loop [] lst
98+
99+
let c0 = create (Id ([1..10]))
100+
let res0 = c0 |> run |> create |> run
101+

0 commit comments

Comments
 (0)