Support more types in simple for-loops

Author: brianrourkeboll

docs/release-notes/.FSharp.Compiler.Service/9.0.300.md

@@ -17,6 +17,7 @@
 * Add support for C# `Experimental` attribute. ([PR #18253](https://github.com/dotnet/fsharp/pull/18253))
 * Nullness warnings are issued for signature<>implementation conformance ([PR #18186](https://github.com/dotnet/fsharp/pull/18186))
 * Symbols: Add FSharpAssembly.IsFSharp ([PR #18290](https://github.com/dotnet/fsharp/pull/18290))
+* Support more types in simple for-loops. ([Language suggestion #876](https://github.com/fsharp/fslang-suggestions/issues/876), [PR #18301](https://github.com/dotnet/fsharp/pull/18301))
 
 ### Changed
 

docs/release-notes/.Language/preview.md

@@ -4,6 +4,7 @@
 * Deprecate places where `seq` can be omitted. ([Language suggestion #1033](https://github.com/fsharp/fslang-suggestions/issues/1033), [PR #17772](https://github.com/dotnet/fsharp/pull/17772))
 * Added type conversions cache, only enabled for compiler runs ([PR#17668](https://github.com/dotnet/fsharp/pull/17668))
 * Support ValueOption + Struct attribute as optional parameter for methods ([Language suggestion #1136](https://github.com/fsharp/fslang-suggestions/issues/1136), [PR #18098](https://github.com/dotnet/fsharp/pull/18098))
+* Support more types in simple for-loops. ([Language suggestion #876](https://github.com/fsharp/fslang-suggestions/issues/876), [PR #18301](https://github.com/dotnet/fsharp/pull/18301))
 
 ### Fixed
 

src/Compiler/Checking/Expressions/CheckExpressions.fs

@@ -6271,24 +6271,64 @@ and TcExprIntegerForLoop (cenv: cenv) overallTy env tpenv (spFor, spTo, id, star
     let g = cenv.g
     UnifyTypes cenv env m overallTy.Commit g.unit_ty
 
-    let startExpr, tpenv =
-        let env = { env with eIsControlFlow = false }
-        TcExpr cenv (MustEqual g.int_ty) env tpenv start
+    let tryTcStartAndFinishAsInt32 tpenv start finish =
+        let tcDefaultInt32 tpenv (synExpr: SynExpr) =
+            let addCxTyparDefaultsToInt32 ty =
+                tryDestTyparTy g ty
+                |> ValueOption.iter (fun typar ->
+                    AddCxTyparDefaultsTo env.DisplayEnv cenv.css synExpr.Range env.eContextInfo typar 1 g.int_ty)
 
-    let finishExpr, tpenv =
-        let env = { env with eIsControlFlow = false }
-        TcExpr cenv (MustEqual g.int_ty) env tpenv finish
+            let exprTy = NewInferenceType g
+            addCxTyparDefaultsToInt32 exprTy
+            let env = { env with eIsControlFlow = false }
+            let expr, tpenv = TcExpr cenv (MustEqual exprTy) env tpenv synExpr
+            expr, exprTy, tpenv
 
-    let idv, _ = mkLocal id.idRange id.idText g.int_ty
-    let envinner = AddLocalVal g cenv.tcSink m idv env
-    let envinner = { envinner with eIsControlFlow = true }
+        let startExpr, startTy, tpenv = tcDefaultInt32 tpenv start
+        let finishExpr, finishTy, tpenv = tcDefaultInt32 tpenv finish
+
+        if typeEquiv g startTy g.int_ty && typeEquiv g finishTy g.int_ty then
+            Some (tpenv, startExpr, finishExpr)
+        else
+            None
+
+    // First try to typecheck the start and finish expressions as int32
+    // for backwards compatibility. Otherwise, treat the for-loop
+    // as though it were a for-each loop over a range expression.
+    match tryTcStartAndFinishAsInt32 tpenv start finish with
+    | Some (tpenv, startExpr, finishExpr) ->
+        let idv, _ = mkLocal id.idRange id.idText g.int_ty
+        let envinner = AddLocalVal g cenv.tcSink m idv env
+        let envinner = { envinner with eIsControlFlow = true }
+
+        // notify name resolution sink about loop variable
+        let item = Item.Value(mkLocalValRef idv)
+        CallNameResolutionSink cenv.tcSink (idv.Range, env.NameEnv, item, emptyTyparInst, ItemOccurrence.Binding, env.AccessRights)
 
-    // notify name resolution sink about loop variable
-    let item = Item.Value(mkLocalValRef idv)
-    CallNameResolutionSink cenv.tcSink (idv.Range, env.NameEnv, item, emptyTyparInst, ItemOccurrence.Binding, env.AccessRights)
+        let bodyExpr, tpenv = TcStmt cenv envinner tpenv body
+        mkFastForLoop g (spFor, spTo, m, idv, startExpr, dir, finishExpr, bodyExpr), tpenv
 
-    let bodyExpr, tpenv = TcStmt cenv envinner tpenv body
-    mkFastForLoop g (spFor, spTo, m, idv, startExpr, dir, finishExpr, bodyExpr), tpenv
+    | None ->
+        // TODO: Figure this out.
+        //checkLanguageFeatureAndRecover g.langVersion LanguageFeature.MoreTypesInSimpleForLoops m
+        let pat = SynPat.Named (SynIdent (id, None), false, None, id.idRange)
+
+        let rangeExpr =
+            let mTo = match spTo with DebugPointAtInOrTo.Yes m -> m | DebugPointAtInOrTo.No -> Range.range0
+
+            if dir then
+                //   for x = start to finish do …
+                // → for x in start..finish do …
+                mkSynInfix mTo start ".." finish
+            else
+                //   for x = start downto finish do …
+                // → for x in start..-1..finish do …
+                let minus = mkSynOperator mTo "~-"
+                let one = mkSynLidGet mTo ["Microsoft"; "FSharp"; "Core"; "LanguagePrimitives"] "GenericOne"
+                let step = mkSynApp1 minus one mTo
+                mkSynTrifix (mTo.MakeSynthetic()) ".. .." start step finish
+
+        TcForEachExpr cenv overallTy env tpenv (false, true, pat, rangeExpr, body, m, spFor, spTo, m)
 
 and TcExprTryWith (cenv: cenv) overallTy env tpenv (synBodyExpr, synWithClauses, mWithToLast, mTryToLast, spTry, spWith) =
     let g = cenv.g

src/Compiler/FSComp.txt

@@ -1794,3 +1794,4 @@ featureDontWarnOnUppercaseIdentifiersInBindingPatterns,"Don't warn on uppercase
 3874,tcExpectedTypeParamMarkedWithUnitOfMeasureAttribute,"Expected unit-of-measure type parameter must be marked with the [<Measure>] attribute."
 featureDeprecatePlacesWhereSeqCanBeOmitted,"Deprecate places where 'seq' can be omitted"
 featureSupportValueOptionsAsOptionalParameters,"Support ValueOption as valid type for optional member parameters"
+featureMoreTypesInSimpleForLoops,"Support more types in simple for-loops"

src/Compiler/Facilities/LanguageFeatures.fs

@@ -98,6 +98,7 @@ type LanguageFeature =
     | UseTypeSubsumptionCache
     | DeprecatePlacesWhereSeqCanBeOmitted
     | SupportValueOptionsAsOptionalParameters
+    | MoreTypesInSimpleForLoops
 
 /// LanguageVersion management
 type LanguageVersion(versionText) =
@@ -227,6 +228,7 @@ type LanguageVersion(versionText) =
                 LanguageFeature.DontWarnOnUppercaseIdentifiersInBindingPatterns, previewVersion
                 LanguageFeature.DeprecatePlacesWhereSeqCanBeOmitted, previewVersion
                 LanguageFeature.SupportValueOptionsAsOptionalParameters, previewVersion
+                LanguageFeature.MoreTypesInSimpleForLoops, previewVersion
             ]
 
     static let defaultLanguageVersion = LanguageVersion("default")
@@ -388,6 +390,7 @@ type LanguageVersion(versionText) =
         | LanguageFeature.UseTypeSubsumptionCache -> FSComp.SR.featureUseTypeSubsumptionCache ()
         | LanguageFeature.DeprecatePlacesWhereSeqCanBeOmitted -> FSComp.SR.featureDeprecatePlacesWhereSeqCanBeOmitted ()
         | LanguageFeature.SupportValueOptionsAsOptionalParameters -> FSComp.SR.featureSupportValueOptionsAsOptionalParameters ()
+        | LanguageFeature.MoreTypesInSimpleForLoops -> FSComp.SR.featureMoreTypesInSimpleForLoops ()
 
     /// Get a version string associated with the given feature.
     static member GetFeatureVersionString feature =

src/Compiler/Facilities/LanguageFeatures.fsi

@@ -89,6 +89,7 @@ type LanguageFeature =
     | UseTypeSubsumptionCache
     | DeprecatePlacesWhereSeqCanBeOmitted
     | SupportValueOptionsAsOptionalParameters
+    | MoreTypesInSimpleForLoops
 
 /// LanguageVersion management
 type LanguageVersion =

src/Compiler/TypedTree/TcGlobals.fs

@@ -731,6 +731,8 @@ type TcGlobals(
   let v_generic_equality_withc_outer_info       = makeIntrinsicValRef(fslib_MFLanguagePrimitives_nleref,       "GenericEqualityWithComparer"          , None                 , None          , [vara],     mk_equality_withc_sig varaTy)
   let v_generic_hash_withc_outer_info           = makeIntrinsicValRef(fslib_MFLanguagePrimitives_nleref,       "GenericHashWithComparer"              , None                 , None          , [vara],     mk_hash_withc_sig varaTy)
 
+  let v_generic_one_info                        = makeIntrinsicValRef(fslib_MFLanguagePrimitives_nleref,       "GenericOne"                           , None                 , None          , [],         ([[v_unit_ty]], varaTy))
+
   let v_generic_equality_er_inner_info         = makeIntrinsicValRef(fslib_MFHashCompare_nleref,               "GenericEqualityERIntrinsic"           , None                 , None          , [vara],     mk_rel_sig varaTy)
   let v_generic_equality_per_inner_info     = makeIntrinsicValRef(fslib_MFHashCompare_nleref,                  "GenericEqualityIntrinsic"             , None                 , None          , [vara],     mk_rel_sig varaTy)
   let v_generic_equality_withc_inner_info   = makeIntrinsicValRef(fslib_MFHashCompare_nleref,                  "GenericEqualityWithComparerIntrinsic" , None                 , None          , [vara],     mk_equality_withc_sig varaTy)
@@ -1591,6 +1593,8 @@ type TcGlobals(
   member val generic_hash_inner_vref = ValRefForIntrinsic v_generic_hash_inner_info
   member val generic_hash_withc_inner_vref = ValRefForIntrinsic v_generic_hash_withc_inner_info
 
+  member val generic_one_vref = ValRefForIntrinsic v_generic_one_info
+
   member val reference_equality_inner_vref         = ValRefForIntrinsic v_reference_equality_inner_info
 
   member val piperight_vref            = ValRefForIntrinsic v_piperight_info

src/Compiler/TypedTree/TcGlobals.fsi

@@ -724,6 +724,8 @@ type internal TcGlobals =
 
     member generic_hash_withc_outer_info: IntrinsicValRef
 
+    member generic_one_vref: FSharp.Compiler.TypedTree.ValRef
+
     member generic_hash_withc_tuple2_vref: FSharp.Compiler.TypedTree.ValRef
 
     member generic_hash_withc_tuple3_vref: FSharp.Compiler.TypedTree.ValRef

src/Compiler/TypedTree/TypedTreeOps.fs

@@ -7647,6 +7647,17 @@ let mkTypedOne g m ty =
     elif typeEquivAux EraseMeasures g ty g.decimal_ty then Expr.Const (Const.Decimal 1m, m, ty)
     else error (InternalError ($"Unrecognized numeric type '{ty}'.", m))
 
+let mkTypedMinusOne g m ty =
+    if typeEquivAux EraseMeasures g ty g.int32_ty then Expr.Const (Const.Int32 -1, m, ty)
+    elif typeEquivAux EraseMeasures g ty g.int64_ty then Expr.Const (Const.Int64 -1L, m, ty)
+    elif typeEquivAux EraseMeasures g ty g.nativeint_ty then Expr.Const (Const.IntPtr -1L, m, ty)
+    elif typeEquivAux EraseMeasures g ty g.int16_ty then Expr.Const (Const.Int16 -1s, m, ty)
+    elif typeEquivAux EraseMeasures g ty g.sbyte_ty then Expr.Const (Const.SByte -1y, m, ty)
+    elif typeEquivAux EraseMeasures g ty g.float32_ty then Expr.Const (Const.Single -1.0f, m, ty)
+    elif typeEquivAux EraseMeasures g ty g.float_ty then Expr.Const (Const.Double -1.0, m, ty)
+    elif typeEquivAux EraseMeasures g ty g.decimal_ty then Expr.Const (Const.Decimal -1m, m, ty)
+    else error (InternalError ($"Unrecognized or unsigned numeric type '{ty}'.", m))
+
 let destInt32 = function Expr.Const (Const.Int32 n, _, _) -> Some n | _ -> None
 
 let isIDelegateEventType g ty =
@@ -10460,8 +10471,26 @@ let (|Let|_|) expr =
     | Expr.Let (TBind(v, e1, sp), e2, _, _) -> ValueSome(v, e1, sp, e2)
     | _ -> ValueNone
 
+/// Microsoft.FSharp.Core.LanguagePrimitives.GenericOne
+let (|GenericOne|_|) g expr =
+    match expr with
+    | Expr.Val (vref, _, _) -> valRefEq g vref g.generic_one_vref
+    | _ -> false
+
+/// Microsoft.FSharp.Core.Operators.(~-)
+let (|UnaryMinus|_|) g expr =
+    match expr with
+    | Expr.Val (vref, _, _) -> valRefEq g vref g.unchecked_unary_minus_vref
+    | _ -> false
+
 [<return: Struct>]
 let (|RangeInt32Step|_|) g expr = 
+    let (|GenericPlusOrMinusOne|_|) g expr =
+        match expr with
+        | Expr.App (funcExpr = UnaryMinus g; args = [Expr.App (funcExpr = GenericOne g)]) -> ValueSome -1
+        | Expr.App (funcExpr = GenericOne g) -> ValueSome 1
+        | _ -> ValueNone
+
     match expr with 
     // detect 'n .. m' 
     | Expr.App (Expr.Val (vf, _, _), _, [tyarg], [startExpr;finishExpr], _)
@@ -10471,6 +10500,9 @@ let (|RangeInt32Step|_|) g expr =
     | Expr.App (Expr.Val (vf, _, _), _, [], [startExpr; Int32Expr n; finishExpr], _)
          when valRefEq g vf g.range_int32_op_vref -> ValueSome(startExpr, n, finishExpr)
 
+    | Expr.App (Expr.Val (vf, _, _), _, [ty1; ty2], [startExpr; GenericPlusOrMinusOne g n; finishExpr], _)
+         when valRefEq g vf g.range_step_op_vref && typeEquiv g ty1 g.int_ty && typeEquiv g ty2 g.int_ty -> ValueSome(startExpr, n, finishExpr)
+
     | _ -> ValueNone
 
 [<return: Struct>]
@@ -11078,6 +11110,17 @@ let mkRangeCount g m rangeTy rangeExpr start step finish =
 
 let mkOptimizedRangeLoop (g: TcGlobals) (mBody, mFor, mIn, spInWhile) (rangeTy, rangeExpr) (start, step, finish) (buildLoop: (Count -> ((Idx -> Elem -> Body) -> Loop) -> Expr)) =
     let inline mkLetBindingsIfNeeded f =
+        /// Replace LanguagePrimitives.GenericOne or -LanguagePrimitives.GenericOne with their constant equivalents.
+        /// -LanguagePrimitives.GenericOne is emitted in CheckExpressions.TcExprIntegerForLoop for `downto`
+        /// for types other than System.Int32.
+        let constifyPlusOrMinusGenericOne expr =
+            match expr with
+            | Expr.App (funcExpr = UnaryMinus g; args = [Expr.App (funcExpr = GenericOne g)]) -> Some (mkTypedMinusOne g expr.Range (tyOfExpr g expr))
+            | Expr.App (funcExpr = GenericOne g) -> Some (mkTypedOne g expr.Range (tyOfExpr g expr))
+            | _ -> None
+
+        let step = constifyPlusOrMinusGenericOne step |> Option.defaultValue step
+
         match start, step, finish with
         | (Expr.Const _ | Expr.Val _), (Expr.Const _ | Expr.Val _), (Expr.Const _ | Expr.Val _) ->
             f start step finish