open Internal.Utilities

open System.Text

open Microsoft.FSharp.Compiler

open Microsoft.FSharp.Compiler.AbstractIL

open Microsoft.FSharp.Compiler.AbstractIL.IL

open Microsoft.FSharp.Compiler.AbstractIL.Internal

open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library

open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics

open Microsoft.FSharp.Compiler.Range

open Microsoft.FSharp.Compiler.Ast

open Microsoft.FSharp.Compiler.ErrorLogger

open Microsoft.FSharp.Compiler.Tast

open Microsoft.FSharp.Compiler.Tastops

open Microsoft.FSharp.Compiler.Tastops.DebugPrint

open Microsoft.FSharp.Compiler.TcGlobals

open Microsoft.FSharp.Compiler.AbstractIL.IL

open Microsoft.FSharp.Compiler.Lib

open Microsoft.FSharp.Compiler.Infos

open Microsoft.FSharp.Compiler.PrettyNaming

open Microsoft.FSharp.Compiler.Infos.AccessibilityLogic

open Microsoft.FSharp.Compiler.NameResolution

#if EXTENSIONTYPING

open Microsoft.FSharp.Compiler.ExtensionTyping

let rec TypeDefinitelySubsumesTypeNoCoercion ndeep g amap m ty1 ty2 =

if ndeep > 100 then error(InternalError("recursive class hierarchy (detected in TypeDefinitelySubsumesTypeNoCoercion), ty1 = "^(DebugPrint.showType ty1),m))

if ty1 === ty2 then true

// QUERY : quadratic

elif typeEquiv g ty1 ty2 then true

else

let ty1 = stripTyEqns g ty1

let ty2 = stripTyEqns g ty2

match ty1,ty2 with

| TType_app (tc1,l1) ,TType_app (tc2,l2) when tyconRefEq g tc1 tc2 ->

List.lengthsEqAndForall2 (typeEquiv g) l1 l2

| TType_ucase (tc1,l1) ,TType_ucase (tc2,l2) when g.unionCaseRefEq tc1 tc2 ->

List.lengthsEqAndForall2 (typeEquiv g) l1 l2

| TType_tuple l1 ,TType_tuple l2 ->

List.lengthsEqAndForall2 (typeEquiv g) l1 l2

| TType_fun (d1,r1) ,TType_fun (d2,r2) ->

typeEquiv g d1 d2 && typeEquiv g r1 r2

| TType_measure measure1, TType_measure measure2 ->

measureEquiv g measure1 measure2

| _ ->

