Break a long type application (not TypeApplications) (#664)

* Break a long type application (not `TypeApplications`) Although it was reported as a type synonym issue, it was a general problem with types being written, not limited to type synonyms. This commit involves a considerable change. While we were able to keep each line within 80 lines, honestly, I feel that some parts lost readability (especially the multi-line headers in the instance declarations). Fixes: #534 * Fix a missing verb * Add a test for a type signature * Add a changelog * Remove a duplicated branch
mihaimaruseac · Jan 7, 2023 · 6926b7d · 6926b7d
1 parent 2bfb7a7
commit 6926b7d
Show file tree

Hide file tree

Showing 5 changed files with 139 additions and 41 deletions.
diff --git a/CHANGELOG.md b/CHANGELOG.md
@@ -13,6 +13,8 @@
 - Changed how to format a data type with a record constructor to follow
   the [Johan Tibell's Haskell Style Guide]. ([#662]).
 - A newline is no longer inserted after a pattern signature ([#663]).
+- A type with many type applications are now broken into multiple lines.
+  ([#664]).
 
 ### Removed
 
@@ -303,6 +305,7 @@ This version is accidentally pushlished, and is the same as 5.3.3.
 [@uhbif19]: https://github.com/uhbif19
 [@toku-sa-n]: https://github.com/toku-sa-n
 
+[#664]: https://github.com/mihaimaruseac/hindent/pull/664
 [#663]: https://github.com/mihaimaruseac/hindent/pull/663
 [#662]: https://github.com/mihaimaruseac/hindent/pull/662
 [#588]: https://github.com/mihaimaruseac/hindent/pull/588

diff --git a/TESTS.md b/TESTS.md
@@ -1553,10 +1553,11 @@ A long type is broken into lines
 -- https://github.com/mihaimaruseac/hindent/issues/359
 thing ::
      ( ResB.BomEx
-     , Maybe [( Entity BomSnapshot
-              , ( [ResBS.OrderSubstituteAggr]
-                , ( Maybe (Entity BomSnapshotHistory)
-                  , Maybe (Entity BomSnapshotHistory))))])
+     , Maybe
+         [( Entity BomSnapshot
+          , ( [ResBS.OrderSubstituteAggr]
+            , ( Maybe (Entity BomSnapshotHistory)
+              , Maybe (Entity BomSnapshotHistory))))])
   -> [(ResB.BomEx, Maybe ResBS.BomSnapshotAggr)]
 ```
 
@@ -1637,6 +1638,20 @@ foo = undefined
     go = undefined
 ```
 
+Types with many type applications
+
+```haskell
+foo ::
+     Foo
+       LongLongType
+       LongLongType
+       LongLongType
+       LongLongType
+       LongLongType
+       LongLongType
+  -> Int
+```
+
 #### Promoted types
 
 Promoted lists
@@ -1801,12 +1816,35 @@ Long
 ```haskell
 -- https://github.com/mihaimaruseac/hindent/issues/290
 type MyContext m
-   = ( MonadState Int m
-     , MonadReader Int m
-     , MonadError Text m
-     , MonadMask m
-     , Monoid m
-     , Functor m)
+  = ( MonadState Int m
+    , MonadReader Int m
+    , MonadError Text m
+    , MonadMask m
+    , Monoid m
+    , Functor m)
+```
+
+Very higher-kinded type
+
+```haskell
+-- https://github.com/mihaimaruseac/hindent/issues/534
+type SomeTypeSynonym
+  = RecordWithManyFields
+      FieldNumber1
+      FieldNumber2
+      FieldNumber3
+      FieldNumber4
+      FieldNumber5
+      FieldNumber6
+      FieldNumber7
+      FieldNumber8
+      FieldNumber9
+      FieldNumber10
+      FieldNumber11
+      FieldNumber12
+      FieldNumber13
+      FieldNumber14
+      FieldNumber15
 ```
 
 Infix type constructor

diff --git a/src/HIndent/Pretty.hs b/src/HIndent/Pretty.hs
@@ -205,14 +205,8 @@ prettyTyClDecl SynDecl {..} = do
         _ -> error "Not enough parameters are given."
   hor <-|> ver
   where
-    hor = do
-      string " = "
-      pretty tcdRhs
-    ver =
-      indentedBlock $ do
-        newline
-        string " = "
-        indentedBlock $ pretty tcdRhs
+    hor = string " = " >> pretty tcdRhs
+    ver = newline >> indentedBlock (string "= " |=> pretty tcdRhs)
 #if MIN_VERSION_ghc_lib_parser(9,4,1)
 prettyTyClDecl DataDecl {..} = do
   printDataNewtype |=> do
@@ -1021,6 +1015,10 @@ instance Pretty HsType' where
         string " =>"
         newline
         pretty hst_body
+  pretty' (HsTypeWithVerticalAppTy (HsAppTy _ l r)) = do
+    pretty $ fmap HsTypeWithVerticalAppTy l
+    newline
+    indentedBlock $ pretty $ fmap HsTypeWithVerticalAppTy r
   pretty' (HsType' _ _ x) = prettyHsType x
 
 prettyHsType :: HsType GhcPs -> Printer ()
@@ -1030,7 +1028,10 @@ prettyHsType HsQualTy {..} = do
   lined [string " =>", indentedBlock $ pretty hst_body]
 prettyHsType (HsTyVar _ NotPromoted x) = pretty x
 prettyHsType (HsTyVar _ IsPromoted x) = string "'" >> pretty x
-prettyHsType (HsAppTy _ l r) = spaced $ fmap pretty [l, r]
+prettyHsType x@(HsAppTy _ l r) = hor <-|> ver
+  where
+    hor = spaced $ fmap pretty [l, r]
+    ver = pretty $ HsTypeWithVerticalAppTy x
 prettyHsType (HsAppKindTy _ l r) = pretty l >> string " @" >> pretty r
 prettyHsType (HsFunTy _ _ a b) = (pretty a >> string " -> ") |=> pretty b
 prettyHsType (HsListTy _ xs) = brackets $ pretty xs
@@ -1358,12 +1359,14 @@ instance Pretty RecConField where
       pretty hfbRHS
 #else
 -- | For pattern matching against a record.
-instance Pretty (HsRecField' (FieldOcc GhcPs) (GenLocated SrcSpanAnnA (Pat GhcPs))) where
+instance Pretty
+           (HsRecField' (FieldOcc GhcPs) (GenLocated SrcSpanAnnA (Pat GhcPs))) where
   pretty' HsRecField {..} =
     (pretty hsRecFieldLbl >> string " = ") |=> pretty hsRecFieldArg
 
 -- | For record updates.
-instance Pretty (HsRecField' (FieldOcc GhcPs) (GenLocated SrcSpanAnnA (HsExpr GhcPs))) where
+instance Pretty
+           (HsRecField' (FieldOcc GhcPs) (GenLocated SrcSpanAnnA (HsExpr GhcPs))) where
   pretty' HsRecField {..} = do
     pretty hsRecFieldLbl
     unless hsRecPun $ do
@@ -1375,11 +1378,17 @@ instance Pretty (HsRecField' (FieldOcc GhcPs) (GenLocated SrcSpanAnnA (HsExpr Gh
 #endif
 #if MIN_VERSION_ghc_lib_parser(9,4,1)
 -- | For pattern matchings against records.
-instance Pretty (HsFieldBind (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs)) (GenLocated SrcSpanAnnA (Pat GhcPs))) where
+instance Pretty
+           (HsFieldBind
+              (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs))
+              (GenLocated SrcSpanAnnA (Pat GhcPs))) where
   pretty' HsFieldBind {..} = (pretty hfbLHS >> string " = ") |=> pretty hfbRHS
 
 -- | For record updates.
-instance Pretty (HsFieldBind (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs)) (GenLocated SrcSpanAnnA (HsExpr GhcPs))) where
+instance Pretty
+           (HsFieldBind
+              (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs))
+              (GenLocated SrcSpanAnnA (HsExpr GhcPs))) where
   pretty' HsFieldBind {..} = do
     pretty hfbLHS
     unless hfbPun $ do
@@ -1404,7 +1413,13 @@ instance Pretty (FieldOcc GhcPs) where
   pretty' FieldOcc {..} = pretty rdrNameFieldOcc
 #endif
 -- HsConDeclH98Details
-instance Pretty (HsConDetails Void (HsScaled GhcPs (GenLocated SrcSpanAnnA (BangType GhcPs))) (GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcPs)])) where
+instance Pretty
+           (HsConDetails
+              Void
+              (HsScaled GhcPs (GenLocated SrcSpanAnnA (BangType GhcPs)))
+              (GenLocated
+                 SrcSpanAnnL
+                 [GenLocated SrcSpanAnnA (ConDeclField GhcPs)])) where
   pretty' (PrefixCon _ xs) = horizontal <-|> vertical
     where
       horizontal = spacePrefixed $ fmap pretty xs
@@ -1720,7 +1735,10 @@ instance Pretty (FamEqn GhcPs (HsDataDefn GhcPs)) where
     pretty feqn_rhs
 
 -- | HsArg (LHsType GhcPs) (LHsType GhcPs)
-instance Pretty (HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))) where
+instance Pretty
+           (HsArg
+              (GenLocated SrcSpanAnnA (HsType GhcPs))
+              (GenLocated SrcSpanAnnA (HsType GhcPs))) where
   pretty' (HsValArg x) = pretty x
   pretty' (HsTypeArg _ x) = string "@" >> pretty x
   pretty' HsArgPar {} = notUsedInParsedStage
@@ -1812,7 +1830,8 @@ instance Pretty (DerivDecl GhcPs) where
     pretty deriv_type
 
 -- | 'Pretty' for 'LHsSigWcType GhcPs'.
-instance Pretty (HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))) where
+instance Pretty
+           (HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))) where
   pretty' HsWC {..} = pretty hswc_body
 
 -- | 'Pretty' for 'LHsWcType'
@@ -1906,7 +1925,11 @@ instance Pretty (PatSynBind GhcPs GhcPs) where
       _ -> pure ()
 
 -- | 'Pretty' for 'HsPatSynDetails'.
-instance Pretty (HsConDetails Void (GenLocated SrcSpanAnnN RdrName) [RecordPatSynField GhcPs]) where
+instance Pretty
+           (HsConDetails
+              Void
+              (GenLocated SrcSpanAnnN RdrName)
+              [RecordPatSynField GhcPs]) where
   pretty' (PrefixCon _ xs) = spaced $ fmap pretty xs
   pretty' (RecCon rec) = hFields $ fmap pretty rec
   pretty' InfixCon {} =

diff --git a/src/HIndent/Pretty/NodeComments.hs b/src/HIndent/Pretty/NodeComments.hs
@@ -204,7 +204,8 @@ instance CommentExtraction (ConDecl GhcPs) where
 instance CommentExtraction (Match GhcPs a) where
   nodeComments Match {..} = nodeComments m_ext
 
-instance CommentExtraction (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))) where
+instance CommentExtraction
+           (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))) where
   nodeComments LastStmt {} = emptyNodeComments
   nodeComments (BindStmt x _ _) = nodeComments x
   nodeComments ApplicativeStmt {} = emptyNodeComments
