Fix for #83 (improve constraint error message)

src/Compiler/Checking/CheckExpressions.fs

@@ -4076,7 +4076,8 @@ and TcConstraintWhereTyparSupportsMember cenv env newOk tpenv synSupportTys synM
     let g = cenv.g
     let traitInfo, tpenv = TcPseudoMemberSpec cenv newOk env synSupportTys tpenv synMemberSig m
     match traitInfo with
-    | TTrait(objTys, ".ctor", memberFlags, argTys, returnTy, _) when memberFlags.MemberKind = SynMemberKind.Constructor ->
+    | TTrait(tys=objTys; memberName=".ctor"; memberFlags=memberFlags; objAndArgTys=argTys; returnTyOpt=returnTy)
+      when memberFlags.MemberKind = SynMemberKind.Constructor ->
         match objTys, argTys with
         | [ty], [] when typeEquiv g ty (GetFSharpViewOfReturnType g returnTy) ->
             AddCxTypeMustSupportDefaultCtor env.DisplayEnv cenv.css m NoTrace ty
@@ -4125,7 +4126,7 @@ and TcPseudoMemberSpec cenv newOk env synTypes tpenv synMemberSig m =
             let item = Item.OtherName (Some id, memberConstraintTy, None, None, id.idRange)
             CallNameResolutionSink cenv.tcSink (id.idRange, env.NameEnv, item, emptyTyparInst, ItemOccurence.Use, env.AccessRights)
 
-            TTrait(tys, logicalCompiledName, memberFlags, argTys, returnTy, ref None), tpenv
+            TTrait(tys, logicalCompiledName, memberFlags, argTys, returnTy, ref None, ref None), tpenv
 
         | _ -> error(Error(FSComp.SR.tcInvalidConstraint(), m))
 
@@ -8813,7 +8814,7 @@ and TcImplicitOpItemThen (cenv: cenv) overallTy env id sln tpenv mItem delayed =
 
     let memberFlags = StaticMemberFlags SynMemberKind.Member
     let logicalCompiledName = ComputeLogicalName id memberFlags
-    let traitInfo = TTrait(argTys, logicalCompiledName, memberFlags, argTys, Some retTy, sln)
+    let traitInfo = TTrait(argTys, logicalCompiledName, memberFlags, argTys, Some retTy, ref None, sln)
 
     let expr = Expr.Op (TOp.TraitCall traitInfo, [], ves, mItem)
     let expr = mkLambdas g mItem [] vs (expr, retTy)

src/Compiler/Checking/ConstraintSolver.fs

