Merge pull request #1 from nojaf/syntype-tuple-type-segment

Introduce TupleTypeSegment to SynType.Tuple.

src/Compiler/Checking/CheckExpressions.fs

@@ -4538,8 +4538,8 @@ and TcTypeOrMeasure kindOpt cenv newOk checkConstraints occ env (tpenv: Unscoped
     | SynType.LongIdentApp (synLeftTy, synLongId, _, args, _commas, _, m) ->
         TcNestedAppType cenv newOk checkConstraints occ env tpenv synLeftTy synLongId args m
 
-    | SynType.Tuple(isStruct, _, _, args, m) ->
-        TcTupleType kindOpt cenv newOk checkConstraints occ env tpenv isStruct args m
+    | SynType.Tuple(isStruct, segments, m) ->
+        TcTupleType kindOpt cenv newOk checkConstraints occ env tpenv isStruct segments m
 
     | SynType.AnonRecd(_, [],m) ->
         error(Error((FSComp.SR.tcAnonymousTypeInvalidInDeclaration()), m))
@@ -4649,24 +4649,24 @@ and TcNestedAppType cenv newOk checkConstraints occ env tpenv synLeftTy synLongI
     | _ ->
         error(Error(FSComp.SR.tcTypeHasNoNestedTypes(), m))
 
-and TcTupleType kindOpt cenv newOk checkConstraints occ env tpenv isStruct args m =
-
-    let tupInfo = mkTupInfo isStruct
-    if isStruct then
-        let argsR,tpenv = TcTypesAsTuple cenv newOk checkConstraints occ env tpenv args m
-        TType_tuple(tupInfo, argsR), tpenv
-    else
-        let isMeasure =
-            match kindOpt with
-            | Some TyparKind.Measure -> true
-            | None -> List.exists (fun (isquot,_) -> isquot) args | _ -> false
-
-        if isMeasure then
-            let ms,tpenv = TcMeasuresAsTuple cenv newOk checkConstraints occ env tpenv args m
-            TType_measure ms,tpenv
-        else
-            let argsR,tpenv = TcTypesAsTuple cenv newOk checkConstraints occ env tpenv args m
-            TType_tuple(tupInfo, argsR), tpenv
+and TcTupleType _kindOpt _cenv _newOk _checkConstraints _occ _env _tpenv _isStruct _args _m =
+    failwith "todo"
+    // let tupInfo = mkTupInfo isStruct
+    // if isStruct then
+    //     let argsR,tpenv = TcTypesAsTuple cenv newOk checkConstraints occ env tpenv args m
+    //     TType_tuple(tupInfo, argsR), tpenv
+    // else
+    //     let isMeasure =
+    //         match kindOpt with
+    //         | Some TyparKind.Measure -> true
+    //         | None -> List.exists (fun (isquot,_) -> isquot) args | _ -> false
+    //
+    //     if isMeasure then
+    //         let ms,tpenv = TcMeasuresAsTuple cenv newOk checkConstraints occ env tpenv args m
+    //         TType_measure ms,tpenv
+    //     else
+    //         let argsR,tpenv = TcTypesAsTuple cenv newOk checkConstraints occ env tpenv args m
+    //         TType_tuple(tupInfo, argsR), tpenv
 
 and TcAnonRecdType cenv newOk checkConstraints occ env tpenv isStruct args m =
     let tupInfo = mkTupInfo isStruct

src/Compiler/Service/ServiceParseTreeWalk.fs

@@ -819,7 +819,7 @@ module SyntaxTraversal =
                 | SynType.Array (_, ty, _) -> traverseSynType path ty
                 | SynType.StaticConstantNamed (ty1, ty2, _)
                 | SynType.MeasureDivide (ty1, ty2, _) -> [ ty1; ty2 ] |> List.tryPick (traverseSynType path)
-                | SynType.Tuple (_, _, firstType, tys, _) -> firstType :: (List.map snd tys) |> List.tryPick (traverseSynType path)
+                | SynType.Tuple (path = segments) -> getTypeFromTuplePath segments |> List.tryPick (traverseSynType path)
                 | SynType.StaticConstantExpr (expr, _) -> traverseSynExpr [] expr
                 | SynType.Anon _ -> None
                 | _ -> None

src/Compiler/Service/ServiceParsedInputOps.fs

@@ -661,7 +661,7 @@ module ParsedInput =
                     None
             | SynType.App (ty, _, types, _, _, _, _) -> walkType ty |> Option.orElseWith (fun () -> List.tryPick walkType types)
             | SynType.LongIdentApp (_, _, _, types, _, _, _) -> List.tryPick walkType types
-            | SynType.Tuple (_, _, firstType, tys, _) -> firstType :: (List.map snd tys) |> List.tryPick (fun t -> walkType t)
+            | SynType.Tuple (path = segments) -> getTypeFromTuplePath segments |> List.tryPick walkType
             | SynType.Array (_, t, _) -> walkType t
             | SynType.Fun (argType = t1; returnType = t2) -> walkType t1 |> Option.orElseWith (fun () -> walkType t2)
             | SynType.WithGlobalConstraints (t, _, _) -> walkType t
@@ -1669,7 +1669,7 @@ module ParsedInput =
                 walkType ty
                 List.iter walkType types
             | SynType.LongIdentApp (_, _, _, types, _, _, _) -> List.iter walkType types
-            | SynType.Tuple (_, _, firstType, tys, _) -> firstType :: (List.map snd tys) |> List.iter (fun t -> walkType t)
+            | SynType.Tuple (path = segment) -> getTypeFromTuplePath segment |> List.iter walkType
             | SynType.WithGlobalConstraints (t, typeConstraints, _) ->
                 walkType t
                 List.iter walkTypeConstraint typeConstraints

src/Compiler/SyntaxTree/ParseHelpers.fs

@@ -813,18 +813,13 @@ let mkSynMemberDefnGetSet
     | _ -> []
 
 // The last element of elementTypes does not have a star or slash
-let mkTupleOrDivide (isStruct: bool) (leadingType: SynType) (isStar: bool) (elementTypes: (bool * SynType) list) : SynType =
-    // x * y
+let mkTupleOrDivide (isStruct: bool) (elementTypes: TupleTypeSegment list) : SynType =
     let range =
-        (leadingType.Range, elementTypes)
-        ||> List.fold (fun acc (_, t) -> unionRanges acc t.Range)
+        match elementTypes with
+        | [] -> Range.Zero
+        | head :: tail ->
 
-    let newElementTypes =
-        elementTypes
-        |> List.fold (fun (lastIsStar, currentList) (isStar, t) -> (isStar, (lastIsStar, t) :: currentList)) (isStar, [])
-        |> snd
-        |> List.rev
+            (head.Range, tail)
+            ||> List.fold (fun acc segment -> unionRanges acc segment.Range)
 
-    SynType.Tuple(isStruct, false, leadingType, newElementTypes, range)
-
-let mkDivideWithLeadingSlash (_: (bool * SynType) list) : SynType = failwith "TODO"
+    SynType.Tuple(isStruct, elementTypes, range)

src/Compiler/SyntaxTree/ParseHelpers.fsi

@@ -176,9 +176,4 @@ val mkSynMemberDefnGetSet:
     rangeStart: range ->
         SynMemberDefn list
 
-val mkTupleOrDivide:
-    isStruct: bool -> leadingType: SynType -> isStar: bool -> elementTypes: (bool * SynType) list -> SynType
-
-val mkDivideWithLeadingSlash: elementTypes: (bool * SynType) list -> SynType
-
-//| Tuple of isStruct:bool * hasLeadingSlash:bool * firstType:SynType * elements: (bool * SynType) list * range: range
+val mkTupleOrDivide: isStruct: bool -> elementTypes: TupleTypeSegment list -> SynType

src/Compiler/SyntaxTree/SyntaxTree.fs

@@ -369,6 +369,18 @@ type SynTyparDecls =
         | PrefixList (range = range) -> range
         | SinglePrefix (range = range) -> range
 
+[<NoEquality; NoComparison; RequireQualifiedAccess>]
+type TupleTypeSegment =
+    | Type of typeName: SynType
+    | Star of range: range
+    | Slash of range: range
+
+    member this.Range =
+        match this with
+        | TupleTypeSegment.Type t -> t.Range
+        | TupleTypeSegment.Star (range = range)
+        | TupleTypeSegment.Slash (range = range) -> range
+
 [<NoEquality; NoComparison; RequireQualifiedAccess>]
 type SynType =
 
@@ -392,7 +404,7 @@ type SynType =
         greaterRange: range option *
         range: range
 
-    | Tuple of isStruct: bool * hasLeadingSlash: bool * firstType: SynType * elements: (bool * SynType) list * range: range
+    | Tuple of isStruct: bool * path: TupleTypeSegment list * range: range
 
     | AnonRecd of isStruct: bool * fields: (Ident * SynType) list * range: range
 

src/Compiler/SyntaxTree/SyntaxTree.fsi

@@ -427,6 +427,14 @@ type SynTyparDecls =
     member Constraints: SynTypeConstraint list
     member Range: range
 
+[<NoEquality; NoComparison; RequireQualifiedAccess>]
+type TupleTypeSegment =
+    | Type of typeName: SynType
+    | Star of range: range
+    | Slash of range: range
+
+    member Range: range
+
 /// Represents a syntax tree for F# types
 [<NoEquality; NoComparison; RequireQualifiedAccess>]
 type SynType =
@@ -457,12 +465,7 @@ type SynType =
 
     /// F# syntax: type * ... * type
     /// F# syntax: struct (type * ... * type)
-    | Tuple of
-        isStruct: bool *
-        hasLeadingSlash: bool *
-        firstType: SynType *
-        elements: (bool * SynType) list *
-        range: range
+    | Tuple of isStruct: bool * path: TupleTypeSegment list * range: range
 
     /// F# syntax: {| id: type; ...; id: type |}
     /// F# syntax: struct {| id: type; ...; id: type |}

src/Compiler/SyntaxTree/SyntaxTreeOps.fs

@@ -1017,3 +1017,9 @@ let rec desugarGetSetMembers (memberDefns: SynMemberDefns) =
             let members = Option.map desugarGetSetMembers members
             [ SynMemberDefn.Interface(interfaceType, withKeyword, members, m) ]
         | md -> [ md ])
