Fix some issues with record field padding

See #318 and #319

4 files changed, 198 insertions, 102 deletions

diff --git a/lib/Language/Haskell/Stylish/Printer.hs b/lib/Language/Haskell/Stylish/Printer.hs
index 886f912..a7ddf5e 100644
--- a/lib/Language/Haskell/Stylish/Printer.hs
+++ b/lib/Language/Haskell/Stylish/Printer.hs
@@ -44,6 +44,7 @@ module Language.Haskell.Stylish.Printer
   , space
   , spaces
   , suffix
+  , pad
 
     -- ** Advanced combinators
   , withColumns
@@ -323,6 +324,13 @@ prefix pa pb = pa >> pb
 suffix :: P a -> P b -> P a
 suffix pa pb = pb >> pa
 
+-- | Indent to a given number of spaces.  If the current line already exceeds
+-- that number in length, nothing happens.
+pad :: Int -> P ()
+pad n = do
+    len <- length <$> getCurrentLine
+    spaces $ n - len
+
 -- | Gets comment on supplied 'line' and removes it from the state
 removeLineComment :: Int -> P (Maybe AnnotationComment)
 removeLineComment line =
diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs
index 523389b..77d12a0 100644
--- a/lib/Language/Haskell/Stylish/Step/Data.hs
+++ b/lib/Language/Haskell/Stylish/Step/Data.hs
@@ -1,10 +1,12 @@
-{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE BlockArguments  #-}
 {-# LANGUAGE DoAndIfThenElse #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE LambdaCase      #-}
+{-# LANGUAGE NamedFieldPuns  #-}
 {-# LANGUAGE RecordWildCards #-}
 module Language.Haskell.Stylish.Step.Data
   ( Config(..)
+  , defaultConfig
+
   , Indent(..)
   , MaxColumns(..)
   , step
@@ -22,19 +24,24 @@ import           Data.Maybe                       (listToMaybe)
 
 --------------------------------------------------------------------------------
 import           ApiAnnotation                    (AnnotationComment)
-import           BasicTypes                       (LexicalFixity(..))
-import           GHC.Hs.Decls                     (HsDecl(..), HsDataDefn(..))
-import           GHC.Hs.Decls                     (TyClDecl(..), NewOrData(..))
-import           GHC.Hs.Decls                     (HsDerivingClause(..), DerivStrategy(..))
-import           GHC.Hs.Decls                     (ConDecl(..))
-import           GHC.Hs.Extension                 (GhcPs, NoExtField(..), noExtCon)
-import           GHC.Hs.Types                     (ConDeclField(..), HsContext)
-import           GHC.Hs.Types                     (HsType(..), ForallVisFlag(..))
-import           GHC.Hs.Types                     (LHsQTyVars(..), HsTyVarBndr(..))
-import           GHC.Hs.Types                     (HsConDetails(..), HsImplicitBndrs(..))
+import           BasicTypes                       (LexicalFixity (..))
+import           GHC.Hs.Decls                     (ConDecl (..),
+                                                   DerivStrategy (..),
+                                                   HsDataDefn (..), HsDecl (..),
+                                                   HsDerivingClause (..),
+                                                   NewOrData (..),
+                                                   TyClDecl (..))
+import           GHC.Hs.Extension                 (GhcPs, NoExtField (..),
+                                                   noExtCon)
+import           GHC.Hs.Types                     (ConDeclField (..),
+                                                   ForallVisFlag (..),
+                                                   HsConDetails (..), HsContext,
+                                                   HsImplicitBndrs (..),
+                                                   HsTyVarBndr (..),
+                                                   HsType (..), LHsQTyVars (..))
 import           RdrName                          (RdrName)
-import           SrcLoc                           (Located, RealLocated)
-import           SrcLoc                           (GenLocated(..))
+import           SrcLoc                           (GenLocated (..), Located,
+                                                   RealLocated)
 
 --------------------------------------------------------------------------------
 import           Language.Haskell.Stylish.Block
@@ -76,6 +83,21 @@ data Config = Config
     , cMaxColumns              :: !MaxColumns
     } deriving (Show)
 
+-- | TODO: pass in MaxColumns?
+defaultConfig :: Config
+defaultConfig = Config
+    { cEquals          = Indent 4
+    , cFirstField      = Indent 4
+    , cFieldComment    = 2
+    , cDeriving        = 4
+    , cBreakEnums      = True
+    , cBreakSingleConstructors = False
+    , cVia             = Indent 4
+    , cSortDeriving    = True
+    , cMaxColumns      = NoMaxColumns
+    , cCurriedContext    = False
+    }
+
 step :: Config -> Step
 step cfg = makeStep "Data" \ls m -> applyChanges (changes m) ls
   where
@@ -190,8 +212,8 @@ formatDataDecl cfg@Config{..} m ldecl@(L declPos decl) =
 data DataDecl = MkDataDecl
   { dataDeclName :: Located RdrName
   , dataTypeVars :: LHsQTyVars GhcPs
-  , dataDefn :: HsDataDefn GhcPs
-  , dataFixity :: LexicalFixity
+  , dataDefn     :: HsDataDefn GhcPs
+  , dataFixity   :: LexicalFixity
   }
 
 putDeriving :: Config -> Located (HsDerivingClause GhcPs) -> P ()
@@ -199,10 +221,10 @@ putDeriving Config{..} (L pos clause) = do
   putText "deriving"
 
   forM_ (deriv_clause_strategy clause) \case
-    L _ StockStrategy -> space >> putText "stock"
+    L _ StockStrategy    -> space >> putText "stock"
     L _ AnyclassStrategy -> space >> putText "anyclass"
-    L _ NewtypeStrategy -> space >> putText "newtype"
-    L _ (ViaStrategy _) -> pure ()
+    L _ NewtypeStrategy  -> space >> putText "newtype"
+    L _ (ViaStrategy _)  -> pure ()
 
   putCond
     withinColumns
@@ -224,13 +246,13 @@ putDeriving Config{..} (L pos clause) = do
 
   where
     getType = \case
-      HsIB _ tp -> tp
+      HsIB _ tp          -> tp
       XHsImplicitBndrs x -> noExtCon x
 
     withinColumns PrinterState{currentLine} =
       case cMaxColumns of
         MaxColumns maxCols -> length currentLine <= maxCols
-        NoMaxColumns -> True
+        NoMaxColumns       -> True
 
     oneLinePrint = do
       space
@@ -361,8 +383,10 @@ putConstructor cfg consIndent (L _ cons) = case cons of
         sep space (fmap putOutputable xs)
       RecCon (L recPos (L posFirst firstArg : args)) -> do
         putRdrName con_name
-        skipToBrace >> putText "{"
+        skipToBrace
         bracePos <- getCurrentLineLength
+        putText "{"
+        let fieldPos = bracePos + 2
         space
 
         -- Unless everything's configured to be on the same line, put pending
@@ -371,7 +395,7 @@ putConstructor cfg consIndent (L _ cons) = case cons of
           removeCommentTo posFirst >>= mapM_ \c -> putComment c >> sepDecl bracePos
 
         -- Put first decl field
-        putConDeclField cfg firstArg
+        pad fieldPos >> putConDeclField cfg firstArg
         unless (cFirstField cfg == SameLine) (putEolComment posFirst)
 
         -- Put tail decl fields
@@ -395,6 +419,7 @@ putConstructor cfg consIndent (L _ cons) = case cons of
         skipToBrace >> putText "}"
 
     where
+      -- Jump to the first brace of the first record of the first constructor.
       skipToBrace = case (cEquals cfg, cFirstField cfg) of
         (_, Indent y) | not (cBreakSingleConstructors cfg) -> newline >> spaces y
         (SameLine, SameLine) -> space
@@ -402,12 +427,13 @@ putConstructor cfg consIndent (L _ cons) = case cons of
         (SameLine, Indent y) -> newline >> spaces (consIndent + y)
         (Indent _, SameLine) -> space
 
+      -- Jump to the next declaration.
       sepDecl bracePos = newline >> spaces case (cEquals cfg, cFirstField cfg) of
         (_, Indent y) | not (cBreakSingleConstructors cfg) -> y
-        (SameLine, SameLine) -> bracePos - 1 -- back one from brace pos to place comma
+        (SameLine, SameLine) -> bracePos
         (Indent x, Indent y) -> x + y + 2
-        (SameLine, Indent y) -> bracePos - 1 + y - 2
-        (Indent x, SameLine) -> bracePos - 1 + x - 2
+        (SameLine, Indent y) -> bracePos + y - 2
+        (Indent x, SameLine) -> bracePos + x - 2
 
 putNewtypeConstructor :: Config -> Located (ConDecl GhcPs) -> P ()
 putNewtypeConstructor cfg (L _ cons) = case cons of
@@ -493,7 +519,7 @@ isGADT = any isGADTCons . dd_cons . dataDefn
   where
     isGADTCons = \case
       L _ (ConDeclGADT {}) -> True
-      _ -> False
+      _                    -> False
 
 isNewtype :: DataDecl -> Bool
 isNewtype = (== NewType) . dd_ND . dataDefn
@@ -507,7 +533,7 @@ isEnum = all isUnary . dd_cons . dataDefn
     isUnary = \case
       L _ (ConDeclH98 {..}) -> case con_args of
         PrefixCon [] -> True
-        _ -> False
+        _            -> False
       _ -> False
 
 hasConstructors :: DataDecl -> Bool
diff --git a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs
index 728ce4a..58752fe 100644
--- a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs
+++ b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs
@@ -182,9 +182,7 @@ printExportList conf (L srcLoc exports) = do
     -- > xxxxyyfoo
     -- > xxxx) where
     doIndent = spaces (indent conf)
-    doHang = do
-        len <- length <$> getCurrentLine
-        spaces $ indent conf + 2 - len
+    doHang = pad (indent conf + 2)
 
     doSort = if sort conf then NonEmpty.sortBy compareLIE else id
 
diff --git a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs
index 9ed9d0d..1d50bf1 100644
--- a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs
+++ b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs
@@ -1,9 +1,11 @@
+{-# LANGUAGE OverloadedLists   #-}
+{-# LANGUAGE OverloadedStrings #-}
 module Language.Haskell.Stylish.Step.Data.Tests
     ( tests
     ) where
 
 import           Language.Haskell.Stylish.Step.Data
-import           Language.Haskell.Stylish.Tests.Util (testStep)
+import           Language.Haskell.Stylish.Tests.Util (assertSnippet, testStep)
 import           Test.Framework                      (Test, testGroup)
 import           Test.Framework.Providers.HUnit      (testCase)
 import           Test.HUnit                          (Assertion, (@=?))
@@ -66,6 +68,8 @@ tests = testGroup "Language.Haskell.Stylish.Step.Data.Tests"
     , testCase "case 53" case53
     , testCase "case 54" case54
     , testCase "case 55" case55
+    , testCase "case 56" case56
+    , testCase "case 57" case57
     ]
 
 case00 :: Assertion
@@ -456,79 +460,67 @@ case20 = input @=? testStep (step indentIndentStyle) input
        ]
 
 case21 :: Assertion
-case21 = expected @=? testStep (step sameSameStyle) input
-  where
-    input = unlines
-       [ "data Foo a"
-       , "  = Foo { a :: Int,"
-       , "          a2 :: String"
-       , "          -- ^ some haddock"
-       , "        }"
-       , "  | Bar { b :: a }  deriving (Eq, Show)"
-       , "  deriving (ToJSON)"
-       ]
-
-    expected = unlines
-       [ "data Foo a = Foo { a :: Int"
-       , "                 , a2 :: String"
-       , "                   -- ^ some haddock"
-       , "                 }"
-       , "           | Bar { b :: a"
-       , "                 }"
-       , "  deriving (Eq, Show)"
-       , "  deriving (ToJSON)"
-       ]
+case21 = assertSnippet (step sameSameStyle)
+   [ "data Foo a"
+   , "  = Foo { a :: Int,"
+   , "          a2 :: String"
+   , "          -- ^ some haddock"
+   , "        }"
+   , "  | Bar { b :: a }  deriving (Eq, Show)"
+   , "  deriving (ToJSON)"
+   ]
+   [ "data Foo a = Foo { a :: Int"
+   , "                 , a2 :: String"
+   , "                   -- ^ some haddock"
+   , "                 }"
+   , "           | Bar { b :: a"
+   , "                 }"
+   , "  deriving (Eq, Show)"
+   , "  deriving (ToJSON)"
+   ]
 
 case22 :: Assertion
-case22 = expected @=? testStep (step sameIndentStyle) input
-  where
-    input = unlines
-       [ "data Foo a"
-       , "  = Foo { a :: Int,"
-       , "          a2 :: String"
-       , "          -- ^ some haddock"
-       , "        }"
-       , "  | Bar { b :: a }  deriving (Eq, Show)"
-       , "  deriving (ToJSON)"
-       ]
-
-    expected = unlines
-       [ "data Foo a = Foo"
-       , "               { a :: Int"
-       , "               , a2 :: String"
-       , "                 -- ^ some haddock"
-       , "               }"
-       , "           | Bar"
-       , "               { b :: a"
-       , "               }"
-       , "  deriving (Eq, Show)"
-       , "  deriving (ToJSON)"
-       ]
+case22 = assertSnippet (step sameIndentStyle)
+   [ "data Foo a"
+   , "  = Foo { a :: Int,"
+   , "          a2 :: String"
+   , "          -- ^ some haddock"
+   , "        }"
+   , "  | Bar { b :: a }  deriving (Eq, Show)"
+   , "  deriving (ToJSON)"
+   ]
+   [ "data Foo a = Foo"
+   , "               { a :: Int"
+   , "               , a2 :: String"
+   , "                 -- ^ some haddock"
+   , "               }"
+   , "           | Bar"
+   , "               { b :: a"
+   , "               }"
+   , "  deriving (Eq, Show)"
+   , "  deriving (ToJSON)"
+   ]
 
 case23 :: Assertion
-case23 = expected @=? testStep (step indentSameStyle) input
-  where
-    input = unlines
-       [ "data Foo a"
-       , "  = Foo { a :: Int,"
-       , "          a2 :: String"
-       , "          -- ^ some haddock"
-       , "        }"
-       , "  | Bar { b :: a }  deriving (Eq, Show)"
-       , "  deriving (ToJSON)"
-       ]
-
-    expected = unlines
-       [ "data Foo a"
-       , "  = Foo { a :: Int"
-       , "        , a2 :: String"
-       , "          -- ^ some haddock"
-       , "        }"
-       , "  | Bar { b :: a"
-       , "        }"
-       , "  deriving (Eq, Show)"
-       , "  deriving (ToJSON)"
-       ]
+case23 = assertSnippet (step indentSameStyle)
+   [ "data Foo a"
+   , "  = Foo { a :: Int,"
+   , "          a2 :: String"
+   , "          -- ^ some haddock"
+   , "        }"
+   , "  | Bar { b :: a }  deriving (Eq, Show)"
+   , "  deriving (ToJSON)"
+   ]
+   [ "data Foo a"
+   , "  = Foo { a :: Int"
+   , "        , a2 :: String"
+   , "          -- ^ some haddock"
+   , "        }"
+   , "  | Bar { b :: a"
+   , "        }"
+   , "  deriving (Eq, Show)"
+   , "  deriving (ToJSON)"
+   ]
 
 case24 :: Assertion
 case24 = expected @=? testStep (step indentIndentStyle) input
@@ -1210,6 +1202,78 @@ case55 = expected @=? testStep (step sameSameNoSortStyle) input
 
     expected = input
 
+case56 :: Assertion
+case56 = assertSnippet (step defaultConfig)
+    [ "data Foo = Foo"
+    , "  { -- | Comment"
+    , "    bar :: Int"
+    , "  , baz :: Int"
+    , "  }"
+    ]
+    [ "data Foo = Foo"
+    , "    { -- | Comment"
+    , "      bar :: Int"
+    , "    , baz :: Int"
+    , "    }"
+    ]
+
+case57 :: Assertion
+case57 = assertSnippet (step defaultConfig)
+    [ "data Foo = Foo"
+    , "    { {- | A"
+    , "      -}"
+    , "      fooA :: Int"
+    , ""
+    , "      {- | B"
+    , "      -}"
+    , "    , fooB :: Int"
+    , ""
+    , "      {- | C"
+    , "      -}"
+    , "    , fooC :: Int"
+    , ""
+    , "      {- | D"
+    , "      -}"
+    , "    , fooD :: Int"
+    , ""
+    , "      {- | E"
+    , "      -}"
+    , "    , fooE :: Int"
+    , ""
+    , "      {- | F"
+    , "      -}"
+    , "    , fooFooFoo :: Int"
+    , ""
+    , "      {- | G"
+    , "      -}"
+    , "    , fooBarBar :: Int"
+    , "    }"
+    ]
+    [ "data Foo = Foo"
+    , "    { {- | A"
+    , "      -}"
+    , "      fooA :: Int"
+    , "      {- | B"
+    , "      -}"
+    , "    , fooB :: Int"
+    , "      {- | C"
+    , "      -}"
+    , "    , fooC :: Int"
+    , "      {- | D"
+    , "      -}"
+    , "    , fooD :: Int"
+    , "      {- | E"
+    , "      -}"
+    , "    , fooE :: Int"
+    , "      {- | F"
+    , "      -}"
+    , "    , fooFooFoo :: Int"
+    , "      {- | G"
+    , "      -}"
+    , "    , fooBarBar :: Int"
+    , "    }"
+    ]
+
 sameSameStyle :: Config
 sameSameStyle = Config SameLine SameLine 2 2 False True SameLine False True NoMaxColumns