diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,13 @@ # CHANGELOG +- 0.12.2.0 (2020-10-08) + * align: Add a new option for aligning only adjacent items (by 1Computer1) + * align: Add support for aligning MultiWayIf syntax (by 1Computer1) + * data: Fix some issues with record field padding + * module_header: Add separate_lists option + * imports: Respect separate_lists for (..) imports + * data: Make sorting deriving list optional (by Maxim Koltsov) + - 0.12.1.0 (2020-10-05) * Bump Cabal-version to 2.4 (by Łukasz Gołębiewski) * Fix "group" import sort with multi-line imports (by Maxim Koltsov) diff --git a/data/stylish-haskell.yaml b/data/stylish-haskell.yaml --- a/data/stylish-haskell.yaml +++ b/data/stylish-haskell.yaml @@ -27,6 +27,9 @@ # # 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. # @@ -58,10 +61,13 @@ # # # How many spaces to insert before "via" clause counted from indentation of deriving clause # # Possible values: - # # - "same_line" -- "{" and first field goes on the same line as the data constructor. - # # - "indent N" -- insert a new line and N spaces from the beginning of the data constructor + # # - "same_line" -- "via" part goes on the same line as "deriving" keyword. + # # - "indent N" -- insert a new line and N spaces from the beginning of "deriving" keyword. # via: "indent 2" # + # # Sort typeclass names in the "deriving" list alphabetically. + # sort_deriving: true + # # # Wheter or not to break enums onto several lines # # # # Default: false @@ -83,11 +89,17 @@ # Align the right hand side of some elements. This is quite conservative # and only applies to statements where each element occupies a single - # line. All default to true. + # line. + # Possible values: + # - always - Always align statements. + # - adjacent - Align statements that are on adjacent lines in groups. + # - never - Never align statements. + # All default to always. - simple_align: - cases: true - top_level_patterns: true - records: true + cases: always + top_level_patterns: always + records: always + multi_way_if: always # Import cleanup - imports: diff --git a/lib/Language/Haskell/Stylish/Config.hs b/lib/Language/Haskell/Stylish/Config.hs --- a/lib/Language/Haskell/Stylish/Config.hs +++ b/lib/Language/Haskell/Stylish/Config.hs @@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- -{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} @@ -10,10 +10,12 @@ , defaultConfigBytes , configFilePath , loadConfig + , parseConfig ) where -------------------------------------------------------------------------------- +import Control.Applicative ((<|>)) import Control.Monad (forM, mzero) import Data.Aeson (FromJSON (..)) import qualified Data.Aeson as A @@ -43,8 +45,8 @@ import Language.Haskell.Stylish.Step import qualified Language.Haskell.Stylish.Step.Data as Data import qualified Language.Haskell.Stylish.Step.Imports as Imports -import qualified Language.Haskell.Stylish.Step.ModuleHeader as ModuleHeader import qualified Language.Haskell.Stylish.Step.LanguagePragmas as LanguagePragmas +import qualified Language.Haskell.Stylish.Step.ModuleHeader as ModuleHeader import qualified Language.Haskell.Stylish.Step.SimpleAlign as SimpleAlign import qualified Language.Haskell.Stylish.Step.Squash as Squash import qualified Language.Haskell.Stylish.Step.Tabs as Tabs @@ -74,7 +76,7 @@ deriving (Eq) instance Show ExitCodeBehavior where - show NormalExitBehavior = "normal" + show NormalExitBehavior = "normal" show ErrorOnFormatExitBehavior = "error_on_format" -------------------------------------------------------------------------------- @@ -195,20 +197,34 @@ -------------------------------------------------------------------------------- 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 parseSimpleAlign c o = SimpleAlign.step <$> pure (configColumns c) <*> (SimpleAlign.Config - <$> withDef SimpleAlign.cCases "cases" - <*> withDef SimpleAlign.cTopLevelPatterns "top_level_patterns" - <*> withDef SimpleAlign.cRecords "records") + <$> parseAlign "cases" SimpleAlign.cCases + <*> parseAlign "top_level_patterns" SimpleAlign.cTopLevelPatterns + <*> parseAlign "records" SimpleAlign.cRecords + <*> parseAlign "multi_way_if" SimpleAlign.cMultiWayIf) where - withDef f k = fromMaybe (f SimpleAlign.defaultConfig) <$> (o A..:? k) + parseAlign key f = + (o A..:? key >>= parseEnum aligns (f SimpleAlign.defaultConfig)) <|> + (boolToAlign <$> o A..: key) + aligns = + [ ("always", SimpleAlign.Always) + , ("adjacent", SimpleAlign.Adjacent) + , ("never", SimpleAlign.Never) + ] + boolToAlign True = SimpleAlign.Always + boolToAlign False = SimpleAlign.Never + -------------------------------------------------------------------------------- parseRecords :: Config -> A.Object -> A.Parser Step parseRecords c o = Data.step @@ -221,6 +237,7 @@ <*> (o A..:? "break_single_constructors" A..!= True) <*> (o A..: "via" >>= parseIndent) <*> (o A..:? "curried_context" A..!= False) + <*> (o A..:? "sort_deriving" A..!= True) <*> pure configMaxColumns) where configMaxColumns = @@ -290,8 +307,8 @@ parseListPadding = \case A.String "module_name" -> pure Imports.LPModuleName - A.Number n | n >= 1 -> pure $ Imports.LPConstant (truncate n) - v -> A.typeMismatch "'module_name' or >=1 number" v + A.Number n | n >= 1 -> pure $ Imports.LPConstant (truncate n) + v -> A.typeMismatch "'module_name' or >=1 number" v -------------------------------------------------------------------------------- parseLanguagePragmas :: Config -> A.Object -> A.Parser Step diff --git a/lib/Language/Haskell/Stylish/GHC.hs b/lib/Language/Haskell/Stylish/GHC.hs --- a/lib/Language/Haskell/Stylish/GHC.hs +++ b/lib/Language/Haskell/Stylish/GHC.hs @@ -6,6 +6,7 @@ , dropBeforeLocated , dropBeforeAndAfter -- * Unsafe getters + , unsafeGetRealSrcSpan , getEndLineUnsafe , getStartLineUnsafe -- * Standard settings @@ -18,32 +19,33 @@ ) where -------------------------------------------------------------------------------- -import Data.Function (on) +import Data.Function (on) -------------------------------------------------------------------------------- -import DynFlags (Settings(..), defaultDynFlags) -import qualified DynFlags as GHC -import FileSettings (FileSettings(..)) -import GHC.Fingerprint (fingerprint0) +import DynFlags (Settings (..), defaultDynFlags) +import qualified DynFlags as GHC +import FileSettings (FileSettings (..)) +import GHC.Fingerprint (fingerprint0) import GHC.Platform -import GHC.Version (cProjectVersion) -import GhcNameVersion (GhcNameVersion(..)) -import PlatformConstants (PlatformConstants(..)) -import SrcLoc (GenLocated(..), SrcSpan(..)) -import SrcLoc (Located, RealLocated) -import SrcLoc (srcSpanStartLine, srcSpanEndLine) -import ToolSettings (ToolSettings(..)) -import qualified Outputable as GHC +import GHC.Version (cProjectVersion) +import GhcNameVersion (GhcNameVersion (..)) +import qualified Outputable as GHC +import PlatformConstants (PlatformConstants (..)) +import SrcLoc (GenLocated (..), Located, RealLocated, + RealSrcSpan, SrcSpan (..), srcSpanEndLine, + srcSpanStartLine) +import ToolSettings (ToolSettings (..)) +unsafeGetRealSrcSpan :: Located a -> RealSrcSpan +unsafeGetRealSrcSpan = \case + (L (RealSrcSpan s) _) -> s + _ -> error "could not get source code location" + getStartLineUnsafe :: Located a -> Int -getStartLineUnsafe = \case - (L (RealSrcSpan s) _) -> srcSpanStartLine s - _ -> error "could not get start line of block" +getStartLineUnsafe = srcSpanStartLine . unsafeGetRealSrcSpan getEndLineUnsafe :: Located a -> Int -getEndLineUnsafe = \case - (L (RealSrcSpan s) _) -> srcSpanEndLine s - _ -> error "could not get end line of block" +getEndLineUnsafe = srcSpanEndLine . unsafeGetRealSrcSpan dropAfterLocated :: Maybe (Located a) -> [RealLocated b] -> [RealLocated b] dropAfterLocated loc xs = case loc of diff --git a/lib/Language/Haskell/Stylish/Module.hs b/lib/Language/Haskell/Stylish/Module.hs --- a/lib/Language/Haskell/Stylish/Module.hs +++ b/lib/Language/Haskell/Stylish/Module.hs @@ -24,6 +24,7 @@ , moduleComments , moduleLanguagePragmas , queryModule + , groupByLine -- * Imports , canMergeImport @@ -192,22 +193,21 @@ -- | Get groups of imports from module moduleImportGroups :: Module -> [NonEmpty (Located Import)] -moduleImportGroups = go [] Nothing . moduleImports +moduleImportGroups = groupByLine unsafeGetRealSrcSpan . moduleImports + +-- The same logic as 'Language.Haskell.Stylish.Module.moduleImportGroups'. +groupByLine :: (a -> RealSrcSpan) -> [a] -> [NonEmpty a] +groupByLine f = go [] Nothing where - -- Run through all imports (assume they are sorted already in order of - -- appearance in the file) and group the ones that are on consecutive - -- lines. - go :: [Located Import] -> Maybe Int -> [Located Import] - -> [NonEmpty (Located Import)] - go acc _ [] = ne acc - go acc mbCurrentLine (imp : impRest) = - let - lStart = getStartLineUnsafe imp - lEnd = getEndLineUnsafe imp in - case mbCurrentLine of - Just lPrevEnd | lPrevEnd + 1 < lStart - -> ne acc ++ go [imp] (Just lEnd) impRest - _ -> go (acc ++ [imp]) (Just lEnd) impRest + go acc _ [] = ne acc + go acc mbCurrentLine (x:xs) = + let + lStart = GHC.srcSpanStartLine (f x) + lEnd = GHC.srcSpanEndLine (f x) in + case mbCurrentLine of + Just lPrevEnd | lPrevEnd + 1 < lStart + -> ne acc ++ go [x] (Just lEnd) xs + _ -> go (acc ++ [x]) (Just lEnd) xs ne [] = [] ne (x : xs) = [x :| xs] diff --git a/lib/Language/Haskell/Stylish/Printer.hs b/lib/Language/Haskell/Stylish/Printer.hs --- a/lib/Language/Haskell/Stylish/Printer.hs +++ b/lib/Language/Haskell/Stylish/Printer.hs @@ -44,6 +44,7 @@ , space , spaces , suffix + , pad -- ** Advanced combinators , withColumns @@ -322,6 +323,13 @@ -- | Suffix a printer with another one 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) diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs --- 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 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 @@ -71,9 +78,26 @@ -- ^ Indentation between @via@ clause and start of deriving column start , cCurriedContext :: !Bool -- ^ If true, use curried context. E.g: @allValues :: Enum a => Bounded a => Proxy a -> [a]@ + , cSortDeriving :: !Bool + -- ^ If true, will sort type classes in a @deriving@ list. , 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 @@ -188,8 +212,8 @@ 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 () @@ -197,10 +221,10 @@ 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 @@ -222,13 +246,13 @@ 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 @@ -266,7 +290,7 @@ = clause & deriv_clause_tys & unLocated - & sortBy compareOutputable + & (if cSortDeriving then sortBy compareOutputable else id) & fmap hsib_body headTy = @@ -359,8 +383,10 @@ 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 @@ -369,7 +395,7 @@ 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 @@ -393,6 +419,7 @@ 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 @@ -400,12 +427,13 @@ (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 @@ -491,7 +519,7 @@ where isGADTCons = \case L _ (ConDeclGADT {}) -> True - _ -> False + _ -> False isNewtype :: DataDecl -> Bool isNewtype = (== NewType) . dd_ND . dataDefn @@ -505,7 +533,7 @@ isUnary = \case L _ (ConDeclH98 {..}) -> case con_args of PrefixCon [] -> True - _ -> False + _ -> False _ -> False hasConstructors :: DataDecl -> Bool diff --git a/lib/Language/Haskell/Stylish/Step/Imports.hs b/lib/Language/Haskell/Stylish/Step/Imports.hs --- a/lib/Language/Haskell/Stylish/Step/Imports.hs +++ b/lib/Language/Haskell/Stylish/Step/Imports.hs @@ -11,6 +11,8 @@ , EmptyListAlign (..) , ListPadding (..) , step + + , printImport ) where -------------------------------------------------------------------------------- @@ -213,7 +215,7 @@ _ -> 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 @@ -------------------------------------------------------------------------------- -printImport :: Options -> IE GhcPs -> P () -printImport Options{..} (IEVar _ name) = do +printImport :: Bool -> IE GhcPs -> P () +printImport _ (IEVar _ name) = do printIeWrappedName name printImport _ (IEThingAbs _ name) = do printIeWrappedName name -printImport _ (IEThingAll _ name) = do +printImport separateLists (IEThingAll _ name) = do printIeWrappedName name - space + 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 $ @@ -332,6 +336,7 @@ error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDocNamed'" printImport _ (XIE ext) = GHC.noExtCon ext + -------------------------------------------------------------------------------- printIeWrappedName :: LIEWrappedName RdrName -> P () diff --git a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs --- a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs +++ b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs @@ -7,27 +7,26 @@ ) 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,19 +36,20 @@ 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 - -- 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 @@ -182,9 +182,7 @@ -- > 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 @@ -218,33 +216,7 @@ 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 - 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 + printExport = Imports.printImport (separateLists conf) . unLoc diff --git a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs --- a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs +++ b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs @@ -1,15 +1,18 @@ -------------------------------------------------------------------------------- -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} module Language.Haskell.Stylish.Step.SimpleAlign ( Config (..) + , Align (..) , defaultConfig , step ) where -------------------------------------------------------------------------------- -import Control.Monad (guard) -import Data.List (foldl') +import Data.Either (partitionEithers) +import Data.Foldable (toList) +import Data.List (foldl', foldl1', sortOn) import Data.Maybe (fromMaybe) import qualified GHC.Hs as Hs import qualified SrcLoc as S @@ -25,21 +28,35 @@ -------------------------------------------------------------------------------- data Config = Config - { cCases :: !Bool - , cTopLevelPatterns :: !Bool - , cRecords :: !Bool + { cCases :: Align + , cTopLevelPatterns :: Align + , cRecords :: Align + , cMultiWayIf :: Align } deriving (Show) +data Align + = Always + | Adjacent + | Never + deriving (Eq, Show) --------------------------------------------------------------------------------- defaultConfig :: Config defaultConfig = Config - { cCases = True - , cTopLevelPatterns = True - , cRecords = True + { cCases = Always + , cTopLevelPatterns = Always + , cRecords = Always + , cMultiWayIf = Always } +groupAlign :: Align -> [Alignable S.RealSrcSpan] -> [[Alignable S.RealSrcSpan]] +groupAlign a xs = case a of + Never -> [] + Adjacent -> byLine . sortOn (S.srcSpanStartLine . aLeft) $ xs + Always -> [xs] + where + byLine = map toList . groupByLine aLeft + -------------------------------------------------------------------------------- type Record = [S.Located (Hs.ConDeclField Hs.GhcPs)] @@ -62,8 +79,8 @@ -------------------------------------------------------------------------------- -recordToAlignable :: Record -> [Alignable S.RealSrcSpan] -recordToAlignable = fromMaybe [] . traverse fieldDeclToAlignable +recordToAlignable :: Config -> Record -> [[Alignable S.RealSrcSpan]] +recordToAlignable conf = groupAlign (cRecords conf) . fromMaybe [] . traverse fieldDeclToAlignable -------------------------------------------------------------------------------- @@ -86,36 +103,36 @@ matchGroupToAlignable :: Config -> Hs.MatchGroup Hs.GhcPs (Hs.LHsExpr Hs.GhcPs) - -> [Alignable S.RealSrcSpan] + -> [[Alignable S.RealSrcSpan]] matchGroupToAlignable _conf (Hs.XMatchGroup x) = Hs.noExtCon x -matchGroupToAlignable conf (Hs.MG _ alts _) = - fromMaybe [] $ traverse (matchToAlignable conf) (S.unLoc alts) +matchGroupToAlignable conf (Hs.MG _ alts _) = cases' ++ patterns' + where + (cases, patterns) = partitionEithers . fromMaybe [] $ traverse matchToAlignable (S.unLoc alts) + cases' = groupAlign (cCases conf) cases + patterns' = groupAlign (cTopLevelPatterns conf) patterns -------------------------------------------------------------------------------- matchToAlignable - :: Config - -> S.Located (Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)) - -> Maybe (Alignable S.RealSrcSpan) -matchToAlignable conf (S.L matchLoc m@(Hs.Match _ Hs.CaseAlt pats@(_ : _) grhss)) = do + :: S.Located (Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)) + -> Maybe (Either (Alignable S.RealSrcSpan) (Alignable S.RealSrcSpan)) +matchToAlignable (S.L matchLoc m@(Hs.Match _ Hs.CaseAlt pats@(_ : _) grhss)) = do let patsLocs = map S.getLoc pats pat = last patsLocs guards = getGuards m guardsLocs = map S.getLoc guards left = foldl' S.combineSrcSpans pat guardsLocs - guard $ cCases conf body <- rhsBody grhss matchPos <- toRealSrcSpan matchLoc leftPos <- toRealSrcSpan left rightPos <- toRealSrcSpan $ S.getLoc body - Just $ Alignable + Just . Left $ Alignable { aContainer = matchPos , aLeft = leftPos , aRight = rightPos , aRightLead = length "-> " } -matchToAlignable conf (S.L matchLoc (Hs.Match _ (Hs.FunRhs name _ _) pats@(_ : _) grhss)) = do - guard $ cTopLevelPatterns conf +matchToAlignable (S.L matchLoc (Hs.Match _ (Hs.FunRhs name _ _) pats@(_ : _) grhss)) = do body <- unguardedRhsBody grhss let patsLocs = map S.getLoc pats nameLoc = S.getLoc name @@ -124,28 +141,62 @@ matchPos <- toRealSrcSpan matchLoc leftPos <- toRealSrcSpan left bodyPos <- toRealSrcSpan bodyLoc - Just $ Alignable + Just . Right $ Alignable { aContainer = matchPos , aLeft = leftPos , aRight = bodyPos , aRightLead = length "= " } -matchToAlignable _conf (S.L _ (Hs.XMatch x)) = Hs.noExtCon x -matchToAlignable _conf (S.L _ (Hs.Match _ _ _ _)) = Nothing +matchToAlignable (S.L _ (Hs.XMatch x)) = Hs.noExtCon x +matchToAlignable (S.L _ (Hs.Match _ _ _ _)) = Nothing -------------------------------------------------------------------------------- +multiWayIfToAlignable + :: Config + -> Hs.LHsExpr Hs.GhcPs + -> [[Alignable S.RealSrcSpan]] +multiWayIfToAlignable conf (S.L _ (Hs.HsMultiIf _ grhss)) = + groupAlign (cMultiWayIf conf) as + where + as = fromMaybe [] $ traverse grhsToAlignable grhss +multiWayIfToAlignable _conf _ = [] + + +-------------------------------------------------------------------------------- +grhsToAlignable + :: S.Located (Hs.GRHS Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)) + -> Maybe (Alignable S.RealSrcSpan) +grhsToAlignable (S.L grhsloc (Hs.GRHS _ guards@(_ : _) body)) = do + let guardsLocs = map S.getLoc guards + bodyLoc = S.getLoc body + left = foldl1' S.combineSrcSpans guardsLocs + matchPos <- toRealSrcSpan grhsloc + leftPos <- toRealSrcSpan left + bodyPos <- toRealSrcSpan bodyLoc + Just $ Alignable + { aContainer = matchPos + , aLeft = leftPos + , aRight = bodyPos + , aRightLead = length "-> " + } +grhsToAlignable (S.L _ (Hs.XGRHS x)) = Hs.noExtCon x +grhsToAlignable (S.L _ _) = Nothing + + +-------------------------------------------------------------------------------- step :: Maybe Int -> Config -> Step -step maxColumns config = makeStep "Cases" $ \ls module' -> +step maxColumns config@(Config {..}) = makeStep "Cases" $ \ls module' -> let changes :: (S.Located (Hs.HsModule Hs.GhcPs) -> [a]) - -> (a -> [Alignable S.RealSrcSpan]) + -> (a -> [[Alignable S.RealSrcSpan]]) -> [Change String] - changes search toAlign = concat $ - map (align maxColumns) . map toAlign $ search (parsedModule module') + changes search toAlign = + (concatMap . concatMap) (align maxColumns) . map toAlign $ search (parsedModule module') configured :: [Change String] configured = concat $ - [changes records recordToAlignable | cRecords config] ++ - [changes everything (matchGroupToAlignable config)] in + [changes records (recordToAlignable config)] ++ + [changes everything (matchGroupToAlignable config)] ++ + [changes everything (multiWayIfToAlignable config)] in applyChanges configured ls diff --git a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs --- a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs +++ b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs @@ -52,38 +52,18 @@ groupPerLine = M.toList . M.fromListWith (++) . map (\((r, c), x) -> (r, [(c, x)])) - --------------------------------------------------------------------------------- -typeSigs :: Module -> Lines -> [((Int, Int), String)] -typeSigs module' ls = - [ (pos, "::") +-- | Find symbol positions in the module. Currently only searches in type +-- signatures. +findSymbol :: Module -> Lines -> String -> [((Int, Int), String)] +findSymbol module' ls sym = + [ (pos, sym) | TypeSig _ funLoc typeLoc <- everything (rawModuleDecls $ moduleDecls module') :: [Sig GhcPs] - , (_, funEnd) <- infoPoints funLoc - , (typeStart, _) <- infoPoints [hsSigWcType typeLoc] - , pos <- maybeToList $ between funEnd typeStart "::" ls + , (funStart, _) <- infoPoints funLoc + , (_, typeEnd) <- infoPoints [hsSigWcType typeLoc] + , pos <- maybeToList $ between funStart typeEnd sym ls ] -------------------------------------------------------------------------------- -contexts :: Module -> Lines -> [((Int, Int), String)] -contexts module' ls = - [ (pos, "=>") - | TypeSig _ _ typeLoc <- everything (rawModuleDecls $ moduleDecls module') :: [Sig GhcPs] - , (start, end) <- infoPoints [hsSigWcType typeLoc] - , pos <- maybeToList $ between start end "=>" ls - ] - - --------------------------------------------------------------------------------- -typeFuns :: Module -> Lines -> [((Int, Int), String)] -typeFuns module' ls = - [ (pos, "->") - | TypeSig _ _ typeLoc <- everything (rawModuleDecls $ moduleDecls module') :: [Sig GhcPs] - , (start, end) <- infoPoints [hsSigWcType typeLoc] - , pos <- maybeToList $ between start end "->" ls - ] - - --------------------------------------------------------------------------------- -- | Search for a needle in a haystack of lines. Only part the inside (startRow, -- startCol), (endRow, endCol) is searched. The return value is the position of -- the needle. @@ -113,7 +93,5 @@ where changes = (if alp then addLanguagePragma lg "UnicodeSyntax" module' else []) ++ replaceAll perLine - perLine = sort $ groupPerLine $ - typeSigs module' ls ++ - contexts module' ls ++ - typeFuns module' ls + toReplace = [ "::", "=>", "->" ] + perLine = sort $ groupPerLine $ concatMap (findSymbol module' ls) toReplace diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -1,6 +1,6 @@ Cabal-version: 2.4 Name: stylish-haskell -Version: 0.12.1.0 +Version: 0.12.2.0 Synopsis: Haskell code prettifier Homepage: https://github.com/jaspervdj/stylish-haskell License: BSD-3-Clause diff --git a/tests/Language/Haskell/Stylish/Config/Tests.hs b/tests/Language/Haskell/Stylish/Config/Tests.hs --- a/tests/Language/Haskell/Stylish/Config/Tests.hs +++ b/tests/Language/Haskell/Stylish/Config/Tests.hs @@ -4,11 +4,14 @@ -------------------------------------------------------------------------------- -import qualified Data.Set as Set +import qualified Data.Aeson.Types as Aeson +import qualified Data.ByteString.Lazy.Char8 as BL8 +import qualified Data.Set as Set +import qualified Data.YAML.Aeson as Yaml import System.Directory -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, assert) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, assert, (@?=)) -------------------------------------------------------------------------------- @@ -31,6 +34,8 @@ testSpecifiedColumns , testCase "Correctly read .stylish-haskell.yaml file with no max column number" testNoColumns + , testCase "Backwards-compatible align options" + testBoolSimpleAlign ] @@ -103,6 +108,22 @@ createFilesAndGetConfig [(".stylish-haskell.yaml", dotStylish3)] where expected = Nothing + + +-------------------------------------------------------------------------------- +testBoolSimpleAlign :: Assertion +testBoolSimpleAlign = do + Right val <- pure $ Yaml.decode1 $ BL8.pack config + Aeson.Success conf <- pure $ Aeson.parse parseConfig val + length (configSteps conf) @?= 1 + where + config = unlines + [ "steps:" + , " - simple_align:" + , " cases: true" + , " top_level_patterns: always" + , " records: false" + ] -- | Example cabal file borrowed from diff --git a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs --- 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, (@=?)) @@ -65,6 +67,9 @@ , testCase "case 52" case52 , testCase "case 53" case53 , testCase "case 54" case54 + , testCase "case 55" case55 + , testCase "case 56" case56 + , testCase "case 57" case57 ] case00 :: Assertion @@ -455,79 +460,67 @@ ] 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 @@ -1200,17 +1193,101 @@ , " deriving newtype (Applicative, Functor, Monad)" ] +case55 :: Assertion +case55 = expected @=? testStep (step sameSameNoSortStyle) input + where + input = unlines + [ "data Foo = Foo deriving (Z, Y, X, Bar, Abcd)" + ] + + 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 NoMaxColumns +sameSameStyle = Config SameLine SameLine 2 2 False True SameLine False True NoMaxColumns sameIndentStyle :: Config -sameIndentStyle = Config SameLine (Indent 2) 2 2 False True SameLine False NoMaxColumns +sameIndentStyle = Config SameLine (Indent 2) 2 2 False True SameLine False True NoMaxColumns indentSameStyle :: Config -indentSameStyle = Config (Indent 2) SameLine 2 2 False True SameLine False NoMaxColumns +indentSameStyle = Config (Indent 2) SameLine 2 2 False True SameLine False True NoMaxColumns indentIndentStyle :: Config -indentIndentStyle = Config (Indent 2) (Indent 2) 2 2 False True SameLine False NoMaxColumns +indentIndentStyle = Config (Indent 2) (Indent 2) 2 2 False True SameLine False True NoMaxColumns indentIndentStyle4 :: Config -indentIndentStyle4 = Config (Indent 4) (Indent 4) 4 4 False True SameLine False NoMaxColumns +indentIndentStyle4 = Config (Indent 4) (Indent 4) 4 4 False True SameLine False True NoMaxColumns + +sameSameNoSortStyle :: Config +sameSameNoSortStyle = Config SameLine SameLine 2 2 False True SameLine False False NoMaxColumns diff --git a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs --- a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs @@ -61,6 +61,7 @@ , testCase "case 27" case27 , testCase "case 28" case28 , testCase "case 29" case29 + , testCase "case 30" case30 ] @@ -834,3 +835,10 @@ , "" , "import A (A)" ] + + +-------------------------------------------------------------------------------- +case30 :: Assertion +case30 = assertSnippet (step Nothing defaultOptions {separateLists = False}) + ["import Data.Monoid (Monoid (..))"] + ["import Data.Monoid (Monoid(..))"] diff --git a/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs b/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs --- a/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs @@ -34,6 +34,7 @@ , 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 @@ , " , no" , " ) where" ] + +ex17 :: Assertion +ex17 = assertSnippet (step defaultConfig {separateLists = False}) + [ "module Foo" + , " ( Bar (..)" + , " ) where" + ] + [ "module Foo" + , " ( Bar(..)" + , " ) where" + ] diff --git a/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs b/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs --- a/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs @@ -31,6 +31,12 @@ , testCase "case 10" case10 , testCase "case 11" case11 , testCase "case 12" case12 + , testCase "case 13" case13 + , testCase "case 13b" case13b + , testCase "case 14" case14 + , testCase "case 15" case15 + , testCase "case 16" case16 + , testCase "case 17" case17 ] @@ -192,10 +198,108 @@ -------------------------------------------------------------------------------- case12 :: Assertion -case12 = assertSnippet (step Nothing defaultConfig {cCases = False}) input input +case12 = assertSnippet (step Nothing defaultConfig { cCases = Never }) input input where input = [ "case x of" , " Just y -> 1" , " Nothing -> 2" ] + + +-------------------------------------------------------------------------------- +case13 :: Assertion +case13 = assertSnippet (step Nothing defaultConfig) + [ "cond n = if" + , " | n < 10, x <- 1 -> x" + , " | otherwise -> 2" + ] + [ "cond n = if" + , " | n < 10, x <- 1 -> x" + , " | otherwise -> 2" + ] + +case13b :: Assertion +case13b = assertSnippet (step Nothing defaultConfig {cMultiWayIf = Never}) + [ "cond n = if" + , " | n < 10, x <- 1 -> x" + , " | otherwise -> 2" + ] + [ "cond n = if" + , " | n < 10, x <- 1 -> x" + , " | otherwise -> 2" + ] + + +-------------------------------------------------------------------------------- +case14 :: Assertion +case14 = assertSnippet (step (Just 80) defaultConfig { cCases = Adjacent }) + [ "catch e = case e of" + , " Left GoodError -> 1" + , " Left BadError -> 2" + , " -- otherwise" + , " Right [] -> 0" + , " Right (x:_) -> x" + ] + [ "catch e = case e of" + , " Left GoodError -> 1" + , " Left BadError -> 2" + , " -- otherwise" + , " Right [] -> 0" + , " Right (x:_) -> x" + ] + + +-------------------------------------------------------------------------------- +case15 :: Assertion +case15 = assertSnippet (step (Just 80) defaultConfig { cTopLevelPatterns = Adjacent }) + [ "catch (Left GoodError) = 1" + , "catch (Left BadError) = 2" + , "-- otherwise" + , "catch (Right []) = 0" + , "catch (Right (x:_)) = x" + ] + [ "catch (Left GoodError) = 1" + , "catch (Left BadError) = 2" + , "-- otherwise" + , "catch (Right []) = 0" + , "catch (Right (x:_)) = x" + ] + + +-------------------------------------------------------------------------------- +case16 :: Assertion +case16 = assertSnippet (step (Just 80) defaultConfig { cRecords = Adjacent }) + [ "data Foo = Foo" + , " { foo :: Int" + , " , foo2 :: String" + , " -- a comment" + , " , barqux :: String" + , " , baz :: String" + , " , baz2 :: Bool" + , " } deriving (Show)" + ] + [ "data Foo = Foo" + , " { foo :: Int" + , " , foo2 :: String" + , " -- a comment" + , " , barqux :: String" + , " , baz :: String" + , " , baz2 :: Bool" + , " } deriving (Show)" + ] + + +-------------------------------------------------------------------------------- +case17 :: Assertion +case17 = assertSnippet (step Nothing defaultConfig { cMultiWayIf = Adjacent }) + [ "cond n = if" + , " | n < 10, x <- 1 -> x" + , " -- comment" + , " | otherwise -> 2" + ] + [ "cond n = if" + , " | n < 10, x <- 1 -> x" + , " -- comment" + , " | otherwise -> 2" + ] diff --git a/tests/Language/Haskell/Stylish/Step/Squash/Tests.hs b/tests/Language/Haskell/Stylish/Step/Squash/Tests.hs --- a/tests/Language/Haskell/Stylish/Step/Squash/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Squash/Tests.hs @@ -1,13 +1,14 @@ -------------------------------------------------------------------------------- +{-# LANGUAGE OverloadedLists #-} module Language.Haskell.Stylish.Step.Squash.Tests ( tests ) where -------------------------------------------------------------------------------- -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, (@=?)) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion) -------------------------------------------------------------------------------- @@ -28,94 +29,74 @@ -------------------------------------------------------------------------------- case01 :: Assertion -case01 = expected @=? testStep step input - where - input = unlines - [ "data Foo = Foo" - , " { foo :: Int" - , " , barqux :: String" - , " } deriving (Show)" - ] - - expected = unlines - [ "data Foo = Foo" - , " { foo :: Int" - , " , barqux :: String" - , " } deriving (Show)" - ] +case01 = assertSnippet step + [ "data Foo = Foo" + , " { foo :: Int" + , " , barqux :: String" + , " } deriving (Show)" + ] + [ "data Foo = Foo" + , " { foo :: Int" + , " , barqux :: String" + , " } deriving (Show)" + ] -------------------------------------------------------------------------------- case02 :: Assertion -case02 = expected @=? testStep step input - where - input = unlines - [ "data Foo = Foo" - , " { fooqux" - , " , bar :: String" - , " } deriving (Show)" - ] - - expected = unlines - [ "data Foo = Foo" - , " { fooqux" - , " , bar :: String" - , " } deriving (Show)" - ] +case02 = assertSnippet step + [ "data Foo = Foo" + , " { fooqux" + , " , bar :: String" + , " } deriving (Show)" + ] + [ "data Foo = Foo" + , " { fooqux" + , " , bar :: String" + , " } deriving (Show)" + ] -------------------------------------------------------------------------------- case03 :: Assertion -case03 = expected @=? testStep step input - where - input = unlines - [ "maybe y0 f mx =" - , " case mx of" - , " Nothing -> y0" - , " Just x -> f x" - ] - - expected = unlines - [ "maybe y0 f mx =" - , " case mx of" - , " Nothing -> y0" - , " Just x -> f x" - ] +case03 = assertSnippet step + [ "maybe y0 f mx =" + , " case mx of" + , " Nothing -> y0" + , " Just x -> f x" + ] + [ "maybe y0 f mx =" + , " case mx of" + , " Nothing -> y0" + , " Just x -> f x" + ] -------------------------------------------------------------------------------- case04 :: Assertion -case04 = expected @=? testStep step input - where - input = unlines - [ "maybe y0 f mx =" - , " case mx of" - , " Nothing ->" - , " y0" - , " Just x ->" - , " f x" - ] - - expected = unlines - [ "maybe y0 f mx =" - , " case mx of" - , " Nothing ->" - , " y0" - , " Just x ->" - , " f x" - ] +case04 = assertSnippet step + [ "maybe y0 f mx =" + , " case mx of" + , " Nothing ->" + , " y0" + , " Just x ->" + , " f x" + ] + [ "maybe y0 f mx =" + , " case mx of" + , " Nothing ->" + , " y0" + , " Just x ->" + , " f x" + ] -------------------------------------------------------------------------------- case05 :: Assertion -case05 = expected @=? testStep step input - where - input = unlines - [ "maybe y0 _ Nothing = y" - , "maybe _ f (Just x) = f x" - ] - - expected = unlines - [ "maybe y0 _ Nothing = y" - , "maybe _ f (Just x) = f x" - ] +case05 = assertSnippet step + [ "maybe y0 _ Nothing = y" + , "maybe _ f (Just x) = f x" + ] + [ "maybe y0 _ Nothing = y" + , "maybe _ f (Just x) = f x" + ]