(typeEquiv g ty1 g.obj_ty && isRefTy g ty2) || (* F# reference types are subtypes of type 'obj' *)

(isAppTy g ty2 &&

isRefTy g ty2 &&

((match GetSuperTypeOfType g amap m ty2 with

| None -> false

| Some ty -> TypeDefinitelySubsumesTypeNoCoercion (ndeep+1) g amap m ty1 ty) ||

(isInterfaceTy g ty1 &&

ty2 |> GetImmediateInterfacesOfType SkipUnrefInterfaces.Yes g amap m

|> List.exists (TypeDefinitelySubsumesTypeNoCoercion (ndeep+1) g amap m ty1))))

type CanCoerce = CanCoerce | NoCoerce

let rec TypesFeasiblyEquiv ndeep g amap m ty1 ty2 =

if ndeep > 100 then error(InternalError("recursive class hierarchy (detected in TypeFeasiblySubsumesType), ty1 = "^(DebugPrint.showType ty1),m));

let ty1 = stripTyEqns g ty1

let ty2 = stripTyEqns g ty2

match ty1,ty2 with

// QUERY: should these be false for non-equal rigid typars? warn-if-not-rigid typars?

| TType_var _ , _

| _, TType_var _ -> true

| TType_app (tc1,l1) ,TType_app (tc2,l2) when tyconRefEq g tc1 tc2 ->

List.lengthsEqAndForall2 (TypesFeasiblyEquiv ndeep g amap m) l1 l2

| TType_tuple l1 ,TType_tuple l2 ->

List.lengthsEqAndForall2 (TypesFeasiblyEquiv ndeep g amap m) l1 l2

| TType_fun (d1,r1) ,TType_fun (d2,r2) ->

(TypesFeasiblyEquiv ndeep g amap m) d1 d2 && (TypesFeasiblyEquiv ndeep g amap m) r1 r2

| TType_measure _, TType_measure _ ->

true

| _ ->

false

let rec TypeFeasiblySubsumesType ndeep g amap m ty1 canCoerce ty2 =

if ndeep > 100 then error(InternalError("recursive class hierarchy (detected in TypeFeasiblySubsumesType), ty1 = "^(DebugPrint.showType ty1),m))

let ty1 = stripTyEqns g ty1

let ty2 = stripTyEqns g ty2

match ty1,ty2 with

// QUERY: should these be false for non-equal rigid typars? warn-if-not-rigid typars?

| TType_var _ , _ | _, TType_var _ -> true

| TType_app (tc1,l1) ,TType_app (tc2,l2) when tyconRefEq g tc1 tc2 ->

List.lengthsEqAndForall2 (TypesFeasiblyEquiv ndeep g amap m) l1 l2

| TType_tuple l1 ,TType_tuple l2 ->

List.lengthsEqAndForall2 (TypesFeasiblyEquiv ndeep g amap m) l1 l2

| TType_fun (d1,r1) ,TType_fun (d2,r2) ->

(TypesFeasiblyEquiv ndeep g amap m) d1 d2 && (TypesFeasiblyEquiv ndeep g amap m) r1 r2

| TType_measure _, TType_measure _ ->

true

| _ ->

// F# reference types are subtypes of type 'obj'

(isObjTy g ty1 && (canCoerce = CanCoerce || isRefTy g ty2))

||

(isAppTy g ty2 &&

(canCoerce = CanCoerce || isRefTy g ty2) &&

begin match GetSuperTypeOfType g amap m ty2 with

| None -> false

| Some ty -> TypeFeasiblySubsumesType (ndeep+1) g amap m ty1 NoCoerce ty

end ||

ty2 |> GetImmediateInterfacesOfType SkipUnrefInterfaces.Yes g amap m

|> List.exists (TypeFeasiblySubsumesType (ndeep+1) g amap m ty1 NoCoerce))

let ChooseTyparSolutionAndRange g amap (tp:Typar) =

let m = tp.Range

let max,m =

let initial =

match tp.Kind with

| TyparKind.Type -> g.obj_ty

| TyparKind.Measure -> TType_measure MeasureOne

// Loop through the constraints computing the lub

((initial,m), tp.Constraints) ||> List.fold (fun (maxSoFar,_) tpc ->

let join m x =

if TypeFeasiblySubsumesType 0 g amap m x CanCoerce maxSoFar then maxSoFar

elif TypeFeasiblySubsumesType 0 g amap m maxSoFar CanCoerce x then x

else errorR(Error(FSComp.SR.typrelCannotResolveImplicitGenericInstantiation((DebugPrint.showType x), (DebugPrint.showType maxSoFar)),m)); maxSoFar

// Don't continue if an error occurred and we set the value eagerly

if tp.IsSolved then maxSoFar,m else

match tpc with

| TyparConstraint.CoercesTo(x,m) ->

join m x,m

| TyparConstraint.MayResolveMember(TTrait(_,nm,_,_,_,_),m) ->

errorR(Error(FSComp.SR.typrelCannotResolveAmbiguityInOverloadedOperator(DemangleOperatorName nm),m))

maxSoFar,m

| TyparConstraint.SimpleChoice(_,m) ->

errorR(Error(FSComp.SR.typrelCannotResolveAmbiguityInPrintf(),m))

maxSoFar,m

| TyparConstraint.SupportsNull m ->

maxSoFar,m

| TyparConstraint.SupportsComparison m ->

join m g.mk_IComparable_ty,m

| TyparConstraint.SupportsEquality m ->

maxSoFar,m

| TyparConstraint.IsEnum(_,m) ->

errorR(Error(FSComp.SR.typrelCannotResolveAmbiguityInEnum(),m))

maxSoFar,m

| TyparConstraint.IsDelegate(_,_,m) ->

errorR(Error(FSComp.SR.typrelCannotResolveAmbiguityInDelegate(),m))

maxSoFar,m

| TyparConstraint.IsNonNullableStruct m ->

join m g.int_ty,m

| TyparConstraint.IsUnmanaged m ->

errorR(Error(FSComp.SR.typrelCannotResolveAmbiguityInUnmanaged(),m))

maxSoFar,m

| TyparConstraint.RequiresDefaultConstructor m ->

maxSoFar,m

| TyparConstraint.IsReferenceType m ->

maxSoFar,m

| TyparConstraint.DefaultsTo(_priority,_ty,m) ->

maxSoFar,m)

max,m

let ChooseTyparSolution g amap tp =

let ty,_m = ChooseTyparSolutionAndRange g amap tp

if tp.Rigidity = TyparRigidity.Anon && typeEquiv g ty (TType_measure MeasureOne) then

warning(Error(FSComp.SR.csCodeLessGeneric(),tp.Range))

ty

let IterativelySubstituteTyparSolutions g tps solutions =

let tpenv = mkTyparInst tps solutions

let rec loop n curr =

let curr' = curr |> instTypes tpenv

// We cut out at n > 40 just in case this loops. It shouldn't, since there should be no cycles in the

// solution equations, and we've only ever seen one example where even n = 2 was required.

// Perhaps it's possible in error recovery some strange situations could occur where cycles

// arise, so it's better to be on the safe side.

//

// We don't give an error if we hit the limit since it's feasible that the solutions of unknowns

// is not actually relevant to the rest of type checking or compilation.

if n > 40 || List.forall2 (typeEquiv g) curr curr' then

curr

else

loop (n+1) curr'

loop 0 solutions

let ChooseTyparSolutionsForFreeChoiceTypars g amap e =

match e with

| Expr.TyChoose(tps,e1,_m) ->

/// Only make choices for variables that are actually used in the expression

let ftvs = (freeInExpr CollectTyparsNoCaching e1).FreeTyvars.FreeTypars

let tps = tps |> List.filter (Zset.memberOf ftvs)

let solutions = tps |> List.map (ChooseTyparSolution g amap) |> IterativelySubstituteTyparSolutions g tps

let tpenv = mkTyparInst tps solutions

instExpr g tpenv e1

| _ -> e

let tryDestTopLambda g amap (ValReprInfo (tpNames,_,_) as tvd) (e,ty) =

let rec stripLambdaUpto n (e,ty) =

match e with

| Expr.Lambda (_,None,None,v,b,_,retTy) when n > 0 ->

let (vs',b',retTy') = stripLambdaUpto (n-1) (b,retTy)

(v :: vs', b', retTy')

| _ ->

([],e,ty)

let rec startStripLambdaUpto n (e,ty) =

match e with

| Expr.Lambda (_,ctorThisValOpt,baseValOpt,v,b,_,retTy) when n > 0 ->

let (vs',b',retTy') = stripLambdaUpto (n-1) (b,retTy)

(ctorThisValOpt,baseValOpt, (v :: vs'), b', retTy')

| Expr.TyChoose (_tps,_b,_) ->

startStripLambdaUpto n (ChooseTyparSolutionsForFreeChoiceTypars g amap e, ty)

| _ ->

(None,None,[],e,ty)

let n = tvd.NumCurriedArgs

let tps,taue,tauty =

match e with

| Expr.TyLambda (_,tps,b,_,retTy) when nonNil tpNames -> tps,b,retTy

| _ -> [],e,ty

let ctorThisValOpt,baseValOpt,vsl,body,retTy = startStripLambdaUpto n (taue,tauty)

if vsl.Length <> n then

None

else

Some (tps,ctorThisValOpt,baseValOpt,vsl,body,retTy)

let destTopLambda g amap topValInfo (e,ty) =

match tryDestTopLambda g amap topValInfo (e,ty) with

| None -> error(Error(FSComp.SR.typrelInvalidValue(), e.Range))

| Some res -> res

let IteratedAdjustArityOfLambdaBody g arities vsl body =

(arities, vsl, ([],body)) |||> List.foldBack2 (fun arities vs (allvs,body) ->

let vs,body = AdjustArityOfLambdaBody g arities vs body

vs :: allvs, body)

let IteratedAdjustArityOfLambda g amap topValInfo e =

let tps,ctorThisValOpt,baseValOpt,vsl,body,bodyty = destTopLambda g amap topValInfo (e, tyOfExpr g e)

let arities = topValInfo.AritiesOfArgs

if arities.Length <> vsl.Length then

errorR(InternalError(sprintf "IteratedAdjustArityOfLambda, List.length arities = %d, List.length vsl = %d" (List.length arities) (List.length vsl), body.Range))

let vsl,body = IteratedAdjustArityOfLambdaBody g arities vsl body

tps,ctorThisValOpt,baseValOpt,vsl,body,bodyty

exception RequiredButNotSpecified of DisplayEnv * Tast.ModuleOrNamespaceRef * string * (StringBuilder -> unit) * range

exception ValueNotContained of DisplayEnv * Tast.ModuleOrNamespaceRef * Val * Val * (string * string * string -> string)

exception ConstrNotContained of DisplayEnv * UnionCase * UnionCase * (string * string -> string)

exception ExnconstrNotContained of DisplayEnv * Tycon * Tycon * (string * string -> string)

exception FieldNotContained of DisplayEnv * RecdField * RecdField * (string * string -> string)

exception InterfaceNotRevealed of DisplayEnv * TType * range

module SignatureConformance = begin

// Use a type to capture the constant, common parameters

type Checker(g, amap, denv, remapInfo: SignatureRepackageInfo, checkingSig) =

// Build a remap that maps tcrefs in the signature to tcrefs in the implementation

// Used when checking attributes.

let sigToImplRemap =

let remap = Remap.Empty

let remap = (remapInfo.mrpiEntities,remap) ||> List.foldBack (fun (implTcref ,signTcref) acc -> addTyconRefRemap signTcref implTcref acc)

let remap = (remapInfo.mrpiVals ,remap) ||> List.foldBack (fun (implValRef,signValRef) acc -> addValRemap signValRef.Deref implValRef.Deref acc)

remap

// For all attributable elements (types, modules, exceptions, record fields, unions, parameters, generic type parameters)

//

// (a) Start with lists AImpl and ASig containing the attributes in the implementation and signature, in declaration order

// (b) Each attribute in AImpl is checked against the available attributes in ASig.

// a. If an attribute is found in ASig which is an exact match (after evaluating attribute arguments), then the attribute in the implementation is ignored, the attribute is removed from ASig, and checking continues

// b. If an attribute is found in ASig that has the same attribute type, then a warning is given and the attribute in the implementation is ignored

// c. Otherwise, the attribute in the implementation is kept

// (c) The attributes appearing in the compiled element are the compiled forms of the attributes from the signature and the kept attributes from the implementation

let checkAttribs _aenv (implAttribs:Attribs) (sigAttribs:Attribs) fixup =

// Remap the signature attributes to make them look as if they were declared in

// the implementation. This allows us to compare them and propagate them to the implementation

// if needed.

let sigAttribs = sigAttribs |> List.map (remapAttrib g sigToImplRemap)

// Helper to check for equality of evaluated attribute expressions

let attribExprEq (AttribExpr(_,e1)) (AttribExpr(_,e2)) = EvaledAttribExprEquality g e1 e2

// Helper to check for equality of evaluated named attribute arguments

let attribNamedArgEq (AttribNamedArg(nm1,ty1,isProp1,e1)) (AttribNamedArg(nm2,ty2,isProp2,e2)) =

(nm1 = nm2) &&

typeEquiv g ty1 ty2 &&

(isProp1 = isProp2) &&

attribExprEq e1 e2

let attribsEq attrib1 attrib2 =

let (Attrib(implTcref,_,implArgs,implNamedArgs,_,_,_implRange)) = attrib1

let (Attrib(signTcref,_,signArgs,signNamedArgs,_,_,_signRange)) = attrib2

tyconRefEq g signTcref implTcref &&

(implArgs,signArgs) ||> List.lengthsEqAndForall2 attribExprEq &&

(implNamedArgs, signNamedArgs) ||> List.lengthsEqAndForall2 attribNamedArgEq

let attribsHaveSameTycon attrib1 attrib2 =

let (Attrib(implTcref,_,_,_,_,_,_)) = attrib1

let (Attrib(signTcref,_,_,_,_,_,_)) = attrib2

tyconRefEq g signTcref implTcref

// For each implementation attribute, only keep if it is not mentioned in the signature.

// Emit a warning if it is mentioned in the signature and the arguments to the attributes are

// not identical.

let rec check keptImplAttribsRev implAttribs sigAttribs =

match implAttribs with

| [] -> keptImplAttribsRev |> List.rev

| implAttrib :: remainingImplAttribs ->

// Look for an attribute in the signature that matches precisely. If so, remove it

let lookForMatchingAttrib = sigAttribs |> List.tryRemove (attribsEq implAttrib)

match lookForMatchingAttrib with

| Some (_, remainingSigAttribs) -> check keptImplAttribsRev remainingImplAttribs remainingSigAttribs

| None ->

// Look for an attribute in the signature that has the same type. If so, give a warning

let existsSimilarAttrib = sigAttribs |> List.exists (attribsHaveSameTycon implAttrib)

if existsSimilarAttrib then

let (Attrib(implTcref,_,_,_,_,_,implRange)) = implAttrib

warning(Error(FSComp.SR.tcAttribArgsDiffer(implTcref.DisplayName), implRange))

check keptImplAttribsRev remainingImplAttribs sigAttribs

else

check (implAttrib :: keptImplAttribsRev) remainingImplAttribs sigAttribs

let keptImplAttribs = check [] implAttribs sigAttribs

fixup (sigAttribs @ keptImplAttribs)

true

let rec checkTypars m (aenv: TypeEquivEnv) (implTypars:Typars) (sigTypars:Typars) =

if implTypars.Length <> sigTypars.Length then

errorR (Error(FSComp.SR.typrelSigImplNotCompatibleParamCountsDiffer(),m))

false

else

let aenv = aenv.BindEquivTypars implTypars sigTypars

(implTypars,sigTypars) ||> List.forall2 (fun implTypar sigTypar ->

let m = sigTypar.Range

if implTypar.StaticReq <> sigTypar.StaticReq then

errorR (Error(FSComp.SR.typrelSigImplNotCompatibleCompileTimeRequirementsDiffer(), m))

// Adjust the actual type parameter name to look like the signature

implTypar.SetIdent (mkSynId implTypar.Range sigTypar.Id.idText)

// Mark it as "not compiler generated", now that we've got a good name for it

implTypar.SetCompilerGenerated false

// Check the constraints in the implementation are present in the signature

implTypar.Constraints |> List.forall (fun implTyparCx ->

match implTyparCx with

// defaults can be dropped in the signature

| TyparConstraint.DefaultsTo(_,_acty,_) -> true

| _ ->

if not (List.exists (typarConstraintsAEquiv g aenv implTyparCx) sigTypar.Constraints)

then (errorR(Error(FSComp.SR.typrelSigImplNotCompatibleConstraintsDiffer(sigTypar.Name, Layout.showL(NicePrint.layoutTyparConstraint denv (implTypar,implTyparCx))),m)); false)

else true) &&

// Check the constraints in the signature are present in the implementation

sigTypar.Constraints |> List.forall (fun sigTyparCx ->

match sigTyparCx with

// defaults can be present in the signature and not in the implementation because they are erased

| TyparConstraint.DefaultsTo(_,_acty,_) -> true

// 'comparison' and 'equality' constraints can be present in the signature and not in the implementation because they are erased

| TyparConstraint.SupportsComparison _ -> true

| TyparConstraint.SupportsEquality _ -> true

| _ ->

if not (List.exists (fun implTyparCx -> typarConstraintsAEquiv g aenv implTyparCx sigTyparCx) implTypar.Constraints) then

(errorR(Error(FSComp.SR.typrelSigImplNotCompatibleConstraintsDifferRemove(sigTypar.Name, Layout.showL(NicePrint.layoutTyparConstraint denv (sigTypar,sigTyparCx))),m)); false)

else

true) &&

(not checkingSig || checkAttribs aenv implTypar.Attribs sigTypar.Attribs (fun attribs -> implTypar.Data.typar_attribs <- attribs)))

and checkTypeDef (aenv: TypeEquivEnv) (implTycon:Tycon) (sigTycon:Tycon) =

let m = implTycon.Range

let err f = Error(f(implTycon.TypeOrMeasureKind.ToString()), m)

if implTycon.LogicalName <> sigTycon.LogicalName then (errorR (err (FSComp.SR.DefinitionsInSigAndImplNotCompatibleNamesDiffer)); false) else

if implTycon.CompiledName <> sigTycon.CompiledName then (errorR (err (FSComp.SR.DefinitionsInSigAndImplNotCompatibleNamesDiffer)); false) else

checkExnInfo (fun f -> ExnconstrNotContained(denv,implTycon,sigTycon,f)) aenv implTycon.ExceptionInfo sigTycon.ExceptionInfo &&

let implTypars = implTycon.Typars m

let sigTypars = sigTycon.Typars m

if implTypars.Length <> sigTypars.Length then

errorR (err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleParameterCountsDiffer))

false

elif isLessAccessible implTycon.Accessibility sigTycon.Accessibility then

errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleAccessibilityDiffer))

false

else

let aenv = aenv.BindEquivTypars implTypars sigTypars

let aintfs = implTycon.ImmediateInterfaceTypesOfFSharpTycon

let fintfs = sigTycon.ImmediateInterfaceTypesOfFSharpTycon

let aintfsUser = implTycon.TypeContents.tcaug_interfaces |> List.filter (fun (_,compgen,_) -> not compgen) |> List.map p13

let flatten tys =

tys

|> List.collect (AllSuperTypesOfType g amap m AllowMultiIntfInstantiations.Yes)

|> ListSet.setify (typeEquiv g)

|> List.filter (isInterfaceTy g)

let aintfs = flatten aintfs

let aintfsUser = flatten aintfsUser

let fintfs = flatten fintfs

let unimpl = ListSet.subtract (fun fity aity -> typeAEquiv g aenv aity fity) fintfs aintfs

(unimpl |> List.forall (fun ity -> errorR (err (fun x -> FSComp.SR.DefinitionsInSigAndImplNotCompatibleMissingInterface(x, NicePrint.minimalStringOfType denv ity))); false)) &&

let hidden = ListSet.subtract (typeAEquiv g aenv) aintfsUser fintfs

hidden |> List.iter (fun ity -> (if implTycon.IsFSharpInterfaceTycon then error else warning) (InterfaceNotRevealed(denv,ity,implTycon.Range)))

let aNull = IsUnionTypeWithNullAsTrueValue g implTycon

let fNull = IsUnionTypeWithNullAsTrueValue g sigTycon

if aNull && not fNull then

errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplementationSaysNull))

elif fNull && not aNull then

errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleSignatureSaysNull))

