From 250e7091edd93ce5a476706ddd968ef3ec1ef336 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 2 Oct 2020 13:08:39 +0200 Subject: Use ghc-lib-parser rather than haskell-src-exts MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This patch swaps out the parsing library from `haskell-src-exts` to `ghc-lib-parser`, which gives us better compatibility with GHC. Because almost every module heavily used the Haskell AST provided by `haskell-src-exts`, this was a huge effort and it would not have been possible without Felix Mulder doing an initial port, GSoC student Beatrice Vergani porting several other steps, and Łukasz Gołębiewski and Paweł Szulc who helped me finish up things in the home stretch. I've generally tried to keep styling 100% compatible with what was there before, but some issues may have unintentionally slipped in so please report those. This introduces one new import styling contributed by Felix: when wrapping import lists over multiple lines, you can repeat the module name, e.g.: import Control.Monad.Except as X (ExceptT (..), MonadError (..), liftEither) import Control.Monad.Except as X (runExceptT, withExceptT) This is activated by using `import_align: repeat`. Secondly, a new Step was added, `module_header`, which formats the export list of a module, including the trailing `where` clause. Details for this new step can be found in the `data/stylish-haskell.yaml`. Co-Authored-By: Beatrice Vergani Co-Authored-By: Paweł Szulc Co-Authored-By: Łukasz Gołębiewski Co-Authored-By: Felix Mulder --- lib/Language/Haskell/Stylish/Step/ModuleHeader.hs | 250 ++++++++++++++++++++++ 1 file changed, 250 insertions(+) create mode 100644 lib/Language/Haskell/Stylish/Step/ModuleHeader.hs (limited to 'lib/Language/Haskell/Stylish/Step/ModuleHeader.hs') diff --git a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs new file mode 100644 index 0000000..90f3478 --- /dev/null +++ b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} +module Language.Haskell.Stylish.Step.ModuleHeader + ( Config (..) + , defaultConfig + , step + ) where + +-------------------------------------------------------------------------------- +import ApiAnnotation (AnnKeywordId (..), + AnnotationComment (..)) +import Control.Monad (forM_, join, when) +import Data.Bifunctor (second) +import Data.Foldable (find, toList) +import Data.Function (on, (&)) +import qualified Data.List as L +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe (isJust, listToMaybe) +import qualified GHC.Hs.Doc as GHC +import GHC.Hs.Extension (GhcPs) +import qualified GHC.Hs.Extension as GHC +import GHC.Hs.ImpExp (IE (..)) +import qualified GHC.Hs.ImpExp as GHC +import qualified Module as GHC +import SrcLoc (GenLocated (..), Located, + RealLocated, SrcSpan (..), + srcSpanEndLine, + srcSpanStartLine, unLoc) +import Util (notNull) + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Block +import Language.Haskell.Stylish.Editor +import Language.Haskell.Stylish.GHC +import Language.Haskell.Stylish.Module +import Language.Haskell.Stylish.Ordering +import Language.Haskell.Stylish.Printer +import Language.Haskell.Stylish.Step + + +data Config = Config + -- TODO(jaspervdj): Use the same sorting as in `Imports`? + -- TODO: make sorting optional? + { indent :: Int + , sort :: Bool + } + +defaultConfig :: Config +defaultConfig = Config + { indent = 4 + , sort = True + } + +step :: Config -> Step +step = makeStep "Module header" . printModuleHeader + +printModuleHeader :: Config -> Lines -> Module -> Lines +printModuleHeader conf ls m = + let + header = moduleHeader m + name = rawModuleName header + haddocks = rawModuleHaddocks header + exports = rawModuleExports header + annotations = rawModuleAnnotations m + + relevantComments :: [RealLocated AnnotationComment] + relevantComments + = moduleComments m + & rawComments + & dropAfterLocated exports + & dropBeforeLocated name + + -- TODO: pass max columns? + printedModuleHeader = runPrinter_ (PrinterConfig Nothing) relevantComments + m (printHeader conf name exports haddocks) + + getBlock loc = + Block <$> fmap getStartLineUnsafe loc <*> fmap getEndLineUnsafe loc + + adjustOffsetFrom :: Block a -> Block a -> Maybe (Block a) + adjustOffsetFrom (Block s0 _) b2@(Block s1 e1) + | s0 >= s1 && s0 >= e1 = Nothing + | s0 >= s1 = Just (Block (s0 + 1) e1) + | otherwise = Just b2 + + nameBlock = + getBlock name + + exportsBlock = + join $ adjustOffsetFrom <$> nameBlock <*> getBlock exports + + whereM :: Maybe SrcSpan + whereM + = annotations + & filter (\(((_, w), _)) -> w == AnnWhere) + & fmap (head . snd) -- get position of annot + & L.sort + & listToMaybe + + isModuleHeaderWhere :: Block a -> Bool + isModuleHeaderWhere w + = not + . overlapping + $ [w] <> toList nameBlock <> toList exportsBlock + + toLineBlock :: SrcSpan -> Block a + toLineBlock (RealSrcSpan s) = Block (srcSpanStartLine s) (srcSpanEndLine s) + toLineBlock s + = error + $ "'where' block was not a RealSrcSpan" <> show s + + whereBlock + = whereM + & fmap toLineBlock + & find isModuleHeaderWhere + + deletes = + fmap delete $ mergeAdjacent $ toList nameBlock <> toList exportsBlock <> toList whereBlock + + startLine = + maybe 1 blockStart nameBlock + + additions = [insert startLine printedModuleHeader] + + changes = deletes <> additions + in + applyChanges changes ls + +printHeader + :: Config + -> Maybe (Located GHC.ModuleName) + -> Maybe (Located [GHC.LIE GhcPs]) + -> Maybe GHC.LHsDocString + -> P () +printHeader conf mname mexps _ = do + forM_ mname \(L loc name) -> do + putText "module" + space + putText (showOutputable name) + attachEolComment loc + + maybe + (when (isJust mname) do newline >> spaces (indent conf) >> putText "where") + (printExportList conf) + mexps + +attachEolComment :: SrcSpan -> P () +attachEolComment = \case + UnhelpfulSpan _ -> pure () + RealSrcSpan rspan -> + removeLineComment (srcSpanStartLine rspan) >>= mapM_ \c -> space >> putComment c + +attachEolCommentEnd :: SrcSpan -> P () +attachEolCommentEnd = \case + UnhelpfulSpan _ -> pure () + RealSrcSpan rspan -> + removeLineComment (srcSpanEndLine rspan) >>= mapM_ \c -> space >> putComment c + +printExportList :: Config -> Located [GHC.LIE GhcPs] -> P () +printExportList conf (L srcLoc exports) = do + newline + doIndent >> putText "(" >> when (notNull exports) space + + exportsWithComments <- fmap (second doSort) <$> groupAttachedComments exports + + printExports exportsWithComments + + putText ")" >> space >> putText "where" >> attachEolCommentEnd srcLoc + where + -- 'doIndent' is @x@: + -- + -- > module Foo + -- > xxxx( foo + -- > xxxx, bar + -- > xxxx) where + -- + -- 'doHang' is @y@: + -- + -- > module Foo + -- > xxxx( -- Some comment + -- > xxxxyyfoo + -- > xxxx) where + doIndent = spaces (indent conf) + doHang = do + len <- length <$> getCurrentLine + spaces $ indent conf + 2 - len + + doSort = if sort conf then NonEmpty.sortBy compareLIE else id + + printExports :: [([AnnotationComment], NonEmpty (GHC.LIE GhcPs))] -> P () + printExports (([], firstInGroup :| groupRest) : rest) = do + printExport firstInGroup + newline + doIndent + printExportsGroupTail groupRest + printExportsTail rest + printExports ((firstComment : comments, firstExport :| groupRest) : rest) = do + putComment firstComment >> newline >> doIndent + forM_ comments \c -> doHang >> putComment c >> newline >> doIndent + doHang + printExport firstExport + newline + doIndent + printExportsGroupTail groupRest + printExportsTail rest + printExports [] = + newline >> doIndent + + printExportsTail :: [([AnnotationComment], NonEmpty (GHC.LIE GhcPs))] -> P () + printExportsTail = mapM_ \(comments, exported) -> do + forM_ comments \c -> doHang >> putComment c >> newline >> doIndent + forM_ exported \export -> do + comma >> space >> printExport export + newline >> doIndent + + printExportsGroupTail :: [GHC.LIE GhcPs] -> P () + printExportsGroupTail (x : xs) = printExportsTail [([], x :| xs)] + printExportsGroupTail [] = pure () + + printExport :: GHC.LIE GhcPs -> P () + printExport (L _ export) = case export of + IEVar _ name -> putOutputable name + IEThingAbs _ name -> putOutputable name + IEThingAll _ name -> do + putOutputable name + space + putText "(..)" + IEModuleContents _ (L _ m) -> do + putText "module" + space + putText (showOutputable m) + IEThingWith _ name _wildcard imps _ -> do + putOutputable name + space + putText "(" + sep (comma >> space) $ + fmap putOutputable $ L.sortBy (compareWrappedName `on` unLoc) imps + putText ")" + IEGroup _ _ _ -> + error $ + "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEGroup'" <> showOutputable export + IEDoc _ _ -> + error $ + "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDoc'" <> showOutputable export + IEDocNamed _ _ -> + error $ + "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDocNamed'" <> showOutputable export + XIE ext -> + GHC.noExtCon ext -- cgit v1.2.3 From 10ce71bb79cf9f6ab47ac9dfef503529c41bef00 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Wed, 7 Oct 2020 12:55:32 +0200 Subject: ModuleHeader: Add separate_lists option See #320 --- data/stylish-haskell.yaml | 3 +++ lib/Language/Haskell/Stylish/Config.hs | 7 +++++-- lib/Language/Haskell/Stylish/Step/ModuleHeader.hs | 18 ++++++++++-------- .../Haskell/Stylish/Step/ModuleHeader/Tests.hs | 12 ++++++++++++ 4 files changed, 30 insertions(+), 10 deletions(-) (limited to 'lib/Language/Haskell/Stylish/Step/ModuleHeader.hs') diff --git a/data/stylish-haskell.yaml b/data/stylish-haskell.yaml index 0a2e21a..e0a739c 100644 --- a/data/stylish-haskell.yaml +++ b/data/stylish-haskell.yaml @@ -27,6 +27,9 @@ steps: # # Should export lists be sorted? Sorting is only performed within the # # export section, as delineated by Haddock comments. # sort: true + # + # # See `separate_lists` for the `imports` step. + # separate_lists: true # Format record definitions. This is disabled by default. # diff --git a/lib/Language/Haskell/Stylish/Config.hs b/lib/Language/Haskell/Stylish/Config.hs index 68638a6..36688a5 100644 --- a/lib/Language/Haskell/Stylish/Config.hs +++ b/lib/Language/Haskell/Stylish/Config.hs @@ -195,8 +195,11 @@ parseEnum strs _ (Just k) = case lookup k strs of -------------------------------------------------------------------------------- parseModuleHeader :: Config -> A.Object -> A.Parser Step parseModuleHeader _ o = fmap ModuleHeader.step $ ModuleHeader.Config - <$> o A..:? "indent" A..!= (ModuleHeader.indent ModuleHeader.defaultConfig) - <*> o A..:? "sort" A..!= (ModuleHeader.sort ModuleHeader.defaultConfig) + <$> o A..:? "indent" A..!= ModuleHeader.indent def + <*> o A..:? "sort" A..!= ModuleHeader.sort def + <*> o A..:? "separate_lists" A..!= ModuleHeader.separateLists def + where + def = ModuleHeader.defaultConfig -------------------------------------------------------------------------------- parseSimpleAlign :: Config -> A.Object -> A.Parser Step diff --git a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs index 90f3478..0c33298 100644 --- a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs +++ b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs @@ -40,16 +40,16 @@ import Language.Haskell.Stylish.Step data Config = Config - -- TODO(jaspervdj): Use the same sorting as in `Imports`? - -- TODO: make sorting optional? - { indent :: Int - , sort :: Bool + { indent :: Int + , sort :: Bool + , separateLists :: Bool } defaultConfig :: Config defaultConfig = Config - { indent = 4 - , sort = True + { indent = 4 + , sort = True + , separateLists = True } step :: Config -> Step @@ -218,13 +218,15 @@ printExportList conf (L srcLoc exports) = do printExportsGroupTail (x : xs) = printExportsTail [([], x :| xs)] printExportsGroupTail [] = pure () + -- NOTE(jaspervdj): This code is almost the same as the import printing + -- in 'Imports' and should be merged. printExport :: GHC.LIE GhcPs -> P () printExport (L _ export) = case export of IEVar _ name -> putOutputable name IEThingAbs _ name -> putOutputable name IEThingAll _ name -> do putOutputable name - space + when (separateLists conf) space putText "(..)" IEModuleContents _ (L _ m) -> do putText "module" @@ -232,7 +234,7 @@ printExportList conf (L srcLoc exports) = do putText (showOutputable m) IEThingWith _ name _wildcard imps _ -> do putOutputable name - space + when (separateLists conf) space putText "(" sep (comma >> space) $ fmap putOutputable $ L.sortBy (compareWrappedName `on` unLoc) imps diff --git a/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs b/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs index b6d6b89..002be7c 100644 --- a/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs @@ -34,6 +34,7 @@ tests = testGroup "Language.Haskell.Stylish.Printer.ModuleHeader" , testCase "Indents with 2 spaces" ex14 , testCase "Group doc with 2 spaces" ex15 , testCase "Does not sort" ex16 + , testCase "Repects separate_lists" ex17 ] -------------------------------------------------------------------------------- @@ -299,3 +300,14 @@ ex16 = assertSnippet (step defaultConfig {sort = False}) input input , " , no" , " ) where" ] + +ex17 :: Assertion +ex17 = assertSnippet (step defaultConfig {separateLists = False}) + [ "module Foo" + , " ( Bar (..)" + , " ) where" + ] + [ "module Foo" + , " ( Bar(..)" + , " ) where" + ] -- cgit v1.2.3 From 1bc2b2c5c3377ed7fe55d53175580eccebb631aa Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Wed, 7 Oct 2020 20:37:43 +0200 Subject: ModuleHeader: reuse printImport from Imports --- lib/Language/Haskell/Stylish/Step/Imports.hs | 13 ++-- lib/Language/Haskell/Stylish/Step/ModuleHeader.hs | 72 +++++++---------------- 2 files changed, 31 insertions(+), 54 deletions(-) (limited to 'lib/Language/Haskell/Stylish/Step/ModuleHeader.hs') diff --git a/lib/Language/Haskell/Stylish/Step/Imports.hs b/lib/Language/Haskell/Stylish/Step/Imports.hs index f2439dc..b89d73f 100644 --- a/lib/Language/Haskell/Stylish/Step/Imports.hs +++ b/lib/Language/Haskell/Stylish/Step/Imports.hs @@ -11,6 +11,8 @@ module Language.Haskell.Stylish.Step.Imports , EmptyListAlign (..) , ListPadding (..) , step + + , printImport ) where -------------------------------------------------------------------------------- @@ -213,7 +215,7 @@ printQualified Options{..} padNames stats (L _ decl) = do _ -> space >> putText "()" Just (L _ imports) -> do let printedImports = flagEnds $ -- [P ()] - fmap ((printImport Options{..}) . unLocated) + fmap ((printImport separateLists) . unLocated) (prepareImportList imports) -- Since we might need to output the import module name several times, we @@ -308,18 +310,20 @@ printQualified Options{..} padNames stats (L _ decl) = do -------------------------------------------------------------------------------- -printImport :: Options -> IE GhcPs -> P () +printImport :: Bool -> IE GhcPs -> P () printImport _ (IEVar _ name) = do printIeWrappedName name printImport _ (IEThingAbs _ name) = do printIeWrappedName name -printImport Options{..} (IEThingAll _ name) = do +printImport separateLists (IEThingAll _ name) = do printIeWrappedName name when separateLists space putText "(..)" printImport _ (IEModuleContents _ (L _ m)) = do + putText "module" + space putText (moduleNameString m) -printImport Options{..} (IEThingWith _ name _wildcard imps _) = do +printImport separateLists (IEThingWith _ name _wildcard imps _) = do printIeWrappedName name when separateLists space parenthesize $ @@ -333,6 +337,7 @@ printImport _ (IEDocNamed _ _) = printImport _ (XIE ext) = GHC.noExtCon ext + -------------------------------------------------------------------------------- printIeWrappedName :: LIEWrappedName RdrName -> P () printIeWrappedName lie = unLocated lie & \case diff --git a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs index 0c33298..728ce4a 100644 --- a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs +++ b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs @@ -7,27 +7,26 @@ module Language.Haskell.Stylish.Step.ModuleHeader ) where -------------------------------------------------------------------------------- -import ApiAnnotation (AnnKeywordId (..), - AnnotationComment (..)) -import Control.Monad (forM_, join, when) -import Data.Bifunctor (second) -import Data.Foldable (find, toList) -import Data.Function (on, (&)) -import qualified Data.List as L -import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.List.NonEmpty as NonEmpty -import Data.Maybe (isJust, listToMaybe) -import qualified GHC.Hs.Doc as GHC -import GHC.Hs.Extension (GhcPs) -import qualified GHC.Hs.Extension as GHC -import GHC.Hs.ImpExp (IE (..)) -import qualified GHC.Hs.ImpExp as GHC -import qualified Module as GHC -import SrcLoc (GenLocated (..), Located, - RealLocated, SrcSpan (..), - srcSpanEndLine, - srcSpanStartLine, unLoc) -import Util (notNull) +import ApiAnnotation (AnnKeywordId (..), + AnnotationComment (..)) +import Control.Monad (forM_, join, when) +import Data.Bifunctor (second) +import Data.Foldable (find, toList) +import Data.Function ((&)) +import qualified Data.List as L +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe (isJust, listToMaybe) +import qualified GHC.Hs.Doc as GHC +import GHC.Hs.Extension (GhcPs) +import qualified GHC.Hs.ImpExp as GHC +import qualified Module as GHC +import SrcLoc (GenLocated (..), + Located, RealLocated, + SrcSpan (..), + srcSpanEndLine, + srcSpanStartLine, unLoc) +import Util (notNull) -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Block @@ -37,6 +36,7 @@ import Language.Haskell.Stylish.Module import Language.Haskell.Stylish.Ordering import Language.Haskell.Stylish.Printer import Language.Haskell.Stylish.Step +import qualified Language.Haskell.Stylish.Step.Imports as Imports data Config = Config @@ -221,32 +221,4 @@ printExportList conf (L srcLoc exports) = do -- NOTE(jaspervdj): This code is almost the same as the import printing -- in 'Imports' and should be merged. printExport :: GHC.LIE GhcPs -> P () - printExport (L _ export) = case export of - IEVar _ name -> putOutputable name - IEThingAbs _ name -> putOutputable name - IEThingAll _ name -> do - putOutputable name - when (separateLists conf) space - putText "(..)" - IEModuleContents _ (L _ m) -> do - putText "module" - space - putText (showOutputable m) - IEThingWith _ name _wildcard imps _ -> do - putOutputable name - when (separateLists conf) space - putText "(" - sep (comma >> space) $ - fmap putOutputable $ L.sortBy (compareWrappedName `on` unLoc) imps - putText ")" - IEGroup _ _ _ -> - error $ - "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEGroup'" <> showOutputable export - IEDoc _ _ -> - error $ - "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDoc'" <> showOutputable export - IEDocNamed _ _ -> - error $ - "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDocNamed'" <> showOutputable export - XIE ext -> - GHC.noExtCon ext + printExport = Imports.printImport (separateLists conf) . unLoc -- cgit v1.2.3 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(-) (limited to 'lib/Language/Haskell/Stylish/Step/ModuleHeader.hs') 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