@@ -214,7 +215,8 @@ instance CommentExtraction (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr G
   nodeComments TransStmt {..} = nodeComments trS_ext
   nodeComments RecStmt {..} = nodeComments recS_ext
 
-instance CommentExtraction (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsCmd GhcPs))) where
+instance CommentExtraction
+           (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsCmd GhcPs))) where
   nodeComments LastStmt {} = emptyNodeComments
   nodeComments (BindStmt x _ _) = nodeComments x
   nodeComments ApplicativeStmt {} = emptyNodeComments
@@ -228,11 +230,13 @@ instance CommentExtraction StmtLRInsideVerticalList where
   nodeComments (StmtLRInsideVerticalList x) = nodeComments x
 
 -- | For pattern matching.
-instance CommentExtraction (HsRecFields GhcPs (GenLocated SrcSpanAnnA (Pat GhcPs))) where
+instance CommentExtraction
+           (HsRecFields GhcPs (GenLocated SrcSpanAnnA (Pat GhcPs))) where
   nodeComments HsRecFields {} = emptyNodeComments
 
 -- | For record updates
-instance CommentExtraction (HsRecFields GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))) where
+instance CommentExtraction
+           (HsRecFields GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))) where
   nodeComments HsRecFields {} = emptyNodeComments
 
 instance CommentExtraction (HsType GhcPs) where