let aNull2 = TypeNullIsExtraValue g m (generalizedTyconRef (mkLocalTyconRef implTycon))

let fNull2 = TypeNullIsExtraValue g m (generalizedTyconRef (mkLocalTyconRef implTycon))

if aNull2 && not fNull2 then

errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplementationSaysNull2))

elif fNull2 && not aNull2 then

errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleSignatureSaysNull2))

let aSealed = isSealedTy g (generalizedTyconRef (mkLocalTyconRef implTycon))

let fSealed = isSealedTy g (generalizedTyconRef (mkLocalTyconRef sigTycon))

if aSealed && not fSealed then

errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplementationSealed))

if not aSealed && fSealed then

errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplementationIsNotSealed))

let aPartial = isAbstractTycon implTycon

let fPartial = isAbstractTycon sigTycon

if aPartial && not fPartial then

errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplementationIsAbstract))

if not aPartial && fPartial then

errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleSignatureIsAbstract))

if not (typeAEquiv g aenv (superOfTycon g implTycon) (superOfTycon g sigTycon)) then

errorR (err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleTypesHaveDifferentBaseTypes))

checkTypars m aenv implTypars sigTypars &&

checkTypeRepr err aenv implTycon.TypeReprInfo sigTycon.TypeReprInfo &&

checkTypeAbbrev err aenv implTycon.TypeOrMeasureKind sigTycon.TypeOrMeasureKind implTycon.TypeAbbrev sigTycon.TypeAbbrev &&