+
+let getTypeFromTuplePath (path: TupleTypeSegment list) : SynType list =
+    path
+    |> List.choose (function
+        | TupleTypeSegment.Type t -> Some t
+        | _ -> None)

src/Compiler/SyntaxTree/SyntaxTreeOps.fsi

@@ -344,3 +344,5 @@ val mkDynamicArgExpr: expr: SynExpr -> SynExpr
 val normalizeTupleExpr: exprs: SynExpr list -> commas: range list -> SynExpr list * range List
 
 val desugarGetSetMembers: memberDefns: SynMemberDefns -> SynMemberDefns
+
+val getTypeFromTuplePath: path: TupleTypeSegment list -> SynType list

src/Compiler/pars.fsy

@@ -5029,17 +5029,23 @@ topType:
 
 topTupleType:
   | topAppType STAR topTupleTypeElements 
-     { let ty, mdata = $1 in let tys, mdatas = List.unzip $3 in (SynType.Tuple(false, false, ty, List.map (fun t -> false, t) tys, lhs parseState)), (mdata :: mdatas) }
+     { let t, argInfo = $1
+       let path = TupleTypeSegment.Type t :: (List.map fst $3)
+       let mdata = argInfo :: (List.choose snd $3)
+       mkTupleOrDivide false path, mdata }
 
   | topAppType                 
      { let ty, mdata = $1 in ty, [mdata] }
 
 topTupleTypeElements:
   | topAppType STAR topTupleTypeElements       