@@ -412,20 +416,28 @@ instance CommentExtraction RecConField where
   nodeComments (RecConField x) = nodeComments x
 #else
 -- | For pattern matching against a record.
-instance CommentExtraction (HsRecField' (FieldOcc GhcPs) (GenLocated SrcSpanAnnA (Pat GhcPs))) where
+instance CommentExtraction
+           (HsRecField' (FieldOcc GhcPs) (GenLocated SrcSpanAnnA (Pat GhcPs))) where
   nodeComments HsRecField {..} = nodeComments hsRecFieldAnn
 
 -- | For record updates.
-instance CommentExtraction (HsRecField' (FieldOcc GhcPs) (GenLocated SrcSpanAnnA (HsExpr GhcPs))) where
+instance CommentExtraction
+           (HsRecField' (FieldOcc GhcPs) (GenLocated SrcSpanAnnA (HsExpr GhcPs))) where
   nodeComments HsRecField {..} = nodeComments hsRecFieldAnn
 #endif
 #if MIN_VERSION_ghc_lib_parser(9,4,1)
 -- | For pattern matchings against records.
-instance CommentExtraction (HsFieldBind (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs)) (GenLocated SrcSpanAnnA (Pat GhcPs))) where
+instance CommentExtraction
+           (HsFieldBind
+              (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs))
+              (GenLocated SrcSpanAnnA (Pat GhcPs))) where
   nodeComments HsFieldBind {..} = nodeComments hfbAnn
 
 -- | For record updates.
-instance CommentExtraction (HsFieldBind (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs)) (GenLocated SrcSpanAnnA (HsExpr GhcPs))) where
+instance CommentExtraction
+           (HsFieldBind
+              (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcPs))
+              (GenLocated SrcSpanAnnA (HsExpr GhcPs))) where
   nodeComments HsFieldBind {..} = nodeComments hfbAnn
 #else
 instance CommentExtraction RecConField where
