Member constraints and PrimitiveConstraints (#7210)

Author: forki

tests/fsharp/Compiler/CompilerAssert.fs

@@ -173,9 +173,15 @@ let main argv = 0"""
 
             Assert.IsEmpty(typeCheckResults.Errors, sprintf "Type Check errors: %A" typeCheckResults.Errors)
 
-    let TypeCheckWithErrors (source: string) expectedTypeErrors =
+    let TypeCheckWithErrorsAndOptions options (source: string) expectedTypeErrors =
         lock gate <| fun () ->
-            let parseResults, fileAnswer = checker.ParseAndCheckFileInProject("test.fs", 0, SourceText.ofString source, defaultProjectOptions) |> Async.RunSynchronously
+            let parseResults, fileAnswer = 
+                checker.ParseAndCheckFileInProject(
+                    "test.fs",
+                    0,
+                    SourceText.ofString source,
+                    { defaultProjectOptions with OtherOptions = Array.append options defaultProjectOptions.OtherOptions}) 
+                |> Async.RunSynchronously
 
             Assert.IsEmpty(parseResults.Errors, sprintf "Parse errors: %A" parseResults.Errors)
 
@@ -198,8 +204,14 @@ let main argv = 0"""
                 Assert.AreEqual(expectedErrorMsg, info.Message, "expectedErrorMsg")
             )
 
+    let TypeCheckWithErrors (source: string) expectedTypeErrors =
+        TypeCheckWithErrorsAndOptions [||] source expectedTypeErrors
+
+    let TypeCheckSingleErrorWithOptions options (source: string) (expectedServerity: FSharpErrorSeverity) (expectedErrorNumber: int) (expectedErrorRange: int * int * int * int) (expectedErrorMsg: string) =
+        TypeCheckWithErrorsAndOptions options source [| expectedServerity, expectedErrorNumber, expectedErrorRange, expectedErrorMsg |]
+
     let TypeCheckSingleError (source: string) (expectedServerity: FSharpErrorSeverity) (expectedErrorNumber: int) (expectedErrorRange: int * int * int * int) (expectedErrorMsg: string) =