-     { $1 :: $3 }
+     { let t, argInfo = $1
+       let mStar = rhs parseState 2
+       (TupleTypeSegment.Type t, Some argInfo) :: (TupleTypeSegment.Star mStar, None) :: $3 }
 
   | topAppType %prec prec_toptuptyptail_prefix 
-     { [$1] }
+     { let t, argInfo = $1
+       [ TupleTypeSegment.Type t, Some argInfo ] }
 
 topAppType:
   | attributes appType COLON appType 
@@ -5080,31 +5086,39 @@ typEOF:
 
 tupleType:
   | appType STAR tupleOrQuotTypeElements 
-    { mkTupleOrDivide false $1 true $3 }
+    { let mStar = rhs parseState 2
+      let path = TupleTypeSegment.Type $1 :: TupleTypeSegment.Star mStar :: $3
+      mkTupleOrDivide false path }
 
   | INFIX_STAR_DIV_MOD_OP tupleOrQuotTypeElements
     { if $1 <> "/" then reportParseErrorAt (rhs parseState 1) (FSComp.SR.parsUnexpectedInfixOperator());
       //SynType.Division((SynType.StaticConstant (SynConst.Int32 1, lhs parseState)) :: $2, lhs parseState)
-      mkDivideWithLeadingSlash $2 }
+      let mSlash = rhs parseState 1
+      let path = TupleTypeSegment.Slash mSlash :: $2
+      mkTupleOrDivide false path }
 
   | appType INFIX_STAR_DIV_MOD_OP tupleOrQuotTypeElements
     { if $2 <> "/" then reportParseErrorAt (rhs parseState 1) (FSComp.SR.parsUnexpectedInfixOperator());
       //SynType.Tuple(false, (true, $1) :: $3, lhs parseState)
-      mkTupleOrDivide false $1 false $3 }
+      let mSlash = rhs parseState 2
+      let path = TupleTypeSegment.Type $1 :: TupleTypeSegment.Slash mSlash :: $3
+      mkTupleOrDivide false path }
 
   | appType %prec prec_tuptyp_prefix 
     { $1 }
 
 tupleOrQuotTypeElements:
   | appType STAR tupleOrQuotTypeElements              