checkAttribs aenv implTycon.Attribs sigTycon.Attribs (fun attribs -> implTycon.Data.entity_attribs <- attribs) &&

checkModuleOrNamespaceContents implTycon.Range aenv (mkLocalEntityRef implTycon) sigTycon.ModuleOrNamespaceType

and checkValInfo aenv err (implVal : Val) (sigVal : Val) =

let id = implVal.Id

match implVal.ValReprInfo, sigVal.ValReprInfo with

| _,None -> true

| None, Some _ -> err(FSComp.SR.ValueNotContainedMutabilityArityNotInferred)

| Some (ValReprInfo (implTyparNames,implArgInfos,implRetInfo) as implValInfo), Some (ValReprInfo (sigTyparNames,sigArgInfos,sigRetInfo) as sigValInfo) ->

let ntps = implTyparNames.Length

let mtps = sigTyparNames.Length

if ntps <> mtps then

err(fun(x, y, z) -> FSComp.SR.ValueNotContainedMutabilityGenericParametersDiffer(x, y, z, string mtps, string ntps))

elif implValInfo.KindsOfTypars <> sigValInfo.KindsOfTypars then

err(FSComp.SR.ValueNotContainedMutabilityGenericParametersAreDifferentKinds)

elif not (sigArgInfos.Length <= implArgInfos.Length && List.forall2 (fun x y -> List.length x <= List.length y) sigArgInfos (fst (List.chop sigArgInfos.Length implArgInfos))) then

err(fun(x, y, z) -> FSComp.SR.ValueNotContainedMutabilityAritiesDiffer(x, y, z, id.idText, string sigArgInfos.Length, id.idText, id.idText))

else

let implArgInfos = implArgInfos |> List.take sigArgInfos.Length

let implArgInfos = (implArgInfos, sigArgInfos) ||> List.map2 (fun l1 l2 -> l1 |> List.take l2.Length)

// Propagate some information signature to implementation.

// Check the attributes on each argument, and update the ValReprInfo for

// the value to reflect the information in the signature.

// This ensures that the compiled form of the value matches the signature rather than

// the implementation. This also propagates argument names from signature to implementation

let res =

(implArgInfos,sigArgInfos) ||> List.forall2 (List.forall2 (fun implArgInfo sigArgInfo ->

checkAttribs aenv implArgInfo.Attribs sigArgInfo.Attribs (fun attribs ->

implArgInfo.Name <- sigArgInfo.Name

implArgInfo.Attribs <- attribs))) &&

checkAttribs aenv implRetInfo.Attribs sigRetInfo.Attribs (fun attribs ->

implRetInfo.Name <- sigRetInfo.Name

implRetInfo.Attribs <- attribs)

