diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index ff3cf43c2f1..d247366288e 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -370,7 +370,6 @@ let ShowAccessDomain ad = // Solve exception NonRigidTypar of DisplayEnv * string option * range * TType * TType * range -exception LocallyAbortOperationThatFailsToResolveOverload exception LocallyAbortOperationThatLosesAbbrevs let localAbortD = ErrorD LocallyAbortOperationThatLosesAbbrevs @@ -739,19 +738,19 @@ and solveTypMeetsTyparConstraints (csenv:ConstraintSolverEnv) ndeep m2 trace ty | Some destTypar -> AddConstraint csenv ndeep m2 trace destTypar (TyparConstraint.DefaultsTo(priority, dty, m)) - | TyparConstraint.SupportsNull m2 -> SolveTypSupportsNull csenv ndeep m2 trace ty - | TyparConstraint.IsEnum(underlying, m2) -> SolveTypIsEnum csenv ndeep m2 trace ty underlying - | TyparConstraint.SupportsComparison(m2) -> SolveTypeSupportsComparison csenv ndeep m2 trace ty - | TyparConstraint.SupportsEquality(m2) -> SolveTypSupportsEquality csenv ndeep m2 trace ty + | TyparConstraint.SupportsNull m2 -> SolveTypSupportsNull csenv ndeep m2 trace ty + | TyparConstraint.IsEnum(underlying, m2) -> SolveTypIsEnum csenv ndeep m2 trace ty underlying + | TyparConstraint.SupportsComparison(m2) -> SolveTypeSupportsComparison csenv ndeep m2 trace ty + | TyparConstraint.SupportsEquality(m2) -> SolveTypSupportsEquality csenv ndeep m2 trace ty | TyparConstraint.IsDelegate(aty, bty, m2) -> SolveTypIsDelegate csenv ndeep m2 trace ty aty bty - | TyparConstraint.IsNonNullableStruct m2 -> SolveTypIsNonNullableValueType csenv ndeep m2 trace ty - | TyparConstraint.IsUnmanaged m2 -> SolveTypIsUnmanaged csenv ndeep m2 trace ty - | TyparConstraint.IsReferenceType m2 -> SolveTypIsReferenceType csenv ndeep m2 trace ty - | TyparConstraint.RequiresDefaultConstructor m2 -> SolveTypRequiresDefaultConstructor csenv ndeep m2 trace ty + | TyparConstraint.IsNonNullableStruct m2 -> SolveTypIsNonNullableValueType csenv ndeep m2 trace ty + | TyparConstraint.IsUnmanaged m2 -> SolveTypIsUnmanaged csenv ndeep m2 trace ty + | TyparConstraint.IsReferenceType m2 -> SolveTypIsReferenceType csenv ndeep m2 trace ty + | TyparConstraint.RequiresDefaultConstructor m2 -> SolveTypRequiresDefaultConstructor csenv ndeep m2 trace ty | TyparConstraint.SimpleChoice(tys, m2) -> SolveTypChoice csenv ndeep m2 trace ty tys | TyparConstraint.CoercesTo(ty2, m2) -> SolveTypSubsumesTypKeepAbbrevs csenv ndeep m2 trace None ty2 ty - | TyparConstraint.MayResolveMember(traitInfo, m2) -> - SolveMemberConstraint csenv false false ndeep m2 trace traitInfo ++ (fun _ -> CompleteD) + | TyparConstraint.MayResolveMember(traitInfo, m2) -> + SolveMemberConstraint csenv false ndeep m2 trace traitInfo ++ (fun _ -> CompleteD) ))) @@ -761,6 +760,7 @@ and SolveTypEqualsTyp (csenv:ConstraintSolverEnv) ndeep m2 (trace: OptionalTrace let ndeep = ndeep + 1 let aenv = csenv.EquivEnv let g = csenv.g + if ty1 === ty2 then CompleteD else match cxsln with | Some (traitInfo, traitSln) when traitInfo.Solution.IsNone -> @@ -768,8 +768,6 @@ and SolveTypEqualsTyp (csenv:ConstraintSolverEnv) ndeep m2 (trace: OptionalTrace TransactMemberConstraintSolution traitInfo trace traitSln | _ -> () - if ty1 === ty2 then CompleteD else - let canShortcut = not trace.HasTrace let sty1 = stripTyEqnsA csenv.g canShortcut ty1 let sty2 = stripTyEqnsA csenv.g canShortcut ty2 @@ -943,7 +941,7 @@ and SolveDimensionlessNumericType (csenv:ConstraintSolverEnv) ndeep m2 trace ty /// We pretend int and other types support a number of operators. In the actual IL for mscorlib they /// don't, however the type-directed static optimization rules in the library code that makes use of this /// will deal with the problem. -and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload permitWeakResolution ndeep m2 trace (TTrait(tys, nm, memFlags, argtys, rty, sln)): OperationResult = +and SolveMemberConstraint (csenv:ConstraintSolverEnv) permitWeakResolution ndeep m2 trace (TTrait(tys,nm,memFlags,argtys,rty,sln)) : OperationResult = // Do not re-solve if already solved if sln.Value.IsSome then ResultD true else let g = csenv.g @@ -1300,12 +1298,9 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p let frees = GetFreeTyparsOfMemberConstraint csenv traitInfo // If there's nothing left to learn then raise the errors - (if (permitWeakResolution && isNil support) || isNil frees then errors - // Otherwise re-record the trait waiting for canonicalization - else AddMemberConstraint csenv ndeep m2 trace traitInfo support frees) ++ (fun () -> - match errors with - | ErrorResult (_, UnresolvedOverloading _) when not ignoreUnresolvedOverload && (not (nm = "op_Explicit" || nm = "op_Implicit")) -> ErrorD LocallyAbortOperationThatFailsToResolveOverload - | _ -> ResultD TTraitUnsolved) + (if (permitWeakResolution && isNil support) || isNil frees then errors + // Otherwise re-record the trait waiting for canonicalization + else AddMemberConstraint csenv ndeep m2 trace traitInfo support frees) ++ (fun () -> ResultD TTraitUnsolved) ) ++ (fun res -> RecordMemberConstraintSolution csenv.SolverState m trace traitInfo res)) @@ -1447,7 +1442,7 @@ and SolveRelevantMemberConstraintsForTypar (csenv:ConstraintSolverEnv) ndeep per cxs |> AtLeastOneD (fun (traitInfo, m2) -> let csenv = { csenv with m = m2 } - SolveMemberConstraint csenv true permitWeakResolution (ndeep+1) m2 trace traitInfo) + SolveMemberConstraint csenv permitWeakResolution (ndeep+1) m2 trace traitInfo) and CanonicalizeRelevantMemberConstraints (csenv:ConstraintSolverEnv) ndeep trace tps = SolveRelevantMemberConstraints csenv ndeep true trace tps @@ -1962,12 +1957,10 @@ and CanMemberSigsMatchUpToCheck // to allow us to report the outer types involved in the constraint and private SolveTypSubsumesTypWithReport (csenv:ConstraintSolverEnv) ndeep m trace cxsln ty1 ty2 = TryD (fun () -> SolveTypSubsumesTypKeepAbbrevs csenv ndeep m trace cxsln ty1 ty2) - (function - | LocallyAbortOperationThatFailsToResolveOverload -> CompleteD - | res -> - match csenv.eContextInfo with - | ContextInfo.RuntimeTypeTest isOperator -> - // test if we can cast other way around + (fun res -> + match csenv.eContextInfo with + | ContextInfo.RuntimeTypeTest isOperator -> + // test if we can cast other way around match CollectThenUndo (fun newTrace -> SolveTypSubsumesTypKeepAbbrevs csenv ndeep m (OptionalTrace.WithTrace newTrace) cxsln ty2 ty1) with | OkResult _ -> ErrorD (ErrorsFromAddingSubsumptionConstraint(csenv.g, csenv.DisplayEnv, ty1, ty2, res, ContextInfo.DowncastUsedInsteadOfUpcast isOperator, m)) | _ -> ErrorD (ErrorsFromAddingSubsumptionConstraint(csenv.g, csenv.DisplayEnv, ty1, ty2, res, ContextInfo.NoContext, m)) @@ -1975,9 +1968,7 @@ and private SolveTypSubsumesTypWithReport (csenv:ConstraintSolverEnv) ndeep m tr and private SolveTypEqualsTypWithReport (csenv:ConstraintSolverEnv) ndeep m trace cxsln ty1 ty2 = TryD (fun () -> SolveTypEqualsTypKeepAbbrevsWithCxsln csenv ndeep m trace cxsln ty1 ty2) - (function - | LocallyAbortOperationThatFailsToResolveOverload -> CompleteD - | res -> ErrorD (ErrorFromAddingTypeEquation(csenv.g, csenv.DisplayEnv, ty1, ty2, res, m))) + (fun res -> ErrorD (ErrorFromAddingTypeEquation(csenv.g, csenv.DisplayEnv, ty1, ty2, res, m))) and ArgsMustSubsumeOrConvert (csenv:ConstraintSolverEnv) @@ -2543,7 +2534,7 @@ let AddCxTypeMustSubsumeType contextInfo denv css m trace ty1 ty2 = |> RaiseOperationResult let AddCxMethodConstraint denv css m trace traitInfo = - TryD (fun () -> SolveMemberConstraint (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) true false 0 m trace traitInfo ++ (fun _ -> CompleteD)) + TryD (fun () -> SolveMemberConstraint (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) false 0 m trace traitInfo ++ (fun _ -> CompleteD)) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult @@ -2601,7 +2592,7 @@ let CodegenWitnessThatTypSupportsTraitConstraint tcVal g amap m (traitInfo:Trait InfoReader = new InfoReader(g, amap) } let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m (DisplayEnv.Empty g) - SolveMemberConstraint csenv true true 0 m NoTrace traitInfo ++ (fun _res -> + SolveMemberConstraint csenv true 0 m NoTrace traitInfo ++ (fun _res -> let sln = match traitInfo.Solution with | None -> Choice4Of4() @@ -2725,5 +2716,4 @@ let IsApplicableMethApprox g amap m (minfo:MethInfo) availObjTy = |> CommitOperationResult | _ -> true else - true - + true \ No newline at end of file diff --git a/tests/fsharpqa/Source/Conformance/DeclarationElements/MemberDefinitions/OverloadingMembers/OverloadsAndSRTPs01.fs b/tests/fsharpqa/Source/Conformance/DeclarationElements/MemberDefinitions/OverloadingMembers/OverloadsAndSRTPs01.fs new file mode 100644 index 00000000000..842d049dc9f --- /dev/null +++ b/tests/fsharpqa/Source/Conformance/DeclarationElements/MemberDefinitions/OverloadingMembers/OverloadsAndSRTPs01.fs @@ -0,0 +1,38 @@ +// #Conformance #DeclarationElements #MemberDefinitions #Overloading +// Exotic case from F#+ https://github.com/gusty/FSharpPlus + +module Applicatives = + open System + + type Ap = Ap with + static member inline Invoke (x:'T) : '``Applicative<'T>`` = + let inline call (mthd : ^M, output : ^R) = ((^M or ^R) : (static member Return: _*_ -> _) output, mthd) + call (Ap, Unchecked.defaultof<'``Applicative<'T>``>) x + static member inline InvokeOnInstance (x:'T) = (^``Applicative<'T>`` : (static member Return: ^T -> ^``Applicative<'T>``) x) + static member inline Return (r:'R , _:obj) = Ap.InvokeOnInstance :_ -> 'R + static member Return (_:seq<'a> , Ap ) = fun x -> Seq.singleton x : seq<'a> + static member Return (_:Tuple<'a>, Ap ) = fun x -> Tuple x : Tuple<'a> + static member Return (_:'r -> 'a , Ap ) = fun k _ -> k : 'a -> 'r -> _ + + let inline result (x:'T) = Ap.Invoke x + + let inline (<*>) (f:'``Applicative<'T->'U>``) (x:'``Applicative<'T>``) : '``Applicative<'U>`` = + (( ^``Applicative<'T->'U>`` or ^``Applicative<'T>`` or ^``Applicative<'U>``) : (static member (<*>): _*_ -> _) f, x) + + let inline (+) (a:'Num) (b:'Num) :'Num = a + b + + type ZipList<'s> = ZipList of 's seq with + static member Return (x:'a) = ZipList (Seq.initInfinite (fun _ -> x)) + static member (<*>) (ZipList (f:seq<'a->'b>), ZipList x) = ZipList (Seq.zip f x |> Seq.map (fun (f, x) -> f x)) :ZipList<'b> + + type Ii = Ii + type Idiomatic = Idiomatic with + static member inline ($) (Idiomatic, si) = fun sfi x -> (Idiomatic $ x) (sfi <*> si) + static member ($) (Idiomatic, Ii) = id + let inline idiomatic a b = (Idiomatic $ b) a + let inline iI x = (idiomatic << result) x + + let res1n2n3 = iI (+) (result 0M ) (ZipList [1M;2M;3M]) Ii + let res2n3n4 = iI (+) (result LanguagePrimitives.GenericOne) (ZipList [1 ;2 ;3 ]) Ii + + exit 0 \ No newline at end of file diff --git a/tests/fsharpqa/Source/Conformance/DeclarationElements/MemberDefinitions/OverloadingMembers/RecursiveOverload01.fs b/tests/fsharpqa/Source/Conformance/DeclarationElements/MemberDefinitions/OverloadingMembers/RecursiveOverload01.fs new file mode 100644 index 00000000000..e8d9355ad44 --- /dev/null +++ b/tests/fsharpqa/Source/Conformance/DeclarationElements/MemberDefinitions/OverloadingMembers/RecursiveOverload01.fs @@ -0,0 +1,26 @@ +// #Conformance #DeclarationElements #MemberDefinitions #Overloading +// Originally from https://gist.github.com/gusty/b6fac370bff36a665d75 +type FoldArgs<'t> = FoldArgs of ('t -> 't -> 't) + +let inline foldArgs f (x:'t) (y:'t) :'rest = (FoldArgs f $ Unchecked.defaultof<'rest>) x y + +type FoldArgs<'t> with + static member inline ($) (FoldArgs f, _:'t-> 'rest) = fun (a:'t) -> f a >> foldArgs f + static member ($) (FoldArgs f, _:'t ) = f + +let test1() = + let x:int = foldArgs (+) 2 3 + let y:int = foldArgs (+) 2 3 4 + let z:int = foldArgs (+) 2 3 4 5 + let d:decimal = foldArgs (+) 2M 3M 4M + let e:string = foldArgs (+) "h" "e" "l" "l" "o" + let f:float = foldArgs (+) 2. 3. 4. + + let mult3Numbers a b c = a * b * c + let res2 = mult3Numbers 3 (foldArgs (+) 3 4) (foldArgs (+) 2 2 3 3) + () + +// Run the test +test1() + +exit 0 \ No newline at end of file diff --git a/tests/fsharpqa/Source/Conformance/DeclarationElements/MemberDefinitions/OverloadingMembers/SlowOverloadResolution.fs b/tests/fsharpqa/Source/Conformance/DeclarationElements/MemberDefinitions/OverloadingMembers/SlowOverloadResolution.fs index 5737cdebf2c..0f6d5f43532 100644 --- a/tests/fsharpqa/Source/Conformance/DeclarationElements/MemberDefinitions/OverloadingMembers/SlowOverloadResolution.fs +++ b/tests/fsharpqa/Source/Conformance/DeclarationElements/MemberDefinitions/OverloadingMembers/SlowOverloadResolution.fs @@ -1,6 +1,6 @@ // #Conformance #DeclarationElements #MemberDefinitions #Overloading // https://github.com/Microsoft/visualfsharp/issues/351 - slow overlaod resolution -//This value is not a function and cannot be applied +//No overloads match type Switcher = Switcher let inline checker< ^s, ^r when (^s or ^r) : (static member pass : ^r -> unit)> (s : ^s) (r : ^r) = () @@ -22,4 +22,4 @@ let main argv = let res : unit = format () "text" 5 "more text" () printfn "%A" res System.Console.ReadKey() - 0 // return an integer exit code + 0 // return an integer exit code \ No newline at end of file diff --git a/tests/fsharpqa/Source/Conformance/DeclarationElements/MemberDefinitions/OverloadingMembers/env.lst b/tests/fsharpqa/Source/Conformance/DeclarationElements/MemberDefinitions/OverloadingMembers/env.lst index 7a3e95f230e..e123d552e69 100644 --- a/tests/fsharpqa/Source/Conformance/DeclarationElements/MemberDefinitions/OverloadingMembers/env.lst +++ b/tests/fsharpqa/Source/Conformance/DeclarationElements/MemberDefinitions/OverloadingMembers/env.lst @@ -27,6 +27,8 @@ NOMONO,NoMT SOURCE=ConsumeOverloadGenericMethods.fs SCFLAGS="-r:lib.dll" PRECMD= SOURCE=InferenceForLambdaArgs.fs # InferenceForLambdaArgs.fs SOURCE=SlowOverloadResolution.fs # SlowOverloadResolution.fs + SOURCE=RecursiveOverload01.fs # RecursiveOverload01.fs + SOURCE=OverloadsAndSRTPs01.fs # OverloadsAndSRTPs01.fs SOURCE=E_OverloadCurriedFunc.fs # E_OverloadCurriedFunc.fs SOURCE=NoWarningWhenOverloadingInSubClass01.fs SCFLAGS="--warnaserror" # NoWarningWhenOverloadingInSubClass01.fs