diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,6 @@ +- 0.5.15.0 + * Add new options for import list alignment (by Ondřej Janošík) + - 0.5.14.4 * Bump `stylish-haskell` to 1.17.0 diff --git a/data/stylish-haskell.yaml b/data/stylish-haskell.yaml --- a/data/stylish-haskell.yaml +++ b/data/stylish-haskell.yaml @@ -33,6 +33,73 @@ # Default: global. align: global + # Folowing options affect only import list alignment. + # + # List align has following options: + # + # - after_alias: Import list is aligned with end of import including + # 'as' and 'hiding' keywords. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # > init, last, length) + # + # - with_alias: Import list is aligned with start of alias or hiding. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # > init, last, length) + # + # - new_line: Import list starts always on new line. + # + # > import qualified Data.List as List + # > (concat, foldl, foldr, head, init, last, length) + # + # Default: after alias + list_align: after_alias + + # Long list align style takes effect when import is too long. This is + # determined by 'columns' setting. + # + # - inline: This option will put as much specs on same line as possible. + # + # - new_line: Import list will start on new line. + # + # - new_line_multiline: Import list will start on new line when it's + # short enough to fit to single line. Otherwise it'll be multiline. + # + # - multiline: One line per import list entry. + # Type with contructor list acts like single import. + # + # > import qualified Data.Map as M + # > ( empty + # > , singleton + # > , ... + # > , delete + # > ) + # + # Default: inline + long_list_align: inline + + # List padding determines indentation of import list on lines after import. + # This option affects 'list_align' and 'long_list_align'. + list_padding: 4 + + # Separate lists option affects formating of import list for type + # or class. The only difference is single space between type and list + # of constructors, selectors and class functions. + # + # - true: There is single space between Foldable type and list of it's + # functions. + # + # > import Data.Foldable (Foldable (fold, foldl, foldMap)) + # + # - false: There is no space between Foldable type and list of it's + # functions. + # + # > import Data.Foldable (Foldable(fold, foldl, foldMap)) + # + # Default: true + separate_lists: true + # Language pragmas - language_pragmas: # We can generate different styles of language pragma lists. @@ -46,6 +113,16 @@ # # Default: vertical. style: vertical + + # Align affects alignment of closing pragma brackets. + # + # - true: Brackets are aligned in same collumn. + # + # - false: Brackets are not aligned together. There is only one space + # between actual import and closing bracket. + # + # Default: true + align: true # stylish-haskell can detect redundancy of some language pragmas. If this # is set to true, it will remove those redundant pragmas. Default: true. diff --git a/lib/Language/Haskell/Stylish.hs b/lib/Language/Haskell/Stylish.hs new file mode 100644 --- /dev/null +++ b/lib/Language/Haskell/Stylish.hs @@ -0,0 +1,92 @@ +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish + ( -- * Run + runSteps + -- * Steps + , imports + , languagePragmas + , records + , tabs + , trailingWhitespace + , unicodeSyntax + -- ** Data types + , Imports.Align (..) + , LanguagePragmas.Style (..) + -- ** Helpers + , stepName + -- * Config + , module Language.Haskell.Stylish.Config + -- * Misc + , module Language.Haskell.Stylish.Verbose + , version + , Lines + , Step + ) where + + +-------------------------------------------------------------------------------- +import Control.Monad (foldM) + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Config +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.Tabs as Tabs +import qualified Language.Haskell.Stylish.Step.TrailingWhitespace as TrailingWhitespace +import qualified Language.Haskell.Stylish.Step.UnicodeSyntax as UnicodeSyntax +import Language.Haskell.Stylish.Verbose +import Paths_stylish_haskell (version) + + +-------------------------------------------------------------------------------- +imports :: Int -- ^ columns + -> Imports.Align + -> Step +imports = Imports.step + + +-------------------------------------------------------------------------------- +languagePragmas :: Int -- ^ columns + -> LanguagePragmas.Style + -> Bool -- ^ Pad to same length in vertical mode? + -> Bool -- ^ remove redundant? + -> Step +languagePragmas = LanguagePragmas.step + + +-------------------------------------------------------------------------------- +records :: Step +records = Records.step + + +-------------------------------------------------------------------------------- +tabs :: Int -- ^ number of spaces + -> Step +tabs = Tabs.step + + +-------------------------------------------------------------------------------- +trailingWhitespace :: Step +trailingWhitespace = TrailingWhitespace.step + + +-------------------------------------------------------------------------------- +unicodeSyntax :: Bool -- ^ add language pragma? + -> Step +unicodeSyntax = UnicodeSyntax.step + + +-------------------------------------------------------------------------------- +runStep :: Extensions -> Maybe FilePath -> Lines -> Step -> Either String Lines +runStep exts mfp ls step = + stepFilter step ls <$> parseModule exts mfp (unlines ls) + + +-------------------------------------------------------------------------------- +runSteps :: Extensions -> Maybe FilePath -> [Step] -> Lines + -> Either String Lines +runSteps exts mfp steps ls = foldM (runStep exts mfp) ls steps diff --git a/lib/Language/Haskell/Stylish/Block.hs b/lib/Language/Haskell/Stylish/Block.hs new file mode 100644 --- /dev/null +++ b/lib/Language/Haskell/Stylish/Block.hs @@ -0,0 +1,91 @@ +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish.Block + ( Block (..) + , LineBlock + , SpanBlock + , blockLength + , linesFromSrcSpan + , spanFromSrcSpan + , moveBlock + , adjacent + , merge + , overlapping + , groupAdjacent + ) where + + +-------------------------------------------------------------------------------- +import Control.Arrow (arr, (&&&), (>>>)) +import qualified Language.Haskell.Exts.Annotated as H + + +-------------------------------------------------------------------------------- +-- | Indicates a line span +data Block a = Block + { blockStart :: Int + , blockEnd :: Int + } deriving (Eq, Ord, Show) + + +-------------------------------------------------------------------------------- +type LineBlock = Block String + + +-------------------------------------------------------------------------------- +type SpanBlock = Block Char + + +-------------------------------------------------------------------------------- +blockLength :: Block a -> Int +blockLength (Block start end) = end - start + 1 + + +-------------------------------------------------------------------------------- +linesFromSrcSpan :: H.SrcSpanInfo -> LineBlock +linesFromSrcSpan = H.srcInfoSpan >>> + H.srcSpanStartLine &&& H.srcSpanEndLine >>> + arr (uncurry Block) + + +-------------------------------------------------------------------------------- +spanFromSrcSpan :: H.SrcSpanInfo -> SpanBlock +spanFromSrcSpan = H.srcInfoSpan >>> + H.srcSpanStartColumn &&& H.srcSpanEndColumn >>> + arr (uncurry Block) + + +-------------------------------------------------------------------------------- +moveBlock :: Int -> Block a -> Block a +moveBlock offset (Block start end) = Block (start + offset) (end + offset) + + +-------------------------------------------------------------------------------- +adjacent :: Block a -> Block a -> Bool +adjacent b1 b2 = follows b1 b2 || follows b2 b1 + where + follows (Block _ e1) (Block s2 _) = e1 + 1 == s2 + + +-------------------------------------------------------------------------------- +merge :: Block a -> Block a -> Block a +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) + where + overlapping' (Block _ e1) (Block s2 _) = e1 >= s2 + + +-------------------------------------------------------------------------------- +-- | Groups adjacent blocks into larger blocks +groupAdjacent :: [(Block a, b)] + -> [(Block a, [b])] +groupAdjacent = foldr go [] + where + -- This code is ugly and not optimal, and no fucks were given. + go (b1, x) gs = case break (adjacent b1 . fst) gs of + (_, []) -> (b1, [x]) : gs + (ys, ((b2, xs) : zs)) -> (merge b1 b2, x : xs) : (ys ++ zs) diff --git a/lib/Language/Haskell/Stylish/Config.hs b/lib/Language/Haskell/Stylish/Config.hs new file mode 100644 --- /dev/null +++ b/lib/Language/Haskell/Stylish/Config.hs @@ -0,0 +1,229 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} +module Language.Haskell.Stylish.Config + ( Extensions + , Config (..) + , defaultConfigFilePath + , configFilePath + , loadConfig + ) where + + +-------------------------------------------------------------------------------- +import Control.Monad (forM, mzero) +import Data.Aeson (FromJSON (..)) +import qualified Data.Aeson as A +import qualified Data.Aeson.Types as A +import qualified Data.ByteString as B +import Data.List (inits, + intercalate) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Yaml (decodeEither) +import System.Directory +import System.FilePath (joinPath, + splitPath, + ()) + + +-------------------------------------------------------------------------------- +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.Tabs as Tabs +import qualified Language.Haskell.Stylish.Step.TrailingWhitespace as TrailingWhitespace +import qualified Language.Haskell.Stylish.Step.UnicodeSyntax as UnicodeSyntax +import Language.Haskell.Stylish.Verbose +import Paths_stylish_haskell (getDataFileName) + + +-------------------------------------------------------------------------------- +type Extensions = [String] + + +-------------------------------------------------------------------------------- +data Config = Config + { configSteps :: [Step] + , configColumns :: Int + , configLanguageExtensions :: [String] + } + + +-------------------------------------------------------------------------------- +instance FromJSON Config where + parseJSON = parseConfig + + +-------------------------------------------------------------------------------- +emptyConfig :: Config +emptyConfig = Config [] 80 [] + + +-------------------------------------------------------------------------------- +configFileName :: String +configFileName = ".stylish-haskell.yaml" + + +-------------------------------------------------------------------------------- +defaultConfigFilePath :: IO FilePath +defaultConfigFilePath = getDataFileName "data/stylish-haskell.yaml" + + +-------------------------------------------------------------------------------- +configFilePath :: Verbose -> Maybe FilePath -> IO (Maybe FilePath) +configFilePath _ (Just userSpecified) = return $ Just userSpecified +configFilePath verbose Nothing = do + current <- getCurrentDirectory + home <- getHomeDirectory + def <- defaultConfigFilePath + search $ + [d configFileName | d <- ancestors current] ++ + [home configFileName, def] + where + -- All ancestors of a dir (including that dir) + ancestors :: FilePath -> [FilePath] + ancestors = init . map joinPath . reverse . inits . splitPath + + search :: [FilePath] -> IO (Maybe FilePath) + search [] = return Nothing + search (f : fs) = do + -- TODO Maybe catch an error here, dir might be unreadable + exists <- doesFileExist f + verbose $ f ++ if exists then " exists" else " does not exist" + if exists then return (Just f) else search fs + + +-------------------------------------------------------------------------------- +loadConfig :: Verbose -> Maybe FilePath -> IO Config +loadConfig verbose mfp = do + mfp' <- configFilePath verbose mfp + case mfp' of + Nothing -> do + verbose $ "Using empty configuration" + return emptyConfig + Just fp -> do + verbose $ "Loading configuration at " ++ fp + bs <- B.readFile fp + case decodeEither bs of + Left err -> error $ + "Language.Haskell.Stylish.Config.loadConfig: " ++ err + Right config -> return config + + +-------------------------------------------------------------------------------- +parseConfig :: A.Value -> A.Parser Config +parseConfig (A.Object o) = do + -- First load the config without the actual steps + config <- Config + <$> pure [] + <*> (o A..:? "columns" A..!= 80) + <*> (o A..:? "language_extensions" A..!= []) + + -- 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} +parseConfig _ = mzero + + +-------------------------------------------------------------------------------- +catalog :: Map String (Config -> A.Object -> A.Parser Step) +catalog = M.fromList + [ ("imports", parseImports) + , ("language_pragmas", parseLanguagePragmas) + , ("records", parseRecords) + , ("tabs", parseTabs) + , ("trailing_whitespace", parseTrailingWhitespace) + , ("unicode_syntax", parseUnicodeSyntax) + ] + + +-------------------------------------------------------------------------------- +parseSteps :: Config -> A.Value -> A.Parser [Step] +parseSteps config val = do + map' <- parseJSON val :: A.Parser (Map String A.Value) + forM (M.toList map') $ \(k, v) -> case (M.lookup k catalog, v) of + (Just parser, A.Object o) -> parser config o + _ -> fail $ "Invalid declaration for " ++ k + + +-------------------------------------------------------------------------------- +-- | Utility for enum-like options +parseEnum :: [(String, a)] -> a -> Maybe String -> A.Parser a +parseEnum _ def Nothing = return def +parseEnum strs _ (Just k) = case lookup k strs of + Just v -> return v + Nothing -> fail $ "Unknown option: " ++ k ++ ", should be one of: " ++ + intercalate ", " (map fst strs) + + +-------------------------------------------------------------------------------- +parseImports :: Config -> A.Object -> A.Parser Step +parseImports config o = Imports.step + <$> pure (configColumns config) + <*> (Imports.Align + <$> (o A..:? "align" >>= parseEnum aligns Imports.Global) + <*> (o A..:? "list_align" >>= parseEnum listAligns Imports.AfterAlias) + <*> (o A..:? "long_list_align" + >>= parseEnum longListAligns Imports.Inline) + <*> (maybe 4 (max 1) <$> o A..:? "list_padding") + -- ^ Padding have to be at least 1. Default is 4. + <*> o A..:? "separate_lists" A..!= True) + where + aligns = + [ ("global", Imports.Global) + , ("file", Imports.File) + , ("group", Imports.Group) + , ("none", Imports.None) + ] + + listAligns = + [ ("new_line", Imports.NewLine) + , ("with_alias", Imports.WithAlias) + , ("after_alias", Imports.AfterAlias) + ] + + longListAligns = + [ ("inline", Imports.Inline) + , ("new_line", Imports.InlineWithBreak) + , ("new_line_multiline", Imports.InlineToMultiline) + , ("multiline", Imports.Multiline) + ] + + +-------------------------------------------------------------------------------- +parseLanguagePragmas :: Config -> A.Object -> A.Parser Step +parseLanguagePragmas config o = LanguagePragmas.step + <$> pure (configColumns config) + <*> (o A..:? "style" >>= parseEnum styles LanguagePragmas.Vertical) + <*> o A..:? "align" A..!= True + <*> o A..:? "remove_redundant" A..!= True + where + styles = + [ ("vertical", LanguagePragmas.Vertical) + , ("compact", LanguagePragmas.Compact) + , ("compact_line", LanguagePragmas.CompactLine) + ] + + +-------------------------------------------------------------------------------- +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 + + +-------------------------------------------------------------------------------- +parseTrailingWhitespace :: Config -> A.Object -> A.Parser Step +parseTrailingWhitespace _ _ = return TrailingWhitespace.step + + +-------------------------------------------------------------------------------- +parseUnicodeSyntax :: Config -> A.Object -> A.Parser Step +parseUnicodeSyntax _ o = UnicodeSyntax.step + <$> o A..:? "add_language_pragma" A..!= True diff --git a/lib/Language/Haskell/Stylish/Editor.hs b/lib/Language/Haskell/Stylish/Editor.hs new file mode 100644 --- /dev/null +++ b/lib/Language/Haskell/Stylish/Editor.hs @@ -0,0 +1,101 @@ +-------------------------------------------------------------------------------- +-- | This module provides you with a line-based editor. It's main feature is +-- that you can specify multiple changes at the same time, e.g.: +-- +-- > [deleteLine 3, changeLine 4 ["Foo"]] +-- +-- when this is evaluated, we take into account that 4th line will become the +-- 3rd line before it needs changing. +module Language.Haskell.Stylish.Editor + ( Change + , applyChanges + + , change + , changeLine + , delete + , deleteLine + , insert + ) where + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Block + + +-------------------------------------------------------------------------------- +-- | Changes the lines indicated by the 'Block' into the given 'Lines' +data Change a = Change + { changeBlock :: Block a + , changeLines :: ([a] -> [a]) + } + + +-------------------------------------------------------------------------------- +moveChange :: Int -> Change a -> Change a +moveChange offset (Change block ls) = Change (moveBlock offset block) ls + + +-------------------------------------------------------------------------------- +applyChanges :: [Change a] -> [a] -> [a] +applyChanges changes + | overlapping blocks = error $ + "Language.Haskell.Stylish.Editor.applyChanges: " ++ + "refusing to make overlapping changes" + | otherwise = go 1 changes + where + blocks = map changeBlock changes + + go _ [] ls = ls + go n (ch : chs) ls = + -- Divide the remaining lines into: + -- + -- > pre + -- > old (lines that are affected by the change) + -- > post + -- + -- And generate: + -- + -- > pre + -- > new + -- > (recurse) + -- + let block = changeBlock ch + (pre, ls') = splitAt (blockStart block - n) ls + (old, post) = splitAt (blockLength block) ls' + new = changeLines ch old + extraLines = length new - blockLength block + chs' = map (moveChange extraLines) chs + n' = blockStart block + blockLength block + extraLines + in pre ++ new ++ go n' chs' post + + +-------------------------------------------------------------------------------- +-- | Change a block of lines for some other lines +change :: Block a -> ([a] -> [a]) -> Change a +change = Change + + +-------------------------------------------------------------------------------- +-- | Change a single line for some other lines +changeLine :: Int -> (a -> [a]) -> Change a +changeLine start f = change (Block start start) $ \xs -> case xs of + [] -> [] + (x : _) -> f x + + +-------------------------------------------------------------------------------- +-- | Delete a block of lines +delete :: Block a -> Change a +delete block = Change block $ const [] + + +-------------------------------------------------------------------------------- +-- | Delete a single line +deleteLine :: Int -> Change a +deleteLine start = delete (Block start start) + + +-------------------------------------------------------------------------------- +-- | Insert something /before/ the given lines +insert :: Int -> [a] -> Change a +insert start = Change (Block start (start - 1)) . const diff --git a/lib/Language/Haskell/Stylish/Parse.hs b/lib/Language/Haskell/Stylish/Parse.hs new file mode 100644 --- /dev/null +++ b/lib/Language/Haskell/Stylish/Parse.hs @@ -0,0 +1,74 @@ +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish.Parse + ( parseModule + ) where + + +-------------------------------------------------------------------------------- +import Data.Maybe (fromMaybe, listToMaybe) +import qualified Language.Haskell.Exts.Annotated as H +import Data.List (isPrefixOf) + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Config +import Language.Haskell.Stylish.Step + + +-------------------------------------------------------------------------------- +-- | Filter out lines which use CPP macros +unCpp :: String -> String +unCpp = unlines . go False . lines + where + go _ [] = [] + go isMultiline (x : xs) = + let isCpp = isMultiline || listToMaybe x == Just '#' + nextMultiline = isCpp && not (null x) && last x == '\\' + in (if isCpp then "" else x) : go nextMultiline xs + + +-------------------------------------------------------------------------------- +-- | Remove shebang from the first line +unShebang :: String -> String +unShebang str + | "#!" `isPrefixOf` str = unlines $ ("" :) $ drop 1 $ lines str + | otherwise = str + + +-------------------------------------------------------------------------------- +-- | If the given string is prefixed with an UTF-8 Byte Order Mark, drop it +-- because haskell-src-exts can't handle it. +dropBom :: String -> String +dropBom ('\xfeff' : str) = str +dropBom str = str + + +-------------------------------------------------------------------------------- +-- | Abstraction over HSE's parsing +parseModule :: Extensions -> Maybe FilePath -> String -> Either String Module +parseModule extraExts mfp string = do + -- Determine the extensions: those specified in the file and the extra ones + let noBom = dropBom string + extraExts' = map H.classifyExtension extraExts + (lang, fileExts) = fromMaybe (Nothing, []) $ H.readExtensions noBom + exts = fileExts ++ extraExts' + + -- Parsing options... + fp = fromMaybe "" mfp + mode = H.defaultParseMode + { H.extensions = exts + , H.fixities = Nothing + , H.baseLanguage = case lang of + Nothing -> H.baseLanguage H.defaultParseMode + Just l -> l + } + + -- Preprocessing + processed = unShebang $ + if H.EnableExtension H.CPP `elem` exts then unCpp noBom else noBom + + case H.parseModuleWithComments mode processed of + H.ParseOk md -> return md + err -> Left $ + "Language.Haskell.Stylish.Parse.parseModule: could not parse " ++ + fp ++ ": " ++ show err diff --git a/lib/Language/Haskell/Stylish/Step.hs b/lib/Language/Haskell/Stylish/Step.hs new file mode 100644 --- /dev/null +++ b/lib/Language/Haskell/Stylish/Step.hs @@ -0,0 +1,32 @@ +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish.Step + ( Lines + , Module + , Step (..) + , makeStep + ) where + + +-------------------------------------------------------------------------------- +import qualified Language.Haskell.Exts.Annotated as H + + +-------------------------------------------------------------------------------- +type Lines = [String] + + +-------------------------------------------------------------------------------- +-- | Concrete module type +type Module = (H.Module H.SrcSpanInfo, [H.Comment]) + + +-------------------------------------------------------------------------------- +data Step = Step + { stepName :: String + , stepFilter :: Lines -> Module -> Lines + } + + +-------------------------------------------------------------------------------- +makeStep :: String -> (Lines -> Module -> Lines) -> Step +makeStep = Step diff --git a/lib/Language/Haskell/Stylish/Step/Imports.hs b/lib/Language/Haskell/Stylish/Step/Imports.hs new file mode 100644 --- /dev/null +++ b/lib/Language/Haskell/Stylish/Step/Imports.hs @@ -0,0 +1,275 @@ +{-# LANGUAGE RecordWildCards #-} +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish.Step.Imports + ( Align (..) + , ImportAlign (..) + , ListAlign (..) + , LongListAlign (..) + , step + ) where + + +-------------------------------------------------------------------------------- +import Control.Arrow ((&&&)) +import Data.Char (toLower) +import Data.List (intercalate, sortBy) +import Data.Maybe (isJust, maybeToList) +import Data.Ord (comparing) +import qualified Language.Haskell.Exts.Annotated as H + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Block +import Language.Haskell.Stylish.Editor +import Language.Haskell.Stylish.Step +import Language.Haskell.Stylish.Util + +-------------------------------------------------------------------------------- +data Align = Align + { importAlign :: ImportAlign + , listAlign :: ListAlign + , longListAlign :: LongListAlign + , listPadding :: Int + , separateLists :: Bool + } + deriving (Eq, Show) + +data ImportAlign + = Global + | File + | Group + | None + deriving (Eq, Show) + +data ListAlign + = NewLine + | WithAlias + | AfterAlias + deriving (Eq, Show) + +data LongListAlign + = Inline + | InlineWithBreak + | InlineToMultiline + | Multiline + deriving (Eq, Show) + +-------------------------------------------------------------------------------- +imports :: H.Module l -> [H.ImportDecl l] +imports (H.Module _ _ _ is _) = is +imports _ = [] + + +-------------------------------------------------------------------------------- +importName :: H.ImportDecl l -> String +importName i = let (H.ModuleName _ n) = H.importModule i in n + + +-------------------------------------------------------------------------------- +longestImport :: [H.ImportDecl l] -> Int +longestImport = maximum . map (length . importName) + + +-------------------------------------------------------------------------------- +-- | Compare imports for ordering +compareImports :: H.ImportDecl l -> H.ImportDecl l -> Ordering +compareImports = comparing (map toLower . importName &&& H.importQualified) + + +-------------------------------------------------------------------------------- +-- | The implementation is a bit hacky to get proper sorting for input specs: +-- constructors first, followed by functions, and then operators. +compareImportSpecs :: H.ImportSpec l -> H.ImportSpec l -> Ordering +compareImportSpecs = comparing key + where + key :: H.ImportSpec l -> (Int, Bool, String) + key (H.IVar _ x) = (1, isOperator x, nameToString x) + key (H.IAbs _ _ x) = (0, False, nameToString x) + key (H.IThingAll _ x) = (0, False, nameToString x) + key (H.IThingWith _ x _) = (0, False, nameToString x) + + +-------------------------------------------------------------------------------- +-- | Sort the input spec list inside an 'H.ImportDecl' +sortImportSpecs :: H.ImportDecl l -> H.ImportDecl l +sortImportSpecs imp = imp {H.importSpecs = sort' <$> H.importSpecs imp} + where + sort' (H.ImportSpecList l h specs) = H.ImportSpecList l h $ + sortBy compareImportSpecs specs + + +-------------------------------------------------------------------------------- +-- | Order of imports in sublist is: +-- Constructors, accessors/methods, operators. +compareImportSubSpecs :: H.CName l -> H.CName l -> Ordering +compareImportSubSpecs = comparing key + where + key :: H.CName l -> (Int, Bool, String) + key (H.ConName _ x) = (0, False, nameToString x) + key (H.VarName _ x) = (1, isOperator x, nameToString x) + + +-------------------------------------------------------------------------------- +-- | By default, haskell-src-exts pretty-prints +-- +-- > import Foo (Bar(..)) +-- +-- but we want +-- +-- > import Foo (Bar (..)) +-- +-- instead. +prettyImportSpec :: (Ord l) => Bool -> H.ImportSpec l -> String +prettyImportSpec separate = prettyImportSpec' + where + prettyImportSpec' (H.IThingAll _ n) = H.prettyPrint n ++ sep "(..)" + prettyImportSpec' (H.IThingWith _ n cns) = H.prettyPrint n + ++ sep "(" + ++ intercalate ", " + (map H.prettyPrint $ sortBy compareImportSubSpecs cns) + ++ ")" + prettyImportSpec' x = H.prettyPrint x + + sep = if separate then (' ' :) else id + + +-------------------------------------------------------------------------------- +prettyImport :: (Ord l, Show l) => + Int -> Align -> Bool -> Bool -> Int -> H.ImportDecl l -> [String] +prettyImport columns Align{..} padQualified padName longest imp = + case longListAlign of + Inline -> inlineWrap + InlineWithBreak -> longListWrapper inlineWrap inlineWithBreakWrap + InlineToMultiline -> longListWrapper inlineWrap inlineToMultilineWrap + Multiline -> longListWrapper inlineWrap multilineWrap + where + longListWrapper shortWrap longWrap + | listAlign == NewLine + || length shortWrap > 1 + || length (head shortWrap) > columns + = longWrap + | otherwise = shortWrap + + inlineWrap = inlineWrapper + $ mapSpecs + $ withInit (++ ",") + . withHead ("(" ++) + . withLast (++ ")") + + inlineWrapper = case listAlign of + NewLine -> (paddedNoSpecBase :) . wrapRest columns listPadding + WithAlias -> wrap columns paddedBase (inlineBaseLength + 1) + -- Add 1 extra space to ensure same padding as in original code. + AfterAlias -> withTail (' ' :) + . wrap columns paddedBase (afterAliasBaseLength + 1) + + inlineWithBreakWrap = paddedNoSpecBase : wrapRest columns listPadding + ( mapSpecs + $ withInit (++ ",") + . withHead ("(" ++) + . withLast (++ ")")) + + inlineToMultilineWrap + | length inlineWithBreakWrap > 2 + || any ((> columns) . length) (tail inlineWithBreakWrap) + = multilineWrap + | otherwise = inlineWithBreakWrap + + -- 'wrapRest 0' ensures that every item of spec list is on new line. + multilineWrap = paddedNoSpecBase : wrapRest 0 listPadding + ( mapSpecs + ( withHead ("( " ++) + . withTail (", " ++)) + ++ [")"]) + + paddedBase = base $ padImport $ importName imp + + paddedNoSpecBase = base $ padImportNoSpec $ importName imp + + padImport = if hasExtras && padName + then padRight longest + else id + + padImportNoSpec = if (isJust (H.importAs imp) || hasHiding) && padName + then padRight longest + else id + + base' baseName importAs hasHiding' = unwords $ concat $ filter (not . null) + [ ["import"] + , qualified + , show <$> maybeToList (H.importPkg imp) + , [baseName] + , importAs + , hasHiding' + ] + + base baseName = base' baseName + ["as " ++ as | H.ModuleName _ as <- maybeToList $ H.importAs imp] + ["hiding" | hasHiding] + + inlineBaseLength = length $ base' (padImport $ importName imp) [] [] + + afterAliasBaseLength = length $ base' (padImport $ importName imp) + ["as " ++ as | H.ModuleName _ as <- maybeToList $ H.importAs imp] [] + + (hasHiding, importSpecs) = case H.importSpecs imp of + Just (H.ImportSpecList _ h l) -> (h, Just l) + _ -> (False, Nothing) + + hasExtras = isJust (H.importAs imp) || isJust (H.importSpecs imp) + + qualified + | H.importQualified imp = ["qualified"] + | padQualified = [" "] + | otherwise = [] + + mapSpecs f = case importSpecs of + Nothing -> [] -- Import everything + Just [] -> ["()"] -- Instance only imports + Just is -> f $ map (prettyImportSpec separateLists) is + + +-------------------------------------------------------------------------------- +prettyImportGroup :: Int -> Align -> Bool -> Int + -> [H.ImportDecl LineBlock] + -> Lines +prettyImportGroup columns align fileAlign longest imps = + concatMap (prettyImport columns align padQual padName longest') $ + sortBy compareImports imps + where + align' = importAlign align + + longest' = case align' of + Group -> longestImport imps + _ -> longest + + padName = align' /= None + + padQual = case align' of + Global -> True + File -> fileAlign + Group -> any H.importQualified imps + None -> False + + +-------------------------------------------------------------------------------- +step :: Int -> Align -> Step +step columns = makeStep "Imports" . step' columns + + +-------------------------------------------------------------------------------- +step' :: Int -> Align -> Lines -> Module -> Lines +step' columns align ls (module', _) = applyChanges + [ change block $ const $ + prettyImportGroup columns align fileAlign longest importGroup + | (block, importGroup) <- groups + ] + ls + where + imps = map sortImportSpecs $ imports $ fmap linesFromSrcSpan module' + longest = longestImport imps + groups = groupAdjacent [(H.ann i, i) | i <- imps] + + fileAlign = case importAlign align of + File -> any H.importQualified imps + _ -> False diff --git a/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs b/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs new file mode 100644 --- /dev/null +++ b/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs @@ -0,0 +1,168 @@ +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish.Step.LanguagePragmas + ( Style (..) + , step + + -- * Utilities + , addLanguagePragma + ) where + + +-------------------------------------------------------------------------------- +import qualified Data.Set as S +import qualified Language.Haskell.Exts.Annotated as H + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Block +import Language.Haskell.Stylish.Editor +import Language.Haskell.Stylish.Step +import Language.Haskell.Stylish.Util + + +-------------------------------------------------------------------------------- +data Style + = Vertical + | Compact + | CompactLine + deriving (Eq, Show) + + +-------------------------------------------------------------------------------- +pragmas :: H.Module l -> [(l, [String])] +pragmas (H.Module _ _ ps _ _) = + [(l, map nameToString names) | H.LanguagePragma l names <- ps] +pragmas _ = [] + + +-------------------------------------------------------------------------------- +-- | The start of the first block +firstLocation :: [(Block a, [String])] -> Int +firstLocation = minimum . map (blockStart . fst) + + +-------------------------------------------------------------------------------- +verticalPragmas :: Int -> Bool -> [String] -> Lines +verticalPragmas longest align pragmas' = + [ "{-# LANGUAGE " ++ pad pragma ++ " #-}" + | pragma <- pragmas' + ] + where + pad + | align = padRight longest + | otherwise = id + + +-------------------------------------------------------------------------------- +compactPragmas :: Int -> [String] -> Lines +compactPragmas columns pragmas' = wrap columns "{-# LANGUAGE" 13 $ + map (++ ",") (init pragmas') ++ [last pragmas', "#-}"] + + +-------------------------------------------------------------------------------- +compactLinePragmas :: Int -> Bool -> [String] -> Lines +compactLinePragmas _ _ [] = [] +compactLinePragmas columns align pragmas' = map (wrapLanguage . pad) prags + where + wrapLanguage ps = "{-# LANGUAGE" ++ ps ++ " #-}" + + maxWidth = columns - 16 + + longest = maximum $ map length prags + + pad + | align = padRight longest + | otherwise = id + + prags = map truncateComma $ wrap maxWidth "" 1 $ + map (++ ",") (init pragmas') ++ [last pragmas'] + + +-------------------------------------------------------------------------------- +truncateComma :: String -> String +truncateComma "" = "" +truncateComma xs + | last xs == ',' = init xs + | otherwise = xs + + +-------------------------------------------------------------------------------- +prettyPragmas :: Int -> Int -> Bool -> Style -> [String] -> Lines +prettyPragmas _ longest align Vertical = verticalPragmas longest align +prettyPragmas cols _ _ Compact = compactPragmas cols +prettyPragmas cols _ align CompactLine = compactLinePragmas cols align + + +-------------------------------------------------------------------------------- +-- | Filter redundant (and duplicate) pragmas out of the groups. As a side +-- effect, we also sort the pragmas in their group... +filterRedundant :: (String -> Bool) + -> [(l, [String])] + -> [(l, [String])] +filterRedundant isRedundant' = snd . foldr filterRedundant' (S.empty, []) + where + filterRedundant' (l, xs) (known, zs) + | S.null xs' = (known', zs) + | otherwise = (known', (l, S.toAscList xs') : zs) + where + fxs = filter (not . isRedundant') xs + xs' = S.fromList fxs `S.difference` known + known' = xs' `S.union` known + +-------------------------------------------------------------------------------- +step :: Int -> Style -> Bool -> Bool -> Step +step = (((makeStep "LanguagePragmas" .) .) .) . step' + + +-------------------------------------------------------------------------------- +step' :: Int -> Style -> Bool -> Bool -> Lines -> Module -> Lines +step' columns style align removeRedundant ls (module', _) + | null pragmas' = ls + | otherwise = applyChanges changes ls + where + isRedundant' + | removeRedundant = isRedundant module' + | otherwise = const False + + pragmas' = pragmas $ fmap linesFromSrcSpan module' + longest = maximum $ map length $ snd =<< pragmas' + groups = [(b, concat pgs) | (b, pgs) <- groupAdjacent pragmas'] + changes = + [ change b (const $ prettyPragmas columns longest align style pg) + | (b, pg) <- filterRedundant isRedundant' groups + ] + + +-------------------------------------------------------------------------------- +-- | Add a LANGUAGE pragma to a module if it is not present already. +addLanguagePragma :: String -> H.Module H.SrcSpanInfo -> [Change String] +addLanguagePragma prag modu + | prag `elem` present = [] + | otherwise = [insert line ["{-# LANGUAGE " ++ prag ++ " #-}"]] + where + pragmas' = pragmas (fmap linesFromSrcSpan modu) + present = concatMap snd pragmas' + line = if null pragmas' then 1 else firstLocation pragmas' + + +-------------------------------------------------------------------------------- +-- | Check if a language pragma is redundant. We can't do this for all pragmas, +-- but we do a best effort. +isRedundant :: H.Module H.SrcSpanInfo -> String -> Bool +isRedundant m "ViewPatterns" = isRedundantViewPatterns m +isRedundant m "BangPatterns" = isRedundantBangPatterns m +isRedundant _ _ = False + + +-------------------------------------------------------------------------------- +-- | Check if the ViewPatterns language pragma is redundant. +isRedundantViewPatterns :: H.Module H.SrcSpanInfo -> Bool +isRedundantViewPatterns m = null + [() | H.PViewPat _ _ _ <- everything m :: [H.Pat H.SrcSpanInfo]] + + +-------------------------------------------------------------------------------- +-- | Check if the BangPatterns language pragma is redundant. +isRedundantBangPatterns :: H.Module H.SrcSpanInfo -> Bool +isRedundantBangPatterns m = null + [() | H.PBangPat _ _ <- everything m :: [H.Pat H.SrcSpanInfo]] diff --git a/lib/Language/Haskell/Stylish/Step/Records.hs b/lib/Language/Haskell/Stylish/Step/Records.hs new file mode 100644 --- /dev/null +++ b/lib/Language/Haskell/Stylish/Step/Records.hs @@ -0,0 +1,79 @@ +-------------------------------------------------------------------------------- +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/Tabs.hs b/lib/Language/Haskell/Stylish/Step/Tabs.hs new file mode 100644 --- /dev/null +++ b/lib/Language/Haskell/Stylish/Step/Tabs.hs @@ -0,0 +1,21 @@ +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish.Step.Tabs + ( step + ) where + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Step + + +-------------------------------------------------------------------------------- +removeTabs :: Int -> String -> String +removeTabs spaces = concatMap removeTabs' + where + removeTabs' '\t' = replicate spaces ' ' + removeTabs' x = [x] + + +-------------------------------------------------------------------------------- +step :: Int -> Step +step spaces = makeStep "Tabs" $ \ls _ -> map (removeTabs spaces) ls diff --git a/lib/Language/Haskell/Stylish/Step/TrailingWhitespace.hs b/lib/Language/Haskell/Stylish/Step/TrailingWhitespace.hs new file mode 100644 --- /dev/null +++ b/lib/Language/Haskell/Stylish/Step/TrailingWhitespace.hs @@ -0,0 +1,22 @@ +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish.Step.TrailingWhitespace + ( step + ) where + + +-------------------------------------------------------------------------------- +import Data.Char (isSpace) + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Step + + +-------------------------------------------------------------------------------- +dropTrailingWhitespace :: String -> String +dropTrailingWhitespace = reverse . dropWhile isSpace . reverse + + +-------------------------------------------------------------------------------- +step :: Step +step = makeStep "TrailingWhitespace" $ \ls _ -> map dropTrailingWhitespace ls diff --git a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs new file mode 100644 --- /dev/null +++ b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs @@ -0,0 +1,115 @@ +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish.Step.UnicodeSyntax + ( step + ) where + + +-------------------------------------------------------------------------------- +import Data.List (isPrefixOf, sort) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (maybeToList) +import qualified Language.Haskell.Exts.Annotated as H + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Block +import Language.Haskell.Stylish.Editor +import Language.Haskell.Stylish.Step +import Language.Haskell.Stylish.Step.LanguagePragmas (addLanguagePragma) +import Language.Haskell.Stylish.Util + + +-------------------------------------------------------------------------------- +unicodeReplacements :: Map String String +unicodeReplacements = M.fromList + [ ("::", "∷") + , ("=>", "⇒") + , ("->", "→") + ] + + +-------------------------------------------------------------------------------- +replaceAll :: [(Int, [(Int, String)])] -> [Change String] +replaceAll = map changeLine' + where + changeLine' (r, ns) = changeLine r $ \str -> return $ + flip applyChanges str + [ change (Block c ec) (const repl) + | (c, needle) <- sort ns + , let ec = c + length needle - 1 + , repl <- maybeToList $ M.lookup needle unicodeReplacements + ] + + +-------------------------------------------------------------------------------- +groupPerLine :: [((Int, Int), a)] -> [(Int, [(Int, a)])] +groupPerLine = M.toList . M.fromListWith (++) . + map (\((r, c), x) -> (r, [(c, x)])) + + +-------------------------------------------------------------------------------- +typeSigs :: H.Module H.SrcSpanInfo -> Lines -> [((Int, Int), String)] +typeSigs module' ls = + [ (pos, "::") + | H.TypeSig loc _ _ <- everything module' :: [H.Decl H.SrcSpanInfo] + , (start, end) <- infoPoints loc + , pos <- maybeToList $ between start end "::" ls + ] + + +-------------------------------------------------------------------------------- +contexts :: H.Module H.SrcSpanInfo -> Lines -> [((Int, Int), String)] +contexts module' ls = + [ (pos, "=>") + | context <- everything module' :: [H.Context H.SrcSpanInfo] + , (start, end) <- infoPoints $ H.ann context + , pos <- maybeToList $ between start end "=>" ls + ] + + +-------------------------------------------------------------------------------- +typeFuns :: H.Module H.SrcSpanInfo -> Lines -> [((Int, Int), String)] +typeFuns module' ls = + [ (pos, "->") + | H.TyFun _ t1 t2 <- everything module' + , let start = H.srcSpanEnd $ H.srcInfoSpan $ H.ann t1 + , let end = H.srcSpanStart $ H.srcInfoSpan $ H.ann t2 + , 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. +between :: (Int, Int) -> (Int, Int) -> String -> Lines -> Maybe (Int, Int) +between (startRow, startCol) (endRow, endCol) needle = + search (startRow, startCol) . + withLast (take endCol) . + withHead (drop $ startCol - 1) . + take (endRow - startRow + 1) . + drop (startRow - 1) + where + search _ [] = Nothing + search (r, _) ([] : xs) = search (r + 1, 1) xs + search (r, c) (x : xs) + | needle `isPrefixOf` x = Just (r, c) + | otherwise = search (r, c + 1) (tail x : xs) + + +-------------------------------------------------------------------------------- +step :: Bool -> Step +step = makeStep "UnicodeSyntax" . step' + + +-------------------------------------------------------------------------------- +step' :: Bool -> Lines -> Module -> Lines +step' alp ls (module', _) = applyChanges changes ls + where + changes = (if alp then addLanguagePragma "UnicodeSyntax" module' else []) ++ + replaceAll perLine + perLine = sort $ groupPerLine $ + typeSigs module' ls ++ + contexts module' ls ++ + typeFuns module' ls diff --git a/lib/Language/Haskell/Stylish/Util.hs b/lib/Language/Haskell/Stylish/Util.hs new file mode 100644 --- /dev/null +++ b/lib/Language/Haskell/Stylish/Util.hs @@ -0,0 +1,128 @@ +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish.Util + ( nameToString + , isOperator + , indent + , padRight + , everything + , infoPoints + , wrap + , wrapRest + + , withHead + , withInit + , withTail + , withLast + ) where + + +-------------------------------------------------------------------------------- +import Control.Arrow ((&&&), (>>>)) +import Data.Char (isAlpha) +import Data.Data (Data) +import qualified Data.Generics as G +import Data.Maybe (fromMaybe, listToMaybe, maybeToList) +import Data.Typeable (cast) +import qualified Language.Haskell.Exts.Annotated as H + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Step + + +-------------------------------------------------------------------------------- +nameToString :: H.Name l -> String +nameToString (H.Ident _ str) = str +nameToString (H.Symbol _ str) = str + + +-------------------------------------------------------------------------------- +isOperator :: H.Name l -> Bool +isOperator = fromMaybe False + . (fmap (not . isAlpha) . listToMaybe) + . nameToString + +-------------------------------------------------------------------------------- +indent :: Int -> String -> String +indent len = (indentPrefix len ++) + + +-------------------------------------------------------------------------------- +indentPrefix :: Int -> String +indentPrefix = (`replicate` ' ') + + +-------------------------------------------------------------------------------- +padRight :: Int -> String -> String +padRight len str = str ++ replicate (len - length str) ' ' + + +-------------------------------------------------------------------------------- +everything :: (Data a, Data b) => a -> [b] +everything = G.everything (++) (maybeToList . cast) + + +-------------------------------------------------------------------------------- +infoPoints :: H.SrcSpanInfo -> [((Int, Int), (Int, Int))] +infoPoints = H.srcInfoPoints >>> map (H.srcSpanStart &&& H.srcSpanEnd) + + +-------------------------------------------------------------------------------- +wrap :: Int -- ^ Maximum line width + -> String -- ^ Leading string + -> Int -- ^ Indentation + -> [String] -- ^ Strings to add/wrap + -> Lines -- ^ Resulting lines +wrap maxWidth leading ind = wrap' leading + where + wrap' ss [] = [ss] + wrap' ss (str:strs) + | overflows ss str = + ss : wrapRest maxWidth ind (str:strs) + | otherwise = wrap' (ss ++ " " ++ str) strs + + overflows ss str = length ss > maxWidth || + ((length ss + length str) >= maxWidth && ind + length str <= maxWidth) + + +-------------------------------------------------------------------------------- +wrapRest :: Int + -> Int + -> [String] + -> Lines +wrapRest maxWidth ind = reverse . wrapRest' [] "" + where + wrapRest' ls ss [] + | null ss = ls + | otherwise = ss:ls + wrapRest' ls ss (str:strs) + | null ss = wrapRest' ls (indent ind str) strs + | overflows ss str = wrapRest' (ss:ls) "" (str:strs) + | otherwise = wrapRest' ls (ss ++ " " ++ str) strs + + overflows ss str = (length ss + length str + 1) >= maxWidth + + +-------------------------------------------------------------------------------- +withHead :: (a -> a) -> [a] -> [a] +withHead _ [] = [] +withHead f (x : xs) = f x : xs + + +-------------------------------------------------------------------------------- +withLast :: (a -> a) -> [a] -> [a] +withLast _ [] = [] +withLast f [x] = [f x] +withLast f (x : xs) = x : withLast f xs + + +-------------------------------------------------------------------------------- +withInit :: (a -> a) -> [a] -> [a] +withInit _ [] = [] +withInit _ [x] = [x] +withInit f (x : xs) = f x : withInit f xs + +-------------------------------------------------------------------------------- +withTail :: (a -> a) -> [a] -> [a] +withTail _ [] = [] +withTail f (x : xs) = x : map f xs diff --git a/lib/Language/Haskell/Stylish/Verbose.hs b/lib/Language/Haskell/Stylish/Verbose.hs new file mode 100644 --- /dev/null +++ b/lib/Language/Haskell/Stylish/Verbose.hs @@ -0,0 +1,20 @@ +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish.Verbose + ( Verbose + , makeVerbose + ) where + + +-------------------------------------------------------------------------------- +import System.IO (hPutStrLn, stderr) + + +-------------------------------------------------------------------------------- +type Verbose = String -> IO () + + +-------------------------------------------------------------------------------- +makeVerbose :: Bool -> Verbose +makeVerbose verbose + | verbose = hPutStrLn stderr + | otherwise = const $ return () diff --git a/src/Language/Haskell/Stylish.hs b/src/Language/Haskell/Stylish.hs deleted file mode 100644 --- a/src/Language/Haskell/Stylish.hs +++ /dev/null @@ -1,92 +0,0 @@ --------------------------------------------------------------------------------- -module Language.Haskell.Stylish - ( -- * Run - runSteps - -- * Steps - , imports - , languagePragmas - , records - , tabs - , trailingWhitespace - , unicodeSyntax - -- ** Data types - , Imports.Align (..) - , LanguagePragmas.Style (..) - -- ** Helpers - , stepName - -- * Config - , module Language.Haskell.Stylish.Config - -- * Misc - , module Language.Haskell.Stylish.Verbose - , version - , Lines - , Step - ) where - - --------------------------------------------------------------------------------- -import Control.Applicative ((<$>)) -import Control.Monad (foldM) - - --------------------------------------------------------------------------------- -import Language.Haskell.Stylish.Config -import Language.Haskell.Stylish.Step -import Language.Haskell.Stylish.Verbose -import Language.Haskell.Stylish.Parse -import Paths_stylish_haskell (version) -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.Tabs as Tabs -import qualified Language.Haskell.Stylish.Step.TrailingWhitespace as TrailingWhitespace -import qualified Language.Haskell.Stylish.Step.UnicodeSyntax as UnicodeSyntax - - --------------------------------------------------------------------------------- -imports :: Int -- ^ columns - -> Imports.Align - -> Step -imports = Imports.step - - --------------------------------------------------------------------------------- -languagePragmas :: Int -- ^ columns - -> LanguagePragmas.Style - -> Bool -- ^ remove redundant? - -> Step -languagePragmas = LanguagePragmas.step - - --------------------------------------------------------------------------------- -records :: Step -records = Records.step - - --------------------------------------------------------------------------------- -tabs :: Int -- ^ number of spaces - -> Step -tabs = Tabs.step - - --------------------------------------------------------------------------------- -trailingWhitespace :: Step -trailingWhitespace = TrailingWhitespace.step - - --------------------------------------------------------------------------------- -unicodeSyntax :: Bool -- ^ add language pragma? - -> Step -unicodeSyntax = UnicodeSyntax.step - - --------------------------------------------------------------------------------- -runStep :: Extensions -> Maybe FilePath -> Lines -> Step -> Either String Lines -runStep exts mfp ls step = - stepFilter step ls <$> parseModule exts mfp (unlines ls) - - --------------------------------------------------------------------------------- -runSteps :: Extensions -> Maybe FilePath -> [Step] -> Lines - -> Either String Lines -runSteps exts mfp steps ls = foldM (runStep exts mfp) ls steps diff --git a/src/Language/Haskell/Stylish/Block.hs b/src/Language/Haskell/Stylish/Block.hs deleted file mode 100644 --- a/src/Language/Haskell/Stylish/Block.hs +++ /dev/null @@ -1,91 +0,0 @@ --------------------------------------------------------------------------------- -module Language.Haskell.Stylish.Block - ( Block (..) - , LineBlock - , SpanBlock - , blockLength - , linesFromSrcSpan - , spanFromSrcSpan - , moveBlock - , adjacent - , merge - , overlapping - , groupAdjacent - ) where - - --------------------------------------------------------------------------------- -import Control.Arrow (arr, (&&&), (>>>)) -import qualified Language.Haskell.Exts.Annotated as H - - --------------------------------------------------------------------------------- --- | Indicates a line span -data Block a = Block - { blockStart :: Int - , blockEnd :: Int - } deriving (Eq, Ord, Show) - - --------------------------------------------------------------------------------- -type LineBlock = Block String - - --------------------------------------------------------------------------------- -type SpanBlock = Block Char - - --------------------------------------------------------------------------------- -blockLength :: Block a -> Int -blockLength (Block start end) = end - start + 1 - - --------------------------------------------------------------------------------- -linesFromSrcSpan :: H.SrcSpanInfo -> LineBlock -linesFromSrcSpan = H.srcInfoSpan >>> - H.srcSpanStartLine &&& H.srcSpanEndLine >>> - arr (uncurry Block) - - --------------------------------------------------------------------------------- -spanFromSrcSpan :: H.SrcSpanInfo -> SpanBlock -spanFromSrcSpan = H.srcInfoSpan >>> - H.srcSpanStartColumn &&& H.srcSpanEndColumn >>> - arr (uncurry Block) - - --------------------------------------------------------------------------------- -moveBlock :: Int -> Block a -> Block a -moveBlock offset (Block start end) = Block (start + offset) (end + offset) - - --------------------------------------------------------------------------------- -adjacent :: Block a -> Block a -> Bool -adjacent b1 b2 = follows b1 b2 || follows b2 b1 - where - follows (Block _ e1) (Block s2 _) = e1 + 1 == s2 - - --------------------------------------------------------------------------------- -merge :: Block a -> Block a -> Block a -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) - where - overlapping' (Block _ e1) (Block s2 _) = e1 >= s2 - - --------------------------------------------------------------------------------- --- | Groups adjacent blocks into larger blocks -groupAdjacent :: [(Block a, b)] - -> [(Block a, [b])] -groupAdjacent = foldr go [] - where - -- This code is ugly and not optimal, and no fucks were given. - go (b1, x) gs = case break (adjacent b1 . fst) gs of - (_, []) -> (b1, [x]) : gs - (ys, ((b2, xs) : zs)) -> (merge b1 b2, x : xs) : (ys ++ zs) diff --git a/src/Language/Haskell/Stylish/Config.hs b/src/Language/Haskell/Stylish/Config.hs deleted file mode 100644 --- a/src/Language/Haskell/Stylish/Config.hs +++ /dev/null @@ -1,206 +0,0 @@ --------------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings #-} -module Language.Haskell.Stylish.Config - ( Extensions - , Config (..) - , defaultConfigFilePath - , configFilePath - , loadConfig - ) where - - --------------------------------------------------------------------------------- -import Control.Applicative (pure, (<$>), (<*>)) -import Control.Monad (forM, mzero) -import Data.Aeson (FromJSON (..)) -import qualified Data.Aeson as A -import qualified Data.Aeson.Types as A -import qualified Data.ByteString as B -import Data.List (inits, intercalate) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Yaml (decodeEither) -import System.Directory -import System.FilePath (joinPath, splitPath, - ()) - - --------------------------------------------------------------------------------- -import Paths_stylish_haskell (getDataFileName) -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.Tabs as Tabs -import qualified Language.Haskell.Stylish.Step.TrailingWhitespace as TrailingWhitespace -import qualified Language.Haskell.Stylish.Step.UnicodeSyntax as UnicodeSyntax -import Language.Haskell.Stylish.Verbose - - --------------------------------------------------------------------------------- -type Extensions = [String] - - --------------------------------------------------------------------------------- -data Config = Config - { configSteps :: [Step] - , configColumns :: Int - , configLanguageExtensions :: [String] - } - - --------------------------------------------------------------------------------- -instance FromJSON Config where - parseJSON = parseConfig - - --------------------------------------------------------------------------------- -emptyConfig :: Config -emptyConfig = Config [] 80 [] - - --------------------------------------------------------------------------------- -configFileName :: String -configFileName = ".stylish-haskell.yaml" - - --------------------------------------------------------------------------------- -defaultConfigFilePath :: IO FilePath -defaultConfigFilePath = getDataFileName "data/stylish-haskell.yaml" - - --------------------------------------------------------------------------------- -configFilePath :: Verbose -> Maybe FilePath -> IO (Maybe FilePath) -configFilePath _ (Just userSpecified) = return $ Just userSpecified -configFilePath verbose Nothing = do - current <- getCurrentDirectory - home <- getHomeDirectory - def <- defaultConfigFilePath - search $ - [d configFileName | d <- ancestors current] ++ - [home configFileName, def] - where - -- All ancestors of a dir (including that dir) - ancestors :: FilePath -> [FilePath] - ancestors = init . map joinPath . reverse . inits . splitPath - - search :: [FilePath] -> IO (Maybe FilePath) - search [] = return Nothing - search (f : fs) = do - -- TODO Maybe catch an error here, dir might be unreadable - exists <- doesFileExist f - verbose $ f ++ if exists then " exists" else " does not exist" - if exists then return (Just f) else search fs - - --------------------------------------------------------------------------------- -loadConfig :: Verbose -> Maybe FilePath -> IO Config -loadConfig verbose mfp = do - mfp' <- configFilePath verbose mfp - case mfp' of - Nothing -> do - verbose $ "Using empty configuration" - return emptyConfig - Just fp -> do - verbose $ "Loading configuration at " ++ fp - bs <- B.readFile fp - case decodeEither bs of - Left err -> error $ - "Language.Haskell.Stylish.Config.loadConfig: " ++ err - Right config -> return config - - --------------------------------------------------------------------------------- -parseConfig :: A.Value -> A.Parser Config -parseConfig (A.Object o) = do - -- First load the config without the actual steps - config <- Config - <$> pure [] - <*> (o A..:? "columns" A..!= 80) - <*> (o A..:? "language_extensions" A..!= []) - - -- 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} -parseConfig _ = mzero - - --------------------------------------------------------------------------------- -catalog :: Map String (Config -> A.Object -> A.Parser Step) -catalog = M.fromList - [ ("imports", parseImports) - , ("language_pragmas", parseLanguagePragmas) - , ("records", parseRecords) - , ("tabs", parseTabs) - , ("trailing_whitespace", parseTrailingWhitespace) - , ("unicode_syntax", parseUnicodeSyntax) - ] - - --------------------------------------------------------------------------------- -parseSteps :: Config -> A.Value -> A.Parser [Step] -parseSteps config val = do - map' <- parseJSON val :: A.Parser (Map String A.Value) - forM (M.toList map') $ \(k, v) -> case (M.lookup k catalog, v) of - (Just parser, A.Object o) -> parser config o - _ -> fail $ "Invalid declaration for " ++ k - - --------------------------------------------------------------------------------- --- | Utility for enum-like options -parseEnum :: [(String, a)] -> a -> Maybe String -> A.Parser a -parseEnum _ def Nothing = return def -parseEnum strs _ (Just k) = case lookup k strs of - Just v -> return v - Nothing -> fail $ "Unknown option: " ++ k ++ ", should be one of: " ++ - intercalate ", " (map fst strs) - - --------------------------------------------------------------------------------- -parseImports :: Config -> A.Object -> A.Parser Step -parseImports config o = Imports.step - <$> pure (configColumns config) - <*> (o A..:? "align" >>= parseEnum aligns Imports.Global) - where - aligns = - [ ("global", Imports.Global) - , ("file", Imports.File) - , ("group", Imports.Group) - , ("none", Imports.None) - ] - - --------------------------------------------------------------------------------- -parseLanguagePragmas :: Config -> A.Object -> A.Parser Step -parseLanguagePragmas config o = LanguagePragmas.step - <$> pure (configColumns config) - <*> (o A..:? "style" >>= parseEnum styles LanguagePragmas.Vertical) - <*> o A..:? "remove_redundant" A..!= True - where - styles = - [ ("vertical", LanguagePragmas.Vertical) - , ("compact", LanguagePragmas.Compact) - , ("compact_line", LanguagePragmas.CompactLine)] - - --------------------------------------------------------------------------------- -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 - - --------------------------------------------------------------------------------- -parseTrailingWhitespace :: Config -> A.Object -> A.Parser Step -parseTrailingWhitespace _ _ = return TrailingWhitespace.step - - --------------------------------------------------------------------------------- -parseUnicodeSyntax :: Config -> A.Object -> A.Parser Step -parseUnicodeSyntax _ o = UnicodeSyntax.step - <$> o A..:? "add_language_pragma" A..!= True diff --git a/src/Language/Haskell/Stylish/Editor.hs b/src/Language/Haskell/Stylish/Editor.hs deleted file mode 100644 --- a/src/Language/Haskell/Stylish/Editor.hs +++ /dev/null @@ -1,101 +0,0 @@ --------------------------------------------------------------------------------- --- | This module provides you with a line-based editor. It's main feature is --- that you can specify multiple changes at the same time, e.g.: --- --- > [deleteLine 3, changeLine 4 ["Foo"]] --- --- when this is evaluated, we take into account that 4th line will become the --- 3rd line before it needs changing. -module Language.Haskell.Stylish.Editor - ( Change - , applyChanges - - , change - , changeLine - , delete - , deleteLine - , insert - ) where - - --------------------------------------------------------------------------------- -import Language.Haskell.Stylish.Block - - --------------------------------------------------------------------------------- --- | Changes the lines indicated by the 'Block' into the given 'Lines' -data Change a = Change - { changeBlock :: Block a - , changeLines :: ([a] -> [a]) - } - - --------------------------------------------------------------------------------- -moveChange :: Int -> Change a -> Change a -moveChange offset (Change block ls) = Change (moveBlock offset block) ls - - --------------------------------------------------------------------------------- -applyChanges :: [Change a] -> [a] -> [a] -applyChanges changes - | overlapping blocks = error $ - "Language.Haskell.Stylish.Editor.applyChanges: " ++ - "refusing to make overlapping changes" - | otherwise = go 1 changes - where - blocks = map changeBlock changes - - go _ [] ls = ls - go n (ch : chs) ls = - -- Divide the remaining lines into: - -- - -- > pre - -- > old (lines that are affected by the change) - -- > post - -- - -- And generate: - -- - -- > pre - -- > new - -- > (recurse) - -- - let block = changeBlock ch - (pre, ls') = splitAt (blockStart block - n) ls - (old, post) = splitAt (blockLength block) ls' - new = changeLines ch old - extraLines = length new - blockLength block - chs' = map (moveChange extraLines) chs - n' = blockStart block + blockLength block + extraLines - in pre ++ new ++ go n' chs' post - - --------------------------------------------------------------------------------- --- | Change a block of lines for some other lines -change :: Block a -> ([a] -> [a]) -> Change a -change = Change - - --------------------------------------------------------------------------------- --- | Change a single line for some other lines -changeLine :: Int -> (a -> [a]) -> Change a -changeLine start f = change (Block start start) $ \xs -> case xs of - [] -> [] - (x : _) -> f x - - --------------------------------------------------------------------------------- --- | Delete a block of lines -delete :: Block a -> Change a -delete block = Change block $ const [] - - --------------------------------------------------------------------------------- --- | Delete a single line -deleteLine :: Int -> Change a -deleteLine start = delete (Block start start) - - --------------------------------------------------------------------------------- --- | Insert something /before/ the given lines -insert :: Int -> [a] -> Change a -insert start = Change (Block start (start - 1)) . const diff --git a/src/Language/Haskell/Stylish/Parse.hs b/src/Language/Haskell/Stylish/Parse.hs deleted file mode 100644 --- a/src/Language/Haskell/Stylish/Parse.hs +++ /dev/null @@ -1,74 +0,0 @@ --------------------------------------------------------------------------------- -module Language.Haskell.Stylish.Parse - ( parseModule - ) where - - --------------------------------------------------------------------------------- -import Data.Maybe (fromMaybe, listToMaybe) -import qualified Language.Haskell.Exts.Annotated as H -import Data.List (isPrefixOf) - - --------------------------------------------------------------------------------- -import Language.Haskell.Stylish.Config -import Language.Haskell.Stylish.Step - - --------------------------------------------------------------------------------- --- | Filter out lines which use CPP macros -unCpp :: String -> String -unCpp = unlines . go False . lines - where - go _ [] = [] - go isMultiline (x : xs) = - let isCpp = isMultiline || listToMaybe x == Just '#' - nextMultiline = isCpp && not (null x) && last x == '\\' - in (if isCpp then "" else x) : go nextMultiline xs - - --------------------------------------------------------------------------------- --- | Remove shebang from the first line -unShebang :: String -> String -unShebang str - | "#!" `isPrefixOf` str = unlines $ ("" :) $ drop 1 $ lines str - | otherwise = str - - --------------------------------------------------------------------------------- --- | If the given string is prefixed with an UTF-8 Byte Order Mark, drop it --- because haskell-src-exts can't handle it. -dropBom :: String -> String -dropBom ('\xfeff' : str) = str -dropBom str = str - - --------------------------------------------------------------------------------- --- | Abstraction over HSE's parsing -parseModule :: Extensions -> Maybe FilePath -> String -> Either String Module -parseModule extraExts mfp string = do - -- Determine the extensions: those specified in the file and the extra ones - let noBom = dropBom string - extraExts' = map H.classifyExtension extraExts - (lang, fileExts) = fromMaybe (Nothing, []) $ H.readExtensions noBom - exts = fileExts ++ extraExts' - - -- Parsing options... - fp = fromMaybe "" mfp - mode = H.defaultParseMode - { H.extensions = exts - , H.fixities = Nothing - , H.baseLanguage = case lang of - Nothing -> H.baseLanguage H.defaultParseMode - Just l -> l - } - - -- Preprocessing - processed = unShebang $ - if H.EnableExtension H.CPP `elem` exts then unCpp noBom else noBom - - case H.parseModuleWithComments mode processed of - H.ParseOk md -> return md - err -> Left $ - "Language.Haskell.Stylish.Parse.parseModule: could not parse " ++ - fp ++ ": " ++ show err diff --git a/src/Language/Haskell/Stylish/Step.hs b/src/Language/Haskell/Stylish/Step.hs deleted file mode 100644 --- a/src/Language/Haskell/Stylish/Step.hs +++ /dev/null @@ -1,32 +0,0 @@ --------------------------------------------------------------------------------- -module Language.Haskell.Stylish.Step - ( Lines - , Module - , Step (..) - , makeStep - ) where - - --------------------------------------------------------------------------------- -import qualified Language.Haskell.Exts.Annotated as H - - --------------------------------------------------------------------------------- -type Lines = [String] - - --------------------------------------------------------------------------------- --- | Concrete module type -type Module = (H.Module H.SrcSpanInfo, [H.Comment]) - - --------------------------------------------------------------------------------- -data Step = Step - { stepName :: String - , stepFilter :: Lines -> Module -> Lines - } - - --------------------------------------------------------------------------------- -makeStep :: String -> (Lines -> Module -> Lines) -> Step -makeStep = Step diff --git a/src/Language/Haskell/Stylish/Step/Imports.hs b/src/Language/Haskell/Stylish/Step/Imports.hs deleted file mode 100644 --- a/src/Language/Haskell/Stylish/Step/Imports.hs +++ /dev/null @@ -1,172 +0,0 @@ --------------------------------------------------------------------------------- -module Language.Haskell.Stylish.Step.Imports - ( Align (..) - , step - ) where - - --------------------------------------------------------------------------------- -import Control.Arrow ((&&&)) -import Data.Char (isAlpha, toLower) -import Data.List (intercalate, sortBy) -import Data.Maybe (isJust, maybeToList) -import Data.Ord (comparing) -import qualified Language.Haskell.Exts.Annotated as H - - --------------------------------------------------------------------------------- -import Language.Haskell.Stylish.Block -import Language.Haskell.Stylish.Editor -import Language.Haskell.Stylish.Step -import Language.Haskell.Stylish.Util - - --------------------------------------------------------------------------------- -data Align - = Global - | File - | Group - | None - deriving (Eq, Show) - - --------------------------------------------------------------------------------- -imports :: H.Module l -> [H.ImportDecl l] -imports (H.Module _ _ _ is _) = is -imports _ = [] - - --------------------------------------------------------------------------------- -importName :: H.ImportDecl l -> String -importName i = let (H.ModuleName _ n) = H.importModule i in n - - --------------------------------------------------------------------------------- -longestImport :: [H.ImportDecl l] -> Int -longestImport = maximum . map (length . importName) - - --------------------------------------------------------------------------------- --- | Compare imports for ordering -compareImports :: H.ImportDecl l -> H.ImportDecl l -> Ordering -compareImports = comparing (map toLower . importName &&& H.importQualified) - - --------------------------------------------------------------------------------- --- | The implementation is a bit hacky to get proper sorting for input specs: --- constructors first, followed by functions, and then operators. -compareImportSpecs :: H.ImportSpec l -> H.ImportSpec l -> Ordering -compareImportSpecs = comparing key - where - key :: H.ImportSpec l -> (Int, Int, String) - key (H.IVar _ x) = let n = nameToString x in (1, operator n, n) - key (H.IAbs _ _ x) = (0, 0, nameToString x) - key (H.IThingAll _ x) = (0, 0, nameToString x) - key (H.IThingWith _ x _) = (0, 0, nameToString x) - - operator [] = 0 -- But this should not happen - operator (x : _) = if isAlpha x then 0 else 1 - - --------------------------------------------------------------------------------- --- | Sort the input spec list inside an 'H.ImportDecl' -sortImportSpecs :: H.ImportDecl l -> H.ImportDecl l -sortImportSpecs imp = imp {H.importSpecs = fmap sort $ H.importSpecs imp} - where - sort (H.ImportSpecList l h specs) = H.ImportSpecList l h $ - sortBy compareImportSpecs specs - - --------------------------------------------------------------------------------- --- | By default, haskell-src-exts pretty-prints --- --- > import Foo (Bar(..)) --- --- but we want --- --- > import Foo (Bar (..)) --- --- instead. -prettyImportSpec :: H.ImportSpec l -> String -prettyImportSpec (H.IThingAll _ n) = H.prettyPrint n ++ " (..)" -prettyImportSpec (H.IThingWith _ n cns) = H.prettyPrint n ++ " (" ++ - intercalate ", " (map H.prettyPrint cns) ++ ")" -prettyImportSpec x = H.prettyPrint x - - --------------------------------------------------------------------------------- -prettyImport :: Int -> Bool -> Bool -> Int -> H.ImportDecl l -> [String] -prettyImport columns padQualified padName longest imp = - wrap columns base (length base + 2) $ - (if hiding then ("hiding" :) else id) $ - case importSpecs of - Nothing -> [] -- Import everything - Just [] -> ["()"] -- Instance only imports - Just is -> - withInit (++ ",") $ - withHead ("(" ++) $ - withLast (++ ")") $ - map prettyImportSpec $ - is - where - base = unwords $ concat - [ ["import"] - , qualified - , (fmap show $ maybeToList $ H.importPkg imp) - , [(if hasExtras && padName then padRight longest else id) - (importName imp)] - , ["as " ++ as | H.ModuleName _ as <- maybeToList $ H.importAs imp] - ] - - (hiding, importSpecs) = case H.importSpecs imp of - Just (H.ImportSpecList _ h l) -> (h, Just l) - _ -> (False, Nothing) - - hasExtras = isJust (H.importAs imp) || isJust (H.importSpecs imp) - - qualified - | H.importQualified imp = ["qualified"] - | padQualified = [" "] - | otherwise = [] - - --------------------------------------------------------------------------------- -prettyImportGroup :: Int -> Align -> Bool -> Int -> [H.ImportDecl LineBlock] - -> Lines -prettyImportGroup columns align fileAlign longest imps = - concatMap (prettyImport columns padQual padName longest') $ - sortBy compareImports imps - where - longest' = case align of - Group -> longestImport imps - _ -> longest - - padName = align /= None - - padQual = case align of - Global -> True - File -> fileAlign - Group -> any H.importQualified imps - None -> False - - --------------------------------------------------------------------------------- -step :: Int -> Align -> Step -step columns = makeStep "Imports" . step' columns - - --------------------------------------------------------------------------------- -step' :: Int -> Align -> Lines -> Module -> Lines -step' columns align ls (module', _) = flip applyChanges ls - [ change block $ const $ - prettyImportGroup columns align fileAlign longest importGroup - | (block, importGroup) <- groups - ] - where - imps = map sortImportSpecs $ imports $ fmap linesFromSrcSpan module' - longest = longestImport imps - groups = groupAdjacent [(H.ann i, i) | i <- imps] - - fileAlign = case align of - File -> any H.importQualified imps - _ -> False diff --git a/src/Language/Haskell/Stylish/Step/LanguagePragmas.hs b/src/Language/Haskell/Stylish/Step/LanguagePragmas.hs deleted file mode 100644 --- a/src/Language/Haskell/Stylish/Step/LanguagePragmas.hs +++ /dev/null @@ -1,158 +0,0 @@ --------------------------------------------------------------------------------- -module Language.Haskell.Stylish.Step.LanguagePragmas - ( Style (..) - , step - - -- * Utilities - , addLanguagePragma - ) where - - --------------------------------------------------------------------------------- -import qualified Data.Set as S -import qualified Language.Haskell.Exts.Annotated as H - - --------------------------------------------------------------------------------- -import Language.Haskell.Stylish.Block -import Language.Haskell.Stylish.Editor -import Language.Haskell.Stylish.Step -import Language.Haskell.Stylish.Util - - --------------------------------------------------------------------------------- -data Style - = Vertical - | Compact - | CompactLine - deriving (Eq, Show) - - --------------------------------------------------------------------------------- -pragmas :: H.Module l -> [(l, [String])] -pragmas (H.Module _ _ ps _ _) = - [(l, map nameToString names) | H.LanguagePragma l names <- ps] -pragmas _ = [] - - --------------------------------------------------------------------------------- --- | The start of the first block -firstLocation :: [(Block a, [String])] -> Int -firstLocation = minimum . map (blockStart . fst) - - --------------------------------------------------------------------------------- -verticalPragmas :: Int -> [String] -> Lines -verticalPragmas longest pragmas' = - [ "{-# LANGUAGE " ++ padRight longest pragma ++ " #-}" - | pragma <- pragmas' - ] - - --------------------------------------------------------------------------------- -compactPragmas :: Int -> [String] -> Lines -compactPragmas columns pragmas' = wrap columns "{-# LANGUAGE" 13 $ - map (++ ",") (init pragmas') ++ [last pragmas', "#-}"] - - --------------------------------------------------------------------------------- -compactLinePragmas :: Int -> [String] -> Lines -compactLinePragmas _ [] = [] -compactLinePragmas columns pragmas' = - let maxWidth = columns - 16 - longest = maximum $ map length prags - prags = map truncateComma $ wrap maxWidth "" 1 $ - map (++ ",") (init pragmas') ++ [last pragmas'] - in map (wrapLanguage . padRight longest) prags - where - wrapLanguage ps = "{-# LANGUAGE" ++ ps ++ " #-}" - - --------------------------------------------------------------------------------- -truncateComma :: String -> String -truncateComma "" = "" -truncateComma xs - | last xs == ',' = init xs - | otherwise = xs - - --------------------------------------------------------------------------------- -prettyPragmas :: Int -> Int -> Style -> [String] -> Lines -prettyPragmas _ longest Vertical = verticalPragmas longest -prettyPragmas columns _ Compact = compactPragmas columns -prettyPragmas columns _ CompactLine = compactLinePragmas columns - - --------------------------------------------------------------------------------- --- | Filter redundant (and duplicate) pragmas out of the groups. As a side --- effect, we also sort the pragmas in their group... -filterRedundant :: (String -> Bool) - -> [(l, [String])] - -> [(l, [String])] -filterRedundant isRedundant' = snd . foldr filterRedundant' (S.empty, []) - where - filterRedundant' (l, xs) (known, zs) - | S.null xs' = (known', zs) - | otherwise = (known', (l, S.toAscList xs') : zs) - where - fxs = filter (not . isRedundant') xs - xs' = S.fromList fxs `S.difference` known - known' = xs' `S.union` known - --------------------------------------------------------------------------------- -step :: Int -> Style -> Bool -> Step -step columns style = makeStep "LanguagePragmas" . step' columns style - - --------------------------------------------------------------------------------- -step' :: Int -> Style -> Bool -> Lines -> Module -> Lines -step' columns style removeRedundant ls (module', _) - | null pragmas' = ls - | otherwise = applyChanges changes ls - where - isRedundant' - | removeRedundant = isRedundant module' - | otherwise = const False - - pragmas' = pragmas $ fmap linesFromSrcSpan module' - longest = maximum $ map length $ snd =<< pragmas' - groups = [(b, concat pgs) | (b, pgs) <- groupAdjacent pragmas'] - changes = - [ change b (const $ prettyPragmas columns longest style pg) - | (b, pg) <- filterRedundant isRedundant' groups - ] - - --------------------------------------------------------------------------------- --- | Add a LANGUAGE pragma to a module if it is not present already. -addLanguagePragma :: String -> H.Module H.SrcSpanInfo -> [Change String] -addLanguagePragma prag modu - | prag `elem` present = [] - | otherwise = [insert line ["{-# LANGUAGE " ++ prag ++ " #-}"]] - where - pragmas' = pragmas (fmap linesFromSrcSpan modu) - present = concatMap snd pragmas' - line = if null pragmas' then 1 else firstLocation pragmas' - - --------------------------------------------------------------------------------- --- | Check if a language pragma is redundant. We can't do this for all pragmas, --- but we do a best effort. -isRedundant :: H.Module H.SrcSpanInfo -> String -> Bool -isRedundant m "ViewPatterns" = isRedundantViewPatterns m -isRedundant m "BangPatterns" = isRedundantBangPatterns m -isRedundant _ _ = False - - --------------------------------------------------------------------------------- --- | Check if the ViewPatterns language pragma is redundant. -isRedundantViewPatterns :: H.Module H.SrcSpanInfo -> Bool -isRedundantViewPatterns m = null - [() | H.PViewPat _ _ _ <- everything m :: [H.Pat H.SrcSpanInfo]] - - --------------------------------------------------------------------------------- --- | Check if the BangPatterns language pragma is redundant. -isRedundantBangPatterns :: H.Module H.SrcSpanInfo -> Bool -isRedundantBangPatterns m = null - [() | H.PBangPat _ _ <- everything m :: [H.Pat H.SrcSpanInfo]] diff --git a/src/Language/Haskell/Stylish/Step/Records.hs b/src/Language/Haskell/Stylish/Step/Records.hs deleted file mode 100644 --- a/src/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/src/Language/Haskell/Stylish/Step/Tabs.hs b/src/Language/Haskell/Stylish/Step/Tabs.hs deleted file mode 100644 --- a/src/Language/Haskell/Stylish/Step/Tabs.hs +++ /dev/null @@ -1,21 +0,0 @@ --------------------------------------------------------------------------------- -module Language.Haskell.Stylish.Step.Tabs - ( step - ) where - - --------------------------------------------------------------------------------- -import Language.Haskell.Stylish.Step - - --------------------------------------------------------------------------------- -removeTabs :: Int -> String -> String -removeTabs spaces = concatMap removeTabs' - where - removeTabs' '\t' = replicate spaces ' ' - removeTabs' x = [x] - - --------------------------------------------------------------------------------- -step :: Int -> Step -step spaces = makeStep "Tabs" $ \ls _ -> map (removeTabs spaces) ls diff --git a/src/Language/Haskell/Stylish/Step/TrailingWhitespace.hs b/src/Language/Haskell/Stylish/Step/TrailingWhitespace.hs deleted file mode 100644 --- a/src/Language/Haskell/Stylish/Step/TrailingWhitespace.hs +++ /dev/null @@ -1,22 +0,0 @@ --------------------------------------------------------------------------------- -module Language.Haskell.Stylish.Step.TrailingWhitespace - ( step - ) where - - --------------------------------------------------------------------------------- -import Data.Char (isSpace) - - --------------------------------------------------------------------------------- -import Language.Haskell.Stylish.Step - - --------------------------------------------------------------------------------- -dropTrailingWhitespace :: String -> String -dropTrailingWhitespace = reverse . dropWhile isSpace . reverse - - --------------------------------------------------------------------------------- -step :: Step -step = makeStep "TrailingWhitespace" $ \ls _ -> map dropTrailingWhitespace ls diff --git a/src/Language/Haskell/Stylish/Step/UnicodeSyntax.hs b/src/Language/Haskell/Stylish/Step/UnicodeSyntax.hs deleted file mode 100644 --- a/src/Language/Haskell/Stylish/Step/UnicodeSyntax.hs +++ /dev/null @@ -1,115 +0,0 @@ --------------------------------------------------------------------------------- -module Language.Haskell.Stylish.Step.UnicodeSyntax - ( step - ) where - - --------------------------------------------------------------------------------- -import Data.List (isPrefixOf, sort) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Maybe (maybeToList) -import qualified Language.Haskell.Exts.Annotated as H - - --------------------------------------------------------------------------------- -import Language.Haskell.Stylish.Block -import Language.Haskell.Stylish.Editor -import Language.Haskell.Stylish.Step -import Language.Haskell.Stylish.Step.LanguagePragmas (addLanguagePragma) -import Language.Haskell.Stylish.Util - - --------------------------------------------------------------------------------- -unicodeReplacements :: Map String String -unicodeReplacements = M.fromList - [ ("::", "∷") - , ("=>", "⇒") - , ("->", "→") - ] - - --------------------------------------------------------------------------------- -replaceAll :: [(Int, [(Int, String)])] -> [Change String] -replaceAll = map changeLine' - where - changeLine' (r, ns) = changeLine r $ \str -> return $ - flip applyChanges str - [ change (Block c ec) (const repl) - | (c, needle) <- sort ns - , let ec = c + length needle - 1 - , repl <- maybeToList $ M.lookup needle unicodeReplacements - ] - - --------------------------------------------------------------------------------- -groupPerLine :: [((Int, Int), a)] -> [(Int, [(Int, a)])] -groupPerLine = M.toList . M.fromListWith (++) . - map (\((r, c), x) -> (r, [(c, x)])) - - --------------------------------------------------------------------------------- -typeSigs :: H.Module H.SrcSpanInfo -> Lines -> [((Int, Int), String)] -typeSigs module' ls = - [ (pos, "::") - | H.TypeSig loc _ _ <- everything module' :: [H.Decl H.SrcSpanInfo] - , (start, end) <- infoPoints loc - , pos <- maybeToList $ between start end "::" ls - ] - - --------------------------------------------------------------------------------- -contexts :: H.Module H.SrcSpanInfo -> Lines -> [((Int, Int), String)] -contexts module' ls = - [ (pos, "=>") - | context <- everything module' :: [H.Context H.SrcSpanInfo] - , (start, end) <- infoPoints $ H.ann context - , pos <- maybeToList $ between start end "=>" ls - ] - - --------------------------------------------------------------------------------- -typeFuns :: H.Module H.SrcSpanInfo -> Lines -> [((Int, Int), String)] -typeFuns module' ls = - [ (pos, "->") - | H.TyFun _ t1 t2 <- everything module' - , let start = H.srcSpanEnd $ H.srcInfoSpan $ H.ann t1 - , let end = H.srcSpanStart $ H.srcInfoSpan $ H.ann t2 - , 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. -between :: (Int, Int) -> (Int, Int) -> String -> Lines -> Maybe (Int, Int) -between (startRow, startCol) (endRow, endCol) needle = - search (startRow, startCol) . - withLast (take endCol) . - withHead (drop $ startCol - 1) . - take (endRow - startRow + 1) . - drop (startRow - 1) - where - search _ [] = Nothing - search (r, _) ([] : xs) = search (r + 1, 1) xs - search (r, c) (x : xs) - | needle `isPrefixOf` x = Just (r, c) - | otherwise = search (r, c + 1) (tail x : xs) - - --------------------------------------------------------------------------------- -step :: Bool -> Step -step = makeStep "UnicodeSyntax" . step' - - --------------------------------------------------------------------------------- -step' :: Bool -> Lines -> Module -> Lines -step' alp ls (module', _) = applyChanges changes ls - where - changes = (if alp then addLanguagePragma "UnicodeSyntax" module' else []) ++ - replaceAll perLine - perLine = sort $ groupPerLine $ - typeSigs module' ls ++ - contexts module' ls ++ - typeFuns module' ls diff --git a/src/Language/Haskell/Stylish/Util.hs b/src/Language/Haskell/Stylish/Util.hs deleted file mode 100644 --- a/src/Language/Haskell/Stylish/Util.hs +++ /dev/null @@ -1,95 +0,0 @@ --------------------------------------------------------------------------------- -module Language.Haskell.Stylish.Util - ( nameToString - , indent - , padRight - , everything - , infoPoints - , wrap - - , withHead - , withLast - , withInit - ) where - - --------------------------------------------------------------------------------- -import Control.Arrow ((&&&), (>>>)) -import Data.Data (Data) -import qualified Data.Generics as G -import Data.Maybe (maybeToList) -import Data.Typeable (cast) -import qualified Language.Haskell.Exts.Annotated as H - - --------------------------------------------------------------------------------- -import Language.Haskell.Stylish.Step - - --------------------------------------------------------------------------------- -nameToString :: H.Name l -> String -nameToString (H.Ident _ str) = str -nameToString (H.Symbol _ str) = str - - --------------------------------------------------------------------------------- -indent :: Int -> String -> String -indent len str = replicate len ' ' ++ str - - --------------------------------------------------------------------------------- -padRight :: Int -> String -> String -padRight len str = str ++ replicate (len - length str) ' ' - - --------------------------------------------------------------------------------- -everything :: (Data a, Data b) => a -> [b] -everything = G.everything (++) (maybeToList . cast) - - --------------------------------------------------------------------------------- -infoPoints :: H.SrcSpanInfo -> [((Int, Int), (Int, Int))] -infoPoints = H.srcInfoPoints >>> map (H.srcSpanStart &&& H.srcSpanEnd) - - --------------------------------------------------------------------------------- -wrap :: Int -- ^ Maximum line width - -> String -- ^ Leading string - -> Int -- ^ Indentation - -> [String] -- ^ Strings to add/wrap - -> Lines -- ^ Resulting lines -wrap maxWidth leading ind strs = - let (ls, curr, _) = foldl step ([], leading, length leading) strs - in ls ++ [curr] - where - -- TODO: In order to optimize this, use a difference list instead of a - -- regular list for 'ls'. - step (ls, curr, width) str - | nextLine = (ls ++ [curr], indent ind str, ind + len) - | otherwise = (ls, curr ++ " " ++ str, width') - where - -- Put it on the next line if it would make the current line too long, - -- AND if it doesn't make the next line too long. - nextLine = width' > maxWidth && ind + len <= maxWidth - len = length str - width' = width + 1 + len - - --------------------------------------------------------------------------------- -withHead :: (a -> a) -> [a] -> [a] -withHead _ [] = [] -withHead f (x : xs) = f x : xs - - --------------------------------------------------------------------------------- -withLast :: (a -> a) -> [a] -> [a] -withLast _ [] = [] -withLast f (x : []) = [f x] -withLast f (x : xs) = x : withLast f xs - - --------------------------------------------------------------------------------- -withInit :: (a -> a) -> [a] -> [a] -withInit _ [] = [] -withInit _ (x : []) = [x] -withInit f (x : xs) = f x : withInit f xs diff --git a/src/Language/Haskell/Stylish/Verbose.hs b/src/Language/Haskell/Stylish/Verbose.hs deleted file mode 100644 --- a/src/Language/Haskell/Stylish/Verbose.hs +++ /dev/null @@ -1,20 +0,0 @@ --------------------------------------------------------------------------------- -module Language.Haskell.Stylish.Verbose - ( Verbose - , makeVerbose - ) where - - --------------------------------------------------------------------------------- -import System.IO (hPutStrLn, stderr) - - --------------------------------------------------------------------------------- -type Verbose = String -> IO () - - --------------------------------------------------------------------------------- -makeVerbose :: Bool -> Verbose -makeVerbose verbose - | verbose = hPutStrLn stderr - | otherwise = const $ return () diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -1,5 +1,5 @@ Name: stylish-haskell -Version: 0.5.14.4 +Version: 0.5.15.0 Synopsis: Haskell code prettifier Homepage: https://github.com/jaspervdj/stylish-haskell License: BSD3 @@ -26,7 +26,7 @@ Library Exposed-modules: Language.Haskell.Stylish - Hs-source-dirs: src + Hs-source-dirs: lib Ghc-options: -Wall Other-modules: @@ -47,7 +47,7 @@ Build-depends: aeson >= 0.6 && < 0.11, - base >= 4 && < 5, + base >= 4.8 && < 5, bytestring >= 0.9 && < 0.11, containers >= 0.3 && < 0.6, directory >= 1.1 && < 1.3, @@ -68,7 +68,7 @@ cmdargs >= 0.9 && < 0.11, -- Copied from regular dependencies... aeson >= 0.6 && < 0.11, - base >= 4 && < 5, + base >= 4.8 && < 5, bytestring >= 0.9 && < 0.11, containers >= 0.3 && < 0.6, directory >= 1.1 && < 1.3, @@ -80,7 +80,7 @@ Test-suite stylish-haskell-tests Ghc-options: -Wall - Hs-source-dirs: src tests + Hs-source-dirs: tests lib Main-is: TestSuite.hs Type: exitcode-stdio-1.0 @@ -100,7 +100,7 @@ test-framework-hunit >= 0.2 && < 0.4, -- Copied from regular dependencies... aeson >= 0.6 && < 0.11, - base >= 4 && < 5, + base >= 4.8 && < 5, bytestring >= 0.9 && < 0.11, cmdargs >= 0.9 && < 0.11, containers >= 0.3 && < 0.6, 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 @@ -16,6 +16,15 @@ -------------------------------------------------------------------------------- +defaultAlign :: Align +defaultAlign = Align Global AfterAlias Inline 4 True + + +-------------------------------------------------------------------------------- +fromImportAlign :: ImportAlign -> Align +fromImportAlign align = defaultAlign { importAlign = align } + +-------------------------------------------------------------------------------- tests :: Test tests = testGroup "Language.Haskell.Stylish.Step.Imports.Tests" [ testCase "case 01" case01 @@ -25,6 +34,17 @@ , testCase "case 05" case05 , testCase "case 06" case06 , testCase "case 07" case07 + , testCase "case 08" case08 + , testCase "case 09" case09 + , testCase "case 10" case10 + , testCase "case 11" case11 + , testCase "case 12" case12 + , testCase "case 13" case13 + , testCase "case 14" case14 + , testCase "case 15" case15 + , testCase "case 16" case16 + , testCase "case 17" case17 + , testCase "case 18" case18 ] @@ -37,6 +57,8 @@ , "import Control.Monad" , "import Only.Instances()" , "import Data.Map (lookup, (!), insert, Map)" + , "import Data.List as List (concat, foldl, foldr, head, init, last,\ + \ length, map, null, reverse, tail, (++))" , "" , "import Herp.Derp.Internals hiding (foo)" , "import Foo (Bar (..))" @@ -47,12 +69,15 @@ -------------------------------------------------------------------------------- case01 :: Assertion -case01 = expected @=? testStep (step 80 Global) input +case01 = expected @=? testStep (step 80 $ fromImportAlign Global) input where expected = unlines [ "module Herp where" , "" , "import Control.Monad" + , "import Data.List as List (concat, foldl, foldr, head, init," + , " last, length, map, null, reverse," + , " tail, (++))" , "import Data.Map (Map, insert, lookup, (!))" , "import qualified Data.Map as M" , "import Only.Instances ()" @@ -66,12 +91,14 @@ -------------------------------------------------------------------------------- case02 :: Assertion -case02 = expected @=? testStep (step 80 Group) input +case02 = expected @=? testStep (step 80 $ fromImportAlign Group) input where expected = unlines [ "module Herp where" , "" , "import Control.Monad" + , "import Data.List as List (concat, foldl, foldr, head, init, last," + , " length, map, null, reverse, tail, (++))" , "import Data.Map (Map, insert, lookup, (!))" , "import qualified Data.Map as M" , "import Only.Instances ()" @@ -85,12 +112,14 @@ -------------------------------------------------------------------------------- case03 :: Assertion -case03 = expected @=? testStep (step 80 None) input +case03 = expected @=? testStep (step 80 $ fromImportAlign None) input where expected = unlines [ "module Herp where" , "" , "import Control.Monad" + , "import Data.List as List (concat, foldl, foldr, head, init, last, length, map," + , " null, reverse, tail, (++))" , "import Data.Map (Map, insert, lookup, (!))" , "import qualified Data.Map as M" , "import Only.Instances ()" @@ -104,7 +133,7 @@ -------------------------------------------------------------------------------- case04 :: Assertion -case04 = expected @=? testStep (step 80 Global) input' +case04 = expected @=? testStep (step 80 $ fromImportAlign Global) input' where input' = "import Data.Aeson.Types (object, typeMismatch, FromJSON(..)," ++ @@ -119,7 +148,7 @@ -------------------------------------------------------------------------------- case05 :: Assertion -case05 = input' @=? testStep (step 80 Group) input' +case05 = input' @=? testStep (step 80 $ fromImportAlign Group) input' where input' = "import Distribution.PackageDescription.Configuration " ++ "(finalizePackageDescription)\n" @@ -127,7 +156,7 @@ -------------------------------------------------------------------------------- case06 :: Assertion -case06 = input' @=? testStep (step 80 File) input' +case06 = input' @=? testStep (step 80 $ fromImportAlign File) input' where input' = unlines [ "import Bar.Qux" @@ -137,7 +166,7 @@ -------------------------------------------------------------------------------- case07 :: Assertion -case07 = expected @=? testStep (step 80 File) input' +case07 = expected @=? testStep (step 80 $ fromImportAlign File) input' where input' = unlines [ "import Bar.Qux" @@ -149,4 +178,267 @@ [ "import Bar.Qux" , "" , "import qualified Foo.Bar" + ] + + +-------------------------------------------------------------------------------- +case08 :: Assertion +case08 = expected + @=? testStep (step 80 $ Align Global WithAlias Inline 4 True) input + where + expected = unlines + [ "module Herp where" + , "" + , "import Control.Monad" + , "import Data.List as List (concat, foldl, foldr, head, init," + , " last, length, map, null, reverse, tail," + , " (++))" + , "import Data.Map (Map, insert, lookup, (!))" + , "import qualified Data.Map as M" + , "import Only.Instances ()" + , "" + , "import Foo (Bar (..))" + , "import Herp.Derp.Internals hiding (foo)" + , "" + , "herp = putStrLn \"import Hello world\"" + ] + + +-------------------------------------------------------------------------------- +case09 :: Assertion +case09 = expected + @=? testStep (step 80 $ Align Global WithAlias Multiline 4 True) input + where + expected = unlines + [ "module Herp where" + , "" + , "import Control.Monad" + , "import Data.List as List" + , " ( concat" + , " , foldl" + , " , foldr" + , " , head" + , " , init" + , " , last" + , " , length" + , " , map" + , " , null" + , " , reverse" + , " , tail" + , " , (++)" + , " )" + , "import Data.Map (Map, insert, lookup, (!))" + , "import qualified Data.Map as M" + , "import Only.Instances ()" + , "" + , "import Foo (Bar (..))" + , "import Herp.Derp.Internals hiding (foo)" + , "" + , "herp = putStrLn \"import Hello world\"" + ] + + +-------------------------------------------------------------------------------- +case10 :: Assertion +case10 = expected + @=? testStep (step 40 $ Align Group WithAlias Multiline 4 True) input + where + expected = unlines + [ "module Herp where" + , "" + , "import Control.Monad" + , "import Data.List as List" + , " ( concat" + , " , foldl" + , " , foldr" + , " , head" + , " , init" + , " , last" + , " , length" + , " , map" + , " , null" + , " , reverse" + , " , tail" + , " , (++)" + , " )" + , "import Data.Map" + , " ( Map" + , " , insert" + , " , lookup" + , " , (!)" + , " )" + , "import qualified Data.Map as M" + , "import Only.Instances ()" + , "" + , "import Foo (Bar (..))" + , "import Herp.Derp.Internals hiding (foo)" + , "" + , "herp = putStrLn \"import Hello world\"" + ] + + +-------------------------------------------------------------------------------- +case11 :: Assertion +case11 = expected + @=? testStep (step 80 $ Align Group NewLine Inline 4 True) input + where + expected = unlines + [ "module Herp where" + , "" + , "import Control.Monad" + , "import Data.List as List" + , " (concat, foldl, foldr, head, init, last, length, map, null, reverse, tail," + , " (++))" + , "import Data.Map" + , " (Map, insert, lookup, (!))" + , "import qualified Data.Map as M" + , "import Only.Instances" + , " ()" + , "" + , "import Foo" + , " (Bar (..))" + , "import Herp.Derp.Internals hiding" + , " (foo)" + + , "" + , "herp = putStrLn \"import Hello world\"" + ] + + +-------------------------------------------------------------------------------- +case12 :: Assertion +case12 = expected + @=? testStep (step 80 $ Align Group NewLine Inline 2 True) input' + where + input' = unlines + [ "import Data.List (map)" + ] + + expected = unlines + [ "import Data.List" + , " (map)" + ] + + +-------------------------------------------------------------------------------- +case13 :: Assertion +case13 = expected + @=? testStep (step 80 $ Align None WithAlias InlineWithBreak 4 True) input' + where + input' = unlines + [ "import qualified Data.List as List (concat, foldl, foldr, head, init," + , " last, length, map, null, reverse, tail, (++))" + ] + + expected = unlines + [ "import qualified Data.List as List" + , " (concat, foldl, foldr, head, init, last, length, map, null, reverse, tail," + , " (++))" + ] + + +-------------------------------------------------------------------------------- +case14 :: Assertion +case14 = expected + @=? testStep + (step 80 $ Align None WithAlias InlineWithBreak 10 True) expected + where + expected = unlines + [ "import qualified Data.List as List (concat, map, null, reverse, tail, (++))" + ] + + +-------------------------------------------------------------------------------- +case15 :: Assertion +case15 = expected + @=? testStep (step 80 $ Align None AfterAlias Multiline 4 True) input' + where + expected = unlines + [ "import Data.Acid (AcidState)" + , "import qualified Data.Acid as Acid" + , " ( closeAcidState" + , " , createCheckpoint" + , " , openLocalStateFrom" + , " )" + , "import Data.Default.Class (Default (def))" + , "" + , "import qualified Herp.Derp.Internal.Types.Foobar as Internal (bar, foo)" + ] + + input' = unlines + [ "import Data.Acid (AcidState)" + , "import qualified Data.Acid as Acid (closeAcidState, createCheckpoint, openLocalStateFrom)" + , "import Data.Default.Class (Default (def))" + , "" + , "import qualified Herp.Derp.Internal.Types.Foobar as Internal (foo, bar)" + ] + + +-------------------------------------------------------------------------------- +case16 :: Assertion +case16 = expected + @=? testStep (step 80 $ Align None AfterAlias Multiline 4 False) input' + where + expected = unlines + [ "import Data.Acid (AcidState)" + , "import Data.Default.Class (Default(def))" + , "" + , "import Data.Maybe (Maybe(Just, Nothing))" + , "" + , "import Data.Foo (Foo(Bar, Foo), Goo(Goo))" + ] + + input' = unlines + [ "import Data.Acid (AcidState)" + , "import Data.Default.Class (Default(def))" + , "" + , "import Data.Maybe (Maybe (Just, Nothing))" + , "" + , "import Data.Foo (Foo (Foo,Bar), Goo(Goo))" + ] + + +-------------------------------------------------------------------------------- +case17 :: Assertion +case17 = expected + @=? testStep (step 80 $ Align None AfterAlias Multiline 4 True) input' + where + expected = unlines + [ "import Control.Applicative (Applicative (pure, (<*>)))" + , "" + , "import Data.Identity (Identity (Identity, runIdentity))" + ] + + input' = unlines + [ "import Control.Applicative (Applicative ((<*>),pure))" + , "" + , "import Data.Identity (Identity (runIdentity,Identity))" + ] + + +-------------------------------------------------------------------------------- +case18 :: Assertion +case18 = expected @=? testStep + (step 40 $ Align None AfterAlias InlineToMultiline 4 True) input' + where + expected = unlines + ---------------------------------------- + [ "import Data.Foo as Foo (Bar, Baz, Foo)" + , "" + , "import Data.Identity" + , " (Identity (Identity, runIdentity))" + , "" + , "import Data.Acid as Acid" + , " ( closeAcidState" + , " , createCheckpoint" + , " , openLocalStateFrom" + , " )" + ] + + input' = unlines + [ "import Data.Foo as Foo (Bar, Baz, Foo)" + , "" + , "import Data.Identity (Identity (Identity, runIdentity))" + , "" + , "import Data.Acid as Acid (closeAcidState, createCheckpoint, openLocalStateFrom)" ] diff --git a/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs b/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs --- a/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs @@ -24,12 +24,14 @@ , testCase "case 04" case04 , testCase "case 05" case05 , testCase "case 06" case06 + , testCase "case 07" case07 + , testCase "case 08" case08 ] -------------------------------------------------------------------------------- case01 :: Assertion -case01 = expected @=? testStep (step 80 Vertical False) input +case01 = expected @=? testStep (step 80 Vertical True False) input where input = unlines [ "{-# LANGUAGE ViewPatterns #-}" @@ -48,7 +50,7 @@ -------------------------------------------------------------------------------- case02 :: Assertion -case02 = expected @=? testStep (step 80 Vertical True) input +case02 = expected @=? testStep (step 80 Vertical True True) input where input = unlines [ "{-# LANGUAGE BangPatterns #-}" @@ -64,7 +66,7 @@ -------------------------------------------------------------------------------- case03 :: Assertion -case03 = expected @=? testStep (step 80 Vertical True) input +case03 = expected @=? testStep (step 80 Vertical True True) input where input = unlines [ "{-# LANGUAGE BangPatterns #-}" @@ -80,7 +82,7 @@ -------------------------------------------------------------------------------- case04 :: Assertion -case04 = expected @=? testStep (step 80 Compact False) input +case04 = expected @=? testStep (step 80 Compact True False) input where input = unlines [ "{-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable," @@ -97,7 +99,7 @@ -------------------------------------------------------------------------------- case05 :: Assertion -case05 = expected @=? testStep (step 80 Vertical False) input +case05 = expected @=? testStep (step 80 Vertical True False) input where input = unlines [ "{-# LANGUAGE CPP #-}" @@ -115,8 +117,10 @@ , "#endif" ] + +-------------------------------------------------------------------------------- case06 :: Assertion -case06 = expected @=? testStep (step 80 CompactLine False) input +case06 = expected @=? testStep (step 80 CompactLine True False) input where input = unlines [ "{-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable," @@ -127,4 +131,39 @@ [ "{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, " ++ "TemplateHaskell #-}" , "{-# LANGUAGE TypeOperators, ViewPatterns #-}" + ] + +-------------------------------------------------------------------------------- +case07 :: Assertion +case07 = expected @=? testStep (step 80 Vertical False False) input + where + input = unlines + [ "{-# LANGUAGE ViewPatterns #-}" + , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" + , "{-# LANGUAGE ScopedTypeVariables, NoImplicitPrelude #-}" + , "module Main where" + ] + + expected = unlines + [ "{-# LANGUAGE NoImplicitPrelude #-}" + , "{-# LANGUAGE ScopedTypeVariables #-}" + , "{-# LANGUAGE TemplateHaskell #-}" + , "{-# LANGUAGE ViewPatterns #-}" + , "module Main where" + ] + + +-------------------------------------------------------------------------------- +case08 :: Assertion +case08 = expected @=? testStep (step 80 CompactLine False False) input + where + input = unlines + [ "{-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable," + , " TemplateHaskell #-}" + , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" + ] + expected = unlines + [ "{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, " ++ + "TemplateHaskell #-}" + , "{-# LANGUAGE TypeOperators, ViewPatterns #-}" ]