implVal.SetValReprInfo (Some (ValReprInfo (sigTyparNames,implArgInfos,implRetInfo)))

res

and checkVal implModRef (aenv:TypeEquivEnv) (implVal:Val) (sigVal:Val) =

// Propagate defn location information from implementation to signature .

sigVal.SetDefnRange implVal.DefinitionRange

let mk_err denv f = ValueNotContained(denv,implModRef,implVal,sigVal,f)

let err denv f = errorR(mk_err denv f); false

let m = implVal.Range

if implVal.IsMutable <> sigVal.IsMutable then (err denv FSComp.SR.ValueNotContainedMutabilityAttributesDiffer)

elif implVal.LogicalName <> sigVal.LogicalName then (err denv FSComp.SR.ValueNotContainedMutabilityNamesDiffer)

elif implVal.CompiledName <> sigVal.CompiledName then (err denv FSComp.SR.ValueNotContainedMutabilityCompiledNamesDiffer)

elif implVal.DisplayName <> sigVal.DisplayName then (err denv FSComp.SR.ValueNotContainedMutabilityDisplayNamesDiffer)

elif isLessAccessible implVal.Accessibility sigVal.Accessibility then (err denv FSComp.SR.ValueNotContainedMutabilityAccessibilityMore)

elif implVal.MustInline <> sigVal.MustInline then (err denv FSComp.SR.ValueNotContainedMutabilityInlineFlagsDiffer)

elif implVal.LiteralValue <> sigVal.LiteralValue then (err denv FSComp.SR.ValueNotContainedMutabilityLiteralConstantValuesDiffer)

elif implVal.IsTypeFunction <> sigVal.IsTypeFunction then (err denv FSComp.SR.ValueNotContainedMutabilityOneIsTypeFunction)

else

let implTypars,atau = implVal.TypeScheme

let sigTypars,ftau = sigVal.TypeScheme

if implTypars.Length <> sigTypars.Length then (err {denv with showTyparBinding=true} FSComp.SR.ValueNotContainedMutabilityParameterCountsDiffer) else

let aenv = aenv.BindEquivTypars implTypars sigTypars

checkTypars m aenv implTypars sigTypars &&

if not (typeAEquiv g aenv atau ftau) then err denv (FSComp.SR.ValueNotContainedMutabilityTypesDiffer)

elif not (checkValInfo aenv (err denv) implVal sigVal) then false

elif not (implVal.IsExtensionMember = sigVal.IsExtensionMember) then err denv (FSComp.SR.ValueNotContainedMutabilityExtensionsDiffer)

elif not (checkMemberDatasConform (err denv) (implVal.Attribs, implVal,implVal.MemberInfo) (sigVal.Attribs,sigVal,sigVal.MemberInfo)) then false

else checkAttribs aenv implVal.Attribs sigVal.Attribs (fun attribs -> implVal.Data.val_attribs <- attribs)

and checkExnInfo err aenv implTypeRepr sigTypeRepr =

match implTypeRepr,sigTypeRepr with

| TExnAsmRepr _, TExnFresh _ ->

(errorR (err FSComp.SR.ExceptionDefsNotCompatibleHiddenBySignature); false)

| TExnAsmRepr tcr1, TExnAsmRepr tcr2 ->

if tcr1 <> tcr2 then (errorR (err FSComp.SR.ExceptionDefsNotCompatibleDotNetRepresentationsDiffer); false) else true

| TExnAbbrevRepr _, TExnFresh _ ->

(errorR (err FSComp.SR.ExceptionDefsNotCompatibleAbbreviationHiddenBySignature); false)

| TExnAbbrevRepr ecr1, TExnAbbrevRepr ecr2 ->

if not (tcrefAEquiv g aenv ecr1 ecr2) then

(errorR (err FSComp.SR.ExceptionDefsNotCompatibleSignaturesDiffer); false)

else true

| TExnFresh r1, TExnFresh r2-> checkRecordFieldsForExn g denv err aenv r1 r2

| TExnNone,TExnNone -> true

| _ ->

(errorR (err FSComp.SR.ExceptionDefsNotCompatibleExceptionDeclarationsDiffer); false)

and checkUnionCase aenv implUnionCase sigUnionCase =

let err f = errorR(ConstrNotContained(denv,implUnionCase,sigUnionCase,f));false

if implUnionCase.Id.idText <> sigUnionCase.Id.idText then err FSComp.SR.ModuleContainsConstructorButNamesDiffer

elif implUnionCase.RecdFields.Length <> sigUnionCase.RecdFields.Length then err FSComp.SR.ModuleContainsConstructorButDataFieldsDiffer

elif not (List.forall2 (checkField aenv) implUnionCase.RecdFields sigUnionCase.RecdFields) then err FSComp.SR.ModuleContainsConstructorButTypesOfFieldsDiffer

elif isLessAccessible implUnionCase.Accessibility sigUnionCase.Accessibility then err FSComp.SR.ModuleContainsConstructorButAccessibilityDiffers

else checkAttribs aenv implUnionCase.Attribs sigUnionCase.Attribs (fun attribs -> implUnionCase.Attribs <- attribs)

and checkField aenv implField sigField =

let err f = errorR(FieldNotContained(denv,implField,sigField,f)); false

if implField.rfield_id.idText <> sigField.rfield_id.idText then err FSComp.SR.FieldNotContainedNamesDiffer

elif isLessAccessible implField.Accessibility sigField.Accessibility then err FSComp.SR.FieldNotContainedAccessibilitiesDiffer

elif implField.IsStatic <> sigField.IsStatic then err FSComp.SR.FieldNotContainedStaticsDiffer

elif implField.IsMutable <> sigField.IsMutable then err FSComp.SR.FieldNotContainedMutablesDiffer

elif implField.LiteralValue <> sigField.LiteralValue then err FSComp.SR.FieldNotContainedLiteralsDiffer

elif not (typeAEquiv g aenv implField.FormalType sigField.FormalType) then err FSComp.SR.FieldNotContainedTypesDiffer

else

checkAttribs aenv implField.FieldAttribs sigField.FieldAttribs (fun attribs -> implField.rfield_fattribs <- attribs) &&

checkAttribs aenv implField.PropertyAttribs sigField.PropertyAttribs (fun attribs -> implField.rfield_pattribs <- attribs)

and checkMemberDatasConform err (_implAttrs,implVal,implMemberInfo) (_sigAttrs, sigVal,sigMemberInfo) =

match implMemberInfo,sigMemberInfo with

| None,None -> true

| Some implMembInfo, Some sigMembInfo ->

if not (implVal.CompiledName = sigVal.CompiledName) then

err(FSComp.SR.ValueNotContainedMutabilityDotNetNamesDiffer)

elif not (implMembInfo.MemberFlags.IsInstance = sigMembInfo.MemberFlags.IsInstance) then