@@ -1394,7 +1394,7 @@ and SolveDimensionlessNumericType (csenv: ConstraintSolverEnv) ndeep m2 trace ty
 ///
 /// 2. Some additional solutions are forced prior to generalization (permitWeakResolution= Yes or YesDuringCodeGen). See above
 and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload permitWeakResolution ndeep m2 trace traitInfo : OperationResult<bool> = trackErrors {
-    let (TTrait(supportTys, nm, memFlags, traitObjAndArgTys, retTy, sln)) = traitInfo
+    let (TTrait(supportTys, nm, memFlags, traitObjAndArgTys, retTy, source, sln)) = traitInfo
     // Do not re-solve if already solved
     if sln.Value.IsSome then return true else
 
@@ -1411,8 +1411,8 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload
     let supportTys = ListSet.setify (typeAEquiv g aenv) supportTys
 
     // Rebuild the trait info after removing duplicates 
-    let traitInfo = TTrait(supportTys, nm, memFlags, traitObjAndArgTys, retTy, sln)
-    let retTy = GetFSharpViewOfReturnType g retTy    
+    let traitInfo = traitInfo.WithSupportTypes supportTys
+    let retTy = GetFSharpViewOfReturnType g retTy
 
     // Assert the object type if the constraint is for an instance member    
     if memFlags.IsInstance then 
@@ -1754,8 +1754,17 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload
                              if List.isSingleton supportTys then FSComp.SR.csTypeDoesNotSupportOperatorNullable(tyString, opName)
                              else FSComp.SR.csTypesDoNotSupportOperatorNullable(tyString, opName)
                           | _ ->
-                             if List.isSingleton supportTys then FSComp.SR.csTypeDoesNotSupportOperator(tyString, opName)
-                             else FSComp.SR.csTypesDoNotSupportOperator(tyString, opName)
+                             match supportTys, source.Value with
+                                | [_], Some s when s.StartsWith("Operators.") ->
+                                    let opSource = s[10..]
+                                    if opSource = nm then FSComp.SR.csTypeDoesNotSupportOperator(tyString, opName)
+                                    else FSComp.SR.csTypeDoesNotSupportOperator(tyString, opSource)
+                                | [_], Some s ->
+                                    FSComp.SR.csFunctionDoesNotSupportType(s, tyString, nm)
+                                | [_], _
+                                    -> FSComp.SR.csTypeDoesNotSupportOperator(tyString, opName)
+                                | _, _ 
+                                    -> FSComp.SR.csTypesDoNotSupportOperator(tyString, opName)
                       return! ErrorD(ConstraintSolverError(err, m, m2))
 
           | _ -> 
@@ -1928,7 +1937,6 @@ and TransactMemberConstraintSolution traitInfo (trace: OptionalTrace) sln  =
 /// Only consider overload resolution if canonicalizing or all the types are now nominal. 
 /// That is, don't perform resolution if more nominal information may influence the set of available overloads 
 and GetRelevantMethodsForTrait (csenv: ConstraintSolverEnv) (permitWeakResolution: PermitWeakResolution) nm traitInfo : (TType * MethInfo) list =
-    let (TTrait(_, _, memFlags, _, _, _)) = traitInfo
     let results = 
         if permitWeakResolution.Permit || MemberConstraintSupportIsReadyForDeterminingOverloads csenv traitInfo then
             let m = csenv.m
@@ -1938,7 +1946,7 @@ and GetRelevantMethodsForTrait (csenv: ConstraintSolverEnv) (permitWeakResolutio
             let minfos =
                 [ for (supportTy, nominalTy) in nominalTys do
                     let infos =
-                        match memFlags.MemberKind with
+                        match traitInfo.MemberFlags.MemberKind with
                         | SynMemberKind.Constructor ->
                             GetIntrinsicConstructorInfosOfType csenv.SolverState.InfoReader m nominalTy
                         | _ ->
@@ -1962,8 +1970,7 @@ and GetRelevantMethodsForTrait (csenv: ConstraintSolverEnv) (permitWeakResolutio
 
     // The trait name "op_Explicit" also covers "op_Implicit", so look for that one too.
     if nm = "op_Explicit" then 
-        let (TTrait(supportTys, _, memFlags, argTys, retTy, soln)) = traitInfo
-        let traitInfo2 = TTrait(supportTys, "op_Implicit", memFlags, argTys, retTy, soln)
+        let traitInfo2 = traitInfo.WithMemberName "op_Implicit"
         results @ GetRelevantMethodsForTrait csenv permitWeakResolution "op_Implicit" traitInfo2
     else
         results
@@ -2020,7 +2027,7 @@ and SupportTypeOfMemberConstraintIsSolved (csenv: ConstraintSolverEnv) (traitInf
 
 /// Get all the unsolved typars (statically resolved or not) relevant to the member constraint
 and GetFreeTyparsOfMemberConstraint (csenv: ConstraintSolverEnv) traitInfo =
-    let (TTrait(supportTys, _, _, argTys, retTy, _)) = traitInfo
+    let (TTrait(tys=supportTys; objAndArgTys=argTys; returnTyOpt=retTy)) = traitInfo
     freeInTypesLeftToRightSkippingConstraints csenv.g (supportTys @ argTys @ Option.toList retTy)
 
 and MemberConstraintIsReadyForWeakResolution csenv traitInfo =
@@ -2104,8 +2111,8 @@ and AddMemberConstraint (csenv: ConstraintSolverEnv) ndeep m2 (trace: OptionalTr
 
 and TraitsAreRelated (csenv: ConstraintSolverEnv) retry traitInfo1 traitInfo2 =
     let g = csenv.g
-    let (TTrait(tys1, nm1, memFlags1, argTys1, _, _)) = traitInfo1
-    let (TTrait(tys2, nm2, memFlags2, argTys2, _, _)) = traitInfo2
+    let (TTrait(tys=tys1; memberName=nm1; memberFlags=memFlags1; objAndArgTys=argTys1)) = traitInfo1
+    let (TTrait(tys=tys2; memberName=nm2; memberFlags=memFlags2; objAndArgTys=argTys2)) = traitInfo2
     memFlags1.IsInstance = memFlags2.IsInstance &&
     nm1 = nm2 &&
     // Multiple op_Explicit and op_Implicit constraints can exist for the same type variable.
@@ -2130,8 +2137,8 @@ and EnforceConstraintConsistency (csenv: ConstraintSolverEnv) ndeep m2 trace ret
     match tpc1, tpc2 with
     | TyparConstraint.MayResolveMember(traitInfo1, _), TyparConstraint.MayResolveMember(traitInfo2, _)
         when TraitsAreRelated csenv retry traitInfo1 traitInfo2 ->
-        let (TTrait(tys1, _, _, argTys1, rty1, _)) = traitInfo1
-        let (TTrait(tys2, _, _, argTys2, rty2, _)) = traitInfo2
+        let (TTrait(tys=tys1; objAndArgTys=argTys1; returnTyOpt=rty1)) = traitInfo1
+        let (TTrait(tys=tys2; objAndArgTys=argTys2; returnTyOpt=rty2)) = traitInfo2
         if retry then
             match tys1, tys2 with
             | [ty1], [ty2] -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace ty1 ty2

src/Compiler/Checking/FindUnsolved.fs

@@ -167,7 +167,7 @@ and accOp cenv env (op, tyargs, args, m) =
     | _ ->    ()
 
 /// Walk a trait call, collecting type variables
-and accTraitInfo cenv env (mFallback : range) (TTrait(tys, _nm, _, argTys, retTy, _sln)) =
+and accTraitInfo cenv env (mFallback : range) (TTrait(tys=tys; objAndArgTys=argTys; returnTyOpt=retTy)) =
     argTys |> accTypeInst cenv env mFallback
     retTy |> Option.iter (accTy cenv env mFallback)
     tys |> List.iter (accTy cenv env mFallback)

src/Compiler/Checking/NicePrint.fs

@@ -823,7 +823,7 @@ module PrintTypes =
 
     and layoutTraitWithInfo denv env traitInfo =
         let g = denv.g
-        let (TTrait(tys, _, memFlags, _, _, _)) = traitInfo
+        let (TTrait(tys=tys;memberFlags=memFlags)) = traitInfo
         let nm = traitInfo.MemberDisplayNameCore
         let nameL = ConvertValLogicalNameToDisplayLayout false (tagMember >> wordL) nm
         if denv.shortConstraints then 

src/Compiler/Checking/PostInferenceChecks.fs

@@ -346,7 +346,7 @@ let rec CheckTypeDeep (cenv: cenv) (visitTy, visitTyconRefOpt, visitAppTyOpt, vi
     | TType_var (tp, _) when tp.Solution.IsSome ->
         for cx in tp.Constraints do
             match cx with
-            | TyparConstraint.MayResolveMember(TTrait(_, _, _, _, _, soln), _) ->
+            | TyparConstraint.MayResolveMember(TTrait(solution=soln), _) ->
                  match visitTraitSolutionOpt, soln.Value with
                  | Some visitTraitSolution, Some sln -> visitTraitSolution sln
                  | _ -> ()
@@ -432,11 +432,11 @@ and CheckTypeConstraintDeep cenv f g env x =
      | TyparConstraint.IsReferenceType _
      | TyparConstraint.RequiresDefaultConstructor _ -> ()
 
-and CheckTraitInfoDeep cenv (_, _, _, visitTraitSolutionOpt, _ as f) g env (TTrait(tys, _, _, argTys, retTy, soln))  =
-    CheckTypesDeep cenv f g env tys
-    CheckTypesDeep cenv f g env argTys
-    Option.iter (CheckTypeDeep cenv f g env true ) retTy
-    match visitTraitSolutionOpt, soln.Value with
+and CheckTraitInfoDeep cenv (_, _, _, visitTraitSolutionOpt, _ as f) g env traitInfo =
+    CheckTypesDeep cenv f g env traitInfo.SupportTypes
+    CheckTypesDeep cenv f g env traitInfo.CompiledObjectAndArgumentTypes
+    Option.iter (CheckTypeDeep cenv f g env true ) traitInfo.CompiledReturnType
+    match visitTraitSolutionOpt, traitInfo.Solution with
     | Some visitTraitSolution, Some sln -> visitTraitSolution sln
     | _ -> ()
 

src/Compiler/Driver/CompilerImports.fs

@@ -377,6 +377,26 @@ let IsExe fileName =
     let ext = Path.GetExtension fileName
     String.Compare(ext, ".exe", StringComparison.OrdinalIgnoreCase) = 0
 
+let addConstraintSources(ia: ImportedAssembly) =
+    let contents = ia.FSharpViewOfMetadata.Contents
+    let addCxsToMember name (v: Val) =
+        for typar in fst v.GeneralizedType do
+            for cx in typar.Constraints do
+                match cx with
+                | TyparConstraint.MayResolveMember(TTrait(source=source), _) ->
+                    source.Value <- Some name
+                | _ -> ()
+    let rec addCxsToModule name (m: ModuleOrNamespaceType) =
+        for e in m.ModuleAndNamespaceDefinitions do
+            if e.IsModuleOrNamespace then
+                let mname =
+                    if String.length name > 0 then name + "." + e.DisplayName
+                    elif e.IsModule then e.DisplayName
+                    else ""
+                addCxsToModule mname e.ModuleOrNamespaceType
+        for memb in m.AllValsAndMembers do addCxsToMember (name + "." + memb.LogicalName) memb
+    addCxsToModule "" contents.ModuleOrNamespaceType
+
 type TcConfig with
 
     member tcConfig.TryResolveLibWithDirectories(r: AssemblyReference) =
@@ -2233,6 +2253,9 @@ and [<Sealed>] TcImports
             let _dllinfos, phase2s = results |> Array.choose id |> List.ofArray |> List.unzip
             fixupOrphanCcus ()
             let ccuinfos = List.collect (fun phase2 -> phase2 ()) phase2s
+            if importsBase.IsSome then
+                importsBase.Value.CcuTable.Values |> Seq.iter addConstraintSources
+                ccuTable.Values |> Seq.iter addConstraintSources
             return ccuinfos
         }
 

src/Compiler/FSComp.txt

@@ -315,6 +315,7 @@ csExpectTypeWithOperatorButGivenFunction,"Expecting a type supporting the operat
 csExpectTypeWithOperatorButGivenTuple,"Expecting a type supporting the operator '%s' but given a tuple type"
 csTypesDoNotSupportOperator,"None of the types '%s' support the operator '%s'"
 csTypeDoesNotSupportOperator,"The type '%s' does not support the operator '%s'"
+csFunctionDoesNotSupportType,"'%s' does not support the type '%s', because the latter lacks the required (real or built-in) member '%s'"
 csTypesDoNotSupportOperatorNullable,"None of the types '%s' support the operator '%s'. Consider opening the module 'Microsoft.FSharp.Linq.NullableOperators'."
 csTypeDoesNotSupportOperatorNullable,"The type '%s' does not support the operator '%s'. Consider opening the module 'Microsoft.FSharp.Linq.NullableOperators'."
 csTypeDoesNotSupportConversion,"The type '%s' does not support a conversion to the type '%s'"

src/Compiler/Symbols/Exprs.fs

@@ -899,12 +899,12 @@ module FSharpExprConvert =
                 let typR = ConvType cenv (mkAppTy tycr tyargs)
                 E.UnionCaseTag(ConvExpr cenv env arg1, typR) 
 
-            | TOp.TraitCall (TTrait(tys, nm, memFlags, argTys, _retTy, _solution)), _, _                    -> 
-                let tysR = ConvTypes cenv tys
+            | TOp.TraitCall traitInfo, _, _ ->
+                let tysR = ConvTypes cenv traitInfo.SupportTypes
                 let tyargsR = ConvTypes cenv tyargs
-                let argTysR = ConvTypes cenv argTys
+                let argTysR = ConvTypes cenv traitInfo.CompiledObjectAndArgumentTypes
                 let argsR = ConvExprs cenv env args
-                E.TraitCall(tysR, nm, memFlags, argTysR, tyargsR, argsR) 
+                E.TraitCall(tysR, traitInfo.MemberLogicalName, traitInfo.MemberFlags, argTysR, tyargsR, argsR) 
 
             | TOp.RefAddrGet readonly, [ty], [e]  -> 
                 let replExpr = mkRecdFieldGetAddrViaExprAddr(readonly, e, mkRefCellContentsRef g, [ty], m)

src/Compiler/Symbols/Symbols.fs

@@ -1460,18 +1460,18 @@ type FSharpGenericParameterMemberConstraint(cenv, info: TraitConstraintInfo) =
                           (fun () -> Item.Trait(info)), 
                           (fun _ _ _ad -> true))
 
-    let (TTrait(tys, nm, flags, atys, retTy, _)) = info 
     member _.MemberSources = 
-        tys   |> List.map (fun ty -> FSharpType(cenv, ty)) |> makeReadOnlyCollection
+        info.SupportTypes |> List.map (fun ty -> FSharpType(cenv, ty)) |> makeReadOnlyCollection
 
-    member _.MemberName = nm
+    member _.MemberName = info.MemberLogicalName
 
-    member _.MemberIsStatic = not flags.IsInstance
+    member _.MemberIsStatic = not info.MemberFlags.IsInstance
 
-    member _.MemberArgumentTypes = atys   |> List.map (fun ty -> FSharpType(cenv, ty)) |> makeReadOnlyCollection
+    member _.MemberArgumentTypes =
+        info.CompiledObjectAndArgumentTypes |> List.map (fun ty -> FSharpType(cenv, ty)) |> makeReadOnlyCollection
 
     member _.MemberReturnType =
-        match retTy with 
+        match info.CompiledReturnType with 
         | None -> FSharpType(cenv, cenv.g.unit_ty) 
         | Some ty -> FSharpType(cenv, ty) 
     override x.ToString() = "<member constraint info>"

src/Compiler/TypedTree/TypedTree.fs

@@ -2454,29 +2454,41 @@ type TraitWitnessInfo =
 type TraitConstraintInfo = 
 
     /// Indicates the signature of a member constraint. Contains a mutable solution cell
-    /// to store the inferred solution of the constraint.
-    | TTrait of tys: TTypes * memberName: string * memberFlags: SynMemberFlags * objAndArgTys: TTypes * returnTyOpt: TType option * solution: TraitConstraintSln option ref 
+    /// to store the inferred solution of the constraint. And a mutable source cell to store
+    /// the name of the type or member that defined the constraint.
+    | TTrait of
+        tys: TTypes * 
+        memberName: string * 
+        memberFlags: SynMemberFlags * 
+        objAndArgTys: TTypes * 
+        returnTyOpt: TType option * 
+        source: string option ref * 
+        solution: TraitConstraintSln option ref 
 
     /// Get the types that may provide solutions for the traits
-    member x.SupportTypes = (let (TTrait(tys, _, _, _, _, _)) = x in tys)
+    member x.SupportTypes = (let (TTrait(tys = tys)) = x in tys)
 
     /// Get the logical member name associated with the member constraint.
-    member x.MemberLogicalName = (let (TTrait(_, nm, _, _, _, _)) = x in nm)
+    member x.MemberLogicalName = (let (TTrait(memberName = nm)) = x in nm)
 
     /// Get the member flags associated with the member constraint.
-    member x.MemberFlags = (let (TTrait(_, _, flags, _, _, _)) = x in flags)
-
-    member x.CompiledObjectAndArgumentTypes = (let (TTrait(_, _, _, objAndArgTys, _, _)) = x in objAndArgTys)
-
-    member x.WithMemberKind(kind) = (let (TTrait(a, b, c, d, e, f)) = x in TTrait(a, b, { c with MemberKind=kind }, d, e, f))
+    member x.MemberFlags = (let (TTrait(memberFlags = flags)) = x in flags)
 
+    member x.CompiledObjectAndArgumentTypes = (let (TTrait(objAndArgTys = objAndArgTys)) = x in objAndArgTys)
+
     /// Get the optional return type recorded in the member constraint.
-    member x.CompiledReturnType = (let (TTrait(_, _, _, _, retTy, _)) = x in retTy)
-
+    member x.CompiledReturnType = (let (TTrait(returnTyOpt = retTy)) = x in retTy)
+    
     /// Get or set the solution of the member constraint during inference
     member x.Solution 
-        with get() = (let (TTrait(_, _, _, _, _, sln)) = x in sln.Value)
-        and set v = (let (TTrait(_, _, _, _, _, sln)) = x in sln.Value <- v)
+        with get() = (let (TTrait(solution = sln)) = x in sln.Value)
+        and set v = (let (TTrait(solution = sln)) = x in sln.Value <- v)
+
+    member x.WithMemberKind(kind) = (let (TTrait(a, b, c, d, e, f, g)) = x in TTrait(a, b, { c with MemberKind=kind }, d, e, f, g))
+
+    member x.WithSupportTypes(tys) = (let (TTrait(_, b, c, d, e, f, g)) = x in TTrait(tys, b, c, d, e, f, g))
+
+    member x.WithMemberName(name) = (let (TTrait(a, _, c, d, e, f, g)) = x in TTrait(a, name, c, d, e, f, g))
 
     [<DebuggerBrowsable(DebuggerBrowsableState.Never)>]
     member x.DebugText = x.ToString()

src/Compiler/TypedTree/TypedTree.fsi

@@ -1678,13 +1678,15 @@ type TraitWitnessInfo =
 type TraitConstraintInfo =
 
     /// Indicates the signature of a member constraint. Contains a mutable solution cell
-    /// to store the inferred solution of the constraint.
+    /// to store the inferred solution of the constraint. And a mutable source cell to store
+    /// the name of the type or member that defined the constraint.
     | TTrait of
         tys: TTypes *
         memberName: string *
         memberFlags: Syntax.SynMemberFlags *
         objAndArgTys: TTypes *
         returnTyOpt: TType option *
+        source: string option ref *
         solution: TraitConstraintSln option ref
 
     override ToString: unit -> string
@@ -1719,6 +1721,10 @@ type TraitConstraintInfo =
     /// the extension property MemberDisplayNameCore
     member WithMemberKind: SynMemberKind -> TraitConstraintInfo
 
+    member WithSupportTypes: TTypes -> TraitConstraintInfo
+
+    member WithMemberName: string -> TraitConstraintInfo
+
 /// Represents the solution of a member constraint during inference.
 [<NoEquality; NoComparison>]
 type TraitConstraintSln =