From 0e2ebd1722871dce2207b44266a6e4420c13a588 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Wed, 7 Oct 2020 21:53:36 +0200 Subject: Fix some issues with record field padding See #318 and #319 --- lib/Language/Haskell/Stylish/Printer.hs | 8 + lib/Language/Haskell/Stylish/Step/Data.hs | 84 ++++++--- lib/Language/Haskell/Stylish/Step/ModuleHeader.hs | 4 +- tests/Language/Haskell/Stylish/Step/Data/Tests.hs | 204 ++++++++++++++-------- 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 -- cgit v1.2.3