err(FSComp.SR.ValueNotContainedMutabilityStaticsDiffer)

elif false then

err(FSComp.SR.ValueNotContainedMutabilityVirtualsDiffer)

elif not (implMembInfo.MemberFlags.IsDispatchSlot = sigMembInfo.MemberFlags.IsDispatchSlot) then

err(FSComp.SR.ValueNotContainedMutabilityAbstractsDiffer)

// The final check is an implication:

// classes have non-final CompareTo/Hash methods

// abstract have non-final CompareTo/Hash methods

// records have final CompareTo/Hash methods

// unions have final CompareTo/Hash methods

// This is an example where it is OK for the signature to say 'non-final' when the implementation says 'final'

elif not implMembInfo.MemberFlags.IsFinal && sigMembInfo.MemberFlags.IsFinal then

err(FSComp.SR.ValueNotContainedMutabilityFinalsDiffer)

elif not (implMembInfo.MemberFlags.IsOverrideOrExplicitImpl = sigMembInfo.MemberFlags.IsOverrideOrExplicitImpl) then

err(FSComp.SR.ValueNotContainedMutabilityOverridesDiffer)

elif not (implMembInfo.MemberFlags.MemberKind = sigMembInfo.MemberFlags.MemberKind) then

err(FSComp.SR.ValueNotContainedMutabilityOneIsConstructor)

else

let finstance = ValSpecIsCompiledAsInstance g sigVal

let ainstance = ValSpecIsCompiledAsInstance g implVal

if finstance && not ainstance then

err(FSComp.SR.ValueNotContainedMutabilityStaticButInstance)

elif not finstance && ainstance then

err(FSComp.SR.ValueNotContainedMutabilityInstanceButStatic)

else true

| _ -> false

// -------------------------------------------------------------------------------

// WARNING!!!!

// checkRecordFields and checkRecordFieldsForExn are the EXACT SAME FUNCTION.

// The only difference is the signature for err - this is because err is a function

// that reports errors, and checkRecordFields is called with a different

// sig for err then checkRecordFieldsForExn.

// -------------------------------------------------------------------------------

and checkRecordFields _g _amap _denv err aenv (implFields:TyconRecdFields) (sigFields:TyconRecdFields) =

let implFields = implFields.TrueFieldsAsList

let sigFields = sigFields.TrueFieldsAsList

let m1 = implFields |> NameMap.ofKeyedList (fun rfld -> rfld.Name)

let m2 = sigFields |> NameMap.ofKeyedList (fun rfld -> rfld.Name)

NameMap.suball2 (fun s _ -> errorR(err (fun x -> FSComp.SR.DefinitionsInSigAndImplNotCompatibleFieldRequiredButNotSpecified(x, s))); false) (checkField aenv) m1 m2 &&

NameMap.suball2 (fun s _ -> errorR(err (fun x -> FSComp.SR.DefinitionsInSigAndImplNotCompatibleFieldWasPresent(x, s))); false) (fun x y -> checkField aenv y x) m2 m1 &&

// This check is required because constructors etc. are externally visible

// and thus compiled representations do pick up dependencies on the field order

(if List.forall2 (checkField aenv) implFields sigFields

then true

else (errorR(err (FSComp.SR.DefinitionsInSigAndImplNotCompatibleFieldOrderDiffer)); false))

and checkRecordFieldsForExn _g _denv err aenv (implFields:TyconRecdFields) (sigFields:TyconRecdFields) =

let implFields = implFields.TrueFieldsAsList

let sigFields = sigFields.TrueFieldsAsList

let m1 = implFields |> NameMap.ofKeyedList (fun rfld -> rfld.Name)

let m2 = sigFields |> NameMap.ofKeyedList (fun rfld -> rfld.Name)

NameMap.suball2 (fun s _ -> errorR(err (fun (x, y) -> FSComp.SR.ExceptionDefsNotCompatibleFieldInSigButNotImpl(s, x, y))); false) (checkField aenv) m1 m2 &&

NameMap.suball2 (fun s _ -> errorR(err (fun (x, y) -> FSComp.SR.ExceptionDefsNotCompatibleFieldInImplButNotSig(s, x, y))); false) (fun x y -> checkField aenv y x) m2 m1 &&

// This check is required because constructors etc. are externally visible

// and thus compiled representations do pick up dependencies on the field order

(if List.forall2 (checkField aenv) implFields sigFields

then true

else (errorR(err (FSComp.SR.ExceptionDefsNotCompatibleFieldOrderDiffers)); false))

and checkVirtualSlots _g denv err _aenv implAbstractSlots sigAbstractSlots =

let m1 = NameMap.ofKeyedList (fun (v:ValRef) -> v.DisplayName) implAbstractSlots

let m2 = NameMap.ofKeyedList (fun (v:ValRef) -> v.DisplayName) sigAbstractSlots

(m1,m2) ||> NameMap.suball2 (fun _s vref -> errorR(err (fun x -> FSComp.SR.DefinitionsInSigAndImplNotCompatibleAbstractMemberMissingInImpl(x, NicePrint.stringValOrMember denv vref.Deref))); false) (fun _x _y -> true) &&

(m2,m1) ||> NameMap.suball2 (fun _s vref -> errorR(err (fun x -> FSComp.SR.DefinitionsInSigAndImplNotCompatibleAbstractMemberMissingInSig(x, NicePrint.stringValOrMember denv vref.Deref))); false) (fun _x _y -> true)

and checkClassFields isStruct _g _amap _denv err aenv (implFields:TyconRecdFields) (sigFields:TyconRecdFields) =

let implFields = implFields.TrueFieldsAsList

let sigFields = sigFields.TrueFieldsAsList

let m1 = implFields |> NameMap.ofKeyedList (fun rfld -> rfld.Name)

let m2 = sigFields |> NameMap.ofKeyedList (fun rfld -> rfld.Name)

NameMap.suball2 (fun s _ -> errorR(err (fun x -> FSComp.SR.DefinitionsInSigAndImplNotCompatibleFieldRequiredButNotSpecified(x, s))); false) (checkField aenv) m1 m2 &&

(if isStruct then

NameMap.suball2 (fun s _ -> warning(err (fun x -> FSComp.SR.DefinitionsInSigAndImplNotCompatibleFieldIsInImplButNotSig(x, s))); true) (fun x y -> checkField aenv y x) m2 m1

else

true)

and checkTypeRepr err aenv implTypeRepr sigTypeRepr =

let reportNiceError k s1 s2 =

let aset = NameSet.ofList s1

let fset = NameSet.ofList s2

match Zset.elements (Zset.diff aset fset) with

| [] ->

match Zset.elements (Zset.diff fset aset) with

| [] -> (errorR (err (fun x -> FSComp.SR.DefinitionsInSigAndImplNotCompatibleNumbersDiffer(x, k))); false)