@@ -439,7 +451,13 @@ instance CommentExtraction (FieldOcc GhcPs) where
   nodeComments FieldOcc {} = emptyNodeComments
 #endif
 -- HsConDeclH98Details
-instance CommentExtraction (HsConDetails Void (HsScaled GhcPs (GenLocated SrcSpanAnnA (BangType GhcPs))) (GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcPs)])) where
+instance CommentExtraction
+           (HsConDetails
+              Void
+              (HsScaled GhcPs (GenLocated SrcSpanAnnA (BangType GhcPs)))
+              (GenLocated
+                 SrcSpanAnnL
+                 [GenLocated SrcSpanAnnA (ConDeclField GhcPs)])) where
   nodeComments PrefixCon {} = emptyNodeComments
   nodeComments RecCon {} = emptyNodeComments
   nodeComments InfixCon {} = emptyNodeComments
@@ -554,15 +572,19 @@ instance CommentExtraction (IE GhcPs) where
   nodeComments IEDoc {} = emptyNodeComments
   nodeComments IEDocNamed {} = emptyNodeComments
 
-instance CommentExtraction (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))) where
+instance CommentExtraction
+           (FamEqn GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))) where
   nodeComments FamEqn {..} = nodeComments feqn_ext
 
 -- | Pretty-print a data instance.
 instance CommentExtraction (FamEqn GhcPs (HsDataDefn GhcPs)) where
   nodeComments FamEqn {..} = nodeComments feqn_ext
 
 -- | HsArg (LHsType GhcPs) (LHsType GhcPs)
