diff options
| -rw-r--r-- | .travis.yml | 24 | ||||
| -rw-r--r-- | CHANGELOG | 13 | ||||
| -rw-r--r-- | README.markdown | 5 | ||||
| -rw-r--r-- | data/stylish-haskell.yaml | 23 | ||||
| -rw-r--r-- | lib/Language/Haskell/Stylish.hs | 16 | ||||
| -rw-r--r-- | lib/Language/Haskell/Stylish/Align.hs | 97 | ||||
| -rw-r--r-- | lib/Language/Haskell/Stylish/Block.hs | 11 | ||||
| -rw-r--r-- | lib/Language/Haskell/Stylish/Config.hs | 32 | ||||
| -rw-r--r-- | lib/Language/Haskell/Stylish/Editor.hs | 17 | ||||
| -rw-r--r-- | lib/Language/Haskell/Stylish/Parse.hs | 21 | ||||
| -rw-r--r-- | lib/Language/Haskell/Stylish/Step/Records.hs | 79 | ||||
| -rw-r--r-- | lib/Language/Haskell/Stylish/Step/SimpleAlign.hs | 109 | ||||
| -rw-r--r-- | lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs | 4 | ||||
| -rw-r--r-- | src/Main.hs | 43 | ||||
| -rw-r--r-- | stylish-haskell.cabal | 21 | ||||
| -rw-r--r-- | tests/Language/Haskell/Stylish/Parse/Tests.hs | 48 | ||||
| -rw-r--r-- | tests/Language/Haskell/Stylish/Step/Records/Tests.hs | 56 | ||||
| -rw-r--r-- | tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs | 150 | ||||
| -rw-r--r-- | tests/TestSuite.hs | 6 |
19 files changed, 587 insertions, 188 deletions
diff --git a/.travis.yml b/.travis.yml index 7d5fedb..eeb0184 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,2 +1,22 @@ -language: haskell -ghc: '7.10' +sudo: false +language: c # Choose a lightweight base image + +cache: + directories: + - $HOME/.stack + +addons: + apt: + sources: + - hvr-ghc + packages: + - ghc-7.10.3 + +before_install: +- export PATH=/opt/ghc/7.10.3/bin:$PATH +- mkdir -p ~/.local/bin +- export PATH=$HOME/.local/bin:$PATH +- travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' + +script: +- stack --no-terminal test @@ -1,3 +1,16 @@ +# CHANGELOG + +- 0.6.1.0 + * Fix line patching issue in Editor + +- 0.6.0.0 + * Add a `simple_align` step + * Move `records` step into `simple_align` + * Use a set of default language extensions for parsing (by Langston Barrett) + * Add a newline format option (by Svyatolslav Gryaznov) + * Add more symbols from UnicodeSyntax (by Langston Barrett) + * Add a `--version` option (by Ondra Pelech) + - 0.5.17.0 * Remove shebang from input before attempting to extract pragmas * Set stdin and stdout encoding to UTF-8 by default diff --git a/README.markdown b/README.markdown index f6925c0..01f20d9 100644 --- a/README.markdown +++ b/README.markdown @@ -41,7 +41,7 @@ Turns: import System.Directory (doesFileExist) import qualified Data.Map as M - import Data.Map ((!), keys, Map) + import Data.Map ((!), keys, Map) data Point = Point { pointX, pointY :: Double @@ -115,7 +115,10 @@ Atom integration [ide-haskell] for Atom supports `stylish-haskell`. +[atom-beautify] for Atom supports Haskell using `stylish-haskell`. + [ide-haskell]: https://atom.io/packages/ide-haskell +[atom-beautify]: Https://atom.io/packages/atom-beautify Credits ------- diff --git a/data/stylish-haskell.yaml b/data/stylish-haskell.yaml index fb12606..2398e6b 100644 --- a/data/stylish-haskell.yaml +++ b/data/stylish-haskell.yaml @@ -15,6 +15,14 @@ steps: # # true. # add_language_pragma: true + # Align the right hand side of some elements. This is quite conservative + # and only applies to statements where each element occupies a single + # line. + - simple_align: + cases: true + top_level_patterns: true + records: true + # Import cleanup - imports: # There are different ways we can align names and lists. @@ -128,9 +136,6 @@ steps: # is set to true, it will remove those redundant pragmas. Default: true. remove_redundant: true - # Align the types in record declarations - - records: {} - # Replace tabs by spaces. This is disabled by default. # - tabs: # # Number of spaces to use for each tab. Default: 8, as specified by the @@ -144,6 +149,18 @@ steps: # to. Different steps take this into account. Default: 80. columns: 80 +# By default, line endings are converted according to the OS. You can override +# preferred format here. +# +# - native: Native newline format. CRLF on Windows, LF on other OSes. +# +# - lf: Convert to LF ("\n"). +# +# - crlf: Convert to CRLF ("\r\n"). +# +# Default: native. +newline: native + # Sometimes, language extensions are specified in a cabal file or from the # command line instead of using language pragmas in the file. stylish-haskell # needs to be aware of these, so it can parse the file correctly. diff --git a/lib/Language/Haskell/Stylish.hs b/lib/Language/Haskell/Stylish.hs index 103306c..5b1e918 100644 --- a/lib/Language/Haskell/Stylish.hs +++ b/lib/Language/Haskell/Stylish.hs @@ -3,9 +3,9 @@ module Language.Haskell.Stylish ( -- * Run runSteps -- * Steps + , simpleAlign , imports , languagePragmas - , records , tabs , trailingWhitespace , unicodeSyntax @@ -34,7 +34,7 @@ import Language.Haskell.Stylish.Parse import Language.Haskell.Stylish.Step import qualified Language.Haskell.Stylish.Step.Imports as Imports import qualified Language.Haskell.Stylish.Step.LanguagePragmas as LanguagePragmas -import qualified Language.Haskell.Stylish.Step.Records as Records +import qualified Language.Haskell.Stylish.Step.SimpleAlign as SimpleAlign import qualified Language.Haskell.Stylish.Step.Tabs as Tabs import qualified Language.Haskell.Stylish.Step.TrailingWhitespace as TrailingWhitespace import qualified Language.Haskell.Stylish.Step.UnicodeSyntax as UnicodeSyntax @@ -43,6 +43,13 @@ import Paths_stylish_haskell (version) -------------------------------------------------------------------------------- +simpleAlign :: Int -- ^ Columns + -> SimpleAlign.Config + -> Step +simpleAlign = SimpleAlign.step + + +-------------------------------------------------------------------------------- imports :: Int -- ^ columns -> Imports.Align -> Step @@ -59,11 +66,6 @@ languagePragmas = LanguagePragmas.step -------------------------------------------------------------------------------- -records :: Step -records = Records.step - - --------------------------------------------------------------------------------- tabs :: Int -- ^ number of spaces -> Step tabs = Tabs.step diff --git a/lib/Language/Haskell/Stylish/Align.hs b/lib/Language/Haskell/Stylish/Align.hs new file mode 100644 index 0000000..c58b133 --- /dev/null +++ b/lib/Language/Haskell/Stylish/Align.hs @@ -0,0 +1,97 @@ +-------------------------------------------------------------------------------- +-- | This module is useful for aligning things. +module Language.Haskell.Stylish.Align + ( Alignable (..) + , align + ) where + + +-------------------------------------------------------------------------------- +import Data.Char (isSpace) +import Data.List (nub) +import qualified Language.Haskell.Exts.Annotated as H + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Editor +import Language.Haskell.Stylish.Util + + +-------------------------------------------------------------------------------- +-- | This represent a single line which can be aligned. We have something on +-- the left and the right side, e.g.: +-- +-- > [x] -> x + 1 +-- > ^^^^ ^^^^^ +-- > LEFT RIGHT +-- +-- We also have the container which holds the entire line: +-- +-- > [x] -> x + 1 +-- > ^^^^^^^^^^^^^ +-- > CONTAINER +-- +-- And then we have a "right lead" which is just represented by an 'Int', since +-- @haskell-src-exts@ often does not allow us to access it. In the example this +-- is: +-- +-- > [x] -> x + 1 +-- > ^^^ +-- > RLEAD +-- +-- This info is enough to align a bunch of these lines. Users of this module +-- should construct a list of 'Alignable's representing whatever they want to +-- align, and then call 'align' on that. +data Alignable a = Alignable + { aContainer :: !a + , aLeft :: !a + , aRight :: !a + -- | This is the minimal number of columns we need for the leading part not + -- included in our right string. For example, for datatype alignment, this + -- leading part is the string ":: " so we use 3. + , aRightLead :: !Int + } deriving (Show) + + +-------------------------------------------------------------------------------- +-- | Create changes that perform the alignment. +align + :: Int -- ^ Max columns + -> [Alignable H.SrcSpan] -- ^ Alignables + -> [Change String] -- ^ Changes performing the alignment. +align maxColumns alignment + -- Do not make any change if we would go past the maximum number of columns. + | longestLeft + longestRight > maxColumns = [] + | not (fixable alignment) = [] + | otherwise = map align' alignment + where + -- The longest thing in the left column. + longestLeft = maximum $ map (H.srcSpanEndColumn . aLeft) alignment + + -- The longest thing in the right column. + longestRight = maximum + [ H.srcSpanEndColumn (aRight a) - H.srcSpanStartColumn (aRight a) + + aRightLead a + | a <- alignment + ] + + align' a = changeLine (H.srcSpanStartLine $ aContainer a) $ \str -> + let column = H.srcSpanEndColumn $ aLeft a + (pre, post) = splitAt column str + in [padRight longestLeft (trimRight pre) ++ trimLeft post] + + trimLeft = dropWhile isSpace + trimRight = reverse . trimLeft . reverse + + +-------------------------------------------------------------------------------- +-- | Checks that all the alignables appear on a single line, and that they do +-- not overlap. +fixable :: [Alignable H.SrcSpan] -> Bool +fixable [] = False +fixable [_] = False +fixable fields = all singleLine containers && nonOverlapping containers + where + containers = map aContainer fields + singleLine s = H.srcSpanStartLine s == H.srcSpanEndLine s + nonOverlapping ss = length ss == length (nub $ map H.srcSpanStartLine ss) diff --git a/lib/Language/Haskell/Stylish/Block.hs b/lib/Language/Haskell/Stylish/Block.hs index fd680a8..d4cca7d 100644 --- a/lib/Language/Haskell/Stylish/Block.hs +++ b/lib/Language/Haskell/Stylish/Block.hs @@ -16,6 +16,7 @@ module Language.Haskell.Stylish.Block -------------------------------------------------------------------------------- import Control.Arrow (arr, (&&&), (>>>)) +import qualified Data.IntSet as IS import qualified Language.Haskell.Exts.Annotated as H @@ -73,10 +74,14 @@ merge (Block s1 e1) (Block s2 e2) = Block (min s1 s2) (max e1 e2) -------------------------------------------------------------------------------- overlapping :: [Block a] -> Bool -overlapping blocks = - any (uncurry overlapping') $ zip blocks (drop 1 blocks) +overlapping = go IS.empty where - overlapping' (Block _ e1) (Block s2 _) = e1 >= s2 + go _ [] = False + go acc (b : bs) = + let ints = [blockStart b .. blockEnd b] in + if any (`IS.member` acc) ints + then True + else go (IS.union acc $ IS.fromList ints) bs -------------------------------------------------------------------------------- diff --git a/lib/Language/Haskell/Stylish/Config.hs b/lib/Language/Haskell/Stylish/Config.hs index fee7594..d14e1be 100644 --- a/lib/Language/Haskell/Stylish/Config.hs +++ b/lib/Language/Haskell/Stylish/Config.hs @@ -14,6 +14,7 @@ import Control.Monad (forM, mzero) import Data.Aeson (FromJSON (..)) import qualified Data.Aeson as A import qualified Data.Aeson.Types as A +import Data.Maybe (fromMaybe) import qualified Data.ByteString as B import Data.List (inits, intercalate) @@ -24,13 +25,15 @@ import System.Directory import System.FilePath (joinPath, splitPath, (</>)) +import qualified System.IO as IO (Newline (..), + nativeNewline) -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Step import qualified Language.Haskell.Stylish.Step.Imports as Imports import qualified Language.Haskell.Stylish.Step.LanguagePragmas as LanguagePragmas -import qualified Language.Haskell.Stylish.Step.Records as Records +import qualified Language.Haskell.Stylish.Step.SimpleAlign as SimpleAlign import qualified Language.Haskell.Stylish.Step.Tabs as Tabs import qualified Language.Haskell.Stylish.Step.TrailingWhitespace as TrailingWhitespace import qualified Language.Haskell.Stylish.Step.UnicodeSyntax as UnicodeSyntax @@ -47,6 +50,7 @@ data Config = Config { configSteps :: [Step] , configColumns :: Int , configLanguageExtensions :: [String] + , configNewline :: IO.Newline } @@ -115,11 +119,18 @@ parseConfig (A.Object o) = do <$> pure [] <*> (o A..:? "columns" A..!= 80) <*> (o A..:? "language_extensions" A..!= []) + <*> (o A..:? "newline" >>= parseEnum newlines IO.nativeNewline) -- Then fill in the steps based on the partial config we already have stepValues <- o A..: "steps" :: A.Parser [A.Value] steps <- mapM (parseSteps config) stepValues return config {configSteps = concat steps} + where + newlines = + [ ("native", IO.nativeNewline) + , ("lf", IO.LF) + , ("crlf", IO.CRLF) + ] parseConfig _ = mzero @@ -128,7 +139,7 @@ catalog :: Map String (Config -> A.Object -> A.Parser Step) catalog = M.fromList [ ("imports", parseImports) , ("language_pragmas", parseLanguagePragmas) - , ("records", parseRecords) + , ("simple_align", parseSimpleAlign) , ("tabs", parseTabs) , ("trailing_whitespace", parseTrailingWhitespace) , ("unicode_syntax", parseUnicodeSyntax) @@ -155,6 +166,18 @@ parseEnum strs _ (Just k) = case lookup k strs of -------------------------------------------------------------------------------- +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") + where + withDef f k = fromMaybe (f SimpleAlign.defaultConfig) <$> (o A..:? k) + + +-------------------------------------------------------------------------------- parseImports :: Config -> A.Object -> A.Parser Step parseImports config o = Imports.step <$> pure (configColumns config) @@ -204,11 +227,6 @@ parseLanguagePragmas config o = LanguagePragmas.step -------------------------------------------------------------------------------- -parseRecords :: Config -> A.Object -> A.Parser Step -parseRecords _ _ = return Records.step - - --------------------------------------------------------------------------------- parseTabs :: Config -> A.Object -> A.Parser Step parseTabs _ o = Tabs.step <$> o A..:? "spaces" A..!= 8 diff --git a/lib/Language/Haskell/Stylish/Editor.hs b/lib/Language/Haskell/Stylish/Editor.hs index 5d5a864..cad7e68 100644 --- a/lib/Language/Haskell/Stylish/Editor.hs +++ b/lib/Language/Haskell/Stylish/Editor.hs @@ -19,6 +19,11 @@ module Language.Haskell.Stylish.Editor -------------------------------------------------------------------------------- +import Data.List (intercalate, sortBy) +import Data.Ord (comparing) + + +-------------------------------------------------------------------------------- import Language.Haskell.Stylish.Block @@ -37,13 +42,17 @@ moveChange offset (Change block ls) = Change (moveBlock offset block) ls -------------------------------------------------------------------------------- applyChanges :: [Change a] -> [a] -> [a] -applyChanges changes +applyChanges changes0 | overlapping blocks = error $ "Language.Haskell.Stylish.Editor.applyChanges: " ++ - "refusing to make overlapping changes" - | otherwise = go 1 changes + "refusing to make overlapping changes on lines " ++ + intercalate ", " (map printBlock blocks) + | otherwise = go 1 changes1 where - blocks = map changeBlock changes + changes1 = sortBy (comparing (blockStart . changeBlock)) changes0 + blocks = map changeBlock changes1 + + printBlock b = show (blockStart b) ++ "-" ++ show (blockEnd b) go _ [] ls = ls go n (ch : chs) ls = diff --git a/lib/Language/Haskell/Stylish/Parse.hs b/lib/Language/Haskell/Stylish/Parse.hs index 3118380..2b16b30 100644 --- a/lib/Language/Haskell/Stylish/Parse.hs +++ b/lib/Language/Haskell/Stylish/Parse.hs @@ -7,12 +7,29 @@ module Language.Haskell.Stylish.Parse -------------------------------------------------------------------------------- import Data.Maybe (fromMaybe, listToMaybe) import qualified Language.Haskell.Exts.Annotated as H -import Data.List (isPrefixOf) +import Data.List (isPrefixOf, nub) -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Config import Language.Haskell.Stylish.Step +-------------------------------------------------------------------------------- +-- | Syntax-related language extensions are always enabled for parsing. Since we +-- can't authoritatively know which extensions are enabled at compile-time, we +-- should try not to throw errors when parsing any GHC-accepted code. +defaultExtensions :: [H.Extension] +defaultExtensions = map H.EnableExtension + [ H.GADTs + , H.HereDocuments + , H.KindSignatures + , H.MagicHash + , H.NewQualifiedOperators + , H.PatternGuards + , H.StandaloneDeriving + , H.UnicodeSyntax + , H.XmlSyntax + ] + -------------------------------------------------------------------------------- -- | Filter out lines which use CPP macros @@ -50,7 +67,7 @@ parseModule extraExts mfp string = do let noPrefixes = unShebang . dropBom $ string extraExts' = map H.classifyExtension extraExts (lang, fileExts) = fromMaybe (Nothing, []) $ H.readExtensions noPrefixes - exts = fileExts ++ extraExts' + exts = nub $ fileExts ++ extraExts' ++ defaultExtensions -- Parsing options... fp = fromMaybe "<unknown>" mfp diff --git a/lib/Language/Haskell/Stylish/Step/Records.hs b/lib/Language/Haskell/Stylish/Step/Records.hs deleted file mode 100644 index c8f6d19..0000000 --- a/lib/Language/Haskell/Stylish/Step/Records.hs +++ /dev/null @@ -1,79 +0,0 @@ --------------------------------------------------------------------------------- -module Language.Haskell.Stylish.Step.Records - ( step - ) where - - --------------------------------------------------------------------------------- -import Data.Char (isSpace) -import Data.List (nub) -import qualified Language.Haskell.Exts.Annotated as H - - --------------------------------------------------------------------------------- -import Language.Haskell.Stylish.Editor -import Language.Haskell.Stylish.Step -import Language.Haskell.Stylish.Util - - --------------------------------------------------------------------------------- -records :: H.Module l -> [[Alignable l]] -records modu = - [ map fieldDeclToAlignable fields - | H.Module _ _ _ _ decls <- [modu] - , H.DataDecl _ _ _ _ cons _ <- decls - , H.QualConDecl _ _ _ (H.RecDecl _ _ fields) <- cons - ] - - --------------------------------------------------------------------------------- -data Alignable a = Alignable - { aContainer :: !a - , aLeft :: !a - , aRight :: !a - } deriving (Show) - - --------------------------------------------------------------------------------- -fieldDeclToAlignable :: H.FieldDecl a -> Alignable a -fieldDeclToAlignable (H.FieldDecl ann names ty) = Alignable - { aContainer = ann - , aLeft = H.ann (last names) - , aRight = H.ann ty - } - - --------------------------------------------------------------------------------- --- | Align the type of a field -align :: [Alignable H.SrcSpan] -> [Change String] -align alignment = map align' alignment - where - longest = maximum $ map (H.srcSpanEndColumn . aLeft) alignment - - align' a = changeLine (H.srcSpanStartLine $ aContainer a) $ \str -> - let column = H.srcSpanEndColumn $ aLeft a - (pre, post) = splitAt column str - in [padRight longest (trimRight pre) ++ trimLeft post] - - trimLeft = dropWhile isSpace - trimRight = reverse . trimLeft . reverse - - --------------------------------------------------------------------------------- --- | Checks that all no field of the record appears on more than one line, --- amonst other things -fixable :: [Alignable H.SrcSpan] -> Bool -fixable [] = False -fixable fields = all singleLine containers && nonOverlapping containers - where - containers = map aContainer fields - singleLine s = H.srcSpanStartLine s == H.srcSpanEndLine s - nonOverlapping ss = length ss == length (nub $ map H.srcSpanStartLine ss) - - --------------------------------------------------------------------------------- -step :: Step -step = makeStep "Records" $ \ls (module', _) -> - let module'' = fmap H.srcInfoSpan module' - fixableRecords = filter fixable $ records module'' - in applyChanges (fixableRecords >>= align) ls diff --git a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs new file mode 100644 index 0000000..c89e8a1 --- /dev/null +++ b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs @@ -0,0 +1,109 @@ +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish.Step.SimpleAlign + ( Config (..) + , defaultConfig + , step + ) where + + +-------------------------------------------------------------------------------- +import Data.Data (Data) +import Data.Maybe (maybeToList) +import qualified Language.Haskell.Exts.Annotated as H + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Align +import Language.Haskell.Stylish.Editor +import Language.Haskell.Stylish.Step +import Language.Haskell.Stylish.Util + + +-------------------------------------------------------------------------------- +data Config = Config + { cCases :: !Bool + , cTopLevelPatterns :: !Bool + , cRecords :: !Bool + } deriving (Show) + + +-------------------------------------------------------------------------------- +defaultConfig :: Config +defaultConfig = Config + { cCases = True + , cTopLevelPatterns = True + , cRecords = True + } + + +-------------------------------------------------------------------------------- +cases :: Data l => H.Module l -> [[H.Alt l]] +cases modu = [alts | H.Case _ _ alts <- everything modu] + + +-------------------------------------------------------------------------------- +altToAlignable :: H.Alt l -> Maybe (Alignable l) +altToAlignable (H.Alt _ _ _ (Just _)) = Nothing +altToAlignable (H.Alt ann pat rhs Nothing) = Just $ Alignable + { aContainer = ann + , aLeft = H.ann pat + , aRight = H.ann rhs + , aRightLead = length "-> " + } + + +-------------------------------------------------------------------------------- +tlpats :: Data l => H.Module l -> [[H.Match l]] +tlpats modu = [matches | H.FunBind _ matches <- everything modu] + + +-------------------------------------------------------------------------------- +matchToAlignable :: H.Match l -> Maybe (Alignable l) +matchToAlignable (H.InfixMatch _ _ _ _ _ _) = Nothing +matchToAlignable (H.Match _ _ [] _ _) = Nothing +matchToAlignable (H.Match _ _ _ _ (Just _)) = Nothing +matchToAlignable (H.Match ann name pats rhs Nothing) = Just $ Alignable + { aContainer = ann + , aLeft = last (H.ann name : map H.ann pats) + , aRight = H.ann rhs + , aRightLead = length "= " + } + + +-------------------------------------------------------------------------------- +records :: H.Module l -> [[H.FieldDecl l]] +records modu = + [ fields + | H.Module _ _ _ _ decls <- [modu] + , H.DataDecl _ _ _ _ cons _ <- decls + , H.QualConDecl _ _ _ (H.RecDecl _ _ fields) <- cons + ] + + +-------------------------------------------------------------------------------- +fieldDeclToAlignable :: H.FieldDecl a -> Maybe (Alignable a) +fieldDeclToAlignable (H.FieldDecl ann names ty) = Just $ Alignable + { aContainer = ann + , aLeft = H.ann (last names) + , aRight = H.ann ty + , aRightLead = length ":: " + } + + +-------------------------------------------------------------------------------- +step :: Int -> Config -> Step +step maxColumns config = makeStep "Cases" $ \ls (module', _) -> + let module'' = fmap H.srcInfoSpan module' + changes search toAlign = + [ change_ + | case_ <- search module'' + , aligns <- maybeToList (mapM toAlign case_) + , change_ <- align maxColumns aligns + ] + + configured = concat $ + [changes cases altToAlignable | cCases config] ++ + [changes tlpats matchToAlignable | cTopLevelPatterns config] ++ + [changes records fieldDeclToAlignable | cRecords config] + + in applyChanges configured ls diff --git a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs index 1e00275..0a4438a 100644 --- a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs +++ b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs @@ -26,6 +26,10 @@ unicodeReplacements = M.fromList [ ("::", "∷") , ("=>", "⇒") , ("->", "→") + , ("<-", "←") + , ("forall", "∀") + , ("-<", "↢") + , (">-", "↣") ] diff --git a/src/Main.hs b/src/Main.hs index 32d4780..d481517 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,5 +1,4 @@ -------------------------------------------------------------------------------- -{-# LANGUAGE DeriveDataTypeable #-} module Main ( main ) where @@ -21,7 +20,8 @@ import Language.Haskell.Stylish -------------------------------------------------------------------------------- data StylishArgs = StylishArgs - { saConfig :: Maybe FilePath + { saVersion :: Bool + , saConfig :: Maybe FilePath , saVerbose :: Bool , saDefaults :: Bool , saInPlace :: Bool @@ -33,7 +33,11 @@ data StylishArgs = StylishArgs -------------------------------------------------------------------------------- parseStylishArgs :: OA.Parser StylishArgs parseStylishArgs = StylishArgs - <$> OA.optional (OA.strOption $ + <$> OA.switch ( + OA.help "Show version information" <> + OA.long "version" <> + OA.hidden) + <*> OA.optional (OA.strOption $ OA.metavar "CONFIG" <> OA.help "Configuration file" <> OA.long "config" <> @@ -64,10 +68,15 @@ parseStylishArgs = StylishArgs -------------------------------------------------------------------------------- +stylishHaskellVersion :: String +stylishHaskellVersion = "stylish-haskell " <> showVersion Paths_stylish_haskell.version + + +-------------------------------------------------------------------------------- parserInfo :: OA.ParserInfo StylishArgs parserInfo = OA.info (OA.helper <*> parseStylishArgs) $ OA.fullDesc <> - OA.header ("stylish-haskell v" <> showVersion Paths_stylish_haskell.version) + OA.header stylishHaskellVersion -------------------------------------------------------------------------------- @@ -80,12 +89,15 @@ stylishHaskell :: StylishArgs -> IO () stylishHaskell sa = do unless (saNoUtf8 sa) $ mapM_ (`IO.hSetEncoding` IO.utf8) [IO.stdin, IO.stdout] - case saDefaults sa of - True -> do + if saVersion sa then + putStrLn stylishHaskellVersion + + else if saDefaults sa then do fileName <- defaultConfigFilePath verbose' $ "Dumping config from " ++ fileName readUTF8File fileName >>= putStr - False -> do + + else do conf <- loadConfig verbose' (saConfig sa) let steps = configSteps conf forM_ steps $ \s -> verbose' $ "Enabled " ++ stepName s ++ " step" @@ -109,14 +121,21 @@ file sa conf mfp = do Right ok -> write contents $ unlines ok where write old new = case mfp of - Nothing -> putStr new - Just _ | not (saInPlace sa) -> putStr new - Just path | length new /= 0 && old /= new -> writeFile path new + Nothing -> putStrNewline new + Just _ | not (saInPlace sa) -> putStrNewline new + Just path | not (null new) && old /= new -> + IO.withFile path IO.WriteMode $ \h -> do + setNewlineMode h + IO.hPutStr h new _ -> return () + setNewlineMode h = do + let nl = configNewline conf + let mode = IO.NewlineMode IO.nativeNewline nl + IO.hSetNewlineMode h mode + putStrNewline txt = setNewlineMode IO.stdout >> putStr txt readUTF8File :: FilePath -> IO String readUTF8File fp = IO.withFile fp IO.ReadMode $ \h -> do IO.hSetEncoding h IO.utf8 - content <- IO.Strict.hGetContents h - return content + IO.Strict.hGetContents h diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal index 2fed0d1..2c4ee95 100644 --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -1,5 +1,5 @@ Name: stylish-haskell -Version: 0.5.17.0 +Version: 0.6.1.0 Synopsis: Haskell code prettifier Homepage: https://github.com/jaspervdj/stylish-haskell License: BSD3 @@ -30,14 +30,15 @@ Library Ghc-options: -Wall Other-modules: + Language.Haskell.Stylish.Align Language.Haskell.Stylish.Block Language.Haskell.Stylish.Config Language.Haskell.Stylish.Editor Language.Haskell.Stylish.Parse Language.Haskell.Stylish.Step + Language.Haskell.Stylish.Step.SimpleAlign Language.Haskell.Stylish.Step.Imports Language.Haskell.Stylish.Step.LanguagePragmas - Language.Haskell.Stylish.Step.Records Language.Haskell.Stylish.Step.Tabs Language.Haskell.Stylish.Step.TrailingWhitespace Language.Haskell.Stylish.Step.UnicodeSyntax @@ -85,14 +86,28 @@ Test-suite stylish-haskell-tests Type: exitcode-stdio-1.0 Other-modules: + Language.Haskell.Stylish.Align + Language.Haskell.Stylish.Block + Language.Haskell.Stylish.Config + Language.Haskell.Stylish.Editor + Language.Haskell.Stylish.Parse Language.Haskell.Stylish.Parse.Tests + Language.Haskell.Stylish.Step + Language.Haskell.Stylish.Step.SimpleAlign + Language.Haskell.Stylish.Step.SimpleAlign.Tests + Language.Haskell.Stylish.Step.Imports Language.Haskell.Stylish.Step.Imports.Tests + Language.Haskell.Stylish.Step.LanguagePragmas Language.Haskell.Stylish.Step.LanguagePragmas.Tests - Language.Haskell.Stylish.Step.Records.Tests + Language.Haskell.Stylish.Step.Tabs Language.Haskell.Stylish.Step.Tabs.Tests + Language.Haskell.Stylish.Step.TrailingWhitespace Language.Haskell.Stylish.Step.TrailingWhitespace.Tests + Language.Haskell.Stylish.Step.UnicodeSyntax Language.Haskell.Stylish.Step.UnicodeSyntax.Tests Language.Haskell.Stylish.Tests.Util + Language.Haskell.Stylish.Util + Language.Haskell.Stylish.Verbose Build-depends: HUnit >= 1.2 && < 1.4, diff --git a/tests/Language/Haskell/Stylish/Parse/Tests.hs b/tests/Language/Haskell/Stylish/Parse/Tests.hs index 87c0a51..4d3400c 100644 --- a/tests/Language/Haskell/Stylish/Parse/Tests.hs +++ b/tests/Language/Haskell/Stylish/Parse/Tests.hs @@ -16,12 +16,16 @@ import Language.Haskell.Stylish.Parse -------------------------------------------------------------------------------- tests :: Test tests = testGroup "Language.Haskell.Stylish.Parse" - [ testCase "UTF-8 Byte Order Mark" testBom - , testCase "Extra extensions" testExtraExtensions - , testCase "Multiline CPP" testMultilineCpp - , testCase "Haskell2010 extension" testHaskell2010 - , testCase "Shebang" testShebang - , testCase "ShebangExt" testShebangExt + [ testCase "UTF-8 Byte Order Mark" testBom + , testCase "Extra extensions" testExtraExtensions + , testCase "Multiline CPP" testMultilineCpp + , testCase "Haskell2010 extension" testHaskell2010 + , testCase "Shebang" testShebang + , testCase "ShebangExt" testShebangExt + , testCase "GADTs extension" testGADTs + , testCase "KindSignatures extension" testKindSignatures + , testCase "StandalonDeriving extension" testStandaloneDeriving + , testCase "UnicodeSyntax extension" testUnicodeSyntax ] -------------------------------------------------------------------------------- @@ -77,6 +81,38 @@ testShebang = assert $ isRight $ parseModule [] Nothing $ unlines , "main = return ()" ] +-------------------------------------------------------------------------------- + +-- | These tests are for syntactic language extensions that should always be +-- enabled for parsing, even when the pragma is absent. + +testGADTs :: Assertion +testGADTs = assert $ isRight $ parseModule [] Nothing $ unlines + [ "module Main where" + , "data SafeList a b where" + , " Nil :: SafeList a Empty" + , " Cons:: a -> SafeList a b -> SafeList a NonEmpty" + ] + +testKindSignatures :: Assertion +testKindSignatures = assert $ isRight $ parseModule [] Nothing $ unlines + [ "module Main where" + , "data D :: * -> * -> * where" + , " D :: a -> b -> D a b" + ] + +testStandaloneDeriving :: Assertion +testStandaloneDeriving = assert $ isRight $ parseModule [] Nothing $ unlines + [ "module Main where" + , "deriving instance Show MyType" + ] + +testUnicodeSyntax :: Assertion +testUnicodeSyntax = assert $ isRight $ parseModule [] Nothing $ unlines + [ "module Main where" + , "monadic ∷ (Monad m) ⇒ m a → m a" + , "monadic = id" + ] -------------------------------------------------------------------------------- isRight :: Either a b -> Bool diff --git a/tests/Language/Haskell/Stylish/Step/Records/Tests.hs b/tests/Language/Haskell/Stylish/Step/Records/Tests.hs deleted file mode 100644 index 312c6fa..0000000 --- a/tests/Language/Haskell/Stylish/Step/Records/Tests.hs +++ /dev/null @@ -1,56 +0,0 @@ --------------------------------------------------------------------------------- -module Language.Haskell.Stylish.Step.Records.Tests - ( tests - ) where - - --------------------------------------------------------------------------------- -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, (@=?)) - - --------------------------------------------------------------------------------- -import Language.Haskell.Stylish.Step.Records -import Language.Haskell.Stylish.Tests.Util - - --------------------------------------------------------------------------------- -tests :: Test -tests = testGroup "Language.Haskell.Stylish.Step.Records.Tests" - [ testCase "case 01" case01 - , testCase "case 02" case02 - ] - - --------------------------------------------------------------------------------- -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)" - ] - - --------------------------------------------------------------------------------- -case02 :: Assertion -case02 = input @=? testStep step input - where - -- Don't attempt to align this since a field spans multiple lines - input = unlines - [ "data Foo = Foo" - , " { foo :: Int" - , " , barqux" - , " :: String" - , " } deriving (Show)" - ] diff --git a/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs b/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs new file mode 100644 index 0000000..a57e6e9 --- /dev/null +++ b/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs @@ -0,0 +1,150 @@ +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish.Step.SimpleAlign.Tests + ( tests + ) where + + +-------------------------------------------------------------------------------- +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, (@=?)) + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Step.SimpleAlign +import Language.Haskell.Stylish.Tests.Util + + +-------------------------------------------------------------------------------- +tests :: Test +tests = testGroup "Language.Haskell.Stylish.Step.SimpleAlign.Tests" + [ testCase "case 01" case01 + , testCase "case 02" case02 + , testCase "case 03" case03 + , testCase "case 04" case04 + , testCase "case 05" case05 + , testCase "case 06" case06 + , testCase "case 07" case07 + ] + + +-------------------------------------------------------------------------------- +case01 :: Assertion +case01 = expected @=? testStep (step 80 defaultConfig) input + where + input = unlines + [ "eitherToMaybe e = case e of" + , " Left _ -> Nothing" + , " Right x -> Just x" + ] + + expected = unlines + [ "eitherToMaybe e = case e of" + , " Left _ -> Nothing" + , " Right x -> Just x" + ] + + +-------------------------------------------------------------------------------- +case02 :: Assertion +case02 = expected @=? testStep (step 80 defaultConfig) input + where + input = unlines + [ "eitherToMaybe (Left _) = Nothing" + , "eitherToMaybe (Right x) = Just x" + ] + + expected = unlines + [ "eitherToMaybe (Left _) = Nothing" + , "eitherToMaybe (Right x) = Just x" + ] + + +-------------------------------------------------------------------------------- +case03 :: Assertion +case03 = expected @=? testStep (step 80 defaultConfig) input + where + input = unlines + [ "heady def [] = def" + , "heady _ (x : _) = x" + ] + + expected = unlines + [ "heady def [] = def" + , "heady _ (x : _) = x" + ] + + +-------------------------------------------------------------------------------- +case04 :: Assertion +case04 = expected @=? testStep (step 80 defaultConfig) input + where + input = unlines + [ "data Foo = Foo" + , " { foo :: Int" + , " , barqux :: String" + , " } deriving (Show)" + ] + + expected = unlines + [ "data Foo = Foo" + , " { foo :: Int" + , " , barqux :: String" + , " } deriving (Show)" + ] + + +-------------------------------------------------------------------------------- +case05 :: Assertion +case05 = input @=? testStep (step 80 defaultConfig) input + where + -- Don't attempt to align this since a field spans multiple lines + input = unlines + [ "data Foo = Foo" + , " { foo :: Int" + , " , barqux" + , " :: String" + , " } deriving (Show)" + ] + + +-------------------------------------------------------------------------------- +case06 :: Assertion +case06 = + -- 22 max columns is /just/ enough to align this stuff. + expected @=? testStep (step 22 defaultConfig) input + where + input = unlines + [ "data Foo = Foo" + , " { foo :: String" + , " , barqux :: Int" + , " }" + ] + + expected = unlines + [ "data Foo = Foo" + , " { foo :: String" + , " , barqux :: Int" + , " }" + ] + + +-------------------------------------------------------------------------------- +case07 :: Assertion +case07 = + -- 21 max columns is /just NOT/ enough to align this stuff. + expected @=? testStep (step 21 defaultConfig) input + where + input = unlines + [ "data Foo = Foo" + , " { foo :: String" + , " , barqux :: Int" + , " }" + ] + + expected = unlines + [ "data Foo = Foo" + , " { foo :: String" + , " , barqux :: Int" + , " }" + ] diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs index 28c0603..853126d 100644 --- a/tests/TestSuite.hs +++ b/tests/TestSuite.hs @@ -5,14 +5,14 @@ module Main -------------------------------------------------------------------------------- -import Test.Framework (defaultMain) +import Test.Framework (defaultMain) -------------------------------------------------------------------------------- import qualified Language.Haskell.Stylish.Parse.Tests import qualified Language.Haskell.Stylish.Step.Imports.Tests import qualified Language.Haskell.Stylish.Step.LanguagePragmas.Tests -import qualified Language.Haskell.Stylish.Step.Records.Tests +import qualified Language.Haskell.Stylish.Step.SimpleAlign.Tests import qualified Language.Haskell.Stylish.Step.Tabs.Tests import qualified Language.Haskell.Stylish.Step.TrailingWhitespace.Tests import qualified Language.Haskell.Stylish.Step.UnicodeSyntax.Tests @@ -24,7 +24,7 @@ main = defaultMain [ Language.Haskell.Stylish.Parse.Tests.tests , Language.Haskell.Stylish.Step.Imports.Tests.tests , Language.Haskell.Stylish.Step.LanguagePragmas.Tests.tests - , Language.Haskell.Stylish.Step.Records.Tests.tests + , Language.Haskell.Stylish.Step.SimpleAlign.Tests.tests , Language.Haskell.Stylish.Step.Tabs.Tests.tests , Language.Haskell.Stylish.Step.TrailingWhitespace.Tests.tests , Language.Haskell.Stylish.Step.UnicodeSyntax.Tests.tests |