| l -> (errorR (err (fun x -> FSComp.SR.DefinitionsInSigAndImplNotCompatibleSignatureDefinesButImplDoesNot(x, k, String.concat ";" l))); false)

| l -> (errorR (err (fun x -> FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplDefinesButSignatureDoesNot(x, k, String.concat ";" l))); false)

match implTypeRepr,sigTypeRepr with

| (TRecdRepr _

| TFiniteUnionRepr _

| TILObjModelRepr _

#if EXTENSIONTYPING

| TProvidedTypeExtensionPoint _

| TProvidedNamespaceExtensionPoint _

), TNoRepr -> true

| (TFsObjModelRepr r), TNoRepr ->

match r.fsobjmodel_kind with

| TTyconStruct | TTyconEnum ->

(errorR (err FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplDefinesStruct); false)

| _ ->

true

| (TAsmRepr _), TNoRepr ->

(errorR (err FSComp.SR.DefinitionsInSigAndImplNotCompatibleDotNetTypeRepresentationIsHidden); false)

| (TMeasureableRepr _), TNoRepr ->

(errorR (err FSComp.SR.DefinitionsInSigAndImplNotCompatibleTypeIsHidden); false)

| (TFiniteUnionRepr r1), (TFiniteUnionRepr r2) ->

let ucases1 = r1.UnionCasesAsList

let ucases2 = r2.UnionCasesAsList

if ucases1.Length <> ucases2.Length then

let names (l: UnionCase list) = l |> List.map (fun c -> c.Id.idText)

reportNiceError "union case" (names ucases1) (names ucases2)

else List.forall2 (checkUnionCase aenv) ucases1 ucases2

| (TRecdRepr implFields), (TRecdRepr sigFields) ->

checkRecordFields g amap denv err aenv implFields sigFields

| (TFsObjModelRepr r1), (TFsObjModelRepr r2) ->

if not (match r1.fsobjmodel_kind,r2.fsobjmodel_kind with

| TTyconClass,TTyconClass -> true

| TTyconInterface,TTyconInterface -> true

| TTyconStruct,TTyconStruct -> true

| TTyconEnum, TTyconEnum -> true

| TTyconDelegate (TSlotSig(_,typ1,ctps1,mtps1,ps1, rty1)),

TTyconDelegate (TSlotSig(_,typ2,ctps2,mtps2,ps2, rty2)) ->

(typeAEquiv g aenv typ1 typ2) &&

(ctps1.Length = ctps2.Length) &&

(let aenv = aenv.BindEquivTypars ctps1 ctps2

(typarsAEquiv g aenv ctps1 ctps2) &&

(mtps1.Length = mtps2.Length) &&

(let aenv = aenv.BindEquivTypars mtps1 mtps2

(typarsAEquiv g aenv mtps1 mtps2) &&

((ps1,ps2) ||> List.lengthsEqAndForall2 (List.lengthsEqAndForall2 (fun p1 p2 -> typeAEquiv g aenv p1.Type p2.Type))) &&

(returnTypesAEquiv g aenv rty1 rty2)))

| _,_ -> false) then

(errorR (err FSComp.SR.DefinitionsInSigAndImplNotCompatibleTypeIsDifferentKind); false)

else

let isStruct = (match r1.fsobjmodel_kind with TTyconStruct -> true | _ -> false)

checkClassFields isStruct g amap denv err aenv r1.fsobjmodel_rfields r2.fsobjmodel_rfields &&

checkVirtualSlots g denv err aenv r1.fsobjmodel_vslots r2.fsobjmodel_vslots

| (TAsmRepr tcr1), (TAsmRepr tcr2) ->

if tcr1 <> tcr2 then (errorR (err FSComp.SR.DefinitionsInSigAndImplNotCompatibleILDiffer); false) else true

| (TMeasureableRepr ty1), (TMeasureableRepr ty2) ->

if typeAEquiv g aenv ty1 ty2 then true else (errorR (err FSComp.SR.DefinitionsInSigAndImplNotCompatibleRepresentationsDiffer); false)

| TNoRepr, TNoRepr -> true

#if EXTENSIONTYPING

| TProvidedTypeExtensionPoint info1 , TProvidedTypeExtensionPoint info2 ->

Tainted.EqTainted info1.ProvidedType.TypeProvider info2.ProvidedType.TypeProvider && ProvidedType.TaintedEquals(info1.ProvidedType,info2.ProvidedType)

| TProvidedNamespaceExtensionPoint _, TProvidedNamespaceExtensionPoint _ ->

System.Diagnostics.Debug.Assert(false, "unreachable: TProvidedNamespaceExtensionPoint only on namespaces, not types" )

true

| TNoRepr, _ -> (errorR (err FSComp.SR.DefinitionsInSigAndImplNotCompatibleRepresentationsDiffer); false)

| _, _ -> (errorR (err FSComp.SR.DefinitionsInSigAndImplNotCompatibleRepresentationsDiffer); false)

and checkTypeAbbrev err aenv kind1 kind2 implTypeAbbrev sigTypeAbbrev =

if kind1 <> kind2 then (errorR (err (fun x -> FSComp.SR.DefinitionsInSigAndImplNotCompatibleSignatureDeclaresDiffer(x, kind2.ToString(), kind1.ToString()))); false)

else

match implTypeAbbrev,sigTypeAbbrev with

| Some ty1, Some ty2 ->

if not (typeAEquiv g aenv ty1 ty2) then

let s1, s2, _ = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2

errorR (err (fun x -> FSComp.SR.DefinitionsInSigAndImplNotCompatibleAbbreviationsDiffer(x, s1, s2)))

false

else

true

| None,None -> true

| Some _, None -> (errorR (err (FSComp.SR.DefinitionsInSigAndImplNotCompatibleAbbreviationHiddenBySig)); false)

| None, Some _ -> (errorR (err FSComp.SR.DefinitionsInSigAndImplNotCompatibleSigHasAbbreviation); false)

and checkModuleOrNamespaceContents m aenv (implModRef:ModuleOrNamespaceRef) (signModType:ModuleOrNamespaceType) =

let implModType = implModRef.ModuleOrNamespaceType

(if implModType.ModuleOrNamespaceKind <> signModType.ModuleOrNamespaceKind then errorR(Error(FSComp.SR.typrelModuleNamespaceAttributesDifferInSigAndImpl(),m)))

(implModType.TypesByMangledName , signModType.TypesByMangledName)

||> NameMap.suball2

(fun s _fx -> errorR(RequiredButNotSpecified(denv,implModRef,"type",(fun os -> Printf.bprintf os "%s" s),m)); false)

(checkTypeDef aenv) &&

(implModType.ModulesAndNamespacesByDemangledName, signModType.ModulesAndNamespacesByDemangledName )

||> NameMap.suball2