-        TypeCheckWithErrors (source: string) [| expectedServerity, expectedErrorNumber, expectedErrorRange, expectedErrorMsg |]
+        TypeCheckWithErrors source [| expectedServerity, expectedErrorNumber, expectedErrorRange, expectedErrorMsg |]
 
     let CompileExe (source: string) =
         compile true source (fun (errors, _) ->

tests/fsharp/Compiler/ConstraintSolver/MemberConstraints.fs

@@ -0,0 +1,45 @@
+// Copyright (c) Microsoft Corporation.  All Rights Reserved.  See License.txt in the project root for license information.
+
+namespace FSharp.Compiler.UnitTests
+
+open NUnit.Framework
+open FSharp.Compiler.SourceCodeServices
+
+[<TestFixture>]
+module MemberConstraints =
+
+    [<Test>]
+    let ``we can overload operators on a type and not add all the extra jazz such as inlining and the ^ operator.``() = 
+        CompilerAssert.CompileExeAndRun
+            """
+type Foo(x : int) = 
+    member this.Val = x
+    
+    static member (-->) ((src : Foo), (target : Foo)) = new Foo(src.Val + target.Val)
+    static member (-->) ((src : Foo), (target : int)) = new Foo(src.Val + target)
+    
+    static member (+) ((src : Foo), (target : Foo)) = new Foo(src.Val + target.Val)
+    static member (+) ((src : Foo), (target : int)) = new Foo(src.Val + target)
+    
+let x = Foo(3) --> 4
+let y = Foo(3) --> Foo(4)
+let x2 = Foo(3) + 4
+let y2 = Foo(3) + Foo(4)
+
+if x.Val <> 7 then exit 1
+if y.Val <> 7 then exit 1
+if x2.Val <> 7 then exit 1
+if y2.Val <> 7 then exit 1
+            """
+
+    [<Test>]
+    let ``Invalid member constraint with ErrorRanges``() = // Regression test for FSharp1.0:2262
+        CompilerAssert.TypeCheckSingleErrorWithOptions
+            [| "--test:ErrorRanges" |]
+            """
+let inline length (x: ^a) : int = (^a : (member Length : int with get, set) (x, ()))
+            """
+            FSharpErrorSeverity.Error
+            697
+            (2, 42, 2, 75)
+            "Invalid constraint"

tests/fsharp/Compiler/ConstraintSolver/PrimitiveConstraints.fs

@@ -0,0 +1,109 @@
+// Copyright (c) Microsoft Corporation.  All Rights Reserved.  See License.txt in the project root for license information.
+
+namespace FSharp.Compiler.UnitTests
+
+open NUnit.Framework
+open FSharp.Compiler.SourceCodeServices
+
+[<TestFixture>]
+module PrimitiveConstraints =
+
+    [<Test>]
+    let ``Test primitive : constraints``() =
+        CompilerAssert.CompileExeAndRun
+            """
+#light
+
+type Foo(x : int) =
+    member   this.Value      = x
+    override this.ToString() = "Foo"
+
+type Bar(x : int) =
+    inherit Foo(-1)
+    member   this.Value2     = x
+    override this.ToString() = "Bar"
+
+let test1 (x : Foo) = x.Value
+let test2 (x : Bar) = (x.Value, x.Value2)
+
+let f = new Foo(128)
+let b = new Bar(256)
+
+if test1 f <> 128       then exit 1
+if test2 b <> (-1, 256) then exit 1
+"""
+
+    [<Test>]
+    let ``Test primitive :> constraints``() =
+        CompilerAssert.CompileExeAndRun
+            """
+#light
+type Foo(x : int) =
+    member   this.Value      = x
+    override this.ToString() = "Foo"
+
+type Bar(x : int) =
+    inherit Foo(-1)
+    member   this.Value2     = x
+    override this.ToString() = "Bar"
+
+type Ram(x : int) =
+    inherit Foo(10)
+    member   this.ValueA     = x
+    override this.ToString() = "Ram"
+
+let test (x : Foo) = (x.Value, x.ToString())
+
+let f = new Foo(128)
+let b = new Bar(256)
+let r = new Ram(314)
+
+if test f <> (128, "Foo") then exit 1
+if test b <> (-1, "Bar") then exit 1
+if test r <> (10, "Ram") then exit 1
+"""
+
+    [<Test>]
+    let ``Test primitive : null constraint``() =
+        CompilerAssert.CompileExeAndRun
+            """
+let inline isNull<'a when 'a : null> (x : 'a) = 
+    match x with
+    | null -> "is null"
+    | _    -> (x :> obj).ToString()
+
+let runTest =  
+    // Wrapping in try block to work around FSB 1989
+    try
+        if isNull null <> "is null" then exit 1
+        if isNull "F#" <> "F#"      then exit 1
+        true
+    with _ -> exit 1
+
+if runTest <> true then exit 1
+
+exit 0
+"""
+
+    [<Test>]
+    /// Title: Type checking oddity
+    ///
+    /// This suggestion was resolved as by design,
+    /// so the test makes sure, we're emitting error message about 'not being a valid object construction expression'
+    let ``Invalid object constructor``() = // Regression test for FSharp1.0:4189
+        CompilerAssert.TypeCheckWithErrorsAndOptions
+            [| "--test:ErrorRanges" |]
+            """
+type ImmutableStack<'a> private(items: 'a list) = 
+   
+    member this.Push item = ImmutableStack(item::items)
+    member this.Pop = match items with | [] -> failwith "No elements in stack" | x::xs -> x,ImmutableStack(xs)
+    
+    // Notice type annotation is commented out, which results in an error
+    new(col (*: seq<'a>*)) = ImmutableStack(List.ofSeq col)
+
+            """
+            [| FSharpErrorSeverity.Error, 41, (4, 29, 4, 56), "A unique overload for method 'ImmutableStack`1' could not be determined based on type information prior to this program point. A type annotation may be needed. Candidates: new : col:'b -> ImmutableStack<'a>, private new : items:'a list -> ImmutableStack<'a>"
+               FSharpErrorSeverity.Error, 41, (5, 93, 5, 111), "A unique overload for method 'ImmutableStack`1' could not be determined based on type information prior to this program point. A type annotation may be needed. Candidates: new : col:'b -> ImmutableStack<'a>, private new : items:'a list -> ImmutableStack<'a>"
+               FSharpErrorSeverity.Error, 41, (8, 30, 8, 60), "A unique overload for method 'ImmutableStack`1' could not be determined based on type information prior to this program point. A type annotation may be needed. Candidates: new : col:'b -> ImmutableStack<'a> when 'b :> seq<'c>, private new : items:'a list -> ImmutableStack<'a>"
+               FSharpErrorSeverity.Error, 696, (8, 30, 8, 60), "This is not a valid object construction expression. Explicit object constructors must either call an alternate constructor or initialize all fields of the object and specify a call to a super class constructor." |]

tests/fsharp/FSharpSuite.Tests.fsproj

@@ -35,6 +35,8 @@
     <Compile Include="Compiler\ErrorMessages\ConstructorTests.fs" />
     <Compile Include="Compiler\ErrorMessages\AccessOfTypeAbbreviationTests.fs" />
     <Compile Include="Compiler\ErrorMessages\ElseBranchHasWrongTypeTests.fs" />
+    <Compile Include="Compiler\ConstraintSolver\PrimitiveConstraints.fs" />
+    <Compile Include="Compiler\ConstraintSolver\MemberConstraints.fs" />
     <Compile Include="Compiler\ErrorMessages\MissingElseBranch.fs" />
     <Compile Include="Compiler\ErrorMessages\UnitGenericAbstactType.fs" />
     <Compile Include="Compiler\ErrorMessages\NameResolutionTests.fs" />