From 5c21e2f7f40c33ee21490ee31d11c5567f7117cc Mon Sep 17 00:00:00 2001 From: Edgar Gonzalez Date: Sun, 29 Dec 2024 19:33:44 +0000 Subject: [PATCH 01/20] Show obsolete warnings/errors when used with unit of measure --- src/Compiler/Checking/CheckDeclarations.fs | 6 +- src/Compiler/Checking/ConstraintSolver.fs | 47 ++-- .../Checking/Expressions/CheckExpressions.fs | 42 ++-- src/Compiler/Checking/NameResolution.fs | 2 +- src/Compiler/Checking/PostInferenceChecks.fs | 46 +++- src/Compiler/Checking/TypeRelations.fs | 6 +- src/Compiler/Checking/import.fs | 15 +- src/Compiler/Service/ItemKey.fs | 4 +- src/Compiler/Symbols/Exprs.fs | 3 +- src/Compiler/Symbols/Symbols.fs | 16 +- src/Compiler/TypedTree/TypedTree.fs | 21 +- src/Compiler/TypedTree/TypedTree.fsi | 12 +- src/Compiler/TypedTree/TypedTreeBasics.fs | 6 +- src/Compiler/TypedTree/TypedTreeOps.fs | 97 +++++---- src/Compiler/TypedTree/TypedTreePickle.fs | 24 +- .../ObsoleteAttributeCheckingTests.fs | 206 +++++++++++++++++- 16 files changed, 416 insertions(+), 137 deletions(-) diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index bec5c9d9966..329792653e0 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/src/Compiler/Checking/CheckDeclarations.fs @@ -3807,11 +3807,11 @@ module EstablishTypeDefinitionCores = and accInMeasure measureTy acc = match stripUnitEqns measureTy with - | Measure.Const tcref when ListSet.contains (===) tcref.Deref tycons -> + | Measure.Const(tyconRef= tcref) when ListSet.contains (===) tcref.Deref tycons -> (tycon, tcref.Deref) :: acc - | Measure.Const tcref when tcref.IsTypeAbbrev -> + | Measure.Const(tyconRef= tcref) when tcref.IsTypeAbbrev -> accInMeasure (reduceTyconRefAbbrevMeasureable tcref) acc - | Measure.Prod (ms1, ms2) -> accInMeasure ms1 (accInMeasure ms2 acc) + | Measure.Prod(measure1= ms1; measure2= ms2) -> accInMeasure ms1 (accInMeasure ms2 acc) | Measure.Inv invTy -> accInMeasure invTy acc | _ -> acc diff --git a/src/Compiler/Checking/ConstraintSolver.fs b/src/Compiler/Checking/ConstraintSolver.fs index 8be7ec551ea..28971354112 100644 --- a/src/Compiler/Checking/ConstraintSolver.fs +++ b/src/Compiler/Checking/ConstraintSolver.fs @@ -42,6 +42,7 @@ module internal FSharp.Compiler.ConstraintSolver +open FSharp.Compiler.Text.Range open Internal.Utilities.Collections open Internal.Utilities.Library open Internal.Utilities.Library.Extras @@ -729,12 +730,12 @@ let SubstMeasureWarnIfRigid (csenv: ConstraintSolverEnv) trace (v: Typar) ms = let tpnmOpt = if v.IsCompilerGenerated then None else Some v.Name do! SolveTypStaticReq csenv trace v.StaticReq (TType_measure ms) SubstMeasure v ms - return! WarnD(NonRigidTypar(csenv.DisplayEnv, tpnmOpt, v.Range, TType_measure (Measure.Var v), TType_measure ms, csenv.m)) + return! WarnD(NonRigidTypar(csenv.DisplayEnv, tpnmOpt, v.Range, TType_measure (Measure.Var(v, v.Range)), TType_measure ms, csenv.m)) else // Propagate static requirements from 'tp' to 'ty' do! SolveTypStaticReq csenv trace v.StaticReq (TType_measure ms) SubstMeasure v ms - if v.Rigidity = TyparRigidity.Anon && measureEquiv csenv.g ms Measure.One then + if v.Rigidity = TyparRigidity.Anon && measureEquiv csenv.g ms (Measure.One(ms.Range)) then return! WarnD(Error(FSComp.SR.csCodeLessGeneric(), v.Range)) else () @@ -760,17 +761,17 @@ let UnifyMeasureWithOne (csenv: ConstraintSolverEnv) trace ms = match FindPreferredTypar nonRigidVars with | (v, e) :: vs -> let unexpandedCons = ListMeasureConOccsWithNonZeroExponents csenv.g false ms - let newms = ProdMeasures (List.map (fun (c, e') -> Measure.RationalPower (Measure.Const c, NegRational (DivRational e' e))) unexpandedCons - @ List.map (fun (v, e') -> Measure.RationalPower (Measure.Var v, NegRational (DivRational e' e))) (vs @ rigidVars)) + let newms = ProdMeasures (List.map (fun (c, e') -> Measure.RationalPower(Measure.Const(c, c.Range), NegRational (DivRational e' e), ms.Range)) unexpandedCons + @ List.map (fun (v, e') -> Measure.RationalPower (Measure.Var(v, v.Range), NegRational (DivRational e' e), ms.Range)) (vs @ rigidVars)) SubstMeasureWarnIfRigid csenv trace v newms // Otherwise we require ms to be 1 - | [] -> if measureEquiv csenv.g ms Measure.One then CompleteD else localAbortD + | [] -> if measureEquiv csenv.g ms (Measure.One(ms.Range)) then CompleteD else localAbortD /// Imperatively unify unit-of-measure expression ms1 against ms2 let UnifyMeasures (csenv: ConstraintSolverEnv) trace ms1 ms2 = - UnifyMeasureWithOne csenv trace (Measure.Prod(ms1, Measure.Inv ms2)) + UnifyMeasureWithOne csenv trace (Measure.Prod(ms1, Measure.Inv ms2, (unionRanges ms1.Range ms2.Range))) /// Simplify a unit-of-measure expression ms that forms part of a type scheme. /// We make substitutions for vars, which are the (remaining) bound variables @@ -785,18 +786,18 @@ let SimplifyMeasure g vars ms = let newvar = if v.IsCompilerGenerated then NewAnonTypar (TyparKind.Measure, v.Range, TyparRigidity.Flexible, v.StaticReq, v.DynamicReq) else NewNamedInferenceMeasureVar (v.Range, TyparRigidity.Flexible, v.StaticReq, v.Id) let remainingvars = ListSet.remove typarEq v vars - let newvarExpr = if SignRational e < 0 then Measure.Inv (Measure.Var newvar) else Measure.Var newvar + let newvarExpr = if SignRational e < 0 then Measure.Inv (Measure.Var(newvar, newvar.Range)) else Measure.Var(newvar, newvar.Range) let nonZeroCon = ListMeasureConOccsWithNonZeroExponents g false ms let nonZeroVar = ListMeasureVarOccsWithNonZeroExponents ms let newms = ProdMeasures [ for (c, e') in nonZeroCon do - Measure.RationalPower (Measure.Const c, NegRational (DivRational e' e)) + Measure.RationalPower (Measure.Const(c, c.Range), NegRational (DivRational e' e), ms.Range) for (v', e') in nonZeroVar do if typarEq v v' then newvarExpr else - Measure.RationalPower (Measure.Var v', NegRational (DivRational e' e)) + Measure.RationalPower (Measure.Var(v', v'.Range), NegRational (DivRational e' e), ms.Range) ] SubstMeasure v newms match vs with @@ -880,7 +881,7 @@ let NormalizeExponentsInTypeScheme uvars ty = v else let v' = NewAnonTypar (TyparKind.Measure, v.Range, TyparRigidity.Flexible, v.StaticReq, v.DynamicReq) - SubstMeasure v (Measure.RationalPower (Measure.Var v', DivRational OneRational expGcd)) + SubstMeasure v (Measure.RationalPower (Measure.Var(v', v'.Range), DivRational OneRational expGcd, v.Range)) v') // We normalize unit-of-measure-polymorphic type schemes. There @@ -922,7 +923,7 @@ let SimplifyMeasuresInTypeScheme g resultFirst (generalizable: Typar list) ty co let generalized' = NormalizeExponentsInTypeScheme generalized ty vars @ List.rev generalized' -let freshMeasure () = Measure.Var (NewInferenceMeasurePar ()) +let freshMeasure () = Measure.Var((NewInferenceMeasurePar ()), range0) let CheckWarnIfRigid (csenv: ConstraintSolverEnv) ty1 (r: Typar) ty = let g = csenv.g @@ -1112,7 +1113,7 @@ and SolveTyparEqualsType (csenv: ConstraintSolverEnv) ndeep m2 (trace: OptionalT do! DepthCheck ndeep m match ty1 with | TType_var (r, _) - | TType_measure (Measure.Var r) -> + | TType_measure (Measure.Var(r, _)) -> do! SolveTyparEqualsTypePart1 csenv m2 trace ty1 r ty do! SolveTyparEqualsTypePart2 csenv ndeep m2 trace r ty | _ -> failwith "SolveTyparEqualsType" @@ -1125,7 +1126,7 @@ and SolveTyparsEqualTypes (csenv: ConstraintSolverEnv) ndeep m2 (trace: Optional fun tpTy ty -> match tpTy with | TType_var (r, _) - | TType_measure (Measure.Var r) -> + | TType_measure (Measure.Var(r, _)) -> SolveTyparEqualsTypePart1 csenv m2 trace tpTy r ty | _ -> failwith "SolveTyparsEqualTypes") tpTys tys @@ -1133,7 +1134,7 @@ and SolveTyparsEqualTypes (csenv: ConstraintSolverEnv) ndeep m2 (trace: Optional fun tpTy ty -> match tpTy with | TType_var (r, _) - | TType_measure (Measure.Var r) -> + | TType_measure (Measure.Var(r, _)) -> SolveTyparEqualsTypePart2 csenv ndeep m2 trace r ty | _ -> failwith "SolveTyparsEqualTypes") tpTys tys @@ -1329,13 +1330,13 @@ and SolveTypeEqualsType (csenv: ConstraintSolverEnv) ndeep m2 (trace: OptionalTr // Catch float<_>=float<1>, float32<_>=float32<1> and decimal<_>=decimal<1> | (_, TType_app (tc2, [ms2], _)) when (tc2.IsMeasureableReprTycon && typeEquiv csenv.g sty1 (reduceTyconRefMeasureableOrProvided csenv.g tc2 [ms2])) -> trackErrors { - do! SolveTypeEqualsType csenv ndeep m2 trace None (TType_measure Measure.One) ms2 + do! SolveTypeEqualsType csenv ndeep m2 trace None (TType_measure(Measure.One(m2))) ms2 do! SolveNullnessEquiv csenv m2 trace ty1 ty2 (nullnessOfTy g sty1) (nullnessOfTy g sty2) } | (TType_app (tc1, [ms1], _), _) when (tc1.IsMeasureableReprTycon && typeEquiv csenv.g sty2 (reduceTyconRefMeasureableOrProvided csenv.g tc1 [ms1])) -> trackErrors { - do! SolveTypeEqualsType csenv ndeep m2 trace None ms1 (TType_measure Measure.One) + do! SolveTypeEqualsType csenv ndeep m2 trace None ms1 (TType_measure(Measure.One(m2))) do! SolveNullnessEquiv csenv m2 trace ty1 ty2 (nullnessOfTy g sty1) (nullnessOfTy g sty2) } @@ -1518,13 +1519,13 @@ and SolveTypeSubsumesType (csenv: ConstraintSolverEnv) ndeep m2 (trace: Optional // Enforce the identities float=float<1>, float32=float32<1> and decimal=decimal<1> | _, TType_app (tc2, [ms2], _) when tc2.IsMeasureableReprTycon && typeEquiv csenv.g sty1 (reduceTyconRefMeasureableOrProvided csenv.g tc2 [ms2]) -> trackErrors { - do! SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 trace cxsln ms2 (TType_measure Measure.One) + do! SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 trace cxsln ms2 (TType_measure(Measure.One(m2))) do! SolveNullnessSubsumesNullness csenv m2 trace ty1 ty2 (nullnessOfTy g sty1) (nullnessOfTy g sty2) } | TType_app (tc1, [ms1], _), _ when tc1.IsMeasureableReprTycon && typeEquiv csenv.g sty2 (reduceTyconRefMeasureableOrProvided csenv.g tc1 [ms1]) -> trackErrors { - do! SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 trace cxsln ms1 (TType_measure Measure.One) + do! SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 trace cxsln ms1 (TType_measure(Measure.One(m2))) do! SolveNullnessSubsumesNullness csenv m2 trace ty1 ty2 (nullnessOfTy g sty1) (nullnessOfTy g sty2) } @@ -1620,7 +1621,7 @@ and DepthCheck ndeep m = and SolveDimensionlessNumericType (csenv: ConstraintSolverEnv) ndeep m2 trace ty = match getMeasureOfType csenv.g ty with | Some (tcref, _) -> - SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace ty (mkWoNullAppTy tcref [TType_measure Measure.One]) + SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace ty (mkWoNullAppTy tcref [TType_measure(Measure.One(m2))]) | None -> CompleteD @@ -1727,7 +1728,7 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload | Some (tcref, ms1) -> let ms2 = freshMeasure () do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argTy2 (mkWoNullAppTy tcref [TType_measure ms2]) - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace retTy (mkWoNullAppTy tcref [TType_measure (Measure.Prod(ms1, if nm = "op_Multiply" then ms2 else Measure.Inv ms2))]) + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace retTy (mkWoNullAppTy tcref [TType_measure (Measure.Prod(ms1, (if nm = "op_Multiply" then ms2 else Measure.Inv ms2), unionRanges ms1.Range ms2.Range))]) return TTraitBuiltIn | _ -> @@ -1736,7 +1737,7 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload | Some (tcref, ms2) -> let ms1 = freshMeasure () do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argTy1 (mkWoNullAppTy tcref [TType_measure ms1]) - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace retTy (mkWoNullAppTy tcref [TType_measure (Measure.Prod(ms1, if nm = "op_Multiply" then ms2 else Measure.Inv ms2))]) + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace retTy (mkWoNullAppTy tcref [TType_measure (Measure.Prod(ms1, (if nm = "op_Multiply" then ms2 else Measure.Inv ms2), unionRanges ms1.Range ms2.Range))]) return TTraitBuiltIn | _ -> @@ -1870,7 +1871,7 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload match getMeasureOfType g argTy1 with | Some (tcref, _) -> let ms1 = freshMeasure () - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argTy1 (mkWoNullAppTy tcref [TType_measure (Measure.Prod (ms1, ms1))]) + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argTy1 (mkWoNullAppTy tcref [TType_measure (Measure.Prod (ms1, ms1, ms1.Range))]) do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace retTy (mkWoNullAppTy tcref [TType_measure ms1]) return TTraitBuiltIn | None -> @@ -1923,7 +1924,7 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argTy2 argTy1 match getMeasureOfType g argTy1 with | None -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace retTy argTy1 - | Some (tcref, _) -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace retTy (mkWoNullAppTy tcref [TType_measure Measure.One]) + | Some (tcref, _) -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace retTy (mkWoNullAppTy tcref [TType_measure(Measure.One(tcref.Range))]) return TTraitBuiltIn | _ -> diff --git a/src/Compiler/Checking/Expressions/CheckExpressions.fs b/src/Compiler/Checking/Expressions/CheckExpressions.fs index 16dc49c1a61..7ba49ff7696 100644 --- a/src/Compiler/Checking/Expressions/CheckExpressions.fs +++ b/src/Compiler/Checking/Expressions/CheckExpressions.fs @@ -798,23 +798,23 @@ let TcConst (cenv: cenv) (overallTy: TType) m env synConst = let g = cenv.g let rec tcMeasure ms = match ms with - | SynMeasure.One _ -> Measure.One + | SynMeasure.One(range = m) -> Measure.One(m) | SynMeasure.Named(tc, m) -> let ad = env.eAccessRights let _, tcref, _ = ForceRaise(ResolveTypeLongIdent cenv.tcSink cenv.nameResolver ItemOccurrence.Use OpenQualified env.eNameResEnv ad tc TypeNameResolutionStaticArgsInfo.DefiniteEmpty PermitDirectReferenceToGeneratedType.No) match tcref.TypeOrMeasureKind with | TyparKind.Type -> error(Error(FSComp.SR.tcExpectedUnitOfMeasureNotType(), m)) - | TyparKind.Measure -> Measure.Const tcref + | TyparKind.Measure -> Measure.Const(tcref, m) - | SynMeasure.Power(measure = ms; power = exponent) -> Measure.RationalPower (tcMeasure ms, TcSynRationalConst exponent) - | SynMeasure.Product(measure1 = ms1; measure2 = ms2) -> Measure.Prod(tcMeasure ms1, tcMeasure ms2) + | SynMeasure.Power(measure = ms; power = exponent; range= m) -> Measure.RationalPower (tcMeasure ms, TcSynRationalConst exponent, m) + | SynMeasure.Product(measure1 = ms1; measure2 = ms2; range= m) -> Measure.Prod(tcMeasure ms1, tcMeasure ms2, m) | SynMeasure.Divide(ms1, _, (SynMeasure.Seq (_ :: _ :: _, _) as ms2), m) -> warning(Error(FSComp.SR.tcImplicitMeasureFollowingSlash(), m)) let factor1 = ms1 |> Option.defaultValue (SynMeasure.One Range.Zero) - Measure.Prod(tcMeasure factor1, Measure.Inv (tcMeasure ms2)) - | SynMeasure.Divide(measure1 = ms1; measure2 = ms2) -> + Measure.Prod(tcMeasure factor1, Measure.Inv (tcMeasure ms2), m) + | SynMeasure.Divide(measure1 = ms1; measure2 = ms2; range= m) -> let factor1 = ms1 |> Option.defaultValue (SynMeasure.One Range.Zero) - Measure.Prod(tcMeasure factor1, Measure.Inv (tcMeasure ms2)) + Measure.Prod(tcMeasure factor1, Measure.Inv (tcMeasure ms2), m) | SynMeasure.Seq(mss, _) -> ProdMeasures (List.map tcMeasure mss) | SynMeasure.Anon _ -> error(Error(FSComp.SR.tcUnexpectedMeasureAnon(), m)) | SynMeasure.Var(_, m) -> error(Error(FSComp.SR.tcNonZeroConstantCannotHaveGenericUnit(), m)) @@ -826,10 +826,10 @@ let TcConst (cenv: cenv) (overallTy: TType) m env synConst = let measureTy = match synConst with | SynConst.Measure(synMeasure = SynMeasure.Anon _) -> - (mkWoNullAppTy tcr [TType_measure (Measure.Var (NewAnonTypar (TyparKind.Measure, m, TyparRigidity.Anon, (if iszero then TyparStaticReq.None else TyparStaticReq.HeadType), TyparDynamicReq.No)))]) + (mkWoNullAppTy tcr [TType_measure (Measure.Var(NewAnonTypar (TyparKind.Measure, m, TyparRigidity.Anon, (if iszero then TyparStaticReq.None else TyparStaticReq.HeadType), TyparDynamicReq.No), m))]) | SynConst.Measure(synMeasure = ms) -> mkWoNullAppTy tcr [TType_measure (tcMeasure ms)] - | _ -> mkWoNullAppTy tcr [TType_measure Measure.One] + | _ -> mkWoNullAppTy tcr [TType_measure(Measure.One(m))] unif measureTy let expandedMeasurablesEnabled = @@ -4550,7 +4550,7 @@ and TcLongIdentType kindOpt (cenv: cenv) newOk checkConstraints occ iwsam env tp error(Error(FSComp.SR.tcExpectedUnitOfMeasureNotType(), m)) TType_measure (NewErrorMeasure ()), tpenv | _, TyparKind.Measure -> - TType_measure (Measure.Const tcref), tpenv + TType_measure (Measure.Const(tcref, m)), tpenv | _, TyparKind.Type -> TcTypeApp cenv newOk checkConstraints occ env tpenv m tcref tinstEnclosing [] inst @@ -4585,7 +4585,7 @@ and TcLongIdentAppType kindOpt (cenv: cenv) newOk checkConstraints occ iwsam env match args, postfix with | [arg], true -> let ms, tpenv = TcMeasure cenv newOk checkConstraints occ env tpenv arg m - TType_measure (Measure.Prod(Measure.Const tcref, ms)), tpenv + TType_measure (Measure.Prod(Measure.Const(tcref, tcref.Range), ms, ms.Range)), tpenv | _, _ -> errorR(Error(FSComp.SR.tcUnitsOfMeasureInvalidInTypeConstructor(), m)) @@ -4662,14 +4662,14 @@ and TcArrayType (cenv: cenv) newOk checkConstraints occ env tpenv rank elemTy m and TcTypeParameter kindOpt (cenv: cenv) env newOk tpenv tp = let tpR, tpenv = TcTypeOrMeasureParameter kindOpt cenv env newOk tpenv tp match tpR.Kind with - | TyparKind.Measure -> TType_measure (Measure.Var tpR), tpenv + | TyparKind.Measure -> TType_measure (Measure.Var(tpR, tpR.Range)), tpenv | TyparKind.Type -> mkTyparTy tpR, tpenv // _ types and TcAnonType kindOpt (cenv: cenv) newOk tpenv m = let tp: Typar = TcAnonTypeOrMeasure kindOpt cenv TyparRigidity.Anon TyparDynamicReq.No newOk m match tp.Kind with - | TyparKind.Measure -> TType_measure (Measure.Var tp), tpenv + | TyparKind.Measure -> TType_measure (Measure.Var(tp, m)), tpenv | TyparKind.Type -> mkTyparTy tp, tpenv and TcTypeWithConstraints (cenv: cenv) env newOk checkConstraints occ tpenv synTy synConstraints = @@ -4715,7 +4715,7 @@ and TcTypeStaticConstant kindOpt tpenv c m = errorR(Error(FSComp.SR.parsInvalidLiteralInType(), m)) NewErrorType (), tpenv | SynConst.Int32 1, _ -> - TType_measure Measure.One, tpenv + TType_measure (Measure.One(m)), tpenv | _ -> errorR(Error(FSComp.SR.parsInvalidLiteralInType(), m)) NewErrorType (), tpenv @@ -4727,7 +4727,7 @@ and TcTypeMeasurePower kindOpt (cenv: cenv) newOk checkConstraints occ env tpenv NewErrorType (), tpenv | _ -> let ms, tpenv = TcMeasure cenv newOk checkConstraints occ env tpenv ty m - TType_measure (Measure.RationalPower (ms, TcSynRationalConst exponent)), tpenv + TType_measure (Measure.RationalPower (ms, TcSynRationalConst exponent, ms.Range)), tpenv and TcTypeMeasureApp kindOpt (cenv: cenv) newOk checkConstraints occ env tpenv arg1 args postfix m = match arg1 with @@ -4736,7 +4736,7 @@ and TcTypeMeasureApp kindOpt (cenv: cenv) newOk checkConstraints occ env tpenv a | (None | Some TyparKind.Measure), [arg2], true -> let ms1, tpenv = TcMeasure cenv newOk checkConstraints occ env tpenv arg1 m1 let ms2, tpenv = TcMeasure cenv newOk checkConstraints occ env tpenv arg2 m - TType_measure (Measure.Prod(ms1, ms2)), tpenv + TType_measure (Measure.Prod(ms1, ms2, m)), tpenv | _ -> errorR(Error(FSComp.SR.tcTypeParameterInvalidAsTypeConstructor(), m)) @@ -4810,12 +4810,12 @@ and TcMeasuresAsTuple (cenv: cenv) newOk checkConstraints occ env (tpenv: Unscop gather args tpenv ms1 | SynTupleTypeSegment.Star _ :: SynTupleTypeSegment.Type ty :: args -> let ms1, tpenv = TcMeasure cenv newOk checkConstraints occ env tpenv ty m - gather args tpenv (Measure.Prod(acc, ms1)) + gather args tpenv (Measure.Prod(acc, ms1, m)) | SynTupleTypeSegment.Slash _ :: SynTupleTypeSegment.Type ty :: args -> let ms1, tpenv = TcMeasure cenv newOk checkConstraints occ env tpenv ty m - gather args tpenv (Measure.Prod(acc, Measure.Inv ms1)) + gather args tpenv (Measure.Prod(acc, Measure.Inv ms1, m)) | _ -> failwith "impossible" - gather args tpenv Measure.One + gather args tpenv (Measure.One(m)) and TcTypesOrMeasures optKinds (cenv: cenv) newOk checkConstraints occ env tpenv args m = match optKinds with @@ -5043,7 +5043,7 @@ and TcTypeApp (cenv: cenv) newOk checkConstraints occ env tpenv m tcref pathType let tps = tinst |> List.skip pathTypeArgsLength |> List.map (fun t -> match t with | TType_var(typar, _) - | TType_measure(Measure.Var typar) -> typar + | TType_measure(Measure.Var(typar= typar)) -> typar | t -> failwith $"TcTypeApp: {t}" ) @@ -5077,7 +5077,7 @@ and TcTypeOrMeasureAndRecover kindOpt (cenv: cenv) newOk checkConstraints occ iw let recoveryTy = match kindOpt, newOk with - | Some TyparKind.Measure, NoNewTypars -> TType_measure Measure.One + | Some TyparKind.Measure, NoNewTypars -> TType_measure(Measure.One ty.Range) | Some TyparKind.Measure, _ -> TType_measure (NewErrorMeasure ()) | _, NoNewTypars -> g.obj_ty_ambivalent | _ -> NewErrorType () diff --git a/src/Compiler/Checking/NameResolution.fs b/src/Compiler/Checking/NameResolution.fs index 5b0c9842f77..72f94ab04be 100644 --- a/src/Compiler/Checking/NameResolution.fs +++ b/src/Compiler/Checking/NameResolution.fs @@ -1586,7 +1586,7 @@ let NewErrorType () = mkTyparTy (NewErrorTypar ()) let NewErrorMeasure () = - Measure.Var (NewErrorMeasureVar ()) + Measure.Var((NewErrorMeasureVar ()), range0) let NewByRefKindInferenceType (g: TcGlobals) m = let tp = Construct.NewTypar (TyparKind.Type, TyparRigidity.Flexible, SynTypar(compgenId, TyparStaticReq.HeadType, true), false, TyparDynamicReq.No, [], false, false) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index 645f43fe3cb..df8fdb301cd 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -7,6 +7,8 @@ module internal FSharp.Compiler.PostTypeCheckSemanticChecks open System open System.Collections.Generic +open FSharp.Compiler.AttributeChecking +open FSharp.Compiler.NameResolution open Internal.Utilities.Collections open Internal.Utilities.Library open Internal.Utilities.Library.Extras @@ -347,6 +349,18 @@ type TypeInstCtx = match x with | IlGenericInst(_,ilTypar) -> ilTypar.HasAllowsRefStruct | _ -> false + +/// Check the attributes of a measure +[] +let rec (|MeasureAttrib|_|) measure = + match measure with + | Measure.Const(tcref, _) -> ValueSome(tcref.Attribs) + | Measure.Prod(measure1= MeasureAttrib ms1; measure2= MeasureAttrib ms2) -> ValueSome (ms1 @ ms2) + | Measure.Inv(MeasureAttrib ms) -> ValueSome ms + | Measure.One(m) -> ValueNone + | Measure.RationalPower(measure = MeasureAttrib ms) -> ValueSome ms + | Measure.Var _ -> ValueNone + | _ -> ValueNone let rec CheckTypeDeep (cenv: cenv) (visitTy, visitTyconRefOpt, visitAppTyOpt, visitTraitSolutionOpt, visitTyparOpt as f) (g: TcGlobals) env (typeInstParentOpt:TypeInstCtx) ty = // We iterate the _solved_ constraints as well, to pick up any record of trait constraint solutions @@ -383,7 +397,37 @@ let rec CheckTypeDeep (cenv: cenv) (visitTy, visitTyconRefOpt, visitAppTyOpt, vi CheckTypeDeep cenv f g env typeInstParentOpt body tps |> List.iter (fun tp -> tp.Constraints |> List.iter (CheckTypeConstraintDeep cenv f g env)) - | TType_measure _ -> () + | TType_measure (Measure.Var(typar= { typar_solution = Some typeApp } )) -> CheckTypeDeep cenv f g env typeInstParentOpt typeApp + | TType_measure tm -> + match tm with + | Measure.Const(range = m) -> + match tm with + | MeasureAttrib attribs -> + CheckFSharpAttributes g attribs m |> CommitOperationResult + | _ -> () + | Measure.Prod(ms1, ms2, m) -> + match ms1, ms2 with + | MeasureAttrib attribs1, MeasureAttrib attribs2 -> + CheckFSharpAttributes g attribs1 ms1.Range |> CommitOperationResult + CheckFSharpAttributes g attribs2 ms2.Range |> CommitOperationResult + | _ -> () + + | Measure.Inv ms -> + match ms with + | MeasureAttrib attribs -> + CheckFSharpAttributes g attribs ms.Range |> CommitOperationResult + | _ -> () + | Measure.One(m) -> + match tm with + | MeasureAttrib attribs -> + CheckFSharpAttributes g attribs m |> CommitOperationResult + | _ -> () + | Measure.RationalPower(measure = ms; range = m) -> + match ms with + | MeasureAttrib attribs -> + CheckFSharpAttributes g attribs m |> CommitOperationResult + | _ -> () + | Measure.Var(typar, m) -> () | TType_app (tcref, tinst, _) -> match visitTyconRefOpt with diff --git a/src/Compiler/Checking/TypeRelations.fs b/src/Compiler/Checking/TypeRelations.fs index 6c38b68d80a..a24b0d13c6e 100644 --- a/src/Compiler/Checking/TypeRelations.fs +++ b/src/Compiler/Checking/TypeRelations.fs @@ -176,7 +176,7 @@ let ChooseTyparSolutionAndRange (g: TcGlobals) amap (tp:Typar) = let initialTy = match tp.Kind with | TyparKind.Type -> g.obj_ty_noNulls - | TyparKind.Measure -> TType_measure Measure.One + | TyparKind.Measure -> TType_measure(Measure.One(m)) // Loop through the constraints computing the lub (((initialTy, false), m), tp.Constraints) ||> List.fold (fun ((maxTy, isRefined), _) tpc -> let join m x = @@ -226,8 +226,8 @@ let ChooseTyparSolutionAndRange (g: TcGlobals) amap (tp:Typar) = maxTy, m let ChooseTyparSolution g amap tp = - let ty, _m = ChooseTyparSolutionAndRange g amap tp - if tp.Rigidity = TyparRigidity.Anon && typeEquiv g ty (TType_measure Measure.One) then + let ty, m = ChooseTyparSolutionAndRange g amap tp + if tp.Rigidity = TyparRigidity.Anon && typeEquiv g ty (TType_measure(Measure.One(m))) then warning(Error(FSComp.SR.csCodeLessGeneric(), tp.Range)) ty diff --git a/src/Compiler/Checking/import.fs b/src/Compiler/Checking/import.fs index a1deee1c8a1..66ba6abe73c 100644 --- a/src/Compiler/Checking/import.fs +++ b/src/Compiler/Checking/import.fs @@ -6,6 +6,7 @@ module internal FSharp.Compiler.Import open System.Collections.Concurrent open System.Collections.Generic open System.Collections.Immutable +open FSharp.Compiler.Text.Range open Internal.Utilities.Library open Internal.Utilities.Library.Extras open Internal.Utilities.TypeHashing @@ -553,16 +554,20 @@ let rec ImportProvidedType (env: ImportMap) (m: range) (* (tinst: TypeInst) *) ( if tp.Kind = TyparKind.Measure then let rec conv ty = match ty with - | TType_app (tcref, [ty1;ty2], _) when tyconRefEq g tcref g.measureproduct_tcr -> Measure.Prod (conv ty1, conv ty2) + | TType_app (tcref, [ty1;ty2], _) when tyconRefEq g tcref g.measureproduct_tcr -> + let ms1: Measure = conv ty1 + let ms2: Measure = conv ty2 + let m = unionRanges ms1.Range ms2.Range + Measure.Prod(ms1, ms2, m) | TType_app (tcref, [ty1], _) when tyconRefEq g tcref g.measureinverse_tcr -> Measure.Inv (conv ty1) - | TType_app (tcref, [], _) when tyconRefEq g tcref g.measureone_tcr -> Measure.One - | TType_app (tcref, [], _) when tcref.TypeOrMeasureKind = TyparKind.Measure -> Measure.Const tcref + | TType_app (tcref, [], _) when tyconRefEq g tcref g.measureone_tcr -> Measure.One(tcref.Range) + | TType_app (tcref, [], _) when tcref.TypeOrMeasureKind = TyparKind.Measure -> Measure.Const(tcref, tcref.Range) | TType_app (tcref, _, _) -> errorR(Error(FSComp.SR.impInvalidMeasureArgument1(tcref.CompiledName, tp.Name), m)) - Measure.One + Measure.One(tcref.Range) | _ -> errorR(Error(FSComp.SR.impInvalidMeasureArgument2(tp.Name), m)) - Measure.One + Measure.One(Range.Zero) TType_measure (conv genericArg) else diff --git a/src/Compiler/Service/ItemKey.fs b/src/Compiler/Service/ItemKey.fs index 3c030f84c90..34787d93621 100644 --- a/src/Compiler/Service/ItemKey.fs +++ b/src/Compiler/Service/ItemKey.fs @@ -359,10 +359,10 @@ and [] ItemKeyStoreBuilder(tcGlobals: TcGlobals) = debug.WriteMeasure isStandalone ms match ms with - | Measure.Var typar -> + | Measure.Var(typar= typar) -> writeString ItemKeyTags.typeMeasureVar writeTypar isStandalone typar - | Measure.Const tcref -> + | Measure.Const(tyconRef= tcref) -> writeString ItemKeyTags.typeMeasureCon writeEntityRef tcref | _ -> () diff --git a/src/Compiler/Symbols/Exprs.fs b/src/Compiler/Symbols/Exprs.fs index 91480597cc2..5ec81f6861d 100644 --- a/src/Compiler/Symbols/Exprs.fs +++ b/src/Compiler/Symbols/Exprs.fs @@ -3,6 +3,7 @@ namespace FSharp.Compiler.Symbols open FSharp.Compiler +open FSharp.Compiler.Text.Range open Internal.Utilities.Library open Internal.Utilities.Library.Extras open FSharp.Compiler.AbstractIL.IL @@ -775,7 +776,7 @@ module FSharpExprConvert = let argTy2 = tyOfExpr g arg2 let resTy = match getMeasureOfType g argTy1, getMeasureOfType g argTy2 with - | Some (tcref, ms1), Some (_tcref2, ms2) -> mkWoNullAppTy tcref [TType_measure (Measure.Prod(ms1, if isMul then ms2 else Measure.Inv ms2))] + | Some (tcref, ms1), Some (_tcref2, ms2) -> mkWoNullAppTy tcref [TType_measure (Measure.Prod(ms1, (if isMul then ms2 else Measure.Inv ms2), unionRanges ms1.Range ms2.Range))] | Some _, None -> argTy1 | None, Some _ -> argTy2 | None, None -> argTy1 diff --git a/src/Compiler/Symbols/Symbols.fs b/src/Compiler/Symbols/Symbols.fs index c2772cf8736..727321af05a 100644 --- a/src/Compiler/Symbols/Symbols.fs +++ b/src/Compiler/Symbols/Symbols.fs @@ -2512,9 +2512,9 @@ type FSharpType(cenv, ty:TType) = DiagnosticsLogger.protectAssemblyExploration true <| fun () -> match stripTyparEqns ty with | TType_app (tcref, tyargs, _) -> FSharpEntity(cenv, tcref, tyargs).IsUnresolved - | TType_measure (Measure.Const tcref) -> FSharpEntity(cenv, tcref).IsUnresolved + | TType_measure (Measure.Const(tyconRef= tcref)) -> FSharpEntity(cenv, tcref).IsUnresolved | TType_measure (Measure.Prod _) -> FSharpEntity(cenv, cenv.g.measureproduct_tcr).IsUnresolved - | TType_measure Measure.One -> FSharpEntity(cenv, cenv.g.measureone_tcr).IsUnresolved + | TType_measure (Measure.One _) -> FSharpEntity(cenv, cenv.g.measureone_tcr).IsUnresolved | TType_measure (Measure.Inv _) -> FSharpEntity(cenv, cenv.g.measureinverse_tcr).IsUnresolved | _ -> false @@ -2528,7 +2528,7 @@ type FSharpType(cenv, ty:TType) = isResolved() && protect <| fun () -> match stripTyparEqns ty with - | TType_app _ | TType_measure (Measure.Const _ | Measure.Prod _ | Measure.Inv _ | Measure.One) -> true + | TType_app _ | TType_measure (Measure.Const _ | Measure.Prod _ | Measure.Inv _ | Measure.One _) -> true | _ -> false member _.IsMeasureType = @@ -2556,9 +2556,9 @@ type FSharpType(cenv, ty:TType) = protect <| fun () -> match stripTyparEqns ty with | TType_app (tcref, tyargs, _) -> FSharpEntity(cenv, tcref, tyargs) - | TType_measure (Measure.Const tcref) -> FSharpEntity(cenv, tcref) + | TType_measure (Measure.Const(tyconRef= tcref)) -> FSharpEntity(cenv, tcref) | TType_measure (Measure.Prod _) -> FSharpEntity(cenv, cenv.g.measureproduct_tcr) - | TType_measure Measure.One -> FSharpEntity(cenv, cenv.g.measureone_tcr) + | TType_measure (Measure.One _) -> FSharpEntity(cenv, cenv.g.measureone_tcr) | TType_measure (Measure.Inv _) -> FSharpEntity(cenv, cenv.g.measureinverse_tcr) | _ -> invalidOp "not a named type" @@ -2587,8 +2587,8 @@ type FSharpType(cenv, ty:TType) = | TType_tuple (_, tyargs) -> (tyargs |> List.map (fun ty -> FSharpType(cenv, ty)) |> makeReadOnlyCollection) | TType_fun(domainTy, rangeTy, _) -> [| FSharpType(cenv, domainTy); FSharpType(cenv, rangeTy) |] |> makeReadOnlyCollection | TType_measure (Measure.Const _) -> [| |] |> makeReadOnlyCollection - | TType_measure (Measure.Prod (t1, t2)) -> [| FSharpType(cenv, TType_measure t1); FSharpType(cenv, TType_measure t2) |] |> makeReadOnlyCollection - | TType_measure Measure.One -> [| |] |> makeReadOnlyCollection + | TType_measure (Measure.Prod(measure1= t1; measure2 = t2)) -> [| FSharpType(cenv, TType_measure t1); FSharpType(cenv, TType_measure t2) |] |> makeReadOnlyCollection + | TType_measure (Measure.One _) -> [| |] |> makeReadOnlyCollection | TType_measure (Measure.Inv t1) -> [| FSharpType(cenv, TType_measure t1) |] |> makeReadOnlyCollection | _ -> invalidOp "not a named type" @@ -2638,7 +2638,7 @@ type FSharpType(cenv, ty:TType) = protect <| fun () -> match stripTyparEqns ty with | TType_var (tp, _) - | TType_measure (Measure.Var tp) -> + | TType_measure (Measure.Var(typar= tp)) -> FSharpGenericParameter (cenv, tp) | _ -> invalidOp "not a generic parameter type" diff --git a/src/Compiler/TypedTree/TypedTree.fs b/src/Compiler/TypedTree/TypedTree.fs index 1aaa21eb294..494bbf635f3 100644 --- a/src/Compiler/TypedTree/TypedTree.fs +++ b/src/Compiler/TypedTree/TypedTree.fs @@ -4556,28 +4556,37 @@ type TupInfo = type Measure = /// A variable unit-of-measure - | Var of typar: Typar + | Var of typar: Typar * range: range /// A constant, leaf unit-of-measure such as 'kg' or 'm' - | Const of tyconRef: TyconRef + | Const of tyconRef: TyconRef * range: range /// A product of two units of measure - | Prod of measure1: Measure * measure2: Measure + | Prod of measure1: Measure * measure2: Measure * range: range /// An inverse of a units of measure expression | Inv of measure: Measure /// The unit of measure '1', e.g. float = float<1> - | One + | One of range: range /// Raising a measure to a rational power - | RationalPower of measure: Measure * power: Rational + | RationalPower of measure: Measure * power: Rational * range: range // %+A formatting is used, so this is not needed //[] //member x.DebugText = x.ToString() - override x.ToString() = sprintf "%+A" x + override x.ToString() = sprintf "%+A" x + + member x.Range = + match x with + | Var(range= m) -> m + | Const(range= m) -> m + | Prod(range= m) -> m + | Inv(m) -> m.Range + | One(range= m) -> m + | RationalPower(range= m) -> m type Attribs = Attrib list diff --git a/src/Compiler/TypedTree/TypedTree.fsi b/src/Compiler/TypedTree/TypedTree.fsi index 73eeb760b4c..71d06e857ab 100644 --- a/src/Compiler/TypedTree/TypedTree.fsi +++ b/src/Compiler/TypedTree/TypedTree.fsi @@ -3199,24 +3199,26 @@ type TupInfo = type Measure = /// A variable unit-of-measure - | Var of typar: Typar + | Var of typar: Typar * range: range /// A constant, leaf unit-of-measure such as 'kg' or 'm' - | Const of tyconRef: TyconRef + | Const of tyconRef: TyconRef * range: range /// A product of two units of measure - | Prod of measure1: Measure * measure2: Measure + | Prod of measure1: Measure * measure2: Measure * range: range /// An inverse of a units of measure expression | Inv of measure: Measure /// The unit of measure '1', e.g. float = float<1> - | One + | One of range: range /// Raising a measure to a rational power - | RationalPower of measure: Measure * power: Rational + | RationalPower of measure: Measure * power: Rational * range: range override ToString: unit -> string + + member Range: range type Attribs = Attrib list diff --git a/src/Compiler/TypedTree/TypedTreeBasics.fs b/src/Compiler/TypedTree/TypedTreeBasics.fs index 582d6767d7e..7c581abedf2 100644 --- a/src/Compiler/TypedTree/TypedTreeBasics.fs +++ b/src/Compiler/TypedTree/TypedTreeBasics.fs @@ -192,7 +192,7 @@ let KnownWithoutNull = Nullness.Known NullnessInfo.WithoutNull let mkTyparTy (tp:Typar) = match tp.Kind with | TyparKind.Type -> tp.AsType KnownWithoutNull - | TyparKind.Measure -> TType_measure (Measure.Var tp) + | TyparKind.Measure -> TType_measure (Measure.Var(tp, tp.Range)) // For fresh type variables clear the StaticReq when copying because the requirement will be re-established through the // process of type inference. @@ -219,7 +219,7 @@ let tryShortcutSolvedUnitPar canShortcut (r: Typar) = | Some (TType_measure unt) -> if canShortcut then match unt with - | Measure.Var r2 -> + | Measure.Var(typar= r2) -> match r2.Solution with | None -> () | Some _ as soln -> @@ -231,7 +231,7 @@ let tryShortcutSolvedUnitPar canShortcut (r: Typar) = let rec stripUnitEqnsAux canShortcut unt = match unt with - | Measure.Var r when r.IsSolved -> stripUnitEqnsAux canShortcut (tryShortcutSolvedUnitPar canShortcut r) + | Measure.Var(typar = r) when r.IsSolved -> stripUnitEqnsAux canShortcut (tryShortcutSolvedUnitPar canShortcut r) | _ -> unt let combineNullness (nullnessOrig: Nullness) (nullnessNew: Nullness) = diff --git a/src/Compiler/TypedTree/TypedTreeOps.fs b/src/Compiler/TypedTree/TypedTreeOps.fs index ca7292c6369..6f3f4f9db55 100644 --- a/src/Compiler/TypedTree/TypedTreeOps.fs +++ b/src/Compiler/TypedTree/TypedTreeOps.fs @@ -228,15 +228,15 @@ let rec remapTypeAux (tyenv: Remap) (ty: TType) = and remapMeasureAux tyenv unt = match unt with - | Measure.One -> unt - | Measure.Const tcref -> - match tyenv.tyconRefRemap.TryFind tcref with - | Some tcref -> Measure.Const tcref + | Measure.One _ -> unt + | Measure.Const(entityRef, m) -> + match tyenv.tyconRefRemap.TryFind entityRef with + | Some tcref -> Measure.Const(tcref, m) | None -> unt - | Measure.Prod(u1, u2) -> Measure.Prod(remapMeasureAux tyenv u1, remapMeasureAux tyenv u2) - | Measure.RationalPower(u, q) -> Measure.RationalPower(remapMeasureAux tyenv u, q) + | Measure.Prod(u1, u2, m) -> Measure.Prod(remapMeasureAux tyenv u1, remapMeasureAux tyenv u2, m) + | Measure.RationalPower(u, q, m) -> Measure.RationalPower(remapMeasureAux tyenv u, q, m) | Measure.Inv u -> Measure.Inv(remapMeasureAux tyenv u) - | Measure.Var tp as unt -> + | Measure.Var(typar= tp) as unt -> match tp.Solution with | None -> match ListAssoc.tryFind typarEq tp tyenv.tpinst with @@ -444,7 +444,7 @@ let reduceTyconRefAbbrevMeasureable (tcref: TyconRef) = let rec stripUnitEqnsFromMeasureAux canShortcut unt = match stripUnitEqnsAux canShortcut unt with - | Measure.Const tcref when tcref.IsTypeAbbrev -> + | Measure.Const(tyconRef= tcref) when tcref.IsTypeAbbrev -> stripUnitEqnsFromMeasureAux canShortcut (reduceTyconRefAbbrevMeasureable tcref) | m -> m @@ -457,38 +457,38 @@ let stripUnitEqnsFromMeasure m = stripUnitEqnsFromMeasureAux false m /// What is the contribution of unit-of-measure constant ucref to unit-of-measure expression measure? let rec MeasureExprConExponent g abbrev ucref unt = match (if abbrev then stripUnitEqnsFromMeasure unt else stripUnitEqns unt) with - | Measure.Const ucrefR -> if tyconRefEq g ucrefR ucref then OneRational else ZeroRational + | Measure.Const(tyconRef= ucrefR) -> if tyconRefEq g ucrefR ucref then OneRational else ZeroRational | Measure.Inv untR -> NegRational(MeasureExprConExponent g abbrev ucref untR) - | Measure.Prod(unt1, unt2) -> AddRational(MeasureExprConExponent g abbrev ucref unt1) (MeasureExprConExponent g abbrev ucref unt2) - | Measure.RationalPower(untR, q) -> MulRational (MeasureExprConExponent g abbrev ucref untR) q + | Measure.Prod(measure1= unt1; measure2= unt2) -> AddRational(MeasureExprConExponent g abbrev ucref unt1) (MeasureExprConExponent g abbrev ucref unt2) + | Measure.RationalPower(measure= untR; power= q) -> MulRational (MeasureExprConExponent g abbrev ucref untR) q | _ -> ZeroRational /// What is the contribution of unit-of-measure constant ucref to unit-of-measure expression measure /// after remapping tycons? let rec MeasureConExponentAfterRemapping g r ucref unt = match stripUnitEqnsFromMeasure unt with - | Measure.Const ucrefR -> if tyconRefEq g (r ucrefR) ucref then OneRational else ZeroRational + | Measure.Const(tyconRef= ucrefR) -> if tyconRefEq g (r ucrefR) ucref then OneRational else ZeroRational | Measure.Inv untR -> NegRational(MeasureConExponentAfterRemapping g r ucref untR) - | Measure.Prod(unt1, unt2) -> AddRational(MeasureConExponentAfterRemapping g r ucref unt1) (MeasureConExponentAfterRemapping g r ucref unt2) - | Measure.RationalPower(untR, q) -> MulRational (MeasureConExponentAfterRemapping g r ucref untR) q + | Measure.Prod(measure1= unt1; measure2= unt2) -> AddRational(MeasureConExponentAfterRemapping g r ucref unt1) (MeasureConExponentAfterRemapping g r ucref unt2) + | Measure.RationalPower(measure= untR; power= q) -> MulRational (MeasureConExponentAfterRemapping g r ucref untR) q | _ -> ZeroRational /// What is the contribution of unit-of-measure variable tp to unit-of-measure expression unt? let rec MeasureVarExponent tp unt = match stripUnitEqnsFromMeasure unt with - | Measure.Var tpR -> if typarEq tp tpR then OneRational else ZeroRational + | Measure.Var(typar= tpR) -> if typarEq tp tpR then OneRational else ZeroRational | Measure.Inv untR -> NegRational(MeasureVarExponent tp untR) - | Measure.Prod(unt1, unt2) -> AddRational(MeasureVarExponent tp unt1) (MeasureVarExponent tp unt2) - | Measure.RationalPower(untR, q) -> MulRational (MeasureVarExponent tp untR) q + | Measure.Prod(measure1= unt1; measure2= unt2) -> AddRational(MeasureVarExponent tp unt1) (MeasureVarExponent tp unt2) + | Measure.RationalPower(measure = untR; power= q) -> MulRational (MeasureVarExponent tp untR) q | _ -> ZeroRational /// List the *literal* occurrences of unit variables in a unit expression, without repeats let ListMeasureVarOccs unt = let rec gather acc unt = match stripUnitEqnsFromMeasure unt with - | Measure.Var tp -> if List.exists (typarEq tp) acc then acc else tp :: acc - | Measure.Prod(unt1, unt2) -> gather (gather acc unt1) unt2 - | Measure.RationalPower(untR, _) -> gather acc untR + | Measure.Var(typar= tp) -> if List.exists (typarEq tp) acc then acc else tp :: acc + | Measure.Prod(measure1= unt1; measure2= unt2) -> gather (gather acc unt1) unt2 + | Measure.RationalPower(measure= untR) -> gather acc untR | Measure.Inv untR -> gather acc untR | _ -> acc gather [] unt @@ -497,14 +497,14 @@ let ListMeasureVarOccs unt = let ListMeasureVarOccsWithNonZeroExponents untexpr = let rec gather acc unt = match stripUnitEqnsFromMeasure unt with - | Measure.Var tp -> + | Measure.Var(typar= tp) -> if List.exists (fun (tpR, _) -> typarEq tp tpR) acc then acc else let e = MeasureVarExponent tp untexpr if e = ZeroRational then acc else (tp, e) :: acc - | Measure.Prod(unt1, unt2) -> gather (gather acc unt1) unt2 + | Measure.Prod(measure1= unt1; measure2= unt2) -> gather (gather acc unt1) unt2 | Measure.Inv untR -> gather acc untR - | Measure.RationalPower(untR, _) -> gather acc untR + | Measure.RationalPower(measure= untR) -> gather acc untR | _ -> acc gather [] untexpr @@ -512,13 +512,13 @@ let ListMeasureVarOccsWithNonZeroExponents untexpr = let ListMeasureConOccsWithNonZeroExponents g eraseAbbrevs untexpr = let rec gather acc unt = match (if eraseAbbrevs then stripUnitEqnsFromMeasure unt else stripUnitEqns unt) with - | Measure.Const c -> + | Measure.Const(tyconRef= c) -> if List.exists (fun (cR, _) -> tyconRefEq g c cR) acc then acc else let e = MeasureExprConExponent g eraseAbbrevs c untexpr if e = ZeroRational then acc else (c, e) :: acc - | Measure.Prod(unt1, unt2) -> gather (gather acc unt1) unt2 + | Measure.Prod(measure1= unt1; measure2= unt2) -> gather (gather acc unt1) unt2 | Measure.Inv untR -> gather acc untR - | Measure.RationalPower(untR, _) -> gather acc untR + | Measure.RationalPower(measure= untR) -> gather acc untR | _ -> acc gather [] untexpr @@ -527,9 +527,9 @@ let ListMeasureConOccsWithNonZeroExponents g eraseAbbrevs untexpr = let ListMeasureConOccsAfterRemapping g r unt = let rec gather acc unt = match stripUnitEqnsFromMeasure unt with - | Measure.Const c -> if List.exists (tyconRefEq g (r c)) acc then acc else r c :: acc - | Measure.Prod(unt1, unt2) -> gather (gather acc unt1) unt2 - | Measure.RationalPower(untR, _) -> gather acc untR + | Measure.Const(tyconRef= c) -> if List.exists (tyconRefEq g (r c)) acc then acc else r c :: acc + | Measure.Prod(measure1= unt1; measure2= unt2) -> gather (gather acc unt1) unt2 + | Measure.RationalPower(measure= untR) -> gather acc untR | Measure.Inv untR -> gather acc untR | _ -> acc @@ -538,19 +538,19 @@ let ListMeasureConOccsAfterRemapping g r unt = /// Construct a measure expression representing the n'th power of a measure let MeasurePower u n = if n = 1 then u - elif n = 0 then Measure.One - else Measure.RationalPower (u, intToRational n) + elif n = 0 then Measure.One(range0) + else Measure.RationalPower (u, intToRational n, range0) let MeasureProdOpt m1 m2 = match m1, m2 with - | Measure.One, _ -> m2 - | _, Measure.One -> m1 - | _, _ -> Measure.Prod (m1, m2) + | Measure.One _, _ -> m2 + | _, Measure.One _ -> m1 + | _, _ -> Measure.Prod (m1, m2, range0) /// Construct a measure expression representing the product of a list of measures let ProdMeasures ms = match ms with - | [] -> Measure.One + | [] -> Measure.One(range0) | m :: ms -> List.foldBack MeasureProdOpt ms m let isDimensionless g ty = @@ -580,13 +580,26 @@ let normalizeMeasure g ms = let vs = ListMeasureVarOccsWithNonZeroExponents ms let cs = ListMeasureConOccsWithNonZeroExponents g false ms match vs, cs with - | [], [] -> Measure.One - | [(v, e)], [] when e = OneRational -> Measure.Var v - | vs, cs -> List.foldBack (fun (v, e) -> fun m -> Measure.Prod (Measure.RationalPower (Measure.Var v, e), m)) vs (List.foldBack (fun (c, e) -> fun m -> Measure.Prod (Measure.RationalPower (Measure.Const c, e), m)) cs Measure.One) + | [], [] -> Measure.One(range0) + | [(v, e)], [] when e = OneRational -> Measure.Var(v, v.Range) + | vs, cs -> + List.foldBack + (fun (v, e) -> + fun unt -> + let measureVar = Measure.Var(v, v.Range) + let measureRational = Measure.RationalPower(measureVar, e, measureVar.Range) + Measure.Prod(measureRational, unt, unionRanges measureVar.Range unt.Range)) + vs + (List.foldBack + (fun (c, e) -> + fun unt -> + let measureConst = Measure.Const(c, c.Range) + let measureRational = Measure.RationalPower(measureConst, e, measureConst.Range) + Measure.Prod(measureRational, unt, range0)) cs (Measure.One(range0))) let tryNormalizeMeasureInType g ty = match ty with - | TType_measure (Measure.Var v) -> + | TType_measure (Measure.Var(typar= v)) -> match v.Solution with | Some (TType_measure ms) -> v.typar_solution <- Some (TType_measure (normalizeMeasure g ms)) @@ -916,14 +929,14 @@ let tryNiceEntityRefOfTy ty = let ty = stripTyparEqnsAux KnownWithoutNull false ty match ty with | TType_app (tcref, _, _) -> ValueSome tcref - | TType_measure (Measure.Const tcref) -> ValueSome tcref + | TType_measure (Measure.Const(tyconRef= tcref)) -> ValueSome tcref | _ -> ValueNone let tryNiceEntityRefOfTyOption ty = let ty = stripTyparEqnsAux KnownWithoutNull false ty match ty with | TType_app (tcref, _, _) -> Some tcref - | TType_measure (Measure.Const tcref) -> Some tcref + | TType_measure (Measure.Const(tyconRef= tcref)) -> Some tcref | _ -> None let mkInstForAppTy g ty = @@ -1159,7 +1172,7 @@ let getMeasureOfType g ty = match ty with | AppTy g (tcref, [tyarg]) -> match stripTyEqns g tyarg with - | TType_measure ms when not (measureEquiv g ms Measure.One) -> Some (tcref, ms) + | TType_measure ms when not (measureEquiv g ms (Measure.One(tcref.Range))) -> Some (tcref, ms) | _ -> None | _ -> None diff --git a/src/Compiler/TypedTree/TypedTreePickle.fs b/src/Compiler/TypedTree/TypedTreePickle.fs index 9515d49b80d..45a15991da8 100644 --- a/src/Compiler/TypedTree/TypedTreePickle.fs +++ b/src/Compiler/TypedTree/TypedTreePickle.fs @@ -1539,8 +1539,8 @@ let p_measure_one = p_byte 4 // Pickle a unit-of-measure variable or constructor let p_measure_varcon unt st = match unt with - | Measure.Const tcref -> p_measure_con tcref st - | Measure.Var v -> p_measure_var v st + | Measure.Const(tyconRef= tcref) -> p_measure_con tcref st + | Measure.Var(typar= v) -> p_measure_var v st | _ -> pfailwith st "p_measure_varcon: expected measure variable or constructor" // Pickle a positive integer power of a unit-of-measure variable or constructor @@ -1568,12 +1568,12 @@ let rec p_measure_power unt q st = let rec p_normalized_measure unt st = let unt = stripUnitEqnsAux false unt match unt with - | Measure.Const tcref -> p_measure_con tcref st + | Measure.Const(tyconRef= tcref) -> p_measure_con tcref st | Measure.Inv x -> p_byte 1 st; p_normalized_measure x st - | Measure.Prod(x1, x2) -> p_byte 2 st; p_normalized_measure x1 st; p_normalized_measure x2 st - | Measure.Var v -> p_measure_var v st - | Measure.One -> p_measure_one st - | Measure.RationalPower(x, q) -> p_measure_power x q st + | Measure.Prod(measure1= x1; measure2= x2) -> p_byte 2 st; p_normalized_measure x1 st; p_normalized_measure x2 st + | Measure.Var(typar= v) -> p_measure_var v st + | Measure.One _ -> p_measure_one st + | Measure.RationalPower(measure= x; power= q) -> p_measure_power x q st // By normalizing the unit-of-measure and treating integer powers as a special case, // we ensure that the pickle format for rational powers of units (byte 5 followed by @@ -1589,12 +1589,12 @@ let u_rational st = let rec u_measure_expr st = let tag = u_byte st match tag with - | 0 -> let a = u_tcref st in Measure.Const a + | 0 -> let a = u_tcref st in Measure.Const(a, range0) | 1 -> let a = u_measure_expr st in Measure.Inv a - | 2 -> let a, b = u_tup2 u_measure_expr u_measure_expr st in Measure.Prod (a, b) - | 3 -> let a = u_tpref st in Measure.Var a - | 4 -> Measure.One - | 5 -> let a = u_measure_expr st in let b = u_rational st in Measure.RationalPower (a, b) + | 2 -> let a, b = u_tup2 u_measure_expr u_measure_expr st in Measure.Prod (a, b, range0) + | 3 -> let a = u_tpref st in Measure.Var(a, range0) + | 4 -> Measure.One(range0) + | 5 -> let a = u_measure_expr st in let b = u_rational st in Measure.RationalPower (a, b, range0) | _ -> ufailwith st "u_measure_expr" let p_tyar_constraint x st = diff --git a/tests/FSharp.Compiler.ComponentTests/Language/ObsoleteAttributeCheckingTests.fs b/tests/FSharp.Compiler.ComponentTests/Language/ObsoleteAttributeCheckingTests.fs index 002bef2f41b..513f033e82c 100644 --- a/tests/FSharp.Compiler.ComponentTests/Language/ObsoleteAttributeCheckingTests.fs +++ b/tests/FSharp.Compiler.ComponentTests/Language/ObsoleteAttributeCheckingTests.fs @@ -1,6 +1,5 @@ namespace Language -open FSharp.Test open Xunit open FSharp.Test.Compiler @@ -37,6 +36,211 @@ let c = C() (Warning 44, Line 7, Col 9, Line 7, Col 10, "This construct is deprecated. Use B instead") ] + + [] + let ``Obsolete attribute warning taken into account when used with a literal`` () = + Fsx """ +open System +[] +let myLit = 12 + +let myRes = myLit + """ + |> typecheck + |> shouldFail + |> withDiagnostics [ + (Warning 44, Line 6, Col 13, Line 6, Col 18, "This construct is deprecated. Use lit2") + ] + + [] + let ``Obsolete attribute error taken into account when used with a literal`` () = + Fsx """ +open System +[] +let myLit = 12 + +let myRes = myLit + """ + |> typecheck + |> shouldFail + |> withDiagnostics [ + (Error 101, Line 6, Col 13, Line 6, Col 18, "This construct is deprecated. Use lit2") + ] + + [] + let ``Obsolete attribute warning taken into account when used with a simple unit of measure`` () = + Fsx """ +open System +[] +type cm + +let myCm = 3 + """ + |> typecheck + |> shouldFail + |> withDiagnostics [ + (Warning 44, Line 6, Col 14, Line 6, Col 16, "This construct is deprecated. Use cm2") + ] + + [] + let ``Obsolete attribute error taken into account when used with a simple unit of measure`` () = + Fsx """ +open System +[] +type cm + +let myCm = 3 + """ + |> typecheck + |> shouldFail + |> withDiagnostics [ + (Error 101, Line 6, Col 14, Line 6, Col 16, "This construct is deprecated. Use cm2") + ] + + [] + let ``Obsolete attribute warning taken into account when used with a simple unit of measure type abbrev`` () = + Fsx """ +open System +[] type cm + +[] type ml = cm^3 + """ + |> typecheck + |> shouldFail + |> withDiagnostics [ + (Warning 44, Line 5, Col 23, Line 5, Col 25, "This construct is deprecated. Use something else") + ] + + [] + let ``Obsolete attribute error taken into account when used with a simple unit of measure type abbrev`` () = + Fsx """ +open System +[] type cm + +[] type ml = cm^3 + """ + |> typecheck + |> shouldFail + |> withDiagnostics [ + (Error 101, Line 5, Col 23, Line 5, Col 25, "This construct is deprecated. Use something else") + ] + + [] + let ``Obsolete attribute warning taken into account when used with a complex unit of measure definition`` () = + Fsx """ +open System +[] +type kg + +[] type m + +[] +type s + +// Force, Newtons. +[] type N = kg m / s^2 + """ + |> typecheck + |> shouldFail + |> withDiagnostics [ + (Warning 44, Line 12, Col 22, Line 12, Col 24, "This construct is deprecated. Use kg2"); + (Warning 44, Line 12, Col 29, Line 12, Col 30, "This construct is deprecated. Use s2") + ] + + [] + let ``Obsolete attribute error taken into account when used with a complex unit of measure definition`` () = + Fsx """ +open System +[] +type kg + +[] type m + +[] +type s + +// Force, Newtons. +[] type N = kg m / s^2 + """ + |> typecheck + |> shouldFail + |> withDiagnostics [ + (Error 101, Line 12, Col 22, Line 12, Col 24, "This construct is deprecated. Use kg2"); + ] + + [] + let ``Obsolete attribute warning taken into account when used within a complex unit of measure`` () = + Fsx """ +open System + +[] +type kg + +[] +type cm + +let myCm = 3 + """ + |> typecheck + |> shouldFail + |> withDiagnostics [ + (Warning 44, Line 10, Col 14, Line 10, Col 16, "This construct is deprecated. Use cm2") + ] + + [] + let ``Obsolete attribute warning taken into account when used with a complex(multiple obsolete) unit of measure`` () = + Fsx """ +open System + +[] +type kg + +[] +type cm + +let myCm = 3 + """ + |> typecheck + |> shouldFail + |> withDiagnostics [ + (Warning 44, Line 10, Col 14, Line 10, Col 16, "This construct is deprecated. Use cm2"); + (Warning 44, Line 10, Col 17, Line 10, Col 19, "This construct is deprecated. Use kg2") + ] + + [] + let ``Obsolete attribute warning taken into account when used with a complex(multiple obsolete) unit of measure usages`` () = + Fsx """ +open System +// Distance, meters. +[] type m + +// Time, seconds. +[] type s + +let genericSumUnits ( x : float<'u>) (y: float<'u>) = x + y + +let genericSumUnits2 ( x : float) (y: float) = () + +let v1 = 3.1 +let v2 = 2.7 +let x1 = 1.2 +let t1 = 1.0 + +let result1 = genericSumUnits v1 v2 + """ + |> typecheck + |> shouldFail + |> withDiagnostics [ + (Warning 44, Line 11, Col 34, Line 11, Col 35, "This construct is deprecated. Use m2") + (Warning 44, Line 11, Col 48, Line 11, Col 49, "This construct is deprecated. Use s2") + (Warning 44, Line 13, Col 14, Line 13, Col 15, "This construct is deprecated. Use m2") + (Warning 44, Line 13, Col 16, Line 13, Col 17, "This construct is deprecated. Use s2") + (Warning 44, Line 14, Col 14, Line 14, Col 15, "This construct is deprecated. Use m2") + (Warning 44, Line 14, Col 16, Line 14, Col 17, "This construct is deprecated. Use s2") + (Warning 44, Line 15, Col 14, Line 15, Col 15, "This construct is deprecated. Use m2") + (Warning 44, Line 16, Col 14, Line 16, Col 15, "This construct is deprecated. Use s2") + ] + [] let ``Obsolete attribute error taken into account when used instantiating a type`` () = Fsx """ From 15cbc6c7f9ce13bdb247acf7b31d018a4ab8f849 Mon Sep 17 00:00:00 2001 From: Edgar Gonzalez Date: Sun, 29 Dec 2024 19:40:41 +0000 Subject: [PATCH 02/20] format code --- src/Compiler/Service/ItemKey.fs | 4 ++-- src/Compiler/TypedTree/TypedTree.fsi | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Compiler/Service/ItemKey.fs b/src/Compiler/Service/ItemKey.fs index 34787d93621..84a2c6b0cc9 100644 --- a/src/Compiler/Service/ItemKey.fs +++ b/src/Compiler/Service/ItemKey.fs @@ -359,10 +359,10 @@ and [] ItemKeyStoreBuilder(tcGlobals: TcGlobals) = debug.WriteMeasure isStandalone ms match ms with - | Measure.Var(typar= typar) -> + | Measure.Var(typar = typar) -> writeString ItemKeyTags.typeMeasureVar writeTypar isStandalone typar - | Measure.Const(tyconRef= tcref) -> + | Measure.Const(tyconRef = tcref) -> writeString ItemKeyTags.typeMeasureCon writeEntityRef tcref | _ -> () diff --git a/src/Compiler/TypedTree/TypedTree.fsi b/src/Compiler/TypedTree/TypedTree.fsi index 71d06e857ab..58b01879fbb 100644 --- a/src/Compiler/TypedTree/TypedTree.fsi +++ b/src/Compiler/TypedTree/TypedTree.fsi @@ -3217,7 +3217,7 @@ type Measure = | RationalPower of measure: Measure * power: Rational * range: range override ToString: unit -> string - + member Range: range type Attribs = Attrib list From 633cdfcbd4ea3ab770021ee04927dbdec27f0fbd Mon Sep 17 00:00:00 2001 From: Edgar Gonzalez Date: Sun, 29 Dec 2024 21:40:54 +0000 Subject: [PATCH 03/20] refactor --- src/Compiler/Checking/PostInferenceChecks.fs | 39 +++++++------------- 1 file changed, 13 insertions(+), 26 deletions(-) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index df8fdb301cd..45498089cf7 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -397,37 +397,24 @@ let rec CheckTypeDeep (cenv: cenv) (visitTy, visitTyconRefOpt, visitAppTyOpt, vi CheckTypeDeep cenv f g env typeInstParentOpt body tps |> List.iter (fun tp -> tp.Constraints |> List.iter (CheckTypeConstraintDeep cenv f g env)) - | TType_measure (Measure.Var(typar= { typar_solution = Some typeApp } )) -> CheckTypeDeep cenv f g env typeInstParentOpt typeApp | TType_measure tm -> - match tm with - | Measure.Const(range = m) -> + let checkAttribs tm m = match tm with - | MeasureAttrib attribs -> - CheckFSharpAttributes g attribs m |> CommitOperationResult + | MeasureAttrib attribs when not attribs.IsEmpty -> CheckFSharpAttributes g attribs m |> CommitOperationResult | _ -> () + + match tm with + | Measure.Const(range = m) -> checkAttribs tm m + | Measure.Inv ms -> checkAttribs ms ms.Range + | Measure.One(m) -> checkAttribs tm m + | Measure.RationalPower(measure = ms1; range = m) -> checkAttribs ms1 m | Measure.Prod(ms1, ms2, m) -> match ms1, ms2 with - | MeasureAttrib attribs1, MeasureAttrib attribs2 -> - CheckFSharpAttributes g attribs1 ms1.Range |> CommitOperationResult - CheckFSharpAttributes g attribs2 ms2.Range |> CommitOperationResult - | _ -> () - - | Measure.Inv ms -> - match ms with - | MeasureAttrib attribs -> - CheckFSharpAttributes g attribs ms.Range |> CommitOperationResult - | _ -> () - | Measure.One(m) -> - match tm with - | MeasureAttrib attribs -> - CheckFSharpAttributes g attribs m |> CommitOperationResult - | _ -> () - | Measure.RationalPower(measure = ms; range = m) -> - match ms with - | MeasureAttrib attribs -> - CheckFSharpAttributes g attribs m |> CommitOperationResult - | _ -> () - | Measure.Var(typar, m) -> () + | MeasureAttrib _, MeasureAttrib _ -> + checkAttribs ms1 ms1.Range + checkAttribs ms2 ms2.Range + | _ -> () + | _ -> () | TType_app (tcref, tinst, _) -> match visitTyconRefOpt with From 2ffae64b45a4a6c25a4c5cbf3f71697444e64e5b Mon Sep 17 00:00:00 2001 From: Edgar Gonzalez Date: Sun, 29 Dec 2024 21:41:05 +0000 Subject: [PATCH 04/20] release notes --- docs/release-notes/.FSharp.Compiler.Service/9.0.200.md | 1 + 1 file changed, 1 insertion(+) diff --git a/docs/release-notes/.FSharp.Compiler.Service/9.0.200.md b/docs/release-notes/.FSharp.Compiler.Service/9.0.200.md index 740c18edcbc..c2e26da7e86 100644 --- a/docs/release-notes/.FSharp.Compiler.Service/9.0.200.md +++ b/docs/release-notes/.FSharp.Compiler.Service/9.0.200.md @@ -20,6 +20,7 @@ * Completion: fix qualified completion in sequence expressions [PR #18111](https://github.com/dotnet/fsharp/pull/18111) * Symbols: try to use ValReprInfoForDisplay in Mfv.CurriedParameterGroups ([PR #18124](https://github.com/dotnet/fsharp/pull/18124)) * Shim/file system: fix leaks of the shim [PR #18144](https://github.com/dotnet/fsharp/pull/18144) +* Fix for `Obsolete` attribute warning/error not taken into account when used with a unit of measure [PR #18182](https://github.com/dotnet/fsharp/pull/18182) ### Added From a3cca3a33659ba4c7d29fca730d52b22f30a2487 Mon Sep 17 00:00:00 2001 From: Edgar Gonzalez Date: Thu, 2 Jan 2025 20:24:16 +0000 Subject: [PATCH 05/20] Move logic to Checking phase --- src/Compiler/Checking/CheckDeclarations.fs | 27 +++++++++ src/Compiler/Checking/ConstraintSolver.fs | 18 +++--- .../Checking/Expressions/CheckExpressions.fs | 39 ++++++++++-- src/Compiler/Checking/NameResolution.fs | 2 +- src/Compiler/Checking/PostInferenceChecks.fs | 60 ++++++++++--------- src/Compiler/TypedTree/TypedTree.fs | 4 +- src/Compiler/TypedTree/TypedTree.fsi | 2 +- src/Compiler/TypedTree/TypedTreeBasics.fs | 2 +- src/Compiler/TypedTree/TypedTreeOps.fs | 4 +- src/Compiler/TypedTree/TypedTreeOps.fsi | 2 + src/Compiler/TypedTree/TypedTreePickle.fs | 2 +- .../ObsoleteAttributeCheckingTests.fs | 7 +-- 12 files changed, 115 insertions(+), 54 deletions(-) diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index 329792653e0..4f37733942d 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/src/Compiler/Checking/CheckDeclarations.fs @@ -3241,8 +3241,35 @@ module EstablishTypeDefinitionCores = warning(Error(FSComp.SR.chkAttributeAliased(attrib.TypeRef.FullName), tycon.Id.idRange)) | _ -> () + // Check for attributes in unit of measure definitions + // e.g. [] type m = 1 + // ^ + let checkAttributeInMeasure ty = + match ty with + | TType_measure tm -> + let checkAttribs tm m = + let attribs = + ListMeasureConOccsWithNonZeroExponents g true tm + |> List.map fst + |> List.map(_.Attribs) + |> List.concat + + CheckFSharpAttributes g attribs m |> CommitOperationResult + + match tm with + | Measure.Const(range = m) -> checkAttribs tm m + | Measure.Inv ms -> checkAttribs tm ms.Range + | Measure.One(m) -> checkAttribs tm m + | Measure.RationalPower(measure = ms1; range = m) -> checkAttribs tm m + | Measure.Prod(ms1, ms2, m) -> + checkAttribs ms1 ms1.Range + checkAttribs ms2 ms2.Range + | _ -> () + | _ -> () + checkAttributeAliased ty tycon g.attrib_AutoOpenAttribute checkAttributeAliased ty tycon g.attrib_StructAttribute + checkAttributeInMeasure ty if not firstPass then let ftyvs = freeInTypeLeftToRight g false ty diff --git a/src/Compiler/Checking/ConstraintSolver.fs b/src/Compiler/Checking/ConstraintSolver.fs index 28971354112..4aaef5255c6 100644 --- a/src/Compiler/Checking/ConstraintSolver.fs +++ b/src/Compiler/Checking/ConstraintSolver.fs @@ -730,7 +730,7 @@ let SubstMeasureWarnIfRigid (csenv: ConstraintSolverEnv) trace (v: Typar) ms = let tpnmOpt = if v.IsCompilerGenerated then None else Some v.Name do! SolveTypStaticReq csenv trace v.StaticReq (TType_measure ms) SubstMeasure v ms - return! WarnD(NonRigidTypar(csenv.DisplayEnv, tpnmOpt, v.Range, TType_measure (Measure.Var(v, v.Range)), TType_measure ms, csenv.m)) + return! WarnD(NonRigidTypar(csenv.DisplayEnv, tpnmOpt, v.Range, TType_measure (Measure.Var(v)), TType_measure ms, csenv.m)) else // Propagate static requirements from 'tp' to 'ty' do! SolveTypStaticReq csenv trace v.StaticReq (TType_measure ms) @@ -762,7 +762,7 @@ let UnifyMeasureWithOne (csenv: ConstraintSolverEnv) trace ms = | (v, e) :: vs -> let unexpandedCons = ListMeasureConOccsWithNonZeroExponents csenv.g false ms let newms = ProdMeasures (List.map (fun (c, e') -> Measure.RationalPower(Measure.Const(c, c.Range), NegRational (DivRational e' e), ms.Range)) unexpandedCons - @ List.map (fun (v, e') -> Measure.RationalPower (Measure.Var(v, v.Range), NegRational (DivRational e' e), ms.Range)) (vs @ rigidVars)) + @ List.map (fun (v, e') -> Measure.RationalPower (Measure.Var(v), NegRational (DivRational e' e), ms.Range)) (vs @ rigidVars)) SubstMeasureWarnIfRigid csenv trace v newms @@ -786,7 +786,7 @@ let SimplifyMeasure g vars ms = let newvar = if v.IsCompilerGenerated then NewAnonTypar (TyparKind.Measure, v.Range, TyparRigidity.Flexible, v.StaticReq, v.DynamicReq) else NewNamedInferenceMeasureVar (v.Range, TyparRigidity.Flexible, v.StaticReq, v.Id) let remainingvars = ListSet.remove typarEq v vars - let newvarExpr = if SignRational e < 0 then Measure.Inv (Measure.Var(newvar, newvar.Range)) else Measure.Var(newvar, newvar.Range) + let newvarExpr = if SignRational e < 0 then Measure.Inv (Measure.Var(newvar)) else Measure.Var(newvar) let nonZeroCon = ListMeasureConOccsWithNonZeroExponents g false ms let nonZeroVar = ListMeasureVarOccsWithNonZeroExponents ms let newms = @@ -797,7 +797,7 @@ let SimplifyMeasure g vars ms = if typarEq v v' then newvarExpr else - Measure.RationalPower (Measure.Var(v', v'.Range), NegRational (DivRational e' e), ms.Range) + Measure.RationalPower (Measure.Var(v'), NegRational (DivRational e' e), ms.Range) ] SubstMeasure v newms match vs with @@ -881,7 +881,7 @@ let NormalizeExponentsInTypeScheme uvars ty = v else let v' = NewAnonTypar (TyparKind.Measure, v.Range, TyparRigidity.Flexible, v.StaticReq, v.DynamicReq) - SubstMeasure v (Measure.RationalPower (Measure.Var(v', v'.Range), DivRational OneRational expGcd, v.Range)) + SubstMeasure v (Measure.RationalPower (Measure.Var(v'), DivRational OneRational expGcd, v.Range)) v') // We normalize unit-of-measure-polymorphic type schemes. There @@ -923,7 +923,7 @@ let SimplifyMeasuresInTypeScheme g resultFirst (generalizable: Typar list) ty co let generalized' = NormalizeExponentsInTypeScheme generalized ty vars @ List.rev generalized' -let freshMeasure () = Measure.Var((NewInferenceMeasurePar ()), range0) +let freshMeasure () = Measure.Var(NewInferenceMeasurePar ()) let CheckWarnIfRigid (csenv: ConstraintSolverEnv) ty1 (r: Typar) ty = let g = csenv.g @@ -1113,7 +1113,7 @@ and SolveTyparEqualsType (csenv: ConstraintSolverEnv) ndeep m2 (trace: OptionalT do! DepthCheck ndeep m match ty1 with | TType_var (r, _) - | TType_measure (Measure.Var(r, _)) -> + | TType_measure (Measure.Var(r)) -> do! SolveTyparEqualsTypePart1 csenv m2 trace ty1 r ty do! SolveTyparEqualsTypePart2 csenv ndeep m2 trace r ty | _ -> failwith "SolveTyparEqualsType" @@ -1126,7 +1126,7 @@ and SolveTyparsEqualTypes (csenv: ConstraintSolverEnv) ndeep m2 (trace: Optional fun tpTy ty -> match tpTy with | TType_var (r, _) - | TType_measure (Measure.Var(r, _)) -> + | TType_measure (Measure.Var(r)) -> SolveTyparEqualsTypePart1 csenv m2 trace tpTy r ty | _ -> failwith "SolveTyparsEqualTypes") tpTys tys @@ -1134,7 +1134,7 @@ and SolveTyparsEqualTypes (csenv: ConstraintSolverEnv) ndeep m2 (trace: Optional fun tpTy ty -> match tpTy with | TType_var (r, _) - | TType_measure (Measure.Var(r, _)) -> + | TType_measure (Measure.Var(r)) -> SolveTyparEqualsTypePart2 csenv ndeep m2 trace r ty | _ -> failwith "SolveTyparsEqualTypes") tpTys tys diff --git a/src/Compiler/Checking/Expressions/CheckExpressions.fs b/src/Compiler/Checking/Expressions/CheckExpressions.fs index 7ba49ff7696..ee69c43306a 100644 --- a/src/Compiler/Checking/Expressions/CheckExpressions.fs +++ b/src/Compiler/Checking/Expressions/CheckExpressions.fs @@ -826,7 +826,7 @@ let TcConst (cenv: cenv) (overallTy: TType) m env synConst = let measureTy = match synConst with | SynConst.Measure(synMeasure = SynMeasure.Anon _) -> - (mkWoNullAppTy tcr [TType_measure (Measure.Var(NewAnonTypar (TyparKind.Measure, m, TyparRigidity.Anon, (if iszero then TyparStaticReq.None else TyparStaticReq.HeadType), TyparDynamicReq.No), m))]) + (mkWoNullAppTy tcr [TType_measure (Measure.Var(NewAnonTypar (TyparKind.Measure, m, TyparRigidity.Anon, (if iszero then TyparStaticReq.None else TyparStaticReq.HeadType), TyparDynamicReq.No)))]) | SynConst.Measure(synMeasure = ms) -> mkWoNullAppTy tcr [TType_measure (tcMeasure ms)] | _ -> mkWoNullAppTy tcr [TType_measure(Measure.One(m))] @@ -4662,14 +4662,14 @@ and TcArrayType (cenv: cenv) newOk checkConstraints occ env tpenv rank elemTy m and TcTypeParameter kindOpt (cenv: cenv) env newOk tpenv tp = let tpR, tpenv = TcTypeOrMeasureParameter kindOpt cenv env newOk tpenv tp match tpR.Kind with - | TyparKind.Measure -> TType_measure (Measure.Var(tpR, tpR.Range)), tpenv + | TyparKind.Measure -> TType_measure (Measure.Var(tpR)), tpenv | TyparKind.Type -> mkTyparTy tpR, tpenv // _ types and TcAnonType kindOpt (cenv: cenv) newOk tpenv m = let tp: Typar = TcAnonTypeOrMeasure kindOpt cenv TyparRigidity.Anon TyparDynamicReq.No newOk m match tp.Kind with - | TyparKind.Measure -> TType_measure (Measure.Var(tp, m)), tpenv + | TyparKind.Measure -> TType_measure (Measure.Var(tp)), tpenv | TyparKind.Type -> mkTyparTy tp, tpenv and TcTypeWithConstraints (cenv: cenv) env newOk checkConstraints occ tpenv synTy synConstraints = @@ -11155,7 +11155,38 @@ and TcNormalizedBinding declKind (cenv: cenv) env tpenv overallTy safeThisValOpt let supportEnforceAttributeTargets = (g.langVersion.SupportsFeature(LanguageFeature.EnforceAttributeTargets) && memberFlagsOpt.IsNone && not attrs.IsEmpty) - && not isVolatile // // VolatileFieldAttribute has a special treatment(specific error FS823) + && not isVolatile // VolatileFieldAttribute has a special treatment(specific error FS823) + + // Check for attributes in unit of measure expressions + // e.g. let x = 1.0 + // ^ + let rec checkAttributeInMeasure ty = + match stripTyEqns g ty with + | TType_app(typeInstantiation= [ TType_measure tm ]) -> + let checkAttribs tm m = + let attribs = + ListMeasureConOccsWithNonZeroExponents g true tm + |> List.map fst + |> List.map(_.Attribs) + |> List.concat + + CheckFSharpAttributes g attribs m |> CommitOperationResult + + match tm with + | Measure.Const(range = m) -> checkAttribs tm m + | Measure.Inv ms -> checkAttribs tm ms.Range + | Measure.One(m) -> checkAttribs tm m + | Measure.RationalPower(measure = ms1; range = m) -> checkAttribs tm m + | Measure.Prod(ms1, ms2, m) -> + checkAttribs ms1 ms1.Range + checkAttribs ms2 ms2.Range + | Measure.Var(typar) -> checkAttribs tm typar.Range + + | TType_var(typar={typar_solution = Some(typeApp) }) -> checkAttributeInMeasure typeApp + | TType_fun(domainType = domainType) -> checkAttributeInMeasure domainType + | _ -> () + + checkAttributeInMeasure overallExprTy if supportEnforceAttributeTargets then TcAttributeTargetsOnLetBindings { cenv with tcSink = TcResultsSink.NoSink } env attrs overallPatTy overallExprTy (not declaredTypars.IsEmpty) isClassLetBinding diff --git a/src/Compiler/Checking/NameResolution.fs b/src/Compiler/Checking/NameResolution.fs index 72f94ab04be..5c641fa6c7f 100644 --- a/src/Compiler/Checking/NameResolution.fs +++ b/src/Compiler/Checking/NameResolution.fs @@ -1586,7 +1586,7 @@ let NewErrorType () = mkTyparTy (NewErrorTypar ()) let NewErrorMeasure () = - Measure.Var((NewErrorMeasureVar ()), range0) + Measure.Var((NewErrorMeasureVar ())) let NewByRefKindInferenceType (g: TcGlobals) m = let tp = Construct.NewTypar (TyparKind.Type, TyparRigidity.Flexible, SynTypar(compgenId, TyparStaticReq.HeadType, true), false, TyparDynamicReq.No, [], false, false) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index 45498089cf7..62bbce260ad 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -350,17 +350,17 @@ type TypeInstCtx = | IlGenericInst(_,ilTypar) -> ilTypar.HasAllowsRefStruct | _ -> false -/// Check the attributes of a measure -[] -let rec (|MeasureAttrib|_|) measure = - match measure with - | Measure.Const(tcref, _) -> ValueSome(tcref.Attribs) - | Measure.Prod(measure1= MeasureAttrib ms1; measure2= MeasureAttrib ms2) -> ValueSome (ms1 @ ms2) - | Measure.Inv(MeasureAttrib ms) -> ValueSome ms - | Measure.One(m) -> ValueNone - | Measure.RationalPower(measure = MeasureAttrib ms) -> ValueSome ms - | Measure.Var _ -> ValueNone - | _ -> ValueNone +// /// Check the attributes of a measure +// [] +// let rec (|MeasureAttrib|_|) measure = +// match measure with +// | Measure.Const(tcref, _) -> ValueSome(tcref.Attribs) +// | Measure.Prod(measure1= MeasureAttrib ms1; measure2= MeasureAttrib ms2) -> ValueSome (ms1 @ ms2) +// | Measure.Inv(MeasureAttrib ms) -> ValueSome ms +// | Measure.One(m) -> ValueNone +// | Measure.RationalPower(measure = MeasureAttrib ms) -> ValueSome ms +// | Measure.Var _ -> ValueNone +// | _ -> ValueNone let rec CheckTypeDeep (cenv: cenv) (visitTy, visitTyconRefOpt, visitAppTyOpt, visitTraitSolutionOpt, visitTyparOpt as f) (g: TcGlobals) env (typeInstParentOpt:TypeInstCtx) ty = // We iterate the _solved_ constraints as well, to pick up any record of trait constraint solutions @@ -397,24 +397,26 @@ let rec CheckTypeDeep (cenv: cenv) (visitTy, visitTyconRefOpt, visitAppTyOpt, vi CheckTypeDeep cenv f g env typeInstParentOpt body tps |> List.iter (fun tp -> tp.Constraints |> List.iter (CheckTypeConstraintDeep cenv f g env)) - | TType_measure tm -> - let checkAttribs tm m = - match tm with - | MeasureAttrib attribs when not attribs.IsEmpty -> CheckFSharpAttributes g attribs m |> CommitOperationResult - | _ -> () - - match tm with - | Measure.Const(range = m) -> checkAttribs tm m - | Measure.Inv ms -> checkAttribs ms ms.Range - | Measure.One(m) -> checkAttribs tm m - | Measure.RationalPower(measure = ms1; range = m) -> checkAttribs ms1 m - | Measure.Prod(ms1, ms2, m) -> - match ms1, ms2 with - | MeasureAttrib _, MeasureAttrib _ -> - checkAttribs ms1 ms1.Range - checkAttribs ms2 ms2.Range - | _ -> () - | _ -> () + | TType_measure _ -> () + // let checkAttribs tm m = + // let attribs = + // ListMeasureVarOccs tm + // |> List.map(_.Attribs) + // |> List.concat + // CheckFSharpAttributes g attribs m |> CommitOperationResult + // + // match tm with + // | Measure.Const(range = m) -> checkAttribs tm m + // | Measure.Inv ms -> checkAttribs ms ms.Range + // | Measure.One(m) -> checkAttribs tm m + // | Measure.RationalPower(measure = ms1; range = m) -> checkAttribs ms1 m + // | Measure.Prod(ms1, ms2, m) -> + // match ms1, ms2 with + // | MeasureAttrib _, MeasureAttrib _ -> + // checkAttribs ms1 ms1.Range + // checkAttribs ms2 ms2.Range + // | _ -> () + // | _ -> () | TType_app (tcref, tinst, _) -> match visitTyconRefOpt with diff --git a/src/Compiler/TypedTree/TypedTree.fs b/src/Compiler/TypedTree/TypedTree.fs index 494bbf635f3..c7f719ad815 100644 --- a/src/Compiler/TypedTree/TypedTree.fs +++ b/src/Compiler/TypedTree/TypedTree.fs @@ -4556,7 +4556,7 @@ type TupInfo = type Measure = /// A variable unit-of-measure - | Var of typar: Typar * range: range + | Var of typar: Typar /// A constant, leaf unit-of-measure such as 'kg' or 'm' | Const of tyconRef: TyconRef * range: range @@ -4581,7 +4581,7 @@ type Measure = member x.Range = match x with - | Var(range= m) -> m + | Var(typar) -> typar.Range | Const(range= m) -> m | Prod(range= m) -> m | Inv(m) -> m.Range diff --git a/src/Compiler/TypedTree/TypedTree.fsi b/src/Compiler/TypedTree/TypedTree.fsi index 58b01879fbb..d3afecb539e 100644 --- a/src/Compiler/TypedTree/TypedTree.fsi +++ b/src/Compiler/TypedTree/TypedTree.fsi @@ -3199,7 +3199,7 @@ type TupInfo = type Measure = /// A variable unit-of-measure - | Var of typar: Typar * range: range + | Var of typar: Typar /// A constant, leaf unit-of-measure such as 'kg' or 'm' | Const of tyconRef: TyconRef * range: range diff --git a/src/Compiler/TypedTree/TypedTreeBasics.fs b/src/Compiler/TypedTree/TypedTreeBasics.fs index 7c581abedf2..d870e8a8a71 100644 --- a/src/Compiler/TypedTree/TypedTreeBasics.fs +++ b/src/Compiler/TypedTree/TypedTreeBasics.fs @@ -192,7 +192,7 @@ let KnownWithoutNull = Nullness.Known NullnessInfo.WithoutNull let mkTyparTy (tp:Typar) = match tp.Kind with | TyparKind.Type -> tp.AsType KnownWithoutNull - | TyparKind.Measure -> TType_measure (Measure.Var(tp, tp.Range)) + | TyparKind.Measure -> TType_measure (Measure.Var(tp)) // For fresh type variables clear the StaticReq when copying because the requirement will be re-established through the // process of type inference. diff --git a/src/Compiler/TypedTree/TypedTreeOps.fs b/src/Compiler/TypedTree/TypedTreeOps.fs index 6f3f4f9db55..9aacff50a01 100644 --- a/src/Compiler/TypedTree/TypedTreeOps.fs +++ b/src/Compiler/TypedTree/TypedTreeOps.fs @@ -581,12 +581,12 @@ let normalizeMeasure g ms = let cs = ListMeasureConOccsWithNonZeroExponents g false ms match vs, cs with | [], [] -> Measure.One(range0) - | [(v, e)], [] when e = OneRational -> Measure.Var(v, v.Range) + | [(v, e)], [] when e = OneRational -> Measure.Var(v) | vs, cs -> List.foldBack (fun (v, e) -> fun unt -> - let measureVar = Measure.Var(v, v.Range) + let measureVar = Measure.Var(v) let measureRational = Measure.RationalPower(measureVar, e, measureVar.Range) Measure.Prod(measureRational, unt, unionRanges measureVar.Range unt.Range)) vs diff --git a/src/Compiler/TypedTree/TypedTreeOps.fsi b/src/Compiler/TypedTree/TypedTreeOps.fsi index bda6c2c3187..6433cf16d3e 100755 --- a/src/Compiler/TypedTree/TypedTreeOps.fsi +++ b/src/Compiler/TypedTree/TypedTreeOps.fsi @@ -843,6 +843,8 @@ val CollectAllNoCaching: FreeVarOptions val CollectAll: FreeVarOptions +val ListMeasureVarOccs: Measure -> Typar list + val accFreeInTypes: FreeVarOptions -> TType list -> FreeTyvars -> FreeTyvars val accFreeInType: FreeVarOptions -> TType -> FreeTyvars -> FreeTyvars diff --git a/src/Compiler/TypedTree/TypedTreePickle.fs b/src/Compiler/TypedTree/TypedTreePickle.fs index 45a15991da8..a97c1e0e9a3 100644 --- a/src/Compiler/TypedTree/TypedTreePickle.fs +++ b/src/Compiler/TypedTree/TypedTreePickle.fs @@ -1592,7 +1592,7 @@ let rec u_measure_expr st = | 0 -> let a = u_tcref st in Measure.Const(a, range0) | 1 -> let a = u_measure_expr st in Measure.Inv a | 2 -> let a, b = u_tup2 u_measure_expr u_measure_expr st in Measure.Prod (a, b, range0) - | 3 -> let a = u_tpref st in Measure.Var(a, range0) + | 3 -> let a = u_tpref st in Measure.Var(a) | 4 -> Measure.One(range0) | 5 -> let a = u_measure_expr st in let b = u_rational st in Measure.RationalPower (a, b, range0) | _ -> ufailwith st "u_measure_expr" diff --git a/tests/FSharp.Compiler.ComponentTests/Language/ObsoleteAttributeCheckingTests.fs b/tests/FSharp.Compiler.ComponentTests/Language/ObsoleteAttributeCheckingTests.fs index 513f033e82c..a802dd8dad3 100644 --- a/tests/FSharp.Compiler.ComponentTests/Language/ObsoleteAttributeCheckingTests.fs +++ b/tests/FSharp.Compiler.ComponentTests/Language/ObsoleteAttributeCheckingTests.fs @@ -217,9 +217,9 @@ open System // Time, seconds. [] type s -let genericSumUnits ( x : float<'u>) (y: float<'u>) = x + y +let genericSumUnits (x : float<'u>) (y: float<'u>) = x + y -let genericSumUnits2 ( x : float) (y: float) = () +let genericSumUnits2 (x : float) (y: float) = () let v1 = 3.1 let v2 = 2.7 @@ -231,8 +231,7 @@ let result1 = genericSumUnits v1 v2 |> typecheck |> shouldFail |> withDiagnostics [ - (Warning 44, Line 11, Col 34, Line 11, Col 35, "This construct is deprecated. Use m2") - (Warning 44, Line 11, Col 48, Line 11, Col 49, "This construct is deprecated. Use s2") + (Warning 44, Line 11, Col 33, Line 11, Col 34, "This construct is deprecated. Use m2") (Warning 44, Line 13, Col 14, Line 13, Col 15, "This construct is deprecated. Use m2") (Warning 44, Line 13, Col 16, Line 13, Col 17, "This construct is deprecated. Use s2") (Warning 44, Line 14, Col 14, Line 14, Col 15, "This construct is deprecated. Use m2") From a1f68f48144925ea0345a032c5ea5cb8aeeff781 Mon Sep 17 00:00:00 2001 From: Edgar Gonzalez Date: Fri, 3 Jan 2025 07:37:40 +0000 Subject: [PATCH 06/20] Revert changes from PIC --- src/Compiler/Checking/PostInferenceChecks.fs | 31 -------------------- 1 file changed, 31 deletions(-) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index 62bbce260ad..f06f661f427 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -349,18 +349,6 @@ type TypeInstCtx = match x with | IlGenericInst(_,ilTypar) -> ilTypar.HasAllowsRefStruct | _ -> false - -// /// Check the attributes of a measure -// [] -// let rec (|MeasureAttrib|_|) measure = -// match measure with -// | Measure.Const(tcref, _) -> ValueSome(tcref.Attribs) -// | Measure.Prod(measure1= MeasureAttrib ms1; measure2= MeasureAttrib ms2) -> ValueSome (ms1 @ ms2) -// | Measure.Inv(MeasureAttrib ms) -> ValueSome ms -// | Measure.One(m) -> ValueNone -// | Measure.RationalPower(measure = MeasureAttrib ms) -> ValueSome ms -// | Measure.Var _ -> ValueNone -// | _ -> ValueNone let rec CheckTypeDeep (cenv: cenv) (visitTy, visitTyconRefOpt, visitAppTyOpt, visitTraitSolutionOpt, visitTyparOpt as f) (g: TcGlobals) env (typeInstParentOpt:TypeInstCtx) ty = // We iterate the _solved_ constraints as well, to pick up any record of trait constraint solutions @@ -398,25 +386,6 @@ let rec CheckTypeDeep (cenv: cenv) (visitTy, visitTyconRefOpt, visitAppTyOpt, vi tps |> List.iter (fun tp -> tp.Constraints |> List.iter (CheckTypeConstraintDeep cenv f g env)) | TType_measure _ -> () - // let checkAttribs tm m = - // let attribs = - // ListMeasureVarOccs tm - // |> List.map(_.Attribs) - // |> List.concat - // CheckFSharpAttributes g attribs m |> CommitOperationResult - // - // match tm with - // | Measure.Const(range = m) -> checkAttribs tm m - // | Measure.Inv ms -> checkAttribs ms ms.Range - // | Measure.One(m) -> checkAttribs tm m - // | Measure.RationalPower(measure = ms1; range = m) -> checkAttribs ms1 m - // | Measure.Prod(ms1, ms2, m) -> - // match ms1, ms2 with - // | MeasureAttrib _, MeasureAttrib _ -> - // checkAttribs ms1 ms1.Range - // checkAttribs ms2 ms2.Range - // | _ -> () - // | _ -> () | TType_app (tcref, tinst, _) -> match visitTyconRefOpt with From d15381da87e7e96d7ca9ef241077b47ec190d6d0 Mon Sep 17 00:00:00 2001 From: Edgar Gonzalez Date: Fri, 3 Jan 2025 13:18:58 +0000 Subject: [PATCH 07/20] Test for unit-of-measures in class bindings and members --- .../Checking/Expressions/CheckExpressions.fs | 6 +- .../ObsoleteAttributeCheckingTests.fs | 105 ++++++++++++++++-- 2 files changed, 99 insertions(+), 12 deletions(-) diff --git a/src/Compiler/Checking/Expressions/CheckExpressions.fs b/src/Compiler/Checking/Expressions/CheckExpressions.fs index ee69c43306a..7b03291078b 100644 --- a/src/Compiler/Checking/Expressions/CheckExpressions.fs +++ b/src/Compiler/Checking/Expressions/CheckExpressions.fs @@ -11181,9 +11181,11 @@ and TcNormalizedBinding declKind (cenv: cenv) env tpenv overallTy safeThisValOpt checkAttribs ms1 ms1.Range checkAttribs ms2 ms2.Range | Measure.Var(typar) -> checkAttribs tm typar.Range - + | TType_tuple(elementTypes= elementTypes) -> elementTypes |> List.iter checkAttributeInMeasure | TType_var(typar={typar_solution = Some(typeApp) }) -> checkAttributeInMeasure typeApp - | TType_fun(domainType = domainType) -> checkAttributeInMeasure domainType + | TType_fun(domainType = domainType; rangeType= rangeType) -> + checkAttributeInMeasure domainType + checkAttributeInMeasure rangeType | _ -> () checkAttributeInMeasure overallExprTy diff --git a/tests/FSharp.Compiler.ComponentTests/Language/ObsoleteAttributeCheckingTests.fs b/tests/FSharp.Compiler.ComponentTests/Language/ObsoleteAttributeCheckingTests.fs index a802dd8dad3..3962179b396 100644 --- a/tests/FSharp.Compiler.ComponentTests/Language/ObsoleteAttributeCheckingTests.fs +++ b/tests/FSharp.Compiler.ComponentTests/Language/ObsoleteAttributeCheckingTests.fs @@ -208,7 +208,7 @@ let myCm = 3 ] [] - let ``Obsolete attribute warning taken into account when used with a complex(multiple obsolete) unit of measure usages`` () = + let ``TopLevel - Obsolete attribute warning taken into account when used with a complex(multiple obsolete) unit of measure usages`` () = Fsx """ open System // Distance, meters. @@ -217,9 +217,15 @@ open System // Time, seconds. [] type s -let genericSumUnits (x : float<'u>) (y: float<'u>) = x + y +let genericSumUnits (x: float<'u>) (y: float<'u>) = x + y -let genericSumUnits2 (x : float) (y: float) = () +let genericSumUnits2 (x: float) (y: float) = () + +let genericSumUnits3 (x: float) (y: float) (z: float) = () + +let genericSumUnits4 (x: float, y: float) = () + +let genericSumUnits5 (x: float, y: float, z: float) = () let v1 = 3.1 let v2 = 2.7 @@ -231,15 +237,94 @@ let result1 = genericSumUnits v1 v2 |> typecheck |> shouldFail |> withDiagnostics [ - (Warning 44, Line 11, Col 33, Line 11, Col 34, "This construct is deprecated. Use m2") - (Warning 44, Line 13, Col 14, Line 13, Col 15, "This construct is deprecated. Use m2") - (Warning 44, Line 13, Col 16, Line 13, Col 17, "This construct is deprecated. Use s2") - (Warning 44, Line 14, Col 14, Line 14, Col 15, "This construct is deprecated. Use m2") - (Warning 44, Line 14, Col 16, Line 14, Col 17, "This construct is deprecated. Use s2") - (Warning 44, Line 15, Col 14, Line 15, Col 15, "This construct is deprecated. Use m2") - (Warning 44, Line 16, Col 14, Line 16, Col 15, "This construct is deprecated. Use s2") + (Warning 44, Line 11, Col 32, Line 11, Col 33, "This construct is deprecated. Use m2") + (Warning 44, Line 11, Col 46, Line 11, Col 47, "This construct is deprecated. Use s2") + (Warning 44, Line 13, Col 32, Line 13, Col 33, "This construct is deprecated. Use m2") + (Warning 44, Line 13, Col 46, Line 13, Col 47, "This construct is deprecated. Use s2") + (Warning 44, Line 13, Col 60, Line 13, Col 61, "This construct is deprecated. Use m2") + (Warning 44, Line 15, Col 32, Line 15, Col 33, "This construct is deprecated. Use m2") + (Warning 44, Line 15, Col 45, Line 15, Col 46, "This construct is deprecated. Use s2") + (Warning 44, Line 17, Col 32, Line 17, Col 33, "This construct is deprecated. Use m2") + (Warning 44, Line 17, Col 45, Line 17, Col 46, "This construct is deprecated. Use s2") + (Warning 44, Line 17, Col 58, Line 17, Col 59, "This construct is deprecated. Use m2") + (Warning 44, Line 19, Col 14, Line 19, Col 15, "This construct is deprecated. Use m2") + (Warning 44, Line 19, Col 16, Line 19, Col 17, "This construct is deprecated. Use s2") + (Warning 44, Line 20, Col 14, Line 20, Col 15, "This construct is deprecated. Use m2") + (Warning 44, Line 20, Col 16, Line 20, Col 17, "This construct is deprecated. Use s2") + (Warning 44, Line 21, Col 14, Line 21, Col 15, "This construct is deprecated. Use m2") + (Warning 44, Line 22, Col 14, Line 22, Col 15, "This construct is deprecated. Use s2") ] + [] + let ``Class- Obsolete attribute warning taken into account when used with a complex(multiple obsolete) unit of measure usages`` () = + Fsx """ +open System +// Distance, meters. +[] type m + +// Time, seconds. +[] type s + +type MyClass() = + let genericSumUnits (x: float<'u>) (y: float<'u>) = x + y + + let genericSumUnits2 (x: float) (y: float) = () + + static let genericSumUnits3 (x: float) (y: float) (z: float) = () + + let genericSumUnits4 (x: float, y: float) = () + + let genericSumUnits5 (x: float, y: float, z: float) = () + + member this.Prop = 3.1 + + member this.Prop2 = 2.7 + + member this.Prop3 = 1.2 + + member this.Prop4 = 1.0 + + member this.GenericSumUnits (x: float<'u>) (y: float<'u>) = x + y + + member this.GenericSumUnits2 (x: float) (y: float) = () + + member this.GenericSumUnits3 (x: float) (y: float) (z: float) = () + + member this.GenericSumUnits4 (x: float, y: float) = () + + member this.GenericSumUnits5 (x: float, y: float, z: float) = () + """ + |> typecheck + |> shouldFail + |> withDiagnostics [ + (Warning 44, Line 12, Col 36, Line 12, Col 37, "This construct is deprecated. Use m2") + (Warning 44, Line 12, Col 50, Line 12, Col 51, "This construct is deprecated. Use s2") + (Warning 44, Line 14, Col 43, Line 14, Col 44, "This construct is deprecated. Use m2") + (Warning 44, Line 14, Col 57, Line 14, Col 58, "This construct is deprecated. Use s2") + (Warning 44, Line 14, Col 71, Line 14, Col 72, "This construct is deprecated. Use m2") + (Warning 44, Line 16, Col 36, Line 16, Col 37, "This construct is deprecated. Use m2") + (Warning 44, Line 16, Col 49, Line 16, Col 50, "This construct is deprecated. Use s2") + (Warning 44, Line 18, Col 36, Line 18, Col 37, "This construct is deprecated. Use m2") + (Warning 44, Line 18, Col 49, Line 18, Col 50, "This construct is deprecated. Use s2") + (Warning 44, Line 18, Col 62, Line 18, Col 63, "This construct is deprecated. Use m2") + (Warning 44, Line 20, Col 28, Line 20, Col 29, "This construct is deprecated. Use m2") + (Warning 44, Line 20, Col 30, Line 20, Col 31, "This construct is deprecated. Use s2") + (Warning 44, Line 22, Col 29, Line 22, Col 30, "This construct is deprecated. Use m2") + (Warning 44, Line 22, Col 31, Line 22, Col 32, "This construct is deprecated. Use s2") + (Warning 44, Line 24, Col 29, Line 24, Col 30, "This construct is deprecated. Use m2") + (Warning 44, Line 26, Col 29, Line 26, Col 30, "This construct is deprecated. Use s2") + (Warning 44, Line 30, Col 44, Line 30, Col 45, "This construct is deprecated. Use m2") + (Warning 44, Line 30, Col 58, Line 30, Col 59, "This construct is deprecated. Use s2") + (Warning 44, Line 32, Col 44, Line 32, Col 45, "This construct is deprecated. Use m2") + (Warning 44, Line 32, Col 58, Line 32, Col 59, "This construct is deprecated. Use s2") + (Warning 44, Line 32, Col 72, Line 32, Col 73, "This construct is deprecated. Use m2") + (Warning 44, Line 34, Col 44, Line 34, Col 45, "This construct is deprecated. Use m2") + (Warning 44, Line 34, Col 57, Line 34, Col 58, "This construct is deprecated. Use s2") + (Warning 44, Line 36, Col 44, Line 36, Col 45, "This construct is deprecated. Use m2") + (Warning 44, Line 36, Col 57, Line 36, Col 58, "This construct is deprecated. Use s2") + (Warning 44, Line 36, Col 70, Line 36, Col 71, "This construct is deprecated. Use m2") + ] + [] let ``Obsolete attribute error taken into account when used instantiating a type`` () = Fsx """ From 790bf50068bb3efa873e8830a4072836e83d1d1f Mon Sep 17 00:00:00 2001 From: Edgar Gonzalez Date: Fri, 3 Jan 2025 14:04:53 +0000 Subject: [PATCH 08/20] Remove unneeded range from SynMeasure.Power --- src/Compiler/Checking/CheckDeclarations.fs | 15 ++++++++++----- src/Compiler/Checking/ConstraintSolver.fs | 10 +++++----- .../Checking/Expressions/CheckExpressions.fs | 10 +++++----- src/Compiler/TypedTree/TypedTree.fs | 4 ++-- src/Compiler/TypedTree/TypedTree.fsi | 2 +- src/Compiler/TypedTree/TypedTreeOps.fs | 15 ++++++++------- src/Compiler/TypedTree/TypedTreePickle.fs | 2 +- 7 files changed, 32 insertions(+), 26 deletions(-) diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index 4f37733942d..3863ad320ed 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/src/Compiler/Checking/CheckDeclarations.fs @@ -3244,8 +3244,8 @@ module EstablishTypeDefinitionCores = // Check for attributes in unit of measure definitions // e.g. [] type m = 1 // ^ - let checkAttributeInMeasure ty = - match ty with + let rec checkAttributeInMeasure ty = + match stripTyEqns g ty with | TType_measure tm -> let checkAttribs tm m = let attribs = @@ -3260,11 +3260,16 @@ module EstablishTypeDefinitionCores = | Measure.Const(range = m) -> checkAttribs tm m | Measure.Inv ms -> checkAttribs tm ms.Range | Measure.One(m) -> checkAttribs tm m - | Measure.RationalPower(measure = ms1; range = m) -> checkAttribs tm m - | Measure.Prod(ms1, ms2, m) -> + | Measure.RationalPower(measure = ms1) -> checkAttribs tm ms1.Range + | Measure.Prod(measure1= ms1; measure2= ms2) -> checkAttribs ms1 ms1.Range checkAttribs ms2 ms2.Range - | _ -> () + | Measure.Var(typar) -> checkAttribs tm typar.Range + | TType_tuple(elementTypes= elementTypes) -> elementTypes |> List.iter checkAttributeInMeasure + | TType_var(typar={typar_solution = Some(typeApp) }) -> checkAttributeInMeasure typeApp + | TType_fun(domainType = domainType; rangeType= rangeType) -> + checkAttributeInMeasure domainType + checkAttributeInMeasure rangeType | _ -> () checkAttributeAliased ty tycon g.attrib_AutoOpenAttribute diff --git a/src/Compiler/Checking/ConstraintSolver.fs b/src/Compiler/Checking/ConstraintSolver.fs index 4aaef5255c6..0f374065921 100644 --- a/src/Compiler/Checking/ConstraintSolver.fs +++ b/src/Compiler/Checking/ConstraintSolver.fs @@ -761,8 +761,8 @@ let UnifyMeasureWithOne (csenv: ConstraintSolverEnv) trace ms = match FindPreferredTypar nonRigidVars with | (v, e) :: vs -> let unexpandedCons = ListMeasureConOccsWithNonZeroExponents csenv.g false ms - let newms = ProdMeasures (List.map (fun (c, e') -> Measure.RationalPower(Measure.Const(c, c.Range), NegRational (DivRational e' e), ms.Range)) unexpandedCons - @ List.map (fun (v, e') -> Measure.RationalPower (Measure.Var(v), NegRational (DivRational e' e), ms.Range)) (vs @ rigidVars)) + let newms = ProdMeasures (List.map (fun (c, e') -> Measure.RationalPower(Measure.Const(c, c.Range), NegRational (DivRational e' e))) unexpandedCons + @ List.map (fun (v, e') -> Measure.RationalPower (Measure.Var(v), NegRational (DivRational e' e))) (vs @ rigidVars)) SubstMeasureWarnIfRigid csenv trace v newms @@ -792,12 +792,12 @@ let SimplifyMeasure g vars ms = let newms = ProdMeasures [ for (c, e') in nonZeroCon do - Measure.RationalPower (Measure.Const(c, c.Range), NegRational (DivRational e' e), ms.Range) + Measure.RationalPower (Measure.Const(c, c.Range), NegRational (DivRational e' e)) for (v', e') in nonZeroVar do if typarEq v v' then newvarExpr else - Measure.RationalPower (Measure.Var(v'), NegRational (DivRational e' e), ms.Range) + Measure.RationalPower (Measure.Var(v'), NegRational (DivRational e' e)) ] SubstMeasure v newms match vs with @@ -881,7 +881,7 @@ let NormalizeExponentsInTypeScheme uvars ty = v else let v' = NewAnonTypar (TyparKind.Measure, v.Range, TyparRigidity.Flexible, v.StaticReq, v.DynamicReq) - SubstMeasure v (Measure.RationalPower (Measure.Var(v'), DivRational OneRational expGcd, v.Range)) + SubstMeasure v (Measure.RationalPower (Measure.Var(v'), DivRational OneRational expGcd)) v') // We normalize unit-of-measure-polymorphic type schemes. There diff --git a/src/Compiler/Checking/Expressions/CheckExpressions.fs b/src/Compiler/Checking/Expressions/CheckExpressions.fs index 7b03291078b..564879f47c2 100644 --- a/src/Compiler/Checking/Expressions/CheckExpressions.fs +++ b/src/Compiler/Checking/Expressions/CheckExpressions.fs @@ -806,7 +806,7 @@ let TcConst (cenv: cenv) (overallTy: TType) m env synConst = | TyparKind.Type -> error(Error(FSComp.SR.tcExpectedUnitOfMeasureNotType(), m)) | TyparKind.Measure -> Measure.Const(tcref, m) - | SynMeasure.Power(measure = ms; power = exponent; range= m) -> Measure.RationalPower (tcMeasure ms, TcSynRationalConst exponent, m) + | SynMeasure.Power(measure = ms; power = exponent; range= m) -> Measure.RationalPower (tcMeasure ms, TcSynRationalConst exponent) | SynMeasure.Product(measure1 = ms1; measure2 = ms2; range= m) -> Measure.Prod(tcMeasure ms1, tcMeasure ms2, m) | SynMeasure.Divide(ms1, _, (SynMeasure.Seq (_ :: _ :: _, _) as ms2), m) -> warning(Error(FSComp.SR.tcImplicitMeasureFollowingSlash(), m)) @@ -4727,7 +4727,7 @@ and TcTypeMeasurePower kindOpt (cenv: cenv) newOk checkConstraints occ env tpenv NewErrorType (), tpenv | _ -> let ms, tpenv = TcMeasure cenv newOk checkConstraints occ env tpenv ty m - TType_measure (Measure.RationalPower (ms, TcSynRationalConst exponent, ms.Range)), tpenv + TType_measure (Measure.RationalPower (ms, TcSynRationalConst exponent)), tpenv and TcTypeMeasureApp kindOpt (cenv: cenv) newOk checkConstraints occ env tpenv arg1 args postfix m = match arg1 with @@ -11176,8 +11176,8 @@ and TcNormalizedBinding declKind (cenv: cenv) env tpenv overallTy safeThisValOpt | Measure.Const(range = m) -> checkAttribs tm m | Measure.Inv ms -> checkAttribs tm ms.Range | Measure.One(m) -> checkAttribs tm m - | Measure.RationalPower(measure = ms1; range = m) -> checkAttribs tm m - | Measure.Prod(ms1, ms2, m) -> + | Measure.RationalPower(measure = ms1) -> checkAttribs tm ms1.Range + | Measure.Prod(measure1= ms1; measure2= ms2) -> checkAttribs ms1 ms1.Range checkAttribs ms2 ms2.Range | Measure.Var(typar) -> checkAttribs tm typar.Range @@ -11188,7 +11188,7 @@ and TcNormalizedBinding declKind (cenv: cenv) env tpenv overallTy safeThisValOpt checkAttributeInMeasure rangeType | _ -> () - checkAttributeInMeasure overallExprTy + checkAttributeInMeasure overallTy if supportEnforceAttributeTargets then TcAttributeTargetsOnLetBindings { cenv with tcSink = TcResultsSink.NoSink } env attrs overallPatTy overallExprTy (not declaredTypars.IsEmpty) isClassLetBinding diff --git a/src/Compiler/TypedTree/TypedTree.fs b/src/Compiler/TypedTree/TypedTree.fs index c7f719ad815..11ff117cc25 100644 --- a/src/Compiler/TypedTree/TypedTree.fs +++ b/src/Compiler/TypedTree/TypedTree.fs @@ -4571,7 +4571,7 @@ type Measure = | One of range: range /// Raising a measure to a rational power - | RationalPower of measure: Measure * power: Rational * range: range + | RationalPower of measure: Measure * power: Rational // %+A formatting is used, so this is not needed //[] @@ -4586,7 +4586,7 @@ type Measure = | Prod(range= m) -> m | Inv(m) -> m.Range | One(range= m) -> m - | RationalPower(range= m) -> m + | RationalPower(measure= ms) -> ms.Range type Attribs = Attrib list diff --git a/src/Compiler/TypedTree/TypedTree.fsi b/src/Compiler/TypedTree/TypedTree.fsi index d3afecb539e..82a0a8d84c4 100644 --- a/src/Compiler/TypedTree/TypedTree.fsi +++ b/src/Compiler/TypedTree/TypedTree.fsi @@ -3214,7 +3214,7 @@ type Measure = | One of range: range /// Raising a measure to a rational power - | RationalPower of measure: Measure * power: Rational * range: range + | RationalPower of measure: Measure * power: Rational override ToString: unit -> string diff --git a/src/Compiler/TypedTree/TypedTreeOps.fs b/src/Compiler/TypedTree/TypedTreeOps.fs index 9aacff50a01..c402a8a8444 100644 --- a/src/Compiler/TypedTree/TypedTreeOps.fs +++ b/src/Compiler/TypedTree/TypedTreeOps.fs @@ -234,7 +234,7 @@ and remapMeasureAux tyenv unt = | Some tcref -> Measure.Const(tcref, m) | None -> unt | Measure.Prod(u1, u2, m) -> Measure.Prod(remapMeasureAux tyenv u1, remapMeasureAux tyenv u2, m) - | Measure.RationalPower(u, q, m) -> Measure.RationalPower(remapMeasureAux tyenv u, q, m) + | Measure.RationalPower(u, q) -> Measure.RationalPower(remapMeasureAux tyenv u, q) | Measure.Inv u -> Measure.Inv(remapMeasureAux tyenv u) | Measure.Var(typar= tp) as unt -> match tp.Solution with @@ -539,7 +539,7 @@ let ListMeasureConOccsAfterRemapping g r unt = let MeasurePower u n = if n = 1 then u elif n = 0 then Measure.One(range0) - else Measure.RationalPower (u, intToRational n, range0) + else Measure.RationalPower (u, intToRational n) let MeasureProdOpt m1 m2 = match m1, m2 with @@ -580,22 +580,23 @@ let normalizeMeasure g ms = let vs = ListMeasureVarOccsWithNonZeroExponents ms let cs = ListMeasureConOccsWithNonZeroExponents g false ms match vs, cs with - | [], [] -> Measure.One(range0) + | [], [] -> Measure.One(ms.Range) | [(v, e)], [] when e = OneRational -> Measure.Var(v) | vs, cs -> List.foldBack (fun (v, e) -> fun unt -> let measureVar = Measure.Var(v) - let measureRational = Measure.RationalPower(measureVar, e, measureVar.Range) - Measure.Prod(measureRational, unt, unionRanges measureVar.Range unt.Range)) + let measureRational = Measure.RationalPower(measureVar, e) + Measure.Prod(measureRational, unt, unionRanges measureRational.Range unt.Range)) vs (List.foldBack (fun (c, e) -> fun unt -> let measureConst = Measure.Const(c, c.Range) - let measureRational = Measure.RationalPower(measureConst, e, measureConst.Range) - Measure.Prod(measureRational, unt, range0)) cs (Measure.One(range0))) + let measureRational = Measure.RationalPower(measureConst, e) + let prodM = unionRanges measureConst.Range unt.Range + Measure.Prod(measureRational, unt, prodM)) cs (Measure.One(ms.Range))) let tryNormalizeMeasureInType g ty = match ty with diff --git a/src/Compiler/TypedTree/TypedTreePickle.fs b/src/Compiler/TypedTree/TypedTreePickle.fs index a97c1e0e9a3..e92e73157c7 100644 --- a/src/Compiler/TypedTree/TypedTreePickle.fs +++ b/src/Compiler/TypedTree/TypedTreePickle.fs @@ -1594,7 +1594,7 @@ let rec u_measure_expr st = | 2 -> let a, b = u_tup2 u_measure_expr u_measure_expr st in Measure.Prod (a, b, range0) | 3 -> let a = u_tpref st in Measure.Var(a) | 4 -> Measure.One(range0) - | 5 -> let a = u_measure_expr st in let b = u_rational st in Measure.RationalPower (a, b, range0) + | 5 -> let a = u_measure_expr st in let b = u_rational st in Measure.RationalPower (a, b) | _ -> ufailwith st "u_measure_expr" let p_tyar_constraint x st = From 61fed85f8da3160dea4a59e694ae0ec7430c83df Mon Sep 17 00:00:00 2001 From: Edgar Gonzalez Date: Fri, 3 Jan 2025 14:47:05 +0000 Subject: [PATCH 09/20] Update CheckDeclarations --- src/Compiler/Checking/CheckDeclarations.fs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index 3863ad320ed..59dfcea415d 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/src/Compiler/Checking/CheckDeclarations.fs @@ -3266,10 +3266,10 @@ module EstablishTypeDefinitionCores = checkAttribs ms2 ms2.Range | Measure.Var(typar) -> checkAttribs tm typar.Range | TType_tuple(elementTypes= elementTypes) -> elementTypes |> List.iter checkAttributeInMeasure - | TType_var(typar={typar_solution = Some(typeApp) }) -> checkAttributeInMeasure typeApp - | TType_fun(domainType = domainType; rangeType= rangeType) -> - checkAttributeInMeasure domainType - checkAttributeInMeasure rangeType + | TType_var(typar={typar_solution = Some(typeApp) }) -> checkAttributeInMeasure typeApp + | TType_fun(domainType = domainType; rangeType= rangeType) -> + checkAttributeInMeasure domainType + checkAttributeInMeasure rangeType | _ -> () checkAttributeAliased ty tycon g.attrib_AutoOpenAttribute From 7a5fcdb1400dd19593f722b10033f57b0afc8b11 Mon Sep 17 00:00:00 2001 From: Edgar Gonzalez Date: Fri, 3 Jan 2025 21:39:29 +0000 Subject: [PATCH 10/20] Use better ranges --- src/Compiler/Checking/ConstraintSolver.fs | 4 ++-- .../Checking/Expressions/CheckExpressions.fs | 10 +++++----- src/Compiler/SyntaxTree/SyntaxTree.fs | 12 ++++++++++++ src/Compiler/SyntaxTree/SyntaxTree.fsi | 2 ++ 4 files changed, 21 insertions(+), 7 deletions(-) diff --git a/src/Compiler/Checking/ConstraintSolver.fs b/src/Compiler/Checking/ConstraintSolver.fs index 0f374065921..9fb67823da1 100644 --- a/src/Compiler/Checking/ConstraintSolver.fs +++ b/src/Compiler/Checking/ConstraintSolver.fs @@ -761,7 +761,7 @@ let UnifyMeasureWithOne (csenv: ConstraintSolverEnv) trace ms = match FindPreferredTypar nonRigidVars with | (v, e) :: vs -> let unexpandedCons = ListMeasureConOccsWithNonZeroExponents csenv.g false ms - let newms = ProdMeasures (List.map (fun (c, e') -> Measure.RationalPower(Measure.Const(c, c.Range), NegRational (DivRational e' e))) unexpandedCons + let newms = ProdMeasures (List.map (fun (c, e') -> Measure.RationalPower(Measure.Const(c, ms.Range), NegRational (DivRational e' e))) unexpandedCons @ List.map (fun (v, e') -> Measure.RationalPower (Measure.Var(v), NegRational (DivRational e' e))) (vs @ rigidVars)) SubstMeasureWarnIfRigid csenv trace v newms @@ -792,7 +792,7 @@ let SimplifyMeasure g vars ms = let newms = ProdMeasures [ for (c, e') in nonZeroCon do - Measure.RationalPower (Measure.Const(c, c.Range), NegRational (DivRational e' e)) + Measure.RationalPower (Measure.Const(c, ms.Range), NegRational (DivRational e' e)) for (v', e') in nonZeroVar do if typarEq v v' then newvarExpr diff --git a/src/Compiler/Checking/Expressions/CheckExpressions.fs b/src/Compiler/Checking/Expressions/CheckExpressions.fs index 564879f47c2..4831d71b860 100644 --- a/src/Compiler/Checking/Expressions/CheckExpressions.fs +++ b/src/Compiler/Checking/Expressions/CheckExpressions.fs @@ -804,21 +804,21 @@ let TcConst (cenv: cenv) (overallTy: TType) m env synConst = let _, tcref, _ = ForceRaise(ResolveTypeLongIdent cenv.tcSink cenv.nameResolver ItemOccurrence.Use OpenQualified env.eNameResEnv ad tc TypeNameResolutionStaticArgsInfo.DefiniteEmpty PermitDirectReferenceToGeneratedType.No) match tcref.TypeOrMeasureKind with | TyparKind.Type -> error(Error(FSComp.SR.tcExpectedUnitOfMeasureNotType(), m)) - | TyparKind.Measure -> Measure.Const(tcref, m) + | TyparKind.Measure -> Measure.Const(tcref, ms.Range) | SynMeasure.Power(measure = ms; power = exponent; range= m) -> Measure.RationalPower (tcMeasure ms, TcSynRationalConst exponent) | SynMeasure.Product(measure1 = ms1; measure2 = ms2; range= m) -> Measure.Prod(tcMeasure ms1, tcMeasure ms2, m) | SynMeasure.Divide(ms1, _, (SynMeasure.Seq (_ :: _ :: _, _) as ms2), m) -> warning(Error(FSComp.SR.tcImplicitMeasureFollowingSlash(), m)) let factor1 = ms1 |> Option.defaultValue (SynMeasure.One Range.Zero) - Measure.Prod(tcMeasure factor1, Measure.Inv (tcMeasure ms2), m) + Measure.Prod(tcMeasure factor1, Measure.Inv (tcMeasure ms2), ms.Range) | SynMeasure.Divide(measure1 = ms1; measure2 = ms2; range= m) -> let factor1 = ms1 |> Option.defaultValue (SynMeasure.One Range.Zero) - Measure.Prod(tcMeasure factor1, Measure.Inv (tcMeasure ms2), m) + Measure.Prod(tcMeasure factor1, Measure.Inv (tcMeasure ms2), ms.Range) | SynMeasure.Seq(mss, _) -> ProdMeasures (List.map tcMeasure mss) | SynMeasure.Anon _ -> error(Error(FSComp.SR.tcUnexpectedMeasureAnon(), m)) - | SynMeasure.Var(_, m) -> error(Error(FSComp.SR.tcNonZeroConstantCannotHaveGenericUnit(), m)) - | SynMeasure.Paren(measure, _) -> tcMeasure measure + | SynMeasure.Var(range= m) -> error(Error(FSComp.SR.tcNonZeroConstantCannotHaveGenericUnit(), m)) + | SynMeasure.Paren(measure= measure) -> tcMeasure measure let unif expectedTy = UnifyTypes cenv env m overallTy expectedTy diff --git a/src/Compiler/SyntaxTree/SyntaxTree.fs b/src/Compiler/SyntaxTree/SyntaxTree.fs index 8977e8fba6b..bd918e8848a 100644 --- a/src/Compiler/SyntaxTree/SyntaxTree.fs +++ b/src/Compiler/SyntaxTree/SyntaxTree.fs @@ -202,6 +202,18 @@ type SynMeasure = | Paren of measure: SynMeasure * range: range + member x.Range = + match x with + | SynMeasure.Named(range = m) + | SynMeasure.Product(range = m) + | SynMeasure.Seq(range = m) + | SynMeasure.Divide(range = m) + | SynMeasure.Power(range = m) + | SynMeasure.One(range = m) + | SynMeasure.Anon(range = m) + | SynMeasure.Var(range = m) + | SynMeasure.Paren(range = m) -> m + [] type SynRationalConst = diff --git a/src/Compiler/SyntaxTree/SyntaxTree.fsi b/src/Compiler/SyntaxTree/SyntaxTree.fsi index 654a3971175..f50adfa289d 100644 --- a/src/Compiler/SyntaxTree/SyntaxTree.fsi +++ b/src/Compiler/SyntaxTree/SyntaxTree.fsi @@ -213,6 +213,8 @@ type SynMeasure = /// A parenthesized measure | Paren of measure: SynMeasure * range: range + member Range: range + /// Represents an unchecked syntax tree of F# unit of measure exponents. [] type SynRationalConst = From 1774bec9665145d32287f9be7a46128654a12c96 Mon Sep 17 00:00:00 2001 From: Edgar Gonzalez Date: Fri, 3 Jan 2025 22:12:30 +0000 Subject: [PATCH 11/20] More tests --- .../ObsoleteAttributeCheckingTests.fs | 27 +++++++++++++++++++ 1 file changed, 27 insertions(+) diff --git a/tests/FSharp.Compiler.ComponentTests/Language/ObsoleteAttributeCheckingTests.fs b/tests/FSharp.Compiler.ComponentTests/Language/ObsoleteAttributeCheckingTests.fs index 3962179b396..4c32cfbf12f 100644 --- a/tests/FSharp.Compiler.ComponentTests/Language/ObsoleteAttributeCheckingTests.fs +++ b/tests/FSharp.Compiler.ComponentTests/Language/ObsoleteAttributeCheckingTests.fs @@ -186,6 +186,29 @@ let myCm = 3 |> withDiagnostics [ (Warning 44, Line 10, Col 14, Line 10, Col 16, "This construct is deprecated. Use cm2") ] + + [] + let ``Obsolete attribute warning taken into account when used within a complex unit of measure. Define conversion constants.`` () = + Fsx """ +open System + +[] +type m + +[] +type cm + +let cmPerMeter : float = 100.0 +let mPerCm = 0.01 + """ + |> typecheck + |> shouldFail + |> withDiagnostics [ + (Warning 44, Line 10, Col 24, Line 10, Col 26, "This construct is deprecated. Use cm2") + (Warning 44, Line 10, Col 27, Line 10, Col 28, "This construct is deprecated. Use m2") + (Warning 44, Line 11, Col 19, Line 11, Col 20, "This construct is deprecated. Use m2") + (Warning 44, Line 11, Col 21, Line 11, Col 23, "This construct is deprecated. Use cm2") + ] [] let ``Obsolete attribute warning taken into account when used with a complex(multiple obsolete) unit of measure`` () = @@ -293,6 +316,9 @@ type MyClass() = member this.GenericSumUnits4 (x: float, y: float) = () member this.GenericSumUnits5 (x: float, y: float, z: float) = () + +type A<[] 'u>(x: int) = + member _.X = x """ |> typecheck |> shouldFail @@ -323,6 +349,7 @@ type MyClass() = (Warning 44, Line 36, Col 44, Line 36, Col 45, "This construct is deprecated. Use m2") (Warning 44, Line 36, Col 57, Line 36, Col 58, "This construct is deprecated. Use s2") (Warning 44, Line 36, Col 70, Line 36, Col 71, "This construct is deprecated. Use m2") + (Warning 44, Line 38, Col 31, Line 38, Col 32, "This construct is deprecated. Use m2") ] [] From 7c71c9c02f353ac55fbfc5f4d4b857155f9798f6 Mon Sep 17 00:00:00 2001 From: Edgar Gonzalez Date: Fri, 3 Jan 2025 22:22:27 +0000 Subject: [PATCH 12/20] Update SurfaceArea --- .../FSharp.Compiler.Service.SurfaceArea.netstandard20.debug.bsl | 2 ++ ...Sharp.Compiler.Service.SurfaceArea.netstandard20.release.bsl | 2 ++ 2 files changed, 4 insertions(+) diff --git a/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.debug.bsl b/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.debug.bsl index db4105530c8..42c319c8236 100644 --- a/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.debug.bsl +++ b/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.debug.bsl @@ -8040,6 +8040,8 @@ FSharp.Compiler.Syntax.SynMeasure: FSharp.Compiler.Syntax.SynMeasure+Product FSharp.Compiler.Syntax.SynMeasure: FSharp.Compiler.Syntax.SynMeasure+Seq FSharp.Compiler.Syntax.SynMeasure: FSharp.Compiler.Syntax.SynMeasure+Tags FSharp.Compiler.Syntax.SynMeasure: FSharp.Compiler.Syntax.SynMeasure+Var +FSharp.Compiler.Syntax.SynMeasure: FSharp.Compiler.Text.Range Range +FSharp.Compiler.Syntax.SynMeasure: FSharp.Compiler.Text.Range get_Range() FSharp.Compiler.Syntax.SynMeasure: Int32 Tag FSharp.Compiler.Syntax.SynMeasure: Int32 get_Tag() FSharp.Compiler.Syntax.SynMeasure: System.String ToString() diff --git a/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.release.bsl b/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.release.bsl index db4105530c8..42c319c8236 100644 --- a/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.release.bsl +++ b/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.release.bsl @@ -8040,6 +8040,8 @@ FSharp.Compiler.Syntax.SynMeasure: FSharp.Compiler.Syntax.SynMeasure+Product FSharp.Compiler.Syntax.SynMeasure: FSharp.Compiler.Syntax.SynMeasure+Seq FSharp.Compiler.Syntax.SynMeasure: FSharp.Compiler.Syntax.SynMeasure+Tags FSharp.Compiler.Syntax.SynMeasure: FSharp.Compiler.Syntax.SynMeasure+Var +FSharp.Compiler.Syntax.SynMeasure: FSharp.Compiler.Text.Range Range +FSharp.Compiler.Syntax.SynMeasure: FSharp.Compiler.Text.Range get_Range() FSharp.Compiler.Syntax.SynMeasure: Int32 Tag FSharp.Compiler.Syntax.SynMeasure: Int32 get_Tag() FSharp.Compiler.Syntax.SynMeasure: System.String ToString() From 106550db6b40b305a94b1935a09527401f506288 Mon Sep 17 00:00:00 2001 From: Edgar Gonzalez Date: Sat, 4 Jan 2025 11:46:15 +0000 Subject: [PATCH 13/20] Reduce diff in ConstraintSolver.fs --- src/Compiler/Checking/ConstraintSolver.fs | 32 +++++++++++------------ 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/src/Compiler/Checking/ConstraintSolver.fs b/src/Compiler/Checking/ConstraintSolver.fs index 9fb67823da1..6ed62ddae0e 100644 --- a/src/Compiler/Checking/ConstraintSolver.fs +++ b/src/Compiler/Checking/ConstraintSolver.fs @@ -730,12 +730,12 @@ let SubstMeasureWarnIfRigid (csenv: ConstraintSolverEnv) trace (v: Typar) ms = let tpnmOpt = if v.IsCompilerGenerated then None else Some v.Name do! SolveTypStaticReq csenv trace v.StaticReq (TType_measure ms) SubstMeasure v ms - return! WarnD(NonRigidTypar(csenv.DisplayEnv, tpnmOpt, v.Range, TType_measure (Measure.Var(v)), TType_measure ms, csenv.m)) + return! WarnD(NonRigidTypar(csenv.DisplayEnv, tpnmOpt, v.Range, TType_measure (Measure.Var v), TType_measure ms, csenv.m)) else // Propagate static requirements from 'tp' to 'ty' do! SolveTypStaticReq csenv trace v.StaticReq (TType_measure ms) SubstMeasure v ms - if v.Rigidity = TyparRigidity.Anon && measureEquiv csenv.g ms (Measure.One(ms.Range)) then + if v.Rigidity = TyparRigidity.Anon && measureEquiv csenv.g ms (Measure.One ms.Range) then return! WarnD(Error(FSComp.SR.csCodeLessGeneric(), v.Range)) else () @@ -762,12 +762,12 @@ let UnifyMeasureWithOne (csenv: ConstraintSolverEnv) trace ms = | (v, e) :: vs -> let unexpandedCons = ListMeasureConOccsWithNonZeroExponents csenv.g false ms let newms = ProdMeasures (List.map (fun (c, e') -> Measure.RationalPower(Measure.Const(c, ms.Range), NegRational (DivRational e' e))) unexpandedCons - @ List.map (fun (v, e') -> Measure.RationalPower (Measure.Var(v), NegRational (DivRational e' e))) (vs @ rigidVars)) + @ List.map (fun (v, e') -> Measure.RationalPower (Measure.Var v, NegRational (DivRational e' e))) (vs @ rigidVars)) SubstMeasureWarnIfRigid csenv trace v newms // Otherwise we require ms to be 1 - | [] -> if measureEquiv csenv.g ms (Measure.One(ms.Range)) then CompleteD else localAbortD + | [] -> if measureEquiv csenv.g ms (Measure.One ms.Range) then CompleteD else localAbortD /// Imperatively unify unit-of-measure expression ms1 against ms2 let UnifyMeasures (csenv: ConstraintSolverEnv) trace ms1 ms2 = @@ -786,7 +786,7 @@ let SimplifyMeasure g vars ms = let newvar = if v.IsCompilerGenerated then NewAnonTypar (TyparKind.Measure, v.Range, TyparRigidity.Flexible, v.StaticReq, v.DynamicReq) else NewNamedInferenceMeasureVar (v.Range, TyparRigidity.Flexible, v.StaticReq, v.Id) let remainingvars = ListSet.remove typarEq v vars - let newvarExpr = if SignRational e < 0 then Measure.Inv (Measure.Var(newvar)) else Measure.Var(newvar) + let newvarExpr = if SignRational e < 0 then Measure.Inv (Measure.Var newvar) else Measure.Var newvar let nonZeroCon = ListMeasureConOccsWithNonZeroExponents g false ms let nonZeroVar = ListMeasureVarOccsWithNonZeroExponents ms let newms = @@ -797,7 +797,7 @@ let SimplifyMeasure g vars ms = if typarEq v v' then newvarExpr else - Measure.RationalPower (Measure.Var(v'), NegRational (DivRational e' e)) + Measure.RationalPower (Measure.Var v', NegRational (DivRational e' e)) ] SubstMeasure v newms match vs with @@ -881,7 +881,7 @@ let NormalizeExponentsInTypeScheme uvars ty = v else let v' = NewAnonTypar (TyparKind.Measure, v.Range, TyparRigidity.Flexible, v.StaticReq, v.DynamicReq) - SubstMeasure v (Measure.RationalPower (Measure.Var(v'), DivRational OneRational expGcd)) + SubstMeasure v (Measure.RationalPower (Measure.Var v', DivRational OneRational expGcd)) v') // We normalize unit-of-measure-polymorphic type schemes. There @@ -923,7 +923,7 @@ let SimplifyMeasuresInTypeScheme g resultFirst (generalizable: Typar list) ty co let generalized' = NormalizeExponentsInTypeScheme generalized ty vars @ List.rev generalized' -let freshMeasure () = Measure.Var(NewInferenceMeasurePar ()) +let freshMeasure () = Measure.Var (NewInferenceMeasurePar ()) let CheckWarnIfRigid (csenv: ConstraintSolverEnv) ty1 (r: Typar) ty = let g = csenv.g @@ -1113,7 +1113,7 @@ and SolveTyparEqualsType (csenv: ConstraintSolverEnv) ndeep m2 (trace: OptionalT do! DepthCheck ndeep m match ty1 with | TType_var (r, _) - | TType_measure (Measure.Var(r)) -> + | TType_measure (Measure.Var r) -> do! SolveTyparEqualsTypePart1 csenv m2 trace ty1 r ty do! SolveTyparEqualsTypePart2 csenv ndeep m2 trace r ty | _ -> failwith "SolveTyparEqualsType" @@ -1126,7 +1126,7 @@ and SolveTyparsEqualTypes (csenv: ConstraintSolverEnv) ndeep m2 (trace: Optional fun tpTy ty -> match tpTy with | TType_var (r, _) - | TType_measure (Measure.Var(r)) -> + | TType_measure (Measure.Var r) -> SolveTyparEqualsTypePart1 csenv m2 trace tpTy r ty | _ -> failwith "SolveTyparsEqualTypes") tpTys tys @@ -1330,13 +1330,13 @@ and SolveTypeEqualsType (csenv: ConstraintSolverEnv) ndeep m2 (trace: OptionalTr // Catch float<_>=float<1>, float32<_>=float32<1> and decimal<_>=decimal<1> | (_, TType_app (tc2, [ms2], _)) when (tc2.IsMeasureableReprTycon && typeEquiv csenv.g sty1 (reduceTyconRefMeasureableOrProvided csenv.g tc2 [ms2])) -> trackErrors { - do! SolveTypeEqualsType csenv ndeep m2 trace None (TType_measure(Measure.One(m2))) ms2 + do! SolveTypeEqualsType csenv ndeep m2 trace None (TType_measure(Measure.One m2)) ms2 do! SolveNullnessEquiv csenv m2 trace ty1 ty2 (nullnessOfTy g sty1) (nullnessOfTy g sty2) } | (TType_app (tc1, [ms1], _), _) when (tc1.IsMeasureableReprTycon && typeEquiv csenv.g sty2 (reduceTyconRefMeasureableOrProvided csenv.g tc1 [ms1])) -> trackErrors { - do! SolveTypeEqualsType csenv ndeep m2 trace None ms1 (TType_measure(Measure.One(m2))) + do! SolveTypeEqualsType csenv ndeep m2 trace None ms1 (TType_measure(Measure.One m2)) do! SolveNullnessEquiv csenv m2 trace ty1 ty2 (nullnessOfTy g sty1) (nullnessOfTy g sty2) } @@ -1519,13 +1519,13 @@ and SolveTypeSubsumesType (csenv: ConstraintSolverEnv) ndeep m2 (trace: Optional // Enforce the identities float=float<1>, float32=float32<1> and decimal=decimal<1> | _, TType_app (tc2, [ms2], _) when tc2.IsMeasureableReprTycon && typeEquiv csenv.g sty1 (reduceTyconRefMeasureableOrProvided csenv.g tc2 [ms2]) -> trackErrors { - do! SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 trace cxsln ms2 (TType_measure(Measure.One(m2))) + do! SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 trace cxsln ms2 (TType_measure(Measure.One m2)) do! SolveNullnessSubsumesNullness csenv m2 trace ty1 ty2 (nullnessOfTy g sty1) (nullnessOfTy g sty2) } | TType_app (tc1, [ms1], _), _ when tc1.IsMeasureableReprTycon && typeEquiv csenv.g sty2 (reduceTyconRefMeasureableOrProvided csenv.g tc1 [ms1]) -> trackErrors { - do! SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 trace cxsln ms1 (TType_measure(Measure.One(m2))) + do! SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 trace cxsln ms1 (TType_measure(Measure.One m2)) do! SolveNullnessSubsumesNullness csenv m2 trace ty1 ty2 (nullnessOfTy g sty1) (nullnessOfTy g sty2) } @@ -1621,7 +1621,7 @@ and DepthCheck ndeep m = and SolveDimensionlessNumericType (csenv: ConstraintSolverEnv) ndeep m2 trace ty = match getMeasureOfType csenv.g ty with | Some (tcref, _) -> - SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace ty (mkWoNullAppTy tcref [TType_measure(Measure.One(m2))]) + SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace ty (mkWoNullAppTy tcref [TType_measure(Measure.One m2)]) | None -> CompleteD @@ -1924,7 +1924,7 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argTy2 argTy1 match getMeasureOfType g argTy1 with | None -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace retTy argTy1 - | Some (tcref, _) -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace retTy (mkWoNullAppTy tcref [TType_measure(Measure.One(tcref.Range))]) + | Some (tcref, ms) -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace retTy (mkWoNullAppTy tcref [TType_measure(Measure.One ms.Range)]) return TTraitBuiltIn | _ -> From 1e3a8cdf681706cf954bb437d9f73388646fc6e6 Mon Sep 17 00:00:00 2001 From: Edgar Gonzalez Date: Sat, 4 Jan 2025 13:17:22 +0000 Subject: [PATCH 14/20] Reduce diff --- .../Checking/Expressions/CheckExpressions.fs | 23 ++++++++++--------- src/Compiler/Checking/NameResolution.fs | 2 +- src/Compiler/Checking/PostInferenceChecks.fs | 2 -- src/Compiler/Checking/TypeRelations.fs | 4 ++-- src/Compiler/Checking/import.fs | 3 +-- src/Compiler/Service/ItemKey.fs | 2 +- src/Compiler/Symbols/Symbols.fs | 2 +- src/Compiler/TypedTree/TypedTreeBasics.fs | 6 ++--- src/Compiler/TypedTree/TypedTreeOps.fs | 14 +++++------ src/Compiler/TypedTree/TypedTreePickle.fs | 4 ++-- 10 files changed, 30 insertions(+), 32 deletions(-) diff --git a/src/Compiler/Checking/Expressions/CheckExpressions.fs b/src/Compiler/Checking/Expressions/CheckExpressions.fs index 4831d71b860..9d8e96bb3ee 100644 --- a/src/Compiler/Checking/Expressions/CheckExpressions.fs +++ b/src/Compiler/Checking/Expressions/CheckExpressions.fs @@ -806,7 +806,7 @@ let TcConst (cenv: cenv) (overallTy: TType) m env synConst = | TyparKind.Type -> error(Error(FSComp.SR.tcExpectedUnitOfMeasureNotType(), m)) | TyparKind.Measure -> Measure.Const(tcref, ms.Range) - | SynMeasure.Power(measure = ms; power = exponent; range= m) -> Measure.RationalPower (tcMeasure ms, TcSynRationalConst exponent) + | SynMeasure.Power(measure = ms; power = exponent) -> Measure.RationalPower (tcMeasure ms, TcSynRationalConst exponent) | SynMeasure.Product(measure1 = ms1; measure2 = ms2; range= m) -> Measure.Prod(tcMeasure ms1, tcMeasure ms2, m) | SynMeasure.Divide(ms1, _, (SynMeasure.Seq (_ :: _ :: _, _) as ms2), m) -> warning(Error(FSComp.SR.tcImplicitMeasureFollowingSlash(), m)) @@ -826,10 +826,10 @@ let TcConst (cenv: cenv) (overallTy: TType) m env synConst = let measureTy = match synConst with | SynConst.Measure(synMeasure = SynMeasure.Anon _) -> - (mkWoNullAppTy tcr [TType_measure (Measure.Var(NewAnonTypar (TyparKind.Measure, m, TyparRigidity.Anon, (if iszero then TyparStaticReq.None else TyparStaticReq.HeadType), TyparDynamicReq.No)))]) + (mkWoNullAppTy tcr [TType_measure (Measure.Var (NewAnonTypar (TyparKind.Measure, m, TyparRigidity.Anon, (if iszero then TyparStaticReq.None else TyparStaticReq.HeadType), TyparDynamicReq.No)))]) | SynConst.Measure(synMeasure = ms) -> mkWoNullAppTy tcr [TType_measure (tcMeasure ms)] - | _ -> mkWoNullAppTy tcr [TType_measure(Measure.One(m))] + | _ -> mkWoNullAppTy tcr [TType_measure(Measure.One m)] unif measureTy let expandedMeasurablesEnabled = @@ -4662,14 +4662,14 @@ and TcArrayType (cenv: cenv) newOk checkConstraints occ env tpenv rank elemTy m and TcTypeParameter kindOpt (cenv: cenv) env newOk tpenv tp = let tpR, tpenv = TcTypeOrMeasureParameter kindOpt cenv env newOk tpenv tp match tpR.Kind with - | TyparKind.Measure -> TType_measure (Measure.Var(tpR)), tpenv + | TyparKind.Measure -> TType_measure (Measure.Var tpR), tpenv | TyparKind.Type -> mkTyparTy tpR, tpenv // _ types and TcAnonType kindOpt (cenv: cenv) newOk tpenv m = let tp: Typar = TcAnonTypeOrMeasure kindOpt cenv TyparRigidity.Anon TyparDynamicReq.No newOk m match tp.Kind with - | TyparKind.Measure -> TType_measure (Measure.Var(tp)), tpenv + | TyparKind.Measure -> TType_measure (Measure.Var tp), tpenv | TyparKind.Type -> mkTyparTy tp, tpenv and TcTypeWithConstraints (cenv: cenv) env newOk checkConstraints occ tpenv synTy synConstraints = @@ -4715,7 +4715,7 @@ and TcTypeStaticConstant kindOpt tpenv c m = errorR(Error(FSComp.SR.parsInvalidLiteralInType(), m)) NewErrorType (), tpenv | SynConst.Int32 1, _ -> - TType_measure (Measure.One(m)), tpenv + TType_measure (Measure.One m), tpenv | _ -> errorR(Error(FSComp.SR.parsInvalidLiteralInType(), m)) NewErrorType (), tpenv @@ -4736,7 +4736,7 @@ and TcTypeMeasureApp kindOpt (cenv: cenv) newOk checkConstraints occ env tpenv a | (None | Some TyparKind.Measure), [arg2], true -> let ms1, tpenv = TcMeasure cenv newOk checkConstraints occ env tpenv arg1 m1 let ms2, tpenv = TcMeasure cenv newOk checkConstraints occ env tpenv arg2 m - TType_measure (Measure.Prod(ms1, ms2, m)), tpenv + TType_measure (Measure.Prod(ms1, ms2, unionRanges ms1.Range ms2.Range)), tpenv | _ -> errorR(Error(FSComp.SR.tcTypeParameterInvalidAsTypeConstructor(), m)) @@ -4810,12 +4810,13 @@ and TcMeasuresAsTuple (cenv: cenv) newOk checkConstraints occ env (tpenv: Unscop gather args tpenv ms1 | SynTupleTypeSegment.Star _ :: SynTupleTypeSegment.Type ty :: args -> let ms1, tpenv = TcMeasure cenv newOk checkConstraints occ env tpenv ty m - gather args tpenv (Measure.Prod(acc, ms1, m)) + gather args tpenv (Measure.Prod(acc, ms1, unionRanges acc.Range ms1.Range)) | SynTupleTypeSegment.Slash _ :: SynTupleTypeSegment.Type ty :: args -> let ms1, tpenv = TcMeasure cenv newOk checkConstraints occ env tpenv ty m - gather args tpenv (Measure.Prod(acc, Measure.Inv ms1, m)) + let ms2 = Measure.Inv ms1 + gather args tpenv (Measure.Prod(acc, ms2, unionRanges acc.Range ms2.Range)) | _ -> failwith "impossible" - gather args tpenv (Measure.One(m)) + gather args tpenv (Measure.One m) and TcTypesOrMeasures optKinds (cenv: cenv) newOk checkConstraints occ env tpenv args m = match optKinds with @@ -5043,7 +5044,7 @@ and TcTypeApp (cenv: cenv) newOk checkConstraints occ env tpenv m tcref pathType let tps = tinst |> List.skip pathTypeArgsLength |> List.map (fun t -> match t with | TType_var(typar, _) - | TType_measure(Measure.Var(typar= typar)) -> typar + | TType_measure(Measure.Var typar) -> typar | t -> failwith $"TcTypeApp: {t}" ) diff --git a/src/Compiler/Checking/NameResolution.fs b/src/Compiler/Checking/NameResolution.fs index 5c641fa6c7f..5b0c9842f77 100644 --- a/src/Compiler/Checking/NameResolution.fs +++ b/src/Compiler/Checking/NameResolution.fs @@ -1586,7 +1586,7 @@ let NewErrorType () = mkTyparTy (NewErrorTypar ()) let NewErrorMeasure () = - Measure.Var((NewErrorMeasureVar ())) + Measure.Var (NewErrorMeasureVar ()) let NewByRefKindInferenceType (g: TcGlobals) m = let tp = Construct.NewTypar (TyparKind.Type, TyparRigidity.Flexible, SynTypar(compgenId, TyparStaticReq.HeadType, true), false, TyparDynamicReq.No, [], false, false) diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index f06f661f427..645f43fe3cb 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -7,8 +7,6 @@ module internal FSharp.Compiler.PostTypeCheckSemanticChecks open System open System.Collections.Generic -open FSharp.Compiler.AttributeChecking -open FSharp.Compiler.NameResolution open Internal.Utilities.Collections open Internal.Utilities.Library open Internal.Utilities.Library.Extras diff --git a/src/Compiler/Checking/TypeRelations.fs b/src/Compiler/Checking/TypeRelations.fs index a24b0d13c6e..d180bb778dd 100644 --- a/src/Compiler/Checking/TypeRelations.fs +++ b/src/Compiler/Checking/TypeRelations.fs @@ -176,7 +176,7 @@ let ChooseTyparSolutionAndRange (g: TcGlobals) amap (tp:Typar) = let initialTy = match tp.Kind with | TyparKind.Type -> g.obj_ty_noNulls - | TyparKind.Measure -> TType_measure(Measure.One(m)) + | TyparKind.Measure -> TType_measure(Measure.One m) // Loop through the constraints computing the lub (((initialTy, false), m), tp.Constraints) ||> List.fold (fun ((maxTy, isRefined), _) tpc -> let join m x = @@ -227,7 +227,7 @@ let ChooseTyparSolutionAndRange (g: TcGlobals) amap (tp:Typar) = let ChooseTyparSolution g amap tp = let ty, m = ChooseTyparSolutionAndRange g amap tp - if tp.Rigidity = TyparRigidity.Anon && typeEquiv g ty (TType_measure(Measure.One(m))) then + if tp.Rigidity = TyparRigidity.Anon && typeEquiv g ty (TType_measure(Measure.One m)) then warning(Error(FSComp.SR.csCodeLessGeneric(), tp.Range)) ty diff --git a/src/Compiler/Checking/import.fs b/src/Compiler/Checking/import.fs index 66ba6abe73c..c40fd73b234 100644 --- a/src/Compiler/Checking/import.fs +++ b/src/Compiler/Checking/import.fs @@ -557,8 +557,7 @@ let rec ImportProvidedType (env: ImportMap) (m: range) (* (tinst: TypeInst) *) ( | TType_app (tcref, [ty1;ty2], _) when tyconRefEq g tcref g.measureproduct_tcr -> let ms1: Measure = conv ty1 let ms2: Measure = conv ty2 - let m = unionRanges ms1.Range ms2.Range - Measure.Prod(ms1, ms2, m) + Measure.Prod(ms1, ms2, unionRanges ms1.Range ms2.Range) | TType_app (tcref, [ty1], _) when tyconRefEq g tcref g.measureinverse_tcr -> Measure.Inv (conv ty1) | TType_app (tcref, [], _) when tyconRefEq g tcref g.measureone_tcr -> Measure.One(tcref.Range) | TType_app (tcref, [], _) when tcref.TypeOrMeasureKind = TyparKind.Measure -> Measure.Const(tcref, tcref.Range) diff --git a/src/Compiler/Service/ItemKey.fs b/src/Compiler/Service/ItemKey.fs index 84a2c6b0cc9..49cdda18940 100644 --- a/src/Compiler/Service/ItemKey.fs +++ b/src/Compiler/Service/ItemKey.fs @@ -359,7 +359,7 @@ and [] ItemKeyStoreBuilder(tcGlobals: TcGlobals) = debug.WriteMeasure isStandalone ms match ms with - | Measure.Var(typar = typar) -> + | Measure.Var typar -> writeString ItemKeyTags.typeMeasureVar writeTypar isStandalone typar | Measure.Const(tyconRef = tcref) -> diff --git a/src/Compiler/Symbols/Symbols.fs b/src/Compiler/Symbols/Symbols.fs index 727321af05a..36823f65dc0 100644 --- a/src/Compiler/Symbols/Symbols.fs +++ b/src/Compiler/Symbols/Symbols.fs @@ -2638,7 +2638,7 @@ type FSharpType(cenv, ty:TType) = protect <| fun () -> match stripTyparEqns ty with | TType_var (tp, _) - | TType_measure (Measure.Var(typar= tp)) -> + | TType_measure (Measure.Var tp) -> FSharpGenericParameter (cenv, tp) | _ -> invalidOp "not a generic parameter type" diff --git a/src/Compiler/TypedTree/TypedTreeBasics.fs b/src/Compiler/TypedTree/TypedTreeBasics.fs index d870e8a8a71..582d6767d7e 100644 --- a/src/Compiler/TypedTree/TypedTreeBasics.fs +++ b/src/Compiler/TypedTree/TypedTreeBasics.fs @@ -192,7 +192,7 @@ let KnownWithoutNull = Nullness.Known NullnessInfo.WithoutNull let mkTyparTy (tp:Typar) = match tp.Kind with | TyparKind.Type -> tp.AsType KnownWithoutNull - | TyparKind.Measure -> TType_measure (Measure.Var(tp)) + | TyparKind.Measure -> TType_measure (Measure.Var tp) // For fresh type variables clear the StaticReq when copying because the requirement will be re-established through the // process of type inference. @@ -219,7 +219,7 @@ let tryShortcutSolvedUnitPar canShortcut (r: Typar) = | Some (TType_measure unt) -> if canShortcut then match unt with - | Measure.Var(typar= r2) -> + | Measure.Var r2 -> match r2.Solution with | None -> () | Some _ as soln -> @@ -231,7 +231,7 @@ let tryShortcutSolvedUnitPar canShortcut (r: Typar) = let rec stripUnitEqnsAux canShortcut unt = match unt with - | Measure.Var(typar = r) when r.IsSolved -> stripUnitEqnsAux canShortcut (tryShortcutSolvedUnitPar canShortcut r) + | Measure.Var r when r.IsSolved -> stripUnitEqnsAux canShortcut (tryShortcutSolvedUnitPar canShortcut r) | _ -> unt let combineNullness (nullnessOrig: Nullness) (nullnessNew: Nullness) = diff --git a/src/Compiler/TypedTree/TypedTreeOps.fs b/src/Compiler/TypedTree/TypedTreeOps.fs index c402a8a8444..e2bc362c784 100644 --- a/src/Compiler/TypedTree/TypedTreeOps.fs +++ b/src/Compiler/TypedTree/TypedTreeOps.fs @@ -236,7 +236,7 @@ and remapMeasureAux tyenv unt = | Measure.Prod(u1, u2, m) -> Measure.Prod(remapMeasureAux tyenv u1, remapMeasureAux tyenv u2, m) | Measure.RationalPower(u, q) -> Measure.RationalPower(remapMeasureAux tyenv u, q) | Measure.Inv u -> Measure.Inv(remapMeasureAux tyenv u) - | Measure.Var(typar= tp) as unt -> + | Measure.Var tp as unt -> match tp.Solution with | None -> match ListAssoc.tryFind typarEq tp tyenv.tpinst with @@ -476,7 +476,7 @@ let rec MeasureConExponentAfterRemapping g r ucref unt = /// What is the contribution of unit-of-measure variable tp to unit-of-measure expression unt? let rec MeasureVarExponent tp unt = match stripUnitEqnsFromMeasure unt with - | Measure.Var(typar= tpR) -> if typarEq tp tpR then OneRational else ZeroRational + | Measure.Var tpR -> if typarEq tp tpR then OneRational else ZeroRational | Measure.Inv untR -> NegRational(MeasureVarExponent tp untR) | Measure.Prod(measure1= unt1; measure2= unt2) -> AddRational(MeasureVarExponent tp unt1) (MeasureVarExponent tp unt2) | Measure.RationalPower(measure = untR; power= q) -> MulRational (MeasureVarExponent tp untR) q @@ -486,7 +486,7 @@ let rec MeasureVarExponent tp unt = let ListMeasureVarOccs unt = let rec gather acc unt = match stripUnitEqnsFromMeasure unt with - | Measure.Var(typar= tp) -> if List.exists (typarEq tp) acc then acc else tp :: acc + | Measure.Var tp -> if List.exists (typarEq tp) acc then acc else tp :: acc | Measure.Prod(measure1= unt1; measure2= unt2) -> gather (gather acc unt1) unt2 | Measure.RationalPower(measure= untR) -> gather acc untR | Measure.Inv untR -> gather acc untR @@ -497,7 +497,7 @@ let ListMeasureVarOccs unt = let ListMeasureVarOccsWithNonZeroExponents untexpr = let rec gather acc unt = match stripUnitEqnsFromMeasure unt with - | Measure.Var(typar= tp) -> + | Measure.Var tp -> if List.exists (fun (tpR, _) -> typarEq tp tpR) acc then acc else let e = MeasureVarExponent tp untexpr @@ -545,7 +545,7 @@ let MeasureProdOpt m1 m2 = match m1, m2 with | Measure.One _, _ -> m2 | _, Measure.One _ -> m1 - | _, _ -> Measure.Prod (m1, m2, range0) + | _, _ -> Measure.Prod (m1, m2, unionRanges m1.Range m2.Range) /// Construct a measure expression representing the product of a list of measures let ProdMeasures ms = @@ -581,7 +581,7 @@ let normalizeMeasure g ms = let cs = ListMeasureConOccsWithNonZeroExponents g false ms match vs, cs with | [], [] -> Measure.One(ms.Range) - | [(v, e)], [] when e = OneRational -> Measure.Var(v) + | [(v, e)], [] when e = OneRational -> Measure.Var v | vs, cs -> List.foldBack (fun (v, e) -> @@ -600,7 +600,7 @@ let normalizeMeasure g ms = let tryNormalizeMeasureInType g ty = match ty with - | TType_measure (Measure.Var(typar= v)) -> + | TType_measure (Measure.Var v) -> match v.Solution with | Some (TType_measure ms) -> v.typar_solution <- Some (TType_measure (normalizeMeasure g ms)) diff --git a/src/Compiler/TypedTree/TypedTreePickle.fs b/src/Compiler/TypedTree/TypedTreePickle.fs index e92e73157c7..4f18dad1367 100644 --- a/src/Compiler/TypedTree/TypedTreePickle.fs +++ b/src/Compiler/TypedTree/TypedTreePickle.fs @@ -1540,7 +1540,7 @@ let p_measure_one = p_byte 4 let p_measure_varcon unt st = match unt with | Measure.Const(tyconRef= tcref) -> p_measure_con tcref st - | Measure.Var(typar= v) -> p_measure_var v st + | Measure.Var v -> p_measure_var v st | _ -> pfailwith st "p_measure_varcon: expected measure variable or constructor" // Pickle a positive integer power of a unit-of-measure variable or constructor @@ -1571,7 +1571,7 @@ let rec p_normalized_measure unt st = | Measure.Const(tyconRef= tcref) -> p_measure_con tcref st | Measure.Inv x -> p_byte 1 st; p_normalized_measure x st | Measure.Prod(measure1= x1; measure2= x2) -> p_byte 2 st; p_normalized_measure x1 st; p_normalized_measure x2 st - | Measure.Var(typar= v) -> p_measure_var v st + | Measure.Var v -> p_measure_var v st | Measure.One _ -> p_measure_one st | Measure.RationalPower(measure= x; power= q) -> p_measure_power x q st From 87d772e34723c16debb2e2236c7d858055fd1a20 Mon Sep 17 00:00:00 2001 From: Edgar Gonzalez Date: Sat, 4 Jan 2025 13:18:15 +0000 Subject: [PATCH 15/20] Remove unnecessary bool flag --- src/Compiler/Checking/CheckPatterns.fs | 2 +- .../Checking/Expressions/CheckExpressions.fs | 13 ++++++------- .../Checking/Expressions/CheckExpressions.fsi | 1 - 3 files changed, 7 insertions(+), 9 deletions(-) diff --git a/src/Compiler/Checking/CheckPatterns.fs b/src/Compiler/Checking/CheckPatterns.fs index 487c66b0c8c..5d447da6021 100644 --- a/src/Compiler/Checking/CheckPatterns.fs +++ b/src/Compiler/Checking/CheckPatterns.fs @@ -803,7 +803,7 @@ and TcPatLongIdentLiteral warnOnUpper (cenv: cenv) env vFlags patEnv ty (mLongId match vref.LiteralValue with | None -> error (Error(FSComp.SR.tcNonLiteralCannotBeUsedInPattern(), m)) | Some lit -> - let _, _, _, vexpty, _, _ = TcVal true cenv env tpenv vref None None mLongId + let _, _, _, vexpty, _, _ = TcVal cenv env tpenv vref None None mLongId CheckValAccessible mLongId env.AccessRights vref CheckFSharpAttributes g vref.Attribs mLongId |> CommitOperationResult CheckNoArgsForLiteral args m diff --git a/src/Compiler/Checking/Expressions/CheckExpressions.fs b/src/Compiler/Checking/Expressions/CheckExpressions.fs index 9d8e96bb3ee..99b50fb3fd4 100644 --- a/src/Compiler/Checking/Expressions/CheckExpressions.fs +++ b/src/Compiler/Checking/Expressions/CheckExpressions.fs @@ -2739,7 +2739,7 @@ let TcValEarlyGeneralizationConsistencyCheck (cenv: cenv) (env: TcEnv) (v: Val, /// instantiationInfoOpt is is also set when building the final call for a reference to an /// F# object model member, in which case the instantiationInfoOpt is the type instantiation /// inferred by member overload resolution. -let TcVal checkAttributes (cenv: cenv) env (tpenv: UnscopedTyparEnv) (vref: ValRef) instantiationInfoOpt optAfterResolution m = +let TcVal (cenv: cenv) env (tpenv: UnscopedTyparEnv) (vref: ValRef) instantiationInfoOpt optAfterResolution m = let g = cenv.g let tpsorig, _, _, _, tinst, _ as res = @@ -2749,8 +2749,7 @@ let TcVal checkAttributes (cenv: cenv) env (tpenv: UnscopedTyparEnv) (vref: ValR CheckValAccessible m env.eAccessRights vref - if checkAttributes then - CheckValAttributes g vref m |> CommitOperationResult + CheckValAttributes g vref m |> CommitOperationResult let vTy = vref.Type @@ -3046,7 +3045,7 @@ let BuildPossiblyConditionalMethodCall (cenv: cenv) env isMutable m isProp minfo | _ -> #endif let tcVal valref valUse ttypes m = - let _, exprForVal, _, tau, _, _ = TcVal true cenv env emptyUnscopedTyparEnv valref (Some (valUse, (fun x _ -> ttypes, x))) None m + let _, exprForVal, _, tau, _, _ = TcVal cenv env emptyUnscopedTyparEnv valref (Some (valUse, (fun x _ -> ttypes, x))) None m exprForVal, tau BuildMethodCall tcVal g cenv.amap isMutable m isProp minfo valUseFlags minst objArgs args staticTyOpt @@ -5164,7 +5163,7 @@ and TcPatLongIdentActivePatternCase warnOnUpper (cenv: cenv) (env: TcEnv) vFlags CallNameResolutionSink cenv.tcSink (mLongId, env.NameEnv, item, emptyTyparInst, ItemOccurrence.Pattern, env.eAccessRights) // TOTAL/PARTIAL ACTIVE PATTERNS - let _, vExpr, _, _, tinst, _ = TcVal true cenv env tpenv vref None None m + let _, vExpr, _, _, tinst, _ = TcVal cenv env tpenv vref None None m let vExpr = MakeApplicableExprWithFlex cenv env vExpr let vExprTy = vExpr.Type @@ -9259,7 +9258,7 @@ and TcValueItemThen cenv overallTy env vref tpenv mItem afterResolution delayed error (Error(FSComp.SR.expressionHasNoName(), mExprAndTypeArgs)) | _ -> let checkTys tpenv kinds = TcTypesOrMeasures (Some kinds) cenv NewTyparsOK CheckCxs ItemOccurrence.UseInType env tpenv tys mItem - let _, vExpr, isSpecial, _, _, tpenv = TcVal true cenv env tpenv vref (Some (NormalValUse, checkTys)) (Some afterResolution) mItem + let _, vExpr, isSpecial, _, _, tpenv = TcVal cenv env tpenv vref (Some (NormalValUse, checkTys)) (Some afterResolution) mItem let vexpFlex = (if isSpecial then MakeApplicableExprNoFlex cenv vExpr else MakeApplicableExprWithFlex cenv env vExpr) // We need to eventually record the type resolution for an expression, but this is done @@ -9268,7 +9267,7 @@ and TcValueItemThen cenv overallTy env vref tpenv mItem afterResolution delayed // Value get | _ -> - let _, vExpr, isSpecial, _, _, tpenv = TcVal true cenv env tpenv vref None (Some afterResolution) mItem + let _, vExpr, isSpecial, _, _, tpenv = TcVal cenv env tpenv vref None (Some afterResolution) mItem let vExpr, tpenv = match vExpr with diff --git a/src/Compiler/Checking/Expressions/CheckExpressions.fsi b/src/Compiler/Checking/Expressions/CheckExpressions.fsi index 0e4e17a8f83..ed18b07a58a 100644 --- a/src/Compiler/Checking/Expressions/CheckExpressions.fsi +++ b/src/Compiler/Checking/Expressions/CheckExpressions.fsi @@ -919,7 +919,6 @@ val TcPatLongIdentActivePatternCase: val ConvSynPatToSynExpr: synPat: SynPat -> SynExpr val TcVal: - checkAttributes: bool -> cenv: TcFileState -> env: TcEnv -> tpenv: UnscopedTyparEnv -> From d4a0dda26070542ebf7608ea4c601ff51e45843b Mon Sep 17 00:00:00 2001 From: Edgar Gonzalez Date: Sat, 4 Jan 2025 13:23:00 +0000 Subject: [PATCH 16/20] Reduce diff --- src/Compiler/Checking/ConstraintSolver.fs | 2 +- src/Compiler/Checking/Expressions/CheckExpressions.fs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Compiler/Checking/ConstraintSolver.fs b/src/Compiler/Checking/ConstraintSolver.fs index 6ed62ddae0e..82141080743 100644 --- a/src/Compiler/Checking/ConstraintSolver.fs +++ b/src/Compiler/Checking/ConstraintSolver.fs @@ -1134,7 +1134,7 @@ and SolveTyparsEqualTypes (csenv: ConstraintSolverEnv) ndeep m2 (trace: Optional fun tpTy ty -> match tpTy with | TType_var (r, _) - | TType_measure (Measure.Var(r)) -> + | TType_measure (Measure.Var r) -> SolveTyparEqualsTypePart2 csenv ndeep m2 trace r ty | _ -> failwith "SolveTyparsEqualTypes") tpTys tys diff --git a/src/Compiler/Checking/Expressions/CheckExpressions.fs b/src/Compiler/Checking/Expressions/CheckExpressions.fs index 99b50fb3fd4..9bf156b795d 100644 --- a/src/Compiler/Checking/Expressions/CheckExpressions.fs +++ b/src/Compiler/Checking/Expressions/CheckExpressions.fs @@ -798,7 +798,7 @@ let TcConst (cenv: cenv) (overallTy: TType) m env synConst = let g = cenv.g let rec tcMeasure ms = match ms with - | SynMeasure.One(range = m) -> Measure.One(m) + | SynMeasure.One m -> Measure.One m | SynMeasure.Named(tc, m) -> let ad = env.eAccessRights let _, tcref, _ = ForceRaise(ResolveTypeLongIdent cenv.tcSink cenv.nameResolver ItemOccurrence.Use OpenQualified env.eNameResEnv ad tc TypeNameResolutionStaticArgsInfo.DefiniteEmpty PermitDirectReferenceToGeneratedType.No) From f2c398bc697ddda0e12ced4bb5feb902f406a675 Mon Sep 17 00:00:00 2001 From: Edgar Gonzalez Date: Mon, 6 Jan 2025 14:11:07 +0000 Subject: [PATCH 17/20] Add CheckUnitOfMeasureAttributes in AttributeChecking --- src/Compiler/Checking/AttributeChecking.fs | 22 ++++++++++++++++- src/Compiler/Checking/AttributeChecking.fsi | 2 ++ src/Compiler/Checking/CheckDeclarations.fs | 22 ++--------------- .../Checking/Expressions/CheckExpressions.fs | 24 +++---------------- 4 files changed, 28 insertions(+), 42 deletions(-) diff --git a/src/Compiler/Checking/AttributeChecking.fs b/src/Compiler/Checking/AttributeChecking.fs index 8ef659ac20e..563af942829 100644 --- a/src/Compiler/Checking/AttributeChecking.fs +++ b/src/Compiler/Checking/AttributeChecking.fs @@ -417,7 +417,27 @@ let CheckEntityAttributes g (tcref: TyconRef) m = CheckFSharpAttributes g tcref.Attribs m let CheckILEventAttributes g (tcref: TyconRef) cattrs m = - CheckILAttributes g (isByrefLikeTyconRef g m tcref) cattrs m + CheckILAttributes g (isByrefLikeTyconRef g m tcref) cattrs m + +let CheckUnitOfMeasureAttributes g (measure: Measure) = + let checkAttribs tm m = + let attribs = + ListMeasureConOccsWithNonZeroExponents g true tm + |> List.map fst + |> List.map(_.Attribs) + |> List.concat + + CheckFSharpAttributes g attribs m |> CommitOperationResult + + match measure with + | Measure.Const(range = m) -> checkAttribs measure m + | Measure.Inv ms -> checkAttribs measure ms.Range + | Measure.One(m) -> checkAttribs measure m + | Measure.RationalPower(measure = ms1) -> checkAttribs measure ms1.Range + | Measure.Prod(measure1= ms1; measure2= ms2) -> + checkAttribs ms1 ms1.Range + checkAttribs ms2 ms2.Range + | Measure.Var(typar) -> checkAttribs measure typar.Range /// Check the attributes associated with a method, returning warnings and errors as data. let CheckMethInfoAttributes g m tyargsOpt (minfo: MethInfo) = diff --git a/src/Compiler/Checking/AttributeChecking.fsi b/src/Compiler/Checking/AttributeChecking.fsi index b4a608ef1d1..663198f9247 100644 --- a/src/Compiler/Checking/AttributeChecking.fsi +++ b/src/Compiler/Checking/AttributeChecking.fsi @@ -89,6 +89,8 @@ val CheckEntityAttributes: g: TcGlobals -> tcref: TyconRef -> m: range -> Operat val CheckUnionCaseAttributes: g: TcGlobals -> x: UnionCaseRef -> m: range -> OperationResult +val CheckUnitOfMeasureAttributes: g: TcGlobals -> measure: Measure -> unit + val CheckRecdFieldAttributes: g: TcGlobals -> x: RecdFieldRef -> m: range -> OperationResult val CheckValAttributes: g: TcGlobals -> x: ValRef -> m: range -> OperationResult diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index 59dfcea415d..092bcf28f56 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/src/Compiler/Checking/CheckDeclarations.fs @@ -3241,30 +3241,12 @@ module EstablishTypeDefinitionCores = warning(Error(FSComp.SR.chkAttributeAliased(attrib.TypeRef.FullName), tycon.Id.idRange)) | _ -> () - // Check for attributes in unit of measure definitions + // Check for attributes in unit-of-measure declarations // e.g. [] type m = 1 // ^ let rec checkAttributeInMeasure ty = match stripTyEqns g ty with - | TType_measure tm -> - let checkAttribs tm m = - let attribs = - ListMeasureConOccsWithNonZeroExponents g true tm - |> List.map fst - |> List.map(_.Attribs) - |> List.concat - - CheckFSharpAttributes g attribs m |> CommitOperationResult - - match tm with - | Measure.Const(range = m) -> checkAttribs tm m - | Measure.Inv ms -> checkAttribs tm ms.Range - | Measure.One(m) -> checkAttribs tm m - | Measure.RationalPower(measure = ms1) -> checkAttribs tm ms1.Range - | Measure.Prod(measure1= ms1; measure2= ms2) -> - checkAttribs ms1 ms1.Range - checkAttribs ms2 ms2.Range - | Measure.Var(typar) -> checkAttribs tm typar.Range + | TType_measure tm -> CheckUnitOfMeasureAttributes g tm | TType_tuple(elementTypes= elementTypes) -> elementTypes |> List.iter checkAttributeInMeasure | TType_var(typar={typar_solution = Some(typeApp) }) -> checkAttributeInMeasure typeApp | TType_fun(domainType = domainType; rangeType= rangeType) -> diff --git a/src/Compiler/Checking/Expressions/CheckExpressions.fs b/src/Compiler/Checking/Expressions/CheckExpressions.fs index 9bf156b795d..9c0d5198edc 100644 --- a/src/Compiler/Checking/Expressions/CheckExpressions.fs +++ b/src/Compiler/Checking/Expressions/CheckExpressions.fs @@ -11156,31 +11156,13 @@ and TcNormalizedBinding declKind (cenv: cenv) env tpenv overallTy safeThisValOpt let supportEnforceAttributeTargets = (g.langVersion.SupportsFeature(LanguageFeature.EnforceAttributeTargets) && memberFlagsOpt.IsNone && not attrs.IsEmpty) && not isVolatile // VolatileFieldAttribute has a special treatment(specific error FS823) - - // Check for attributes in unit of measure expressions + + // Check for attributes in unit-of-measure expressions // e.g. let x = 1.0 // ^ let rec checkAttributeInMeasure ty = match stripTyEqns g ty with - | TType_app(typeInstantiation= [ TType_measure tm ]) -> - let checkAttribs tm m = - let attribs = - ListMeasureConOccsWithNonZeroExponents g true tm - |> List.map fst - |> List.map(_.Attribs) - |> List.concat - - CheckFSharpAttributes g attribs m |> CommitOperationResult - - match tm with - | Measure.Const(range = m) -> checkAttribs tm m - | Measure.Inv ms -> checkAttribs tm ms.Range - | Measure.One(m) -> checkAttribs tm m - | Measure.RationalPower(measure = ms1) -> checkAttribs tm ms1.Range - | Measure.Prod(measure1= ms1; measure2= ms2) -> - checkAttribs ms1 ms1.Range - checkAttribs ms2 ms2.Range - | Measure.Var(typar) -> checkAttribs tm typar.Range + | TType_app(typeInstantiation= [ TType_measure tm ]) -> CheckUnitOfMeasureAttributes g tm | TType_tuple(elementTypes= elementTypes) -> elementTypes |> List.iter checkAttributeInMeasure | TType_var(typar={typar_solution = Some(typeApp) }) -> checkAttributeInMeasure typeApp | TType_fun(domainType = domainType; rangeType= rangeType) -> From 843f5f6cfaf0304a968c97ed6a9535c3cabd8253 Mon Sep 17 00:00:00 2001 From: Edgar Gonzalez Date: Tue, 7 Jan 2025 20:35:40 +0000 Subject: [PATCH 18/20] handle expression has more than 1 type parameter --- src/Compiler/Checking/Expressions/CheckExpressions.fs | 6 +++++- .../Language/ObsoleteAttributeCheckingTests.fs | 4 ++++ 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/src/Compiler/Checking/Expressions/CheckExpressions.fs b/src/Compiler/Checking/Expressions/CheckExpressions.fs index 9c0d5198edc..5464597c4d0 100644 --- a/src/Compiler/Checking/Expressions/CheckExpressions.fs +++ b/src/Compiler/Checking/Expressions/CheckExpressions.fs @@ -11162,12 +11162,16 @@ and TcNormalizedBinding declKind (cenv: cenv) env tpenv overallTy safeThisValOpt // ^ let rec checkAttributeInMeasure ty = match stripTyEqns g ty with - | TType_app(typeInstantiation= [ TType_measure tm ]) -> CheckUnitOfMeasureAttributes g tm + | TType_app(typeInstantiation= ttypes) -> + match ttypes with + | [ TType_measure tm ] -> CheckUnitOfMeasureAttributes g tm + | ttypes -> ttypes |> List.iter checkAttributeInMeasure | TType_tuple(elementTypes= elementTypes) -> elementTypes |> List.iter checkAttributeInMeasure | TType_var(typar={typar_solution = Some(typeApp) }) -> checkAttributeInMeasure typeApp | TType_fun(domainType = domainType; rangeType= rangeType) -> checkAttributeInMeasure domainType checkAttributeInMeasure rangeType + | TType_measure tm -> CheckUnitOfMeasureAttributes g tm | _ -> () checkAttributeInMeasure overallTy diff --git a/tests/FSharp.Compiler.ComponentTests/Language/ObsoleteAttributeCheckingTests.fs b/tests/FSharp.Compiler.ComponentTests/Language/ObsoleteAttributeCheckingTests.fs index 4c32cfbf12f..941e16a7ac3 100644 --- a/tests/FSharp.Compiler.ComponentTests/Language/ObsoleteAttributeCheckingTests.fs +++ b/tests/FSharp.Compiler.ComponentTests/Language/ObsoleteAttributeCheckingTests.fs @@ -256,6 +256,8 @@ let x1 = 1.2 let t1 = 1.0 let result1 = genericSumUnits v1 v2 + +let res = System.Collections.Generic.Dictionary,int>() """ |> typecheck |> shouldFail @@ -276,6 +278,8 @@ let result1 = genericSumUnits v1 v2 (Warning 44, Line 20, Col 16, Line 20, Col 17, "This construct is deprecated. Use s2") (Warning 44, Line 21, Col 14, Line 21, Col 15, "This construct is deprecated. Use m2") (Warning 44, Line 22, Col 14, Line 22, Col 15, "This construct is deprecated. Use s2") + (Warning 44, Line 26, Col 53, Line 26, Col 54, "This construct is deprecated. Use m2") + (Warning 44, Line 26, Col 60, Line 26, Col 61, "This construct is deprecated. Use s2") ] [] From 59886f4aecfa61307ffc5895338f7ca671499ad6 Mon Sep 17 00:00:00 2001 From: Edgar Gonzalez Date: Wed, 8 Jan 2025 00:31:20 +0000 Subject: [PATCH 19/20] one more check --- src/Compiler/Checking/CheckDeclarations.fs | 13 +++------ .../Checking/Expressions/CheckExpressions.fs | 18 +++++++------ .../ObsoleteAttributeCheckingTests.fs | 27 +++++++++++-------- 3 files changed, 29 insertions(+), 29 deletions(-) diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index 092bcf28f56..76615c8a6c4 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/src/Compiler/Checking/CheckDeclarations.fs @@ -3244,19 +3244,12 @@ module EstablishTypeDefinitionCores = // Check for attributes in unit-of-measure declarations // e.g. [] type m = 1 // ^ - let rec checkAttributeInMeasure ty = - match stripTyEqns g ty with - | TType_measure tm -> CheckUnitOfMeasureAttributes g tm - | TType_tuple(elementTypes= elementTypes) -> elementTypes |> List.iter checkAttributeInMeasure - | TType_var(typar={typar_solution = Some(typeApp) }) -> checkAttributeInMeasure typeApp - | TType_fun(domainType = domainType; rangeType= rangeType) -> - checkAttributeInMeasure domainType - checkAttributeInMeasure rangeType - | _ -> () + match stripTyEqns g ty with + | TType_measure tm -> CheckUnitOfMeasureAttributes g tm + | _ -> () checkAttributeAliased ty tycon g.attrib_AutoOpenAttribute checkAttributeAliased ty tycon g.attrib_StructAttribute - checkAttributeInMeasure ty if not firstPass then let ftyvs = freeInTypeLeftToRight g false ty diff --git a/src/Compiler/Checking/Expressions/CheckExpressions.fs b/src/Compiler/Checking/Expressions/CheckExpressions.fs index 5464597c4d0..ee2eead518b 100644 --- a/src/Compiler/Checking/Expressions/CheckExpressions.fs +++ b/src/Compiler/Checking/Expressions/CheckExpressions.fs @@ -4823,7 +4823,15 @@ and TcTypesOrMeasures optKinds (cenv: cenv) newOk checkConstraints occ env tpenv List.mapFold (TcTypeOrMeasure None cenv newOk checkConstraints occ WarnOnIWSAM.Yes env) tpenv args | Some kinds -> if List.length kinds = List.length args then - List.mapFold (fun tpenv (arg, kind) -> TcTypeOrMeasure (Some kind) cenv newOk checkConstraints occ WarnOnIWSAM.Yes env tpenv arg) tpenv (List.zip args kinds) + let ttypes, tpenv = List.mapFold (fun tpenv (arg, kind) -> TcTypeOrMeasure (Some kind) cenv newOk checkConstraints occ WarnOnIWSAM.Yes env tpenv arg) tpenv (List.zip args kinds) + + for ttype in ttypes do + match stripTyEqns cenv.g ttype with + | TType_measure tm -> CheckUnitOfMeasureAttributes cenv.g tm + | _ -> () + + ttypes, tpenv + elif isNil kinds then error(Error(FSComp.SR.tcUnexpectedTypeArguments(), m)) else error(Error(FSComp.SR.tcTypeParameterArityMismatch((List.length kinds), (List.length args)), m)) @@ -11162,16 +11170,10 @@ and TcNormalizedBinding declKind (cenv: cenv) env tpenv overallTy safeThisValOpt // ^ let rec checkAttributeInMeasure ty = match stripTyEqns g ty with - | TType_app(typeInstantiation= ttypes) -> - match ttypes with - | [ TType_measure tm ] -> CheckUnitOfMeasureAttributes g tm - | ttypes -> ttypes |> List.iter checkAttributeInMeasure - | TType_tuple(elementTypes= elementTypes) -> elementTypes |> List.iter checkAttributeInMeasure - | TType_var(typar={typar_solution = Some(typeApp) }) -> checkAttributeInMeasure typeApp + | TType_app(typeInstantiation= [ TType_measure tm ]) -> CheckUnitOfMeasureAttributes g tm | TType_fun(domainType = domainType; rangeType= rangeType) -> checkAttributeInMeasure domainType checkAttributeInMeasure rangeType - | TType_measure tm -> CheckUnitOfMeasureAttributes g tm | _ -> () checkAttributeInMeasure overallTy diff --git a/tests/FSharp.Compiler.ComponentTests/Language/ObsoleteAttributeCheckingTests.fs b/tests/FSharp.Compiler.ComponentTests/Language/ObsoleteAttributeCheckingTests.fs index 941e16a7ac3..bb43189d39b 100644 --- a/tests/FSharp.Compiler.ComponentTests/Language/ObsoleteAttributeCheckingTests.fs +++ b/tests/FSharp.Compiler.ComponentTests/Language/ObsoleteAttributeCheckingTests.fs @@ -323,10 +323,23 @@ type MyClass() = type A<[] 'u>(x: int) = member _.X = x - """ + +type B(x: int, y: int) = + member _.X = x + """ |> typecheck |> shouldFail |> withDiagnostics [ + (Warning 44, Line 30, Col 44, Line 30, Col 45, "This construct is deprecated. Use m2") + (Warning 44, Line 30, Col 58, Line 30, Col 59, "This construct is deprecated. Use s2") + (Warning 44, Line 32, Col 44, Line 32, Col 45, "This construct is deprecated. Use m2") + (Warning 44, Line 32, Col 58, Line 32, Col 59, "This construct is deprecated. Use s2") + (Warning 44, Line 32, Col 72, Line 32, Col 73, "This construct is deprecated. Use m2") + (Warning 44, Line 34, Col 44, Line 34, Col 45, "This construct is deprecated. Use m2") + (Warning 44, Line 34, Col 57, Line 34, Col 58, "This construct is deprecated. Use s2") + (Warning 44, Line 36, Col 44, Line 36, Col 45, "This construct is deprecated. Use m2") + (Warning 44, Line 36, Col 57, Line 36, Col 58, "This construct is deprecated. Use s2") + (Warning 44, Line 36, Col 70, Line 36, Col 71, "This construct is deprecated. Use m2") (Warning 44, Line 12, Col 36, Line 12, Col 37, "This construct is deprecated. Use m2") (Warning 44, Line 12, Col 50, Line 12, Col 51, "This construct is deprecated. Use s2") (Warning 44, Line 14, Col 43, Line 14, Col 44, "This construct is deprecated. Use m2") @@ -343,17 +356,9 @@ type A<[] 'u>(x: int) = (Warning 44, Line 22, Col 31, Line 22, Col 32, "This construct is deprecated. Use s2") (Warning 44, Line 24, Col 29, Line 24, Col 30, "This construct is deprecated. Use m2") (Warning 44, Line 26, Col 29, Line 26, Col 30, "This construct is deprecated. Use s2") - (Warning 44, Line 30, Col 44, Line 30, Col 45, "This construct is deprecated. Use m2") - (Warning 44, Line 30, Col 58, Line 30, Col 59, "This construct is deprecated. Use s2") - (Warning 44, Line 32, Col 44, Line 32, Col 45, "This construct is deprecated. Use m2") - (Warning 44, Line 32, Col 58, Line 32, Col 59, "This construct is deprecated. Use s2") - (Warning 44, Line 32, Col 72, Line 32, Col 73, "This construct is deprecated. Use m2") - (Warning 44, Line 34, Col 44, Line 34, Col 45, "This construct is deprecated. Use m2") - (Warning 44, Line 34, Col 57, Line 34, Col 58, "This construct is deprecated. Use s2") - (Warning 44, Line 36, Col 44, Line 36, Col 45, "This construct is deprecated. Use m2") - (Warning 44, Line 36, Col 57, Line 36, Col 58, "This construct is deprecated. Use s2") - (Warning 44, Line 36, Col 70, Line 36, Col 71, "This construct is deprecated. Use m2") (Warning 44, Line 38, Col 31, Line 38, Col 32, "This construct is deprecated. Use m2") + (Warning 44, Line 41, Col 15, Line 41, Col 16, "This construct is deprecated. Use m2") + (Warning 44, Line 41, Col 26, Line 41, Col 27, "This construct is deprecated. Use s2") ] [] From b755cd010480fd2627a865e9e53ce19b2bf2cb3e Mon Sep 17 00:00:00 2001 From: Edgar Gonzalez Date: Wed, 8 Jan 2025 22:06:27 +0000 Subject: [PATCH 20/20] Move the check to TcConstExpr --- src/Compiler/Checking/CheckDeclarations.fs | 4 ++-- .../Checking/Expressions/CheckExpressions.fs | 24 ++++++++----------- .../ObsoleteAttributeCheckingTests.fs | 21 +++++++++++++++- 3 files changed, 32 insertions(+), 17 deletions(-) diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index 76615c8a6c4..23c547b36b8 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/src/Compiler/Checking/CheckDeclarations.fs @@ -3242,8 +3242,8 @@ module EstablishTypeDefinitionCores = | _ -> () // Check for attributes in unit-of-measure declarations - // e.g. [] type m = 1 - // ^ + // [] type x = 1 + // ^ match stripTyEqns g ty with | TType_measure tm -> CheckUnitOfMeasureAttributes g tm | _ -> () diff --git a/src/Compiler/Checking/Expressions/CheckExpressions.fs b/src/Compiler/Checking/Expressions/CheckExpressions.fs index ee2eead518b..9987f02759c 100644 --- a/src/Compiler/Checking/Expressions/CheckExpressions.fs +++ b/src/Compiler/Checking/Expressions/CheckExpressions.fs @@ -807,7 +807,8 @@ let TcConst (cenv: cenv) (overallTy: TType) m env synConst = | TyparKind.Measure -> Measure.Const(tcref, ms.Range) | SynMeasure.Power(measure = ms; power = exponent) -> Measure.RationalPower (tcMeasure ms, TcSynRationalConst exponent) - | SynMeasure.Product(measure1 = ms1; measure2 = ms2; range= m) -> Measure.Prod(tcMeasure ms1, tcMeasure ms2, m) + | SynMeasure.Product(measure1 = ms1; measure2 = ms2; range= m) -> + Measure.Prod(tcMeasure ms1, tcMeasure ms2, m) | SynMeasure.Divide(ms1, _, (SynMeasure.Seq (_ :: _ :: _, _) as ms2), m) -> warning(Error(FSComp.SR.tcImplicitMeasureFollowingSlash(), m)) let factor1 = ms1 |> Option.defaultValue (SynMeasure.One Range.Zero) @@ -7681,6 +7682,14 @@ and TcConstExpr cenv (overallTy: OverallTy) env m tpenv c = TcNonPropagatingExprLeafThenConvert cenv overallTy env m (fun () -> let cTy = NewInferenceType g let c' = TcConst cenv cTy m env c + let rec checkAttributeInMeasure ty = + match stripTyEqns g ty with + | TType_app(typeInstantiation= ttypes) -> ttypes |> List.iter checkAttributeInMeasure + | TType_fun(rangeType= rangeType) -> checkAttributeInMeasure rangeType + | TType_measure tm -> CheckUnitOfMeasureAttributes g tm + | _ -> () + + checkAttributeInMeasure cTy Expr.Const (c', m, cTy), cTy, tpenv) //------------------------------------------------------------------------- @@ -11165,19 +11174,6 @@ and TcNormalizedBinding declKind (cenv: cenv) env tpenv overallTy safeThisValOpt (g.langVersion.SupportsFeature(LanguageFeature.EnforceAttributeTargets) && memberFlagsOpt.IsNone && not attrs.IsEmpty) && not isVolatile // VolatileFieldAttribute has a special treatment(specific error FS823) - // Check for attributes in unit-of-measure expressions - // e.g. let x = 1.0 - // ^ - let rec checkAttributeInMeasure ty = - match stripTyEqns g ty with - | TType_app(typeInstantiation= [ TType_measure tm ]) -> CheckUnitOfMeasureAttributes g tm - | TType_fun(domainType = domainType; rangeType= rangeType) -> - checkAttributeInMeasure domainType - checkAttributeInMeasure rangeType - | _ -> () - - checkAttributeInMeasure overallTy - if supportEnforceAttributeTargets then TcAttributeTargetsOnLetBindings { cenv with tcSink = TcResultsSink.NoSink } env attrs overallPatTy overallExprTy (not declaredTypars.IsEmpty) isClassLetBinding diff --git a/tests/FSharp.Compiler.ComponentTests/Language/ObsoleteAttributeCheckingTests.fs b/tests/FSharp.Compiler.ComponentTests/Language/ObsoleteAttributeCheckingTests.fs index bb43189d39b..d9a8bfb28f0 100644 --- a/tests/FSharp.Compiler.ComponentTests/Language/ObsoleteAttributeCheckingTests.fs +++ b/tests/FSharp.Compiler.ComponentTests/Language/ObsoleteAttributeCheckingTests.fs @@ -104,11 +104,24 @@ open System [] type cm [] type ml = cm^3 + +type Mls = int * int + +type IMl2 = + abstract member Ml2 : x: int * y: int -> int + abstract member Ml3 : x: int * y: int -> int """ |> typecheck |> shouldFail |> withDiagnostics [ (Warning 44, Line 5, Col 23, Line 5, Col 25, "This construct is deprecated. Use something else") + (Warning 44, Line 7, Col 16, Line 7, Col 18, "This construct is deprecated. Use something else") + (Warning 44, Line 7, Col 26, Line 7, Col 28, "This construct is deprecated. Use something else") + (Warning 44, Line 10, Col 34, Line 10, Col 36, "This construct is deprecated. Use something else") + (Warning 44, Line 10, Col 47, Line 10, Col 49, "This construct is deprecated. Use something else") + (Warning 44, Line 11, Col 34, Line 11, Col 36, "This construct is deprecated. Use something else") + (Warning 44, Line 11, Col 47, Line 11, Col 49, "This construct is deprecated. Use something else") + (Warning 44, Line 11, Col 58, Line 11, Col 60, "This construct is deprecated. Use something else") ] [] @@ -180,11 +193,15 @@ type kg type cm let myCm = 3 + +let cm2 = 3 * 3 """ |> typecheck |> shouldFail |> withDiagnostics [ - (Warning 44, Line 10, Col 14, Line 10, Col 16, "This construct is deprecated. Use cm2") + (Warning 44, Line 10, Col 14, Line 10, Col 16, "This construct is deprecated. Use cm2"); + (Warning 44, Line 12, Col 13, Line 12, Col 15, "This construct is deprecated. Use cm2"); + (Warning 44, Line 12, Col 24, Line 12, Col 26, "This construct is deprecated. Use cm2") ] [] @@ -206,6 +223,8 @@ let mPerCm = 0.01 |> withDiagnostics [ (Warning 44, Line 10, Col 24, Line 10, Col 26, "This construct is deprecated. Use cm2") (Warning 44, Line 10, Col 27, Line 10, Col 28, "This construct is deprecated. Use m2") + (Warning 44, Line 10, Col 38, Line 10, Col 40, "This construct is deprecated. Use cm2") + (Warning 44, Line 10, Col 41, Line 10, Col 42, "This construct is deprecated. Use m2") (Warning 44, Line 11, Col 19, Line 11, Col 20, "This construct is deprecated. Use m2") (Warning 44, Line 11, Col 21, Line 11, Col 23, "This construct is deprecated. Use cm2") ]