(fun s fx -> errorR(RequiredButNotSpecified(denv,implModRef,(if fx.IsModule then "module" else "namespace"),(fun os -> Printf.bprintf os "%s" s),m)); false)

(fun x1 x2 -> checkModuleOrNamespace aenv (mkLocalModRef x1) x2) &&

let sigValHadNoMatchingImplementation (fx:Val) (_closeActualVal: Val option) =

errorR(RequiredButNotSpecified(denv,implModRef,"value",(fun os ->

(* In the case of missing members show the full required enclosing type and signature *)

if fx.IsMember then

NicePrint.outputQualifiedValOrMember denv os fx

else

Printf.bprintf os "%s" fx.DisplayName),m))

let valuesPartiallyMatch (av:Val) (fv:Val) =

(av.LinkagePartialKey.MemberParentMangledName = fv.LinkagePartialKey.MemberParentMangledName) &&

(av.LinkagePartialKey.LogicalName = fv.LinkagePartialKey.LogicalName) &&

(av.LinkagePartialKey.TotalArgCount = fv.LinkagePartialKey.TotalArgCount)

(implModType.AllValsAndMembersByLogicalNameUncached, signModType.AllValsAndMembersByLogicalNameUncached)

||> NameMap.suball2

(fun _s (fxs:Val list) -> sigValHadNoMatchingImplementation fxs.Head None; false)

(fun avs fvs ->

match avs,fvs with

| [],_ | _,[] -> failwith "unreachable"

| [av],[fv] ->

if valuesPartiallyMatch av fv then

checkVal implModRef aenv av fv

else

sigValHadNoMatchingImplementation fv None

false

| _ ->

// for each formal requirement, try to find a precisely matching actual requirement

let matchingPairs =

fvs |> List.choose (fun fv ->

match avs |> List.tryFind (fun av ->

let res = valLinkageAEquiv g aenv av fv

//if res then printfn "%s" (bufs (fun buf -> Printf.bprintf buf "YES MATCH: fv '%a', av '%a'" (NicePrint.outputQualifiedValOrMember denv) fv (NicePrint.outputQualifiedValOrMember denv) av))

//else printfn "%s" (bufs (fun buf -> Printf.bprintf buf "NO MATCH: fv '%a', av '%a'" (NicePrint.outputQualifiedValOrMember denv) fv (NicePrint.outputQualifiedValOrMember denv) av))

res) with

| None -> None

| Some av -> Some(fv,av))

// Check the ones with matching linkage

let allPairsOk = matchingPairs |> List.map (fun (fv,av) -> checkVal implModRef aenv av fv) |> List.forall id

let someNotOk = matchingPairs.Length < fvs.Length

// Report an error for those that don't. Try pairing up by enclosing-type/name

if someNotOk then

let noMatches,partialMatchingPairs =

fvs |> List.splitChoose (fun fv ->

match avs |> List.tryFind (fun av -> valuesPartiallyMatch av fv) with

| None -> Choice1Of2 fv

| Some av -> Choice2Of2(fv,av))

for (fv,av) in partialMatchingPairs do

checkVal implModRef aenv av fv |> ignore

for fv in noMatches do

sigValHadNoMatchingImplementation fv None

allPairsOk && not someNotOk)

and checkModuleOrNamespace aenv implModRef sigModRef =

checkModuleOrNamespaceContents implModRef.Range aenv implModRef sigModRef.ModuleOrNamespaceType &&

checkAttribs aenv implModRef.Attribs sigModRef.Attribs implModRef.Deref.SetAttribs

member __.CheckSignature aenv (implModRef:ModuleOrNamespaceRef) (signModType:ModuleOrNamespaceType) =

checkModuleOrNamespaceContents implModRef.Range aenv implModRef signModType

member __.CheckTypars m aenv (implTypars: Typars) (signTypars: Typars) =

checkTypars m aenv implTypars signTypars

/// Check the names add up between a signature and its implementation. We check this first.

let rec CheckNamesOfModuleOrNamespaceContents denv (implModRef:ModuleOrNamespaceRef) (signModType:ModuleOrNamespaceType) =

let m = implModRef.Range

let implModType = implModRef.ModuleOrNamespaceType

NameMap.suball2

(fun s _fx -> errorR(RequiredButNotSpecified(denv,implModRef,"type",(fun os -> Printf.bprintf os "%s" s),m)); false)

(fun _ _ -> true)

implModType.TypesByMangledName

signModType.TypesByMangledName &&

(implModType.ModulesAndNamespacesByDemangledName, signModType.ModulesAndNamespacesByDemangledName )

||> NameMap.suball2

(fun s fx -> errorR(RequiredButNotSpecified(denv,implModRef,(if fx.IsModule then "module" else "namespace"),(fun os -> Printf.bprintf os "%s" s),m)); false)

(fun x1 (x2:ModuleOrNamespace) -> CheckNamesOfModuleOrNamespace denv (mkLocalModRef x1) x2.ModuleOrNamespaceType) &&

(implModType.AllValsAndMembersByLogicalNameUncached , signModType.AllValsAndMembersByLogicalNameUncached)

||> NameMap.suball2

(fun _s (fxs:Val list) ->

let fx = fxs.Head

errorR(RequiredButNotSpecified(denv,implModRef,"value",(fun os ->

// In the case of missing members show the full required enclosing type and signature

if isSome fx.MemberInfo then

NicePrint.outputQualifiedValOrMember denv os fx

else

Printf.bprintf os "%s" fx.DisplayName),m)); false)

(fun _ _ -> true)

and CheckNamesOfModuleOrNamespace denv (implModRef:ModuleOrNamespaceRef) signModType =

CheckNamesOfModuleOrNamespaceContents denv implModRef signModType

type OverrideCanImplement =

| CanImplementAnyInterfaceSlot

| CanImplementAnyClassHierarchySlot

| CanImplementAnySlot

| CanImplementNoSlots

type OverrideInfo =

| Override of OverrideCanImplement * TyconRef * Ident * (Typars * TyparInst) * TType list list * TType option * bool

member x.CanImplement = let (Override(a,_,_,_,_,_,_)) = x in a

member x.BoundingTyconRef = let (Override(_,ty,_,_,_,_,_)) = x in ty

member x.LogicalName = let (Override(_,_,id,_,_,_,_)) = x in id.idText

member x.Range = let (Override(_,_,id,_,_,_,_)) = x in id.idRange

member x.IsFakeEventProperty = let (Override(_,_,_,_,_,_,b)) = x in b

member x.ArgTypes = let (Override(_,_,_,_,b,_,_)) = x in b

member x.ReturnType = let (Override(_,_,_,_,_,b,_)) = x in b

type RequiredSlot = RequiredSlot of MethInfo * (* isOptional: *) bool

type SlotImplSet = SlotImplSet of RequiredSlot list * NameMultiMap<RequiredSlot> * OverrideInfo list * PropInfo list

exception TypeIsImplicitlyAbstract of range