diff --git a/tests/fsharp/tests.fs b/tests/fsharp/tests.fs index e88033a5a2a..4dd0f4740a1 100644 --- a/tests/fsharp/tests.fs +++ b/tests/fsharp/tests.fs @@ -2161,6 +2161,12 @@ module TypecheckTests = fsc cfg "%s --target:library -o:pos33.dll --warnaserror" cfg.fsc_flags ["pos33.fsi"; "pos33.fs"] peverify cfg "pos33.dll" + [] + let ``sigs pos34`` () = + let cfg = testConfig "typecheck/sigs" + fsc cfg "%s --target:library -o:pos34.dll --warnaserror" cfg.fsc_flags ["pos34.fs"] + peverify cfg "pos34.dll" + [] let ``sigs pos23`` () = let cfg = testConfig "typecheck/sigs" @@ -2672,6 +2678,15 @@ module TypecheckTests = [] let ``type check neg119`` () = singleNegTest (testConfig "typecheck/sigs") "neg119" + [] + let ``type check neg120`` () = singleNegTest (testConfig "typecheck/sigs") "neg120" + + [] + let ``type check neg121`` () = singleNegTest (testConfig "typecheck/sigs") "neg121" + + [] + let ``type check neg122`` () = singleNegTest (testConfig "typecheck/sigs") "neg122" + [] let ``type check neg_anon_1`` () = singleNegTest (testConfig "typecheck/sigs") "neg_anon_1" diff --git a/tests/fsharp/typecheck/sigs/neg120.bsl b/tests/fsharp/typecheck/sigs/neg120.bsl new file mode 100644 index 00000000000..1d7137c417f --- /dev/null +++ b/tests/fsharp/typecheck/sigs/neg120.bsl @@ -0,0 +1,27 @@ + +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 +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 + 'int -> obj' +is not compatible with type + ''a -> Id<'b>' +. +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 + 'Id' +is not compatible with type + 'Async<'a>' +. +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 + 'Id' +is not compatible with type + ''a option' +. +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 + 'Id' +is not compatible with type + 'Task<'a>' +. +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 + 'Id' +is not compatible with type + 'Lazy<'a>' +. diff --git a/tests/fsharp/typecheck/sigs/neg120.fs b/tests/fsharp/typecheck/sigs/neg120.fs new file mode 100644 index 00000000000..48ab1db0a0c --- /dev/null +++ b/tests/fsharp/typecheck/sigs/neg120.fs @@ -0,0 +1,97 @@ +module Neg120 + +// From https://github.com/dotnet/fsharp/issues/4171#issuecomment-528063764 +open System.Threading.Tasks +// [] +type Id<'t> (v: 't) = + let value = v + member __.getValue = value + +[] +module Id = + let run (x: Id<_>) = x.getValue + let map f (x: Id<_>) = Id (f x.getValue) + let create x = Id x + + +type Bind = + static member (>>=) (source: Lazy<'T> , f: 'T -> Lazy<'U> ) = lazy (f source.Value).Value : Lazy<'U> + static member (>>=) (source: Task<'T> , f: 'T -> Task<'U> ) = source.ContinueWith(fun (x: Task<_>) -> f x.Result).Unwrap () : Task<'U> + static member (>>=) (source , f: 'T -> _ ) = Option.bind f source : option<'U> + static member (>>=) (source , f: 'T -> _ ) = async.Bind (source, f) + static member (>>=) (source : Id<_> , f: 'T -> _ ) = f source.getValue : Id<'U> + + static member inline Invoke (source: '``Monad<'T>``) (binder: 'T -> '``Monad<'U>``) : '``Monad<'U>`` = + let inline call (_mthd: 'M, input: 'I, _output: 'R, f) = ((^M or ^I or ^R) : (static member (>>=) : _*_ -> _) input, f) + call (Unchecked.defaultof, source, Unchecked.defaultof<'``Monad<'U>``>, binder) + +let inline (>>=) (x: '``Monad<'T>``) (f: 'T->'``Monad<'U>``) : '``Monad<'U>`` = Bind.Invoke x f + +type Return = + static member inline Invoke (x: 'T) : '``Applicative<'T>`` = + let inline call (mthd: ^M, output: ^R) = ((^M or ^R) : (static member Return : _*_ -> _) output, mthd) + call (Unchecked.defaultof, Unchecked.defaultof<'``Applicative<'T>``>) x + + static member Return (_: Lazy<'a> , _: Return ) = fun x -> Lazy<_>.CreateFromValue x : Lazy<'a> + static member Return (_: 'a Task , _: Return ) = fun x -> Task.FromResult x : 'a Task + static member Return (_: option<'a> , _: Return ) = fun x -> Some x : option<'a> + static member Return (_: 'a Async , _: Return ) = fun (x: 'a) -> async.Return x + static member Return (_: 'a Id , _: Return ) = fun (x: 'a) -> Id x + +let inline result (x: 'T) : '``Functor<'T>`` = Return.Invoke x + + +type TypeT<'``monad<'t>``> = TypeT of obj +type Node<'``monad<'t>``,'t> = A | B of 't * TypeT<'``monad<'t>``> + +let inline wrap (mit: 'mit) = + let _mnil = (result Unchecked.defaultof<'t> : 'mt) >>= fun (_:'t) -> (result Node<'mt,'t>.A ) : 'mit + TypeT mit : TypeT<'mt> + +let inline unwrap (TypeT mit : TypeT<'mt>) = + let _mnil = (result Unchecked.defaultof<'t> : 'mt) >>= fun (_:'t) -> (result Node<'mt,'t>.A ) : 'mit + unbox mit : 'mit + +let inline empty () = wrap ((result Node<'mt,'t>.A) : 'mit) : TypeT<'mt> + +let inline concat l1 l2 = + let rec loop (l1: TypeT<'mt>) (lst2: TypeT<'mt>) = + let (l1, l2) = unwrap l1, unwrap lst2 + TypeT (l1 >>= function A -> l2 | B (x: 't, xs) -> ((result (B (x, loop xs lst2))) : 'mit)) + loop l1 l2 : TypeT<'mt> + + +let inline bind f (source: TypeT<'mt>) : TypeT<'mu> = + // let _mnil = (result Unchecked.defaultof<'t> : 'mt) >>= fun (_: 't) -> (result Unchecked.defaultof<'u>) : 'mu + let rec loop f input = + TypeT ( + (unwrap input : 'mit) >>= function + | A -> result <| (A : Node<'mu,'u>) : 'miu + | B (h:'t, t: TypeT<'mt>) -> + let res = concat (f h: TypeT<'mu>) (loop f t) + unwrap res : 'miu) + loop f source : TypeT<'mu> + + +let inline map (f: 'T->'U) (x: '``Monad<'T>`` ) = Bind.Invoke x (f >> Return.Invoke) : '``Monad<'U>`` + + +let inline unfold (f:'State -> '``M<('T * 'State) option>``) (s:'State) : TypeT<'MT> = + let rec loop f s = f s |> map (function + | Some (a, s) -> B (a, loop f s) + | None -> A) |> wrap + loop f s + +let inline create (al: '``Monad>``) : TypeT<'``Monad<'T>``> = + unfold (fun i -> map (fun (lst:list<_>) -> if lst.Length > i then Some (lst.[i], i+1) else None) al) 0 + +let inline run (lst: TypeT<'MT>) : '``Monad>`` = + let rec loop acc x = unwrap x >>= function + | A -> result (List.rev acc) + | B (x, xs) -> loop (x::acc) xs + loop [] lst + +let c0 = create (Id ([1..10])) +let res0 = c0 |> run |> create |> run + +// See pos34.fs for the Sealed case that compiles without complaint \ No newline at end of file diff --git a/tests/fsharp/typecheck/sigs/neg121.bsl b/tests/fsharp/typecheck/sigs/neg121.bsl new file mode 100644 index 00000000000..49d735e7295 --- /dev/null +++ b/tests/fsharp/typecheck/sigs/neg121.bsl @@ -0,0 +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 diff --git a/tests/fsharp/typecheck/sigs/neg121.fs b/tests/fsharp/typecheck/sigs/neg121.fs new file mode 100644 index 00000000000..598820f4c9d --- /dev/null +++ b/tests/fsharp/typecheck/sigs/neg121.fs @@ -0,0 +1,19 @@ +module Neg121 + +// See https://github.com/dotnet/fsharp/pull/3582#issuecomment-399755533, which listed +// this as a test case of interest. +// +// This is to pin down that behaviour doesn't change in the future unless we intend it to. +open System +type System.String with static member inline ParseApply (path:string) (fn: string -> ^b) : ^b = fn "" +type System.Int32 with static member inline ParseApply (path:string) (fn: int -> ^b) : ^b = fn 0 +type System.Double with static member inline ParseApply (path:string) (fn: float -> ^b) : ^b = fn 0. +type System.Boolean with static member inline ParseApply (path:string) (fn: bool -> ^b) : ^b = fn true + +let inline parser (fmt:PrintfFormat< ^a -> ^b,_,_,^b>) (fn:^a -> ^b) (v:string) : ^b + when ^a : (static member ParseApply: string -> (^a -> ^b) -> ^b) = + (^a : (static member ParseApply: string -> (^a -> ^b) -> ^b)(v,fn)) + +let inline patternTest (fmt:PrintfFormat< ^a -> Action< ^T>,_,_,Action< ^T>>) (fn:^a -> Action< ^T>) v : Action< ^T> = parser fmt fn v + +let parseFn1 = patternTest "adfadf%i" (fun v -> printfn "%i" v; Unchecked.defaultof> ) diff --git a/tests/fsharp/typecheck/sigs/neg122.bsl b/tests/fsharp/typecheck/sigs/neg122.bsl new file mode 100644 index 00000000000..7fb422b9f43 --- /dev/null +++ b/tests/fsharp/typecheck/sigs/neg122.bsl @@ -0,0 +1,2 @@ + +neg122.fs(19,28,19,38): typecheck error FS0001: The type 'string' does not support the operator 'ParseApply' diff --git a/tests/fsharp/typecheck/sigs/neg122.fs b/tests/fsharp/typecheck/sigs/neg122.fs new file mode 100644 index 00000000000..981460feb12 --- /dev/null +++ b/tests/fsharp/typecheck/sigs/neg122.fs @@ -0,0 +1,19 @@ +module Neg122 + +// See https://github.com/dotnet/fsharp/pull/3582#issuecomment-399755533, which listed +// this as a test case of interest. +// +// This is to pin down that behaviour doesn't change in the future unless we intend it to. +open System +type System.String with static member inline ParseApply (path:string) (fn: string -> ^b) : ^b = fn "" +type System.Int32 with static member inline ParseApply (path:string) (fn: int -> ^b) : ^b = fn 0 +type System.Double with static member inline ParseApply (path:string) (fn: float -> ^b) : ^b = fn 0. +type System.Boolean with static member inline ParseApply (path:string) (fn: bool -> ^b) : ^b = fn true + +let inline parser (fmt:PrintfFormat< ^a -> ^b,_,_,^b>) (fn:^a -> ^b) (v:string) : ^b + when ^a : (static member ParseApply: string -> (^a -> ^b) -> ^b) = + (^a : (static member ParseApply: string -> (^a -> ^b) -> ^b)(v,fn)) + +let inline patternTest (fmt:PrintfFormat< ^a -> Action< ^T>,_,_,Action< ^T>>) (fn:^a -> Action< ^T>) v : Action< ^T> = parser fmt fn v + +let parseFn2 = patternTest "adf%s245" (fun v -> printfn "%s" v; Unchecked.defaultof> ) diff --git a/tests/fsharp/typecheck/sigs/pos34.fs b/tests/fsharp/typecheck/sigs/pos34.fs new file mode 100644 index 00000000000..73cebb29505 --- /dev/null +++ b/tests/fsharp/typecheck/sigs/pos34.fs @@ -0,0 +1,101 @@ +module Pos34 + +// From https://github.com/dotnet/fsharp/issues/4171#issuecomment-528063764 +// This case is where the type gets labelled as Sealed +// This case compiles without complaint +// +// See also neg120.fs +open System.Threading.Tasks + +[] +type Id<'t> (v: 't) = + let value = v + member __.getValue = value + +[] +module Id = + let run (x: Id<_>) = x.getValue + let map f (x: Id<_>) = Id (f x.getValue) + let create x = Id x + + +type Bind = + static member (>>=) (source: Lazy<'T> , f: 'T -> Lazy<'U> ) = lazy (f source.Value).Value : Lazy<'U> + static member (>>=) (source: Task<'T> , f: 'T -> Task<'U> ) = source.ContinueWith(fun (x: Task<_>) -> f x.Result).Unwrap () : Task<'U> + static member (>>=) (source , f: 'T -> _ ) = Option.bind f source : option<'U> + static member (>>=) (source , f: 'T -> _ ) = async.Bind (source, f) + static member (>>=) (source : Id<_> , f: 'T -> _ ) = f source.getValue : Id<'U> + + static member inline Invoke (source: '``Monad<'T>``) (binder: 'T -> '``Monad<'U>``) : '``Monad<'U>`` = + let inline call (_mthd: 'M, input: 'I, _output: 'R, f) = ((^M or ^I or ^R) : (static member (>>=) : _*_ -> _) input, f) + call (Unchecked.defaultof, source, Unchecked.defaultof<'``Monad<'U>``>, binder) + +let inline (>>=) (x: '``Monad<'T>``) (f: 'T->'``Monad<'U>``) : '``Monad<'U>`` = Bind.Invoke x f + +type Return = + static member inline Invoke (x: 'T) : '``Applicative<'T>`` = + let inline call (mthd: ^M, output: ^R) = ((^M or ^R) : (static member Return : _*_ -> _) output, mthd) + call (Unchecked.defaultof, Unchecked.defaultof<'``Applicative<'T>``>) x + + static member Return (_: Lazy<'a> , _: Return ) = fun x -> Lazy<_>.CreateFromValue x : Lazy<'a> + static member Return (_: 'a Task , _: Return ) = fun x -> Task.FromResult x : 'a Task + static member Return (_: option<'a> , _: Return ) = fun x -> Some x : option<'a> + static member Return (_: 'a Async , _: Return ) = fun (x: 'a) -> async.Return x + static member Return (_: 'a Id , _: Return ) = fun (x: 'a) -> Id x + +let inline result (x: 'T) : '``Functor<'T>`` = Return.Invoke x + + +type TypeT<'``monad<'t>``> = TypeT of obj +type Node<'``monad<'t>``,'t> = A | B of 't * TypeT<'``monad<'t>``> + +let inline wrap (mit: 'mit) = + let _mnil = (result Unchecked.defaultof<'t> : 'mt) >>= fun (_:'t) -> (result Node<'mt,'t>.A ) : 'mit + TypeT mit : TypeT<'mt> + +let inline unwrap (TypeT mit : TypeT<'mt>) = + let _mnil = (result Unchecked.defaultof<'t> : 'mt) >>= fun (_:'t) -> (result Node<'mt,'t>.A ) : 'mit + unbox mit : 'mit + +let inline empty () = wrap ((result Node<'mt,'t>.A) : 'mit) : TypeT<'mt> + +let inline concat l1 l2 = + let rec loop (l1: TypeT<'mt>) (lst2: TypeT<'mt>) = + let (l1, l2) = unwrap l1, unwrap lst2 + TypeT (l1 >>= function A -> l2 | B (x: 't, xs) -> ((result (B (x, loop xs lst2))) : 'mit)) + loop l1 l2 : TypeT<'mt> + + +let inline bind f (source: TypeT<'mt>) : TypeT<'mu> = + // let _mnil = (result Unchecked.defaultof<'t> : 'mt) >>= fun (_: 't) -> (result Unchecked.defaultof<'u>) : 'mu + let rec loop f input = + TypeT ( + (unwrap input : 'mit) >>= function + | A -> result <| (A : Node<'mu,'u>) : 'miu + | B (h:'t, t: TypeT<'mt>) -> + let res = concat (f h: TypeT<'mu>) (loop f t) + unwrap res : 'miu) + loop f source : TypeT<'mu> + + +let inline map (f: 'T->'U) (x: '``Monad<'T>`` ) = Bind.Invoke x (f >> Return.Invoke) : '``Monad<'U>`` + + +let inline unfold (f:'State -> '``M<('T * 'State) option>``) (s:'State) : TypeT<'MT> = + let rec loop f s = f s |> map (function + | Some (a, s) -> B (a, loop f s) + | None -> A) |> wrap + loop f s + +let inline create (al: '``Monad>``) : TypeT<'``Monad<'T>``> = + unfold (fun i -> map (fun (lst:list<_>) -> if lst.Length > i then Some (lst.[i], i+1) else None) al) 0 + +let inline run (lst: TypeT<'MT>) : '``Monad>`` = + let rec loop acc x = unwrap x >>= function + | A -> result (List.rev acc) + | B (x, xs) -> loop (x::acc) xs + loop [] lst + +let c0 = create (Id ([1..10])) +let res0 = c0 |> run |> create |> run +