-    { (false, $1) :: $3 }
+    { let mStar = rhs parseState 2
+      TupleTypeSegment.Type $1 :: TupleTypeSegment.Star mStar :: $3 }
 
   | appType INFIX_STAR_DIV_MOD_OP tupleOrQuotTypeElements 
     { if $2 <> "/" then reportParseErrorAt (rhs parseState 1) (FSComp.SR.parsUnexpectedInfixOperator());
-      (true, $1) :: $3 }
+      let mSlash = rhs parseState 2
+      TupleTypeSegment.Type $1 :: TupleTypeSegment.Slash mSlash :: $3 }
 
   | appType %prec prec_tuptyptail_prefix 
-    { [(false, $1)] }
+    { [ TupleTypeSegment.Type $1 ] }
 
 appTypeCon:
   | path %prec prec_atomtyp_path 
@@ -5238,14 +5252,17 @@ atomType:
        SynType.Paren ($2, lhs parseState) }
 
   | STRUCT LPAREN appType STAR tupleOrQuotTypeElements  rparen 
-    { 
+    { let mStar = rhs parseState 4
+      let path = TupleTypeSegment.Type $3 :: TupleTypeSegment.Star mStar :: $5
         //SynType.Tuple(true, (false, $3) :: $5, lhs parseState)
-      mkTupleOrDivide true $3 true $5 }
+      mkTupleOrDivide true path }
 
   | STRUCT LPAREN appType STAR tupleOrQuotTypeElements  recover
     { reportParseErrorAt (rhs parseState 2) (FSComp.SR.parsUnmatchedParen()) 
-      //SynType.Tuple(true, (false, $3) :: $5, lhs parseState)
-      mkTupleOrDivide true $3 true $5 }
+      //SynType.Tuple(true, (false, $3) :: $5, lhs parseState
+      let mStar = rhs parseState 4
+      let path = TupleTypeSegment.Type $3 :: TupleTypeSegment.Star mStar :: $5
+      mkTupleOrDivide true path }
 
   | STRUCT LPAREN appType STAR recover
     { reportParseErrorAt (rhs parseState 2) (FSComp.SR.parsUnmatchedParen()) 

tests/service/ServiceUntypedParseTests.fs

@@ -12,6 +12,7 @@ open FsUnit
 open FSharp.Compiler.EditorServices
 open FSharp.Compiler.Service.Tests.Common
 open FSharp.Compiler.Syntax
+open FSharp.Compiler.SyntaxTreeOps
 open FSharp.Compiler.Text
 open FSharp.Compiler.Text.Position
 open NUnit.Framework
@@ -156,8 +157,8 @@ let rec getParenTypes (synType: SynType): SynType list =
           yield! getParenTypes argType
           yield! getParenTypes returnType
 
-      | SynType.Tuple(_, _, _, elements, _) ->
-          for _, synType in elements do
+      | SynType.Tuple(path = segment) ->
+          for synType in getTypeFromTuplePath segment do
               yield! getParenTypes synType
 
       | SynType.AnonRecd (_, fields, _) ->

tests/service/SyntaxTreeTests/MeasureTests.fs

@@ -46,4 +46,54 @@ let ``SynMeasure.Paren has correct range`` () =
         Assert.AreEqual("staff", staffIdent.idText)
         Assert.AreEqual("weeks", weeksIdent.idText)
         assertRange (2, 9) (2, 22) mParen
+    | _ -> Assert.Fail $"Could not get valid AST, got {parseResults}"
+
+let private (|TypeName|_|) t =
+    match t with
+    | SynType.LongIdent(SynLongIdent([ident], _, _)) -> Some ident.idText
+    | _ -> None
+
+[<Test>]
+let ``SynType.Tuple in measure type with no slashes`` () =
+    let parseResults = 
+        getParseResults
+            """
+[<Measure>] type X = Y * Z
+"""
+
+    match parseResults with
+    | ParsedInput.ImplFile (ParsedImplFileInput (modules = [ SynModuleOrNamespace.SynModuleOrNamespace(decls = [
+        SynModuleDecl.Types(typeDefns = [
+            SynTypeDefn(typeRepr =
+                SynTypeDefnRepr.Simple(simpleRepr =
+                    SynTypeDefnSimpleRepr.TypeAbbrev(rhsType =
+                        SynType.Tuple(false, [ TupleTypeSegment.Type (TypeName "Y")
+                                               TupleTypeSegment.Star mStar
+                                               TupleTypeSegment.Type (TypeName "Z") ], mTuple))))
+        ])
+    ]) ])) ->
+        assertRange (2, 23) (2, 24) mStar
+        assertRange (2, 21) (2, 26) mTuple
+    | _ -> Assert.Fail $"Could not get valid AST, got {parseResults}"
+
+[<Test>]
+let ``SynType.Tuple in measure type with leading slash`` () =
+    let parseResults = 
+        getParseResults
+            """
+[<Measure>] type X = / second
+"""
+
+    match parseResults with
+    | ParsedInput.ImplFile (ParsedImplFileInput (modules = [ SynModuleOrNamespace.SynModuleOrNamespace(decls = [
+        SynModuleDecl.Types(typeDefns = [
+            SynTypeDefn(typeRepr =
+                SynTypeDefnRepr.Simple(simpleRepr =
+                    SynTypeDefnSimpleRepr.TypeAbbrev(rhsType =
+                        SynType.Tuple(false, [ TupleTypeSegment.Slash mSlash
+                                               TupleTypeSegment.Type (TypeName "second") ], mTuple))))
+        ])
+    ]) ])) ->
+        assertRange (2, 21) (2, 22) mSlash
+        assertRange (2, 21) (2, 29) mTuple
     | _ -> Assert.Fail $"Could not get valid AST, got {parseResults}"