Format multiline type function signature in multiple lines. Fixes fsp…

…rojects#1287.
nojaf · Apr 4, 2021 · 616d5b0 · 616d5b0
1 parent dd28438
commit 616d5b0
Show file tree

Hide file tree

Showing 3 changed files with 99 additions and 7 deletions.
diff --git a/src/Fantomas.Tests/SignatureTests.fs b/src/Fantomas.Tests/SignatureTests.fs
@@ -1431,3 +1431,32 @@ module internal FSharp.Compiler.TypedTreePickle
 val inline internal u_tup4 :
     unpickler<'T2> -> unpickler<'T3> -> unpickler<'T4> -> unpickler<'T5> -> unpickler<'T2 * 'T3 * 'T4 * 'T5>
 """
+
+[<Test>]
+let ``comments after indents in multiline type function signature, 1287`` () =
+    formatSourceString
+        true
+        """
+namespace Test
+
+module OrderProcessing =
+  type ValidateOrder =
+    CheckProductCodeExists    // dependency
+      -> CheckAddressExists   // dependency
+      -> UnvalidatedOrder     // input
+      -> Result<ValidatedOrder,ValidationError>  // output (Result b/c one of deps returns a Result)
+"""
+        { config with MaxLineLength = 80 }
+    |> prepend newline
+    |> should
+        equal
+        """
+namespace Test
+
+module OrderProcessing =
+    type ValidateOrder =
+        CheckProductCodeExists -> // dependency
+            CheckAddressExists -> // dependency
+            UnvalidatedOrder -> // input
+            Result<ValidatedOrder, ValidationError> // output (Result b/c one of deps returns a Result)
+"""
diff --git a/src/Fantomas.Tests/TypeDeclarationTests.fs b/src/Fantomas.Tests/TypeDeclarationTests.fs
@@ -2687,3 +2687,27 @@ type X =
     /// Get a blob of data indicating how this type is nested inside other namespaces, modules and types.
     member x.CompilationPathOpt = x.entity_cpath
 """
+
+[<Test>]
+let ``multiline type function signature`` () =
+    formatSourceString false """
+namespace Test
+
+module OrderProcessing =
+  type ValidateOrder =
+    CheckProductCodeExists    // dependency
+      -> CheckAddressExists   // dependency
+      -> UnvalidatedOrder     // input
+      -> Result<ValidatedOrder,ValidationError>  // output (Result b/c one of deps returns a Result)
+"""  config
+    |> prepend newline
+    |> should equal """
+namespace Test
+
+module OrderProcessing =
+    type ValidateOrder =
+        CheckProductCodeExists -> // dependency
+            CheckAddressExists -> // dependency
+            UnvalidatedOrder -> // input
+            Result<ValidatedOrder, ValidationError> // output (Result b/c one of deps returns a Result)
+"""
diff --git a/src/Fantomas/CodePrinter.fs b/src/Fantomas/CodePrinter.fs
@@ -3764,14 +3764,17 @@ and genSigTypeDefn astContext (SigTypeDef (ats, px, ao, tds, tcs, tdr, ms, s, pr
              +> leaveNodeFor SynAttributeList_ h.Range)
                 ctx
 
-    let typeName =
+    let genXmlTypeKeywordAttrsAccess =
         genPreXmlDoc px
         +> ifElse
             astContext.IsFirstChild
             (genAttributes astContext ats -- "type ")
             ((!- "and " +> genOnelinerAttributes astContext ats)
              |> genTriviaForOnelinerAttributes)
         +> opt sepSpace ao genAccess
+
+    let typeName =
+        genXmlTypeKeywordAttrsAccess
         +> genTypeAndParam astContext s tds tcs preferPostfix
 
     match tdr with
@@ -3890,7 +3893,23 @@ and genSigTypeDefn astContext (SigTypeDef (ats, px, ao, tds, tcs, tdr, ms, s, pr
             +> genType astContext false t
             +> ifElse needsParenthesis sepCloseT sepNone
 
-        typeName +> sepEq +> sepSpace +> genTypeAbbrev
+        let short =
+            genTypeAndParam astContext s tds tcs preferPostfix
+            +> sepEq
+            +> sepSpace
+            +> genTypeAbbrev
+
+        let long =
+            genTypeAndParam astContext s tds tcs preferPostfix
+            +> sepSpace
+            +> sepEqFixed
+            +> indent
+            +> sepNln
+            +> genTypeAbbrev
+            +> unindent
+
+        genXmlTypeKeywordAttrsAccess
+        +> expressionFitsOnRestOfLine short long
     | SigSimple (TDSRException (ExceptionDefRepr (ats, px, ao, uc))) -> genExceptionBody astContext ats px ao uc
 
     | SigObjectModel (TCSimple (TCStruct
@@ -4189,11 +4208,15 @@ and genType astContext outerBracket t =
                     +> sepCloseT
                     +> loop t
 
-            ifElse isPostfix postForm (loop t +> genPrefixTypes astContext ts)
+            ifElse
+                isPostfix
+                postForm
+                (loop t
+                 +> genPrefixTypes astContext ts current.Range)
 
         | TLongIdentApp (t, s, ts) ->
             loop t -- sprintf ".%s" s
-            +> genPrefixTypes astContext ts
+            +> genPrefixTypes astContext ts current.Range
         | TTuple ts -> loopTTupleList ts
         | TStructTuple ts ->
             !- "struct "
@@ -4260,7 +4283,23 @@ and genType astContext outerBracket t =
              +> loop t
              +> sepCloseT)
             (loopTTupleList ts +> sepArrow +> loop t)
-    | TFuns ts -> ifElse outerBracket (sepOpenT +> col sepArrow ts loop +> sepCloseT) (col sepArrow ts loop)
+    | TFuns ts ->
+        let short = col sepArrow ts loop
+
+        let long =
+            match ts with
+            | [] -> sepNone
+            | h :: rest ->
+                loop h
+                +> sepSpace
+                +> sepArrowFixed
+                +> indent
+                +> sepNln
+                +> col (sepSpace +> sepArrowFixed +> sepNln) rest loop
+
+        let genTs = expressionFitsOnRestOfLine short long
+
+        ifElse outerBracket (sepOpenT +> genTs +> sepCloseT) genTs
     | TTuple ts -> ifElse outerBracket (sepOpenT +> loopTTupleList ts +> sepCloseT) (loopTTupleList ts)
     | _ -> loop t
 
@@ -4282,7 +4321,7 @@ and addSpaceIfSynTypeStaticConstantHasAtSignBeforeString (t: SynType) (ctx: Cont
 and genAnonRecordFieldType astContext (AnonRecordFieldType (s, t)) =
     !-s +> sepColon +> (genType astContext false t)
 
-and genPrefixTypes astContext node ctx =
+and genPrefixTypes astContext node (range: Range) ctx =
     match node with
     | [] -> ctx
     // Where <  and ^ meet, we need an extra space. For example:  seq< ^a >
@@ -4296,7 +4335,7 @@ and genPrefixTypes astContext node ctx =
          +> addSpaceIfSynTypeStaticConstantHasAtSignBeforeString t
          +> col sepComma node (genType astContext false)
          +> addSpaceIfSynTypeStaticConstantHasAtSignBeforeString t
-         -- ">")
+         +> tokN range GREATER (!- ">"))
             ctx
 
 and genTypeList astContext node =