-instance CommentExtraction (HsArg (GenLocated SrcSpanAnnA (HsType GhcPs)) (GenLocated SrcSpanAnnA (HsType GhcPs))) where
+instance CommentExtraction
+           (HsArg
+              (GenLocated SrcSpanAnnA (HsType GhcPs))
+              (GenLocated SrcSpanAnnA (HsType GhcPs))) where
   nodeComments HsValArg {} = emptyNodeComments
   nodeComments HsTypeArg {} = emptyNodeComments
   nodeComments HsArgPar {} = emptyNodeComments
@@ -609,11 +631,13 @@ instance CommentExtraction (DerivDecl GhcPs) where
   nodeComments DerivDecl {..} = nodeComments deriv_ext
 
 -- | 'Pretty' for 'LHsSigWcType GhcPs'.
-instance CommentExtraction (HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))) where
+instance CommentExtraction
+           (HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))) where
   nodeComments HsWC {} = emptyNodeComments
 
 -- | 'Pretty' for 'LHsWcType'
-instance CommentExtraction (HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))) where
+instance CommentExtraction
+           (HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))) where
   nodeComments HsWC {} = emptyNodeComments
 
 instance CommentExtraction (StandaloneKindSig GhcPs) where
@@ -664,7 +688,11 @@ instance CommentExtraction (PatSynBind GhcPs GhcPs) where
   nodeComments PSB {..} = nodeComments psb_ext
 
 -- | 'Pretty' for 'HsPatSynDetails'.
-instance CommentExtraction (HsConDetails Void (GenLocated SrcSpanAnnN RdrName) [RecordPatSynField GhcPs]) where
+instance CommentExtraction
+           (HsConDetails
+              Void
+              (GenLocated SrcSpanAnnN RdrName)
+              [RecordPatSynField GhcPs]) where
   nodeComments PrefixCon {} = emptyNodeComments
   nodeComments RecCon {} = emptyNodeComments
   nodeComments InfixCon {} = emptyNodeComments

diff --git a/src/HIndent/Pretty/Types.hs b/src/HIndent/Pretty/Types.hs
@@ -24,6 +24,7 @@ module HIndent.Pretty.Types
   , pattern HsTypeInsideVerticalFuncSig
   , pattern HsTypeInsideDeclSig
   , pattern HsTypeInsideInstDecl
+  , pattern HsTypeWithVerticalAppTy
   , StmtLRInsideVerticalList(..)
   , ParStmtBlockInsideVerticalList(..)
   , DeclSig(..)
@@ -151,6 +152,10 @@ pattern HsTypeInsideDeclSig x = HsType' HsTypeForDeclSig HsTypeNoDir x
 pattern HsTypeInsideInstDecl :: HsType GhcPs -> HsType'
 pattern HsTypeInsideInstDecl x = HsType' HsTypeForInstDecl HsTypeNoDir x
 
+-- | `HsType'` to pretty-print a `HsAppTy` vertically.
+pattern HsTypeWithVerticalAppTy :: HsType GhcPs -> HsType'
+pattern HsTypeWithVerticalAppTy x = HsType' HsTypeForVerticalAppTy HsTypeVertical x
+
 -- | `StmtLR` inside a vertically printed list.
 newtype StmtLRInsideVerticalList =
   StmtLRInsideVerticalList (StmtLR GhcPs GhcPs (LHsExpr GhcPs))
@@ -273,6 +278,7 @@ data HsTypeFor
   | HsTypeForInstDecl
   | HsTypeForFuncSig
   | HsTypeForDeclSig
+  | HsTypeForVerticalAppTy
 
 -- | Values indicating how a node should be printed; either horizontally or
 -- vertically.