diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml deleted file mode 100644 --- a/.stylish-haskell.yaml +++ /dev/null @@ -1,71 +0,0 @@ -# stylish-haskell configuration file -# ================================== - -# The stylish-haskell tool is mainly configured by specifying steps. These steps -# are a list, so they have an order, and one specific step may appear more than -# once (if needed). Each file is processed by these steps in the given order. -steps: - # Convert some ASCII sequences to their Unicode equivalents. This is disabled - # by default. - # - unicode_syntax: - # # In order to make this work, we also need to insert the UnicodeSyntax - # # language pragma. If this flag is set to true, we insert it when it's - # # not already present. You may want to disable it if you configure - # # language extensions using some other method than pragmas. Default: - # # true. - # add_language_pragma: true - - # Import cleanup - - imports: - # There are different ways we can align names and lists. - # - # - global: Align the import names and import list throughout the entire - # file. - # - # - group: Only align the imports per group (a group is formed by adjacent - # import lines). - # - # - none: Do not perform any alignment. - # - # Default: global. - align: global - - # Language pragmas - - language_pragmas: - # We can generate different styles of language pragma lists. - # - # - vertical: Vertical-spaced language pragmas, one per line. - # - # - compact: A more compact style. - # - # Default: vertical. - style: vertical - - # stylish-haskell can detect redundancy of some language pragmas. If this - # is set to true, it will remove those redundant pragmas. Default: true. - remove_redundant: true - - # Align the types in record declarations - - records: {} - - # Replace tabs by spaces. This is disabled by default. - # - tabs: - # # Number of spaces to use for each tab. Default: 8, as specified by the - # # Haskell report. - # spaces: 8 - - # Remove trailing whitespace - - trailing_whitespace: {} - -# A common setting is the number of columns (parts of) code will be wrapped -# to. Different steps take this into account. Default: 80. -columns: 80 - -# Sometimes, language extensions are specified in a cabal file or from the -# command line instead of using language pragmas in the file. stylish-haskell -# needs to be aware of these, so it can parse the file correctly. -# -# No language extensions are enabled by default. -# language_extensions: - # - TemplateHaskell - # - QuasiQuotes diff --git a/data/stylish-haskell.yaml b/data/stylish-haskell.yaml new file mode 100644 --- /dev/null +++ b/data/stylish-haskell.yaml @@ -0,0 +1,71 @@ +# stylish-haskell configuration file +# ================================== + +# The stylish-haskell tool is mainly configured by specifying steps. These steps +# are a list, so they have an order, and one specific step may appear more than +# once (if needed). Each file is processed by these steps in the given order. +steps: + # Convert some ASCII sequences to their Unicode equivalents. This is disabled + # by default. + # - unicode_syntax: + # # In order to make this work, we also need to insert the UnicodeSyntax + # # language pragma. If this flag is set to true, we insert it when it's + # # not already present. You may want to disable it if you configure + # # language extensions using some other method than pragmas. Default: + # # true. + # add_language_pragma: true + + # Import cleanup + - imports: + # There are different ways we can align names and lists. + # + # - global: Align the import names and import list throughout the entire + # file. + # + # - group: Only align the imports per group (a group is formed by adjacent + # import lines). + # + # - none: Do not perform any alignment. + # + # Default: global. + align: global + + # Language pragmas + - language_pragmas: + # We can generate different styles of language pragma lists. + # + # - vertical: Vertical-spaced language pragmas, one per line. + # + # - compact: A more compact style. + # + # Default: vertical. + style: vertical + + # stylish-haskell can detect redundancy of some language pragmas. If this + # is set to true, it will remove those redundant pragmas. Default: true. + remove_redundant: true + + # Align the types in record declarations + - records: {} + + # Replace tabs by spaces. This is disabled by default. + # - tabs: + # # Number of spaces to use for each tab. Default: 8, as specified by the + # # Haskell report. + # spaces: 8 + + # Remove trailing whitespace + - trailing_whitespace: {} + +# A common setting is the number of columns (parts of) code will be wrapped +# to. Different steps take this into account. Default: 80. +columns: 80 + +# Sometimes, language extensions are specified in a cabal file or from the +# command line instead of using language pragmas in the file. stylish-haskell +# needs to be aware of these, so it can parse the file correctly. +# +# No language extensions are enabled by default. +# language_extensions: + # - TemplateHaskell + # - QuasiQuotes diff --git a/src/Language/Haskell/Stylish.hs b/src/Language/Haskell/Stylish.hs new file mode 100644 --- /dev/null +++ b/src/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.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 new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Stylish/Block.hs @@ -0,0 +1,78 @@ +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish.Block + ( Block (..) + , LineBlock + , SpanBlock + , blockLength + , linesFromSrcSpan + , spanFromSrcSpan + , moveBlock + , adjacent + , merge + , overlapping + ) 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 diff --git a/src/Language/Haskell/Stylish/Config.hs b/src/Language/Haskell/Stylish/Config.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Stylish/Config.hs @@ -0,0 +1,199 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} +module Language.Haskell.Stylish.Config + ( Extensions + , Config (..) + , defaultConfigFilePath + , configFilePath + , loadConfig + ) where + + +-------------------------------------------------------------------------------- +import Control.Applicative (pure, (<$>), (<*>)) +import Control.Monad (forM, msum, 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 (intercalate) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Yaml (decodeEither) +import System.Directory +import System.FilePath (()) + + +-------------------------------------------------------------------------------- +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 verbose userSpecified = do + (current, currentE) <- check $ ( configFileName) <$> getCurrentDirectory + (home, homeE) <- check $ ( configFileName) <$> getHomeDirectory + (def, defE) <- check defaultConfigFilePath + return $ msum + [ userSpecified + , if currentE then Just current else Nothing + , if homeE then Just home else Nothing + , if defE then Just def else Nothing + ] + where + check fp = do + fp' <- fp + ex <- doesFileExist fp' + verbose $ fp' ++ if ex then " exists" else " does not exist" + return (fp', ex) + + +-------------------------------------------------------------------------------- +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 + steps <- (o A..: "steps" >>= fmap concat . mapM (parseSteps config)) + return config {configSteps = 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) + , ("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) + ] + + +-------------------------------------------------------------------------------- +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 new file mode 100644 --- /dev/null +++ b/src/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/src/Language/Haskell/Stylish/Parse.hs b/src/Language/Haskell/Stylish/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Stylish/Parse.hs @@ -0,0 +1,64 @@ +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish.Parse + ( parseModule + ) where + + +-------------------------------------------------------------------------------- +import Control.Monad.Error (throwError) +import Data.Maybe (fromMaybe) +import qualified Language.Haskell.Exts.Annotated as H + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Config +import Language.Haskell.Stylish.Step + + +-------------------------------------------------------------------------------- +-- | Filter out lines which use CPP macros +unCpp :: String -> String +unCpp = unlines . map unCpp' . lines + where + unCpp' ('#' : _) = "" + unCpp' xs = xs + + +-------------------------------------------------------------------------------- +-- | 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 + + +-------------------------------------------------------------------------------- +-- | Read an extension name from a string +parseExtension :: String -> Either String H.Extension +parseExtension str = case reads str of + [(x, "")] -> return x + _ -> throwError $ "Unknown extension: " ++ 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 + extraExts' <- mapM parseExtension extraExts + let fileExts = fromMaybe [] $ H.readExtensions string + exts = fileExts ++ extraExts' + + -- Parsing options... + fp = fromMaybe "" mfp + mode = H.defaultParseMode + {H.extensions = exts, H.fixities = Nothing} + + -- Preprocessing + string' = dropBom $ (if H.CPP `elem` exts then unCpp else id) $ string + + case H.parseModuleWithComments mode string' of + H.ParseOk md -> return md + err -> throwError $ + "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 new file mode 100644 --- /dev/null +++ b/src/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/src/Language/Haskell/Stylish/Step/Imports.hs b/src/Language/Haskell/Stylish/Step/Imports.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Stylish/Step/Imports.hs @@ -0,0 +1,174 @@ +-------------------------------------------------------------------------------- +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 + | 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) + + +-------------------------------------------------------------------------------- +-- | Groups adjacent imports into larger import blocks +groupAdjacent :: [H.ImportDecl LineBlock] + -> [(LineBlock, [H.ImportDecl LineBlock])] +groupAdjacent = foldr go [] + where + -- This code is ugly and not optimal, and no fucks were given. + go imp is = case break (adjacent b1 . fst) is of + (_, []) -> (b1, [imp]) : is + (xs, ((b2, imps) : ys)) -> (merge b1 b2, imp : imps) : (xs ++ ys) + where + b1 = H.ann imp + + +-------------------------------------------------------------------------------- +-- | 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 = + intercalate "\n" $ + wrap columns base (length base + 2) $ + (if hiding then ("hiding" :) else id) $ + withInit (++ ",") $ + withHead ("(" ++) $ + withLast (++ ")") $ + map prettyImportSpec $ + importSpecs + where + base = unwords $ concat + [ ["import"] + , qualified + , [(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, l) + _ -> (False, []) + + hasExtras = isJust (H.importAs imp) || isJust (H.importSpecs imp) + + qualified + | H.importQualified imp = ["qualified"] + | padQualified = [" "] + | otherwise = [] + + +-------------------------------------------------------------------------------- +prettyImportGroup :: Int -> Align -> Int -> [H.ImportDecl LineBlock] -> Lines +prettyImportGroup columns align longest imps = + map (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 + 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 longest importGroup) + | (block, importGroup) <- groups + ] + where + imps = map sortImportSpecs $ imports $ fmap linesFromSrcSpan module' + longest = longestImport imps + groups = groupAdjacent imps diff --git a/src/Language/Haskell/Stylish/Step/LanguagePragmas.hs b/src/Language/Haskell/Stylish/Step/LanguagePragmas.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Stylish/Step/LanguagePragmas.hs @@ -0,0 +1,119 @@ +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish.Step.LanguagePragmas + ( Style (..) + , step + + -- * Utilities + , addLanguagePragma + ) where + + +-------------------------------------------------------------------------------- +import Data.List (nub, sort) +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 + 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 :: [String] -> Lines +verticalPragmas pragmas' = + [ "{-# LANGUAGE " ++ padRight longest pragma ++ " #-}" + | pragma <- pragmas' + ] + where + longest = maximum $ map length pragmas' + + +-------------------------------------------------------------------------------- +compactPragmas :: Int -> [String] -> Lines +compactPragmas columns pragmas' = wrap columns "{-# LANGUAGE" 13 $ + map (++ ",") (init pragmas') ++ [last pragmas', "#-}"] + + +-------------------------------------------------------------------------------- +prettyPragmas :: Int -> Style -> [String] -> Lines +prettyPragmas _ Vertical = verticalPragmas +prettyPragmas columns Compact = compactPragmas columns + + +-------------------------------------------------------------------------------- +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 + filterRedundant + | removeRedundant = filter (not . isRedundant module') + | otherwise = id + + pragmas' = pragmas $ fmap linesFromSrcSpan module' + uniques = filterRedundant $ nub $ sort $ snd =<< pragmas' + loc = firstLocation pragmas' + deletes = map (delete . fst) pragmas' + changes = insert loc (prettyPragmas columns style uniques) : deletes + + +-------------------------------------------------------------------------------- +-- | 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 new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Stylish/Step/Records.hs @@ -0,0 +1,71 @@ +-------------------------------------------------------------------------------- +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 -> [[H.FieldDecl l]] +records modu = + [ fields + | H.Module _ _ _ _ decls <- [modu] + , H.DataDecl _ _ _ _ cons _ <- decls + , H.QualConDecl _ _ _ (H.RecDecl _ _ fields) <- cons + ] + + +-------------------------------------------------------------------------------- +-- | Align the type of a field +align :: [(Int, Int)] -> [Change String] +align alignment = map align' alignment + where + longest = maximum $ map snd alignment + + align' (line, column) = changeLine line $ \str -> + let (pre, post) = splitAt column str + in [padRight longest (trimRight pre) ++ trimLeft post] + + trimLeft = dropWhile isSpace + trimRight = reverse . trimLeft . reverse + + +-------------------------------------------------------------------------------- +-- | Determine alignment of fields +fieldAlignment :: [H.FieldDecl H.SrcSpan] -> [(Int, Int)] +fieldAlignment fields = + [ (H.srcSpanStartLine ann, H.srcSpanEndColumn ann) + | H.FieldDecl _ names _ <- fields + , let ann = H.ann (last names) + ] + + +-------------------------------------------------------------------------------- +-- | Checks that all no field of the record appears on more than one line, +-- amonst other things +fixable :: [H.FieldDecl H.SrcSpan] -> Bool +fixable [] = False +fixable fields = all singleLine srcSpans && nonOverlapping srcSpans + where + srcSpans = map H.ann 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 . fieldAlignment) ls diff --git a/src/Language/Haskell/Stylish/Step/Tabs.hs b/src/Language/Haskell/Stylish/Step/Tabs.hs new file mode 100644 --- /dev/null +++ b/src/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/src/Language/Haskell/Stylish/Step/TrailingWhitespace.hs b/src/Language/Haskell/Stylish/Step/TrailingWhitespace.hs new file mode 100644 --- /dev/null +++ b/src/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/src/Language/Haskell/Stylish/Step/UnicodeSyntax.hs b/src/Language/Haskell/Stylish/Step/UnicodeSyntax.hs new file mode 100644 --- /dev/null +++ b/src/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/src/Language/Haskell/Stylish/Util.hs b/src/Language/Haskell/Stylish/Util.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Stylish/Util.hs @@ -0,0 +1,92 @@ +-------------------------------------------------------------------------------- +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 + | width' > maxWidth = (ls ++ [curr], indent ind str, ind + len) + | otherwise = (ls, curr ++ " " ++ str, width') + where + 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 new file mode 100644 --- /dev/null +++ b/src/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/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -16,11 +16,7 @@ -------------------------------------------------------------------------------- -import Paths_stylish_haskell (version) -import StylishHaskell -import StylishHaskell.Config -import StylishHaskell.Step -import StylishHaskell.Verbose +import Language.Haskell.Stylish -------------------------------------------------------------------------------- diff --git a/src/StylishHaskell.hs b/src/StylishHaskell.hs deleted file mode 100644 --- a/src/StylishHaskell.hs +++ /dev/null @@ -1,28 +0,0 @@ --------------------------------------------------------------------------------- -module StylishHaskell - ( runStep - , runSteps - ) where - - --------------------------------------------------------------------------------- -import Control.Applicative ((<$>)) -import Control.Monad (foldM) - - --------------------------------------------------------------------------------- -import StylishHaskell.Config -import StylishHaskell.Parse -import StylishHaskell.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/StylishHaskell/Block.hs b/src/StylishHaskell/Block.hs deleted file mode 100644 --- a/src/StylishHaskell/Block.hs +++ /dev/null @@ -1,78 +0,0 @@ --------------------------------------------------------------------------------- -module StylishHaskell.Block - ( Block (..) - , LineBlock - , SpanBlock - , blockLength - , linesFromSrcSpan - , spanFromSrcSpan - , moveBlock - , adjacent - , merge - , overlapping - ) 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 diff --git a/src/StylishHaskell/Config.hs b/src/StylishHaskell/Config.hs deleted file mode 100644 --- a/src/StylishHaskell/Config.hs +++ /dev/null @@ -1,199 +0,0 @@ --------------------------------------------------------------------------------- -{-# LANGUAGE OverloadedStrings #-} -module StylishHaskell.Config - ( Extensions - , Config (..) - , defaultConfigFilePath - , configFilePath - , loadConfig - ) where - - --------------------------------------------------------------------------------- -import Control.Applicative (pure, (<$>), (<*>)) -import Control.Monad (forM, msum, 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 (intercalate) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Yaml (decodeEither) -import System.Directory -import System.FilePath (()) - - --------------------------------------------------------------------------------- -import Paths_stylish_haskell (getDataFileName) -import StylishHaskell.Step -import qualified StylishHaskell.Step.Imports as Imports -import qualified StylishHaskell.Step.LanguagePragmas as LanguagePragmas -import qualified StylishHaskell.Step.Records as Records -import qualified StylishHaskell.Step.Tabs as Tabs -import qualified StylishHaskell.Step.TrailingWhitespace as TrailingWhitespace -import qualified StylishHaskell.Step.UnicodeSyntax as UnicodeSyntax -import StylishHaskell.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 ".stylish-haskell.yaml" - - --------------------------------------------------------------------------------- -configFilePath :: Verbose -> Maybe FilePath -> IO (Maybe FilePath) -configFilePath verbose userSpecified = do - (current, currentE) <- check $ ( configFileName) <$> getCurrentDirectory - (home, homeE) <- check $ ( configFileName) <$> getHomeDirectory - (def, defE) <- check defaultConfigFilePath - return $ msum - [ userSpecified - , if currentE then Just current else Nothing - , if homeE then Just home else Nothing - , if defE then Just def else Nothing - ] - where - check fp = do - fp' <- fp - ex <- doesFileExist fp' - verbose $ fp' ++ if ex then " exists" else " does not exist" - return (fp', ex) - - --------------------------------------------------------------------------------- -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 $ - "StylishHaskell.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 - steps <- (o A..: "steps" >>= fmap concat . mapM (parseSteps config)) - return config {configSteps = 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) - , ("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) - ] - - --------------------------------------------------------------------------------- -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/StylishHaskell/Editor.hs b/src/StylishHaskell/Editor.hs deleted file mode 100644 --- a/src/StylishHaskell/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 StylishHaskell.Editor - ( Change - , applyChanges - - , change - , changeLine - , delete - , deleteLine - , insert - ) where - - --------------------------------------------------------------------------------- -import StylishHaskell.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 $ - "StylishHaskell.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/StylishHaskell/Parse.hs b/src/StylishHaskell/Parse.hs deleted file mode 100644 --- a/src/StylishHaskell/Parse.hs +++ /dev/null @@ -1,64 +0,0 @@ --------------------------------------------------------------------------------- -module StylishHaskell.Parse - ( parseModule - ) where - - --------------------------------------------------------------------------------- -import Control.Monad.Error (throwError) -import Data.Maybe (fromMaybe) -import qualified Language.Haskell.Exts.Annotated as H - - --------------------------------------------------------------------------------- -import StylishHaskell.Config -import StylishHaskell.Step - - --------------------------------------------------------------------------------- --- | Filter out lines which use CPP macros -unCpp :: String -> String -unCpp = unlines . map unCpp' . lines - where - unCpp' ('#' : _) = "" - unCpp' xs = xs - - --------------------------------------------------------------------------------- --- | 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 - - --------------------------------------------------------------------------------- --- | Read an extension name from a string -parseExtension :: String -> Either String H.Extension -parseExtension str = case reads str of - [(x, "")] -> return x - _ -> throwError $ "Unknown extension: " ++ 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 - extraExts' <- mapM parseExtension extraExts - let fileExts = fromMaybe [] $ H.readExtensions string - exts = fileExts ++ extraExts' - - -- Parsing options... - fp = fromMaybe "" mfp - mode = H.defaultParseMode - {H.extensions = exts, H.fixities = Nothing} - - -- Preprocessing - string' = dropBom $ (if H.CPP `elem` exts then unCpp else id) $ string - - case H.parseModuleWithComments mode string' of - H.ParseOk md -> return md - err -> throwError $ - "StylishHaskell.Parse.parseModule: could not parse " ++ - fp ++ ": " ++ show err diff --git a/src/StylishHaskell/Step.hs b/src/StylishHaskell/Step.hs deleted file mode 100644 --- a/src/StylishHaskell/Step.hs +++ /dev/null @@ -1,32 +0,0 @@ --------------------------------------------------------------------------------- -module StylishHaskell.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/StylishHaskell/Step/Imports.hs b/src/StylishHaskell/Step/Imports.hs deleted file mode 100644 --- a/src/StylishHaskell/Step/Imports.hs +++ /dev/null @@ -1,174 +0,0 @@ --------------------------------------------------------------------------------- -module StylishHaskell.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 StylishHaskell.Block -import StylishHaskell.Editor -import StylishHaskell.Step -import StylishHaskell.Util - - --------------------------------------------------------------------------------- -data Align - = Global - | 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) - - --------------------------------------------------------------------------------- --- | Groups adjacent imports into larger import blocks -groupAdjacent :: [H.ImportDecl LineBlock] - -> [(LineBlock, [H.ImportDecl LineBlock])] -groupAdjacent = foldr go [] - where - -- This code is ugly and not optimal, and no fucks were given. - go imp is = case break (adjacent b1 . fst) is of - (_, []) -> (b1, [imp]) : is - (xs, ((b2, imps) : ys)) -> (merge b1 b2, imp : imps) : (xs ++ ys) - where - b1 = H.ann imp - - --------------------------------------------------------------------------------- --- | 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 = - intercalate "\n" $ - wrap columns base (length base + 2) $ - (if hiding then ("hiding" :) else id) $ - withInit (++ ",") $ - withHead ("(" ++) $ - withLast (++ ")") $ - map prettyImportSpec $ - importSpecs - where - base = unwords $ concat - [ ["import"] - , qualified - , [(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, l) - _ -> (False, []) - - hasExtras = isJust (H.importAs imp) || isJust (H.importSpecs imp) - - qualified - | H.importQualified imp = ["qualified"] - | padQualified = [" "] - | otherwise = [] - - --------------------------------------------------------------------------------- -prettyImportGroup :: Int -> Align -> Int -> [H.ImportDecl LineBlock] -> Lines -prettyImportGroup columns align longest imps = - map (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 - 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 longest importGroup) - | (block, importGroup) <- groups - ] - where - imps = map sortImportSpecs $ imports $ fmap linesFromSrcSpan module' - longest = longestImport imps - groups = groupAdjacent imps diff --git a/src/StylishHaskell/Step/LanguagePragmas.hs b/src/StylishHaskell/Step/LanguagePragmas.hs deleted file mode 100644 --- a/src/StylishHaskell/Step/LanguagePragmas.hs +++ /dev/null @@ -1,119 +0,0 @@ --------------------------------------------------------------------------------- -module StylishHaskell.Step.LanguagePragmas - ( Style (..) - , step - - -- * Utilities - , addLanguagePragma - ) where - - --------------------------------------------------------------------------------- -import Data.List (nub, sort) -import qualified Language.Haskell.Exts.Annotated as H - - --------------------------------------------------------------------------------- -import StylishHaskell.Block -import StylishHaskell.Editor -import StylishHaskell.Step -import StylishHaskell.Util - - --------------------------------------------------------------------------------- -data Style - = Vertical - | Compact - 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 :: [String] -> Lines -verticalPragmas pragmas' = - [ "{-# LANGUAGE " ++ padRight longest pragma ++ " #-}" - | pragma <- pragmas' - ] - where - longest = maximum $ map length pragmas' - - --------------------------------------------------------------------------------- -compactPragmas :: Int -> [String] -> Lines -compactPragmas columns pragmas' = wrap columns "{-# LANGUAGE" 13 $ - map (++ ",") (init pragmas') ++ [last pragmas', "#-}"] - - --------------------------------------------------------------------------------- -prettyPragmas :: Int -> Style -> [String] -> Lines -prettyPragmas _ Vertical = verticalPragmas -prettyPragmas columns Compact = compactPragmas columns - - --------------------------------------------------------------------------------- -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 - filterRedundant - | removeRedundant = filter (not . isRedundant module') - | otherwise = id - - pragmas' = pragmas $ fmap linesFromSrcSpan module' - uniques = filterRedundant $ nub $ sort $ snd =<< pragmas' - loc = firstLocation pragmas' - deletes = map (delete . fst) pragmas' - changes = insert loc (prettyPragmas columns style uniques) : deletes - - --------------------------------------------------------------------------------- --- | 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/StylishHaskell/Step/Records.hs b/src/StylishHaskell/Step/Records.hs deleted file mode 100644 --- a/src/StylishHaskell/Step/Records.hs +++ /dev/null @@ -1,71 +0,0 @@ --------------------------------------------------------------------------------- -module StylishHaskell.Step.Records - ( step - ) where - - --------------------------------------------------------------------------------- -import Data.Char (isSpace) -import Data.List (nub) -import qualified Language.Haskell.Exts.Annotated as H - - --------------------------------------------------------------------------------- -import StylishHaskell.Editor -import StylishHaskell.Step -import StylishHaskell.Util - - --------------------------------------------------------------------------------- -records :: H.Module l -> [[H.FieldDecl l]] -records modu = - [ fields - | H.Module _ _ _ _ decls <- [modu] - , H.DataDecl _ _ _ _ cons _ <- decls - , H.QualConDecl _ _ _ (H.RecDecl _ _ fields) <- cons - ] - - --------------------------------------------------------------------------------- --- | Align the type of a field -align :: [(Int, Int)] -> [Change String] -align alignment = map align' alignment - where - longest = maximum $ map snd alignment - - align' (line, column) = changeLine line $ \str -> - let (pre, post) = splitAt column str - in [padRight longest (trimRight pre) ++ trimLeft post] - - trimLeft = dropWhile isSpace - trimRight = reverse . trimLeft . reverse - - --------------------------------------------------------------------------------- --- | Determine alignment of fields -fieldAlignment :: [H.FieldDecl H.SrcSpan] -> [(Int, Int)] -fieldAlignment fields = - [ (H.srcSpanStartLine ann, H.srcSpanEndColumn ann) - | H.FieldDecl _ names _ <- fields - , let ann = H.ann (last names) - ] - - --------------------------------------------------------------------------------- --- | Checks that all no field of the record appears on more than one line, --- amonst other things -fixable :: [H.FieldDecl H.SrcSpan] -> Bool -fixable [] = False -fixable fields = all singleLine srcSpans && nonOverlapping srcSpans - where - srcSpans = map H.ann 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 . fieldAlignment) ls diff --git a/src/StylishHaskell/Step/Tabs.hs b/src/StylishHaskell/Step/Tabs.hs deleted file mode 100644 --- a/src/StylishHaskell/Step/Tabs.hs +++ /dev/null @@ -1,21 +0,0 @@ --------------------------------------------------------------------------------- -module StylishHaskell.Step.Tabs - ( step - ) where - - --------------------------------------------------------------------------------- -import StylishHaskell.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/StylishHaskell/Step/TrailingWhitespace.hs b/src/StylishHaskell/Step/TrailingWhitespace.hs deleted file mode 100644 --- a/src/StylishHaskell/Step/TrailingWhitespace.hs +++ /dev/null @@ -1,22 +0,0 @@ --------------------------------------------------------------------------------- -module StylishHaskell.Step.TrailingWhitespace - ( step - ) where - - --------------------------------------------------------------------------------- -import Data.Char (isSpace) - - --------------------------------------------------------------------------------- -import StylishHaskell.Step - - --------------------------------------------------------------------------------- -dropTrailingWhitespace :: String -> String -dropTrailingWhitespace = reverse . dropWhile isSpace . reverse - - --------------------------------------------------------------------------------- -step :: Step -step = makeStep "TrailingWhitespace" $ \ls _ -> map dropTrailingWhitespace ls diff --git a/src/StylishHaskell/Step/UnicodeSyntax.hs b/src/StylishHaskell/Step/UnicodeSyntax.hs deleted file mode 100644 --- a/src/StylishHaskell/Step/UnicodeSyntax.hs +++ /dev/null @@ -1,115 +0,0 @@ --------------------------------------------------------------------------------- -module StylishHaskell.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 StylishHaskell.Block -import StylishHaskell.Editor -import StylishHaskell.Step -import StylishHaskell.Step.LanguagePragmas (addLanguagePragma) -import StylishHaskell.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/StylishHaskell/Util.hs b/src/StylishHaskell/Util.hs deleted file mode 100644 --- a/src/StylishHaskell/Util.hs +++ /dev/null @@ -1,92 +0,0 @@ --------------------------------------------------------------------------------- -module StylishHaskell.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 StylishHaskell.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 - | width' > maxWidth = (ls ++ [curr], indent ind str, ind + len) - | otherwise = (ls, curr ++ " " ++ str, width') - where - 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/StylishHaskell/Verbose.hs b/src/StylishHaskell/Verbose.hs deleted file mode 100644 --- a/src/StylishHaskell/Verbose.hs +++ /dev/null @@ -1,20 +0,0 @@ --------------------------------------------------------------------------------- -module StylishHaskell.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.4.0.0 +Version: 0.5.0.0 Synopsis: Haskell code prettifier Homepage: https://github.com/jaspervdj/stylish-haskell License: BSD3 @@ -19,41 +19,58 @@ Data-files: - .stylish-haskell.yaml + data/stylish-haskell.yaml -Executable stylish-haskell - Ghc-options: -Wall +Library + Exposed-modules: Language.Haskell.Stylish Hs-source-dirs: src - Main-is: Main.hs + Ghc-options: -Wall Other-modules: - Paths_stylish_haskell - StylishHaskell - StylishHaskell.Block - StylishHaskell.Config - StylishHaskell.Editor - StylishHaskell.Parse - StylishHaskell.Step - StylishHaskell.Step.Imports - StylishHaskell.Step.LanguagePragmas - StylishHaskell.Step.Records - StylishHaskell.Step.Tabs - StylishHaskell.Step.TrailingWhitespace - StylishHaskell.Step.UnicodeSyntax - StylishHaskell.Util - StylishHaskell.Verbose + Language.Haskell.Stylish.Block + Language.Haskell.Stylish.Config + Language.Haskell.Stylish.Editor + Language.Haskell.Stylish.Parse + Language.Haskell.Stylish.Step + Language.Haskell.Stylish.Step.Imports + Language.Haskell.Stylish.Step.LanguagePragmas + Language.Haskell.Stylish.Step.Records + Language.Haskell.Stylish.Step.Tabs + Language.Haskell.Stylish.Step.TrailingWhitespace + Language.Haskell.Stylish.Step.UnicodeSyntax + Language.Haskell.Stylish.Util + Language.Haskell.Stylish.Verbose Build-depends: aeson >= 0.6 && < 0.7, base >= 4 && < 5, bytestring >= 0.9 && < 0.10, - cmdargs >= 0.9 && < 0.11, containers >= 0.3 && < 0.6, directory >= 1.1 && < 1.2, filepath >= 1.1 && < 1.4, haskell-src-exts >= 1.13 && < 1.14, mtl >= 2.0 && < 2.2, + syb >= 0.3 && < 0.4, + yaml >= 0.7 && < 0.9 + +Executable stylish-haskell + Ghc-options: -Wall + Hs-source-dirs: src + Main-is: Main.hs + + Build-depends: + stylish-haskell, strict >= 0.3 && < 0.4, + cmdargs >= 0.9 && < 0.11, + -- Copied from regular dependencies... + aeson >= 0.6 && < 0.7, + base >= 4 && < 5, + bytestring >= 0.9 && < 0.10, + containers >= 0.3 && < 0.6, + directory >= 1.1 && < 1.2, + filepath >= 1.1 && < 1.4, + haskell-src-exts >= 1.13 && < 1.14, + mtl >= 2.0 && < 2.2, syb >= 0.3 && < 0.4, yaml >= 0.7 && < 0.9 @@ -64,14 +81,14 @@ Type: exitcode-stdio-1.0 Other-modules: - StylishHaskell.Parse.Tests - StylishHaskell.Step.Imports.Tests - StylishHaskell.Step.LanguagePragmas.Tests - StylishHaskell.Step.Records.Tests - StylishHaskell.Step.Tabs.Tests - StylishHaskell.Step.TrailingWhitespace.Tests - StylishHaskell.Step.UnicodeSyntax.Tests - StylishHaskell.Tests.Util + Language.Haskell.Stylish.Parse.Tests + Language.Haskell.Stylish.Step.Imports.Tests + Language.Haskell.Stylish.Step.LanguagePragmas.Tests + Language.Haskell.Stylish.Step.Records.Tests + Language.Haskell.Stylish.Step.Tabs.Tests + Language.Haskell.Stylish.Step.TrailingWhitespace.Tests + Language.Haskell.Stylish.Step.UnicodeSyntax.Tests + Language.Haskell.Stylish.Tests.Util Build-depends: HUnit >= 1.2 && < 1.3, @@ -87,7 +104,6 @@ filepath >= 1.1 && < 1.4, haskell-src-exts >= 1.13 && < 1.14, mtl >= 2.0 && < 2.2, - strict >= 0.3 && < 0.4, syb >= 0.3 && < 0.4, yaml >= 0.7 && < 0.9 diff --git a/tests/Language/Haskell/Stylish/Parse/Tests.hs b/tests/Language/Haskell/Stylish/Parse/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Language/Haskell/Stylish/Parse/Tests.hs @@ -0,0 +1,44 @@ +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish.Parse.Tests + ( tests + ) where + + +-------------------------------------------------------------------------------- +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, assert) + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Parse + + +-------------------------------------------------------------------------------- +tests :: Test +tests = testGroup "Language.Haskell.Stylish.Parse" + [ testCase "UTF-8 Byte Order Mark" testBom + , testCase "Extra extensions" testExtraExtensions + ] + + +-------------------------------------------------------------------------------- +testBom :: Assertion +testBom = assert $ isRight $ parseModule [] Nothing input + where + input = unlines + [ '\xfeff' : "foo :: Int" + , "foo = 3" + ] + + +-------------------------------------------------------------------------------- +testExtraExtensions :: Assertion +testExtraExtensions = assert $ isRight $ + parseModule ["TemplateHaskell"] Nothing "$(foo)" + + +-------------------------------------------------------------------------------- +isRight :: Either a b -> Bool +isRight (Right _) = True +isRight _ = False diff --git a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs @@ -0,0 +1,110 @@ +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish.Step.Imports.Tests + ( tests + ) where + + +-------------------------------------------------------------------------------- +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, (@=?)) + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Step.Imports +import Language.Haskell.Stylish.Tests.Util + + +-------------------------------------------------------------------------------- +tests :: Test +tests = testGroup "Language.Haskell.Stylish.Step.Imports.Tests" + [ testCase "case 01" case01 + , testCase "case 02" case02 + , testCase "case 03" case03 + , testCase "case 04" case04 + ] + + +-------------------------------------------------------------------------------- +input :: String +input = unlines + [ "module Herp where" + , "" + , "import qualified Data.Map as M" + , "import Control.Monad" + , "import Data.Map (lookup, (!), insert, Map)" + , "" + , "import Herp.Derp.Internals hiding (foo)" + , "import Foo (Bar (..))" + , "" + , "herp = putStrLn \"import Hello world\"" + ] + + +-------------------------------------------------------------------------------- +case01 :: Assertion +case01 = expected @=? testStep (step 80 Global) input + where + expected = unlines + [ "module Herp where" + , "" + , "import Control.Monad" + , "import Data.Map (Map, insert, lookup, (!))" + , "import qualified Data.Map as M" + , "" + , "import Foo (Bar (..))" + , "import Herp.Derp.Internals hiding (foo)" + , "" + , "herp = putStrLn \"import Hello world\"" + ] + + +-------------------------------------------------------------------------------- +case02 :: Assertion +case02 = expected @=? testStep (step 80 Group) input + where + expected = unlines + [ "module Herp where" + , "" + , "import Control.Monad" + , "import Data.Map (Map, insert, lookup, (!))" + , "import qualified Data.Map as M" + , "" + , "import Foo (Bar (..))" + , "import Herp.Derp.Internals hiding (foo)" + , "" + , "herp = putStrLn \"import Hello world\"" + ] + + +-------------------------------------------------------------------------------- +case03 :: Assertion +case03 = expected @=? testStep (step 80 None) input + where + expected = unlines + [ "module Herp where" + , "" + , "import Control.Monad" + , "import Data.Map (Map, insert, lookup, (!))" + , "import qualified Data.Map as M" + , "" + , "import Foo (Bar (..))" + , "import Herp.Derp.Internals hiding (foo)" + , "" + , "herp = putStrLn \"import Hello world\"" + ] + + +-------------------------------------------------------------------------------- +case04 :: Assertion +case04 = expected @=? testStep (step 80 Global) input' + where + input' = + "import Data.Aeson.Types (object, typeMismatch, FromJSON(..)," ++ + "ToJSON(..), Value(..), parseEither, (.!=), (.:), (.:?), (.=))" + + expected = unlines + [ "import Data.Aeson.Types (FromJSON (..), ToJSON (..), Value (..)," + , " object, parseEither, typeMismatch, (.!=)," + , " (.:), (.:?), (.=))" + ] diff --git a/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs b/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs @@ -0,0 +1,93 @@ +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish.Step.LanguagePragmas.Tests + ( tests + ) where + + +-------------------------------------------------------------------------------- +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, (@=?)) + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Step.LanguagePragmas +import Language.Haskell.Stylish.Tests.Util + + +-------------------------------------------------------------------------------- +tests :: Test +tests = testGroup "Language.Haskell.Stylish.Step.LanguagePragmas.Tests" + [ testCase "case 01" case01 + , testCase "case 02" case02 + , testCase "case 03" case03 + , testCase "case 04" case04 + ] + + +-------------------------------------------------------------------------------- +case01 :: Assertion +case01 = expected @=? testStep (step 80 Vertical False) input + where + input = unlines + [ "{-# LANGUAGE ViewPatterns #-}" + , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" + , "{-# LANGUAGE ScopedTypeVariables #-}" + , "module Main where" + ] + + expected = unlines + [ "{-# LANGUAGE ScopedTypeVariables #-}" + , "{-# LANGUAGE TemplateHaskell #-}" + , "{-# LANGUAGE ViewPatterns #-}" + , "module Main where" + ] + + +-------------------------------------------------------------------------------- +case02 :: Assertion +case02 = expected @=? testStep (step 80 Vertical True) input + where + input = unlines + [ "{-# LANGUAGE BangPatterns #-}" + , "{-# LANGUAGE ViewPatterns #-}" + , "increment ((+ 1) -> x) = x" + ] + + expected = unlines + [ "{-# LANGUAGE ViewPatterns #-}" + , "increment ((+ 1) -> x) = x" + ] + + +-------------------------------------------------------------------------------- +case03 :: Assertion +case03 = expected @=? testStep (step 80 Vertical True) input + where + input = unlines + [ "{-# LANGUAGE BangPatterns #-}" + , "{-# LANGUAGE ViewPatterns #-}" + , "increment x = case x of !_ -> x + 1" + ] + + expected = unlines + [ "{-# LANGUAGE BangPatterns #-}" + , "increment x = case x of !_ -> x + 1" + ] + + +-------------------------------------------------------------------------------- +case04 :: Assertion +case04 = expected @=? testStep (step 80 Compact False) input + where + input = unlines + [ "{-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable," + , " TemplateHaskell #-}" + , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" + ] + + expected = unlines + [ "{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, " ++ + "TemplateHaskell," + , " TypeOperators, ViewPatterns #-}" + ] diff --git a/tests/Language/Haskell/Stylish/Step/Records/Tests.hs b/tests/Language/Haskell/Stylish/Step/Records/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Language/Haskell/Stylish/Step/Records/Tests.hs @@ -0,0 +1,41 @@ +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish.Step.Records.Tests + ( tests + ) where + + +-------------------------------------------------------------------------------- +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, (@=?)) + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Step.Records +import Language.Haskell.Stylish.Tests.Util + + +-------------------------------------------------------------------------------- +tests :: Test +tests = testGroup "Language.Haskell.Stylish.Step.Records.Tests" + [ testCase "case 01" case01 + ] + + +-------------------------------------------------------------------------------- +case01 :: Assertion +case01 = expected @=? testStep step input + where + input = unlines + [ "data Foo = Foo" + , " { foo :: Int" + , " , barqux :: String" + , " } deriving (Show)" + ] + + expected = unlines + [ "data Foo = Foo" + , " { foo :: Int" + , " , barqux :: String" + , " } deriving (Show)" + ] diff --git a/tests/Language/Haskell/Stylish/Step/Tabs/Tests.hs b/tests/Language/Haskell/Stylish/Step/Tabs/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Language/Haskell/Stylish/Step/Tabs/Tests.hs @@ -0,0 +1,43 @@ +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish.Step.Tabs.Tests + ( tests + ) where + + +-------------------------------------------------------------------------------- +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, (@=?)) + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Step.Tabs +import Language.Haskell.Stylish.Tests.Util + + +-------------------------------------------------------------------------------- +tests :: Test +tests = testGroup "Language.Haskell.Stylish.Step.Tabs.Tests" + [ testCase "case 01" case01 + ] + + +-------------------------------------------------------------------------------- +case01 :: Assertion +case01 = expected @=? testStep (step 4) input + where + input = unlines + [ "module Main" + , "\t\twhere" + , "data Foo" + , "\t= Bar" + , " | Qux" + ] + + expected = unlines + [ "module Main" + , " where" + , "data Foo" + , " = Bar" + , " | Qux" + ] diff --git a/tests/Language/Haskell/Stylish/Step/TrailingWhitespace/Tests.hs b/tests/Language/Haskell/Stylish/Step/TrailingWhitespace/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Language/Haskell/Stylish/Step/TrailingWhitespace/Tests.hs @@ -0,0 +1,39 @@ +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish.Step.TrailingWhitespace.Tests + ( tests + ) where + + +-------------------------------------------------------------------------------- +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, (@=?)) + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Step.TrailingWhitespace +import Language.Haskell.Stylish.Tests.Util + + +-------------------------------------------------------------------------------- +tests :: Test +tests = testGroup "Language.Haskell.Stylish.Step.TrailingWhitespace.Tests" + [ testCase "case 01" case01 + ] + + +-------------------------------------------------------------------------------- +case01 :: Assertion +case01 = expected @=? testStep step input + where + input = unlines + [ "module Main where" + , " " + , "data Foo = Bar | Qux\t " + ] + + expected = unlines + [ "module Main where" + , "" + , "data Foo = Bar | Qux" + ] diff --git a/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs b/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs @@ -0,0 +1,38 @@ +-------------------------------------------------------------------------------- +module Language.Haskell.Stylish.Step.UnicodeSyntax.Tests + ( tests + ) where + + +-------------------------------------------------------------------------------- +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, (@=?)) + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Step.UnicodeSyntax +import Language.Haskell.Stylish.Tests.Util + + +-------------------------------------------------------------------------------- +tests :: Test +tests = testGroup "Language.Haskell.Stylish.Step.UnicodeSyntax.Tests" + [ testCase "case 01" case01 + ] + + +-------------------------------------------------------------------------------- +case01 :: Assertion +case01 = expected @=? testStep (step True) input + where + input = unlines + [ "sort :: Ord a => [a] -> [a]" + , "sort _ = []" + ] + + expected = unlines + [ "{-# LANGUAGE UnicodeSyntax #-}" + , "sort ∷ Ord a ⇒ [a] → [a]" + , "sort _ = []" + ] diff --git a/tests/Language/Haskell/Stylish/Tests/Util.hs b/tests/Language/Haskell/Stylish/Tests/Util.hs new file mode 100644 --- /dev/null +++ b/tests/Language/Haskell/Stylish/Tests/Util.hs @@ -0,0 +1,17 @@ +module Language.Haskell.Stylish.Tests.Util + ( testStep + ) where + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Parse +import Language.Haskell.Stylish.Step + + +-------------------------------------------------------------------------------- +testStep :: Step -> String -> String +testStep step str = case parseModule [] Nothing str of + Left err -> error err + Right module' -> unlines $ stepFilter step ls module' + where + ls = lines str diff --git a/tests/StylishHaskell/Parse/Tests.hs b/tests/StylishHaskell/Parse/Tests.hs deleted file mode 100644 --- a/tests/StylishHaskell/Parse/Tests.hs +++ /dev/null @@ -1,44 +0,0 @@ --------------------------------------------------------------------------------- -module StylishHaskell.Parse.Tests - ( tests - ) where - - --------------------------------------------------------------------------------- -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, assert) - - --------------------------------------------------------------------------------- -import StylishHaskell.Parse - - --------------------------------------------------------------------------------- -tests :: Test -tests = testGroup "StylishHaskell.Parse" - [ testCase "UTF-8 Byte Order Mark" testBom - , testCase "Extra extensions" testExtraExtensions - ] - - --------------------------------------------------------------------------------- -testBom :: Assertion -testBom = assert $ isRight $ parseModule [] Nothing input - where - input = unlines - [ '\xfeff' : "foo :: Int" - , "foo = 3" - ] - - --------------------------------------------------------------------------------- -testExtraExtensions :: Assertion -testExtraExtensions = assert $ isRight $ - parseModule ["TemplateHaskell"] Nothing "$(foo)" - - --------------------------------------------------------------------------------- -isRight :: Either a b -> Bool -isRight (Right _) = True -isRight _ = False diff --git a/tests/StylishHaskell/Step/Imports/Tests.hs b/tests/StylishHaskell/Step/Imports/Tests.hs deleted file mode 100644 --- a/tests/StylishHaskell/Step/Imports/Tests.hs +++ /dev/null @@ -1,110 +0,0 @@ --------------------------------------------------------------------------------- -module StylishHaskell.Step.Imports.Tests - ( tests - ) where - - --------------------------------------------------------------------------------- -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, (@=?)) - - --------------------------------------------------------------------------------- -import StylishHaskell.Step.Imports -import StylishHaskell.Tests.Util - - --------------------------------------------------------------------------------- -tests :: Test -tests = testGroup "StylishHaskell.Step.Imports.Tests" - [ testCase "case 01" case01 - , testCase "case 02" case02 - , testCase "case 03" case03 - , testCase "case 04" case04 - ] - - --------------------------------------------------------------------------------- -input :: String -input = unlines - [ "module Herp where" - , "" - , "import qualified Data.Map as M" - , "import Control.Monad" - , "import Data.Map (lookup, (!), insert, Map)" - , "" - , "import Herp.Derp.Internals hiding (foo)" - , "import Foo (Bar (..))" - , "" - , "herp = putStrLn \"import Hello world\"" - ] - - --------------------------------------------------------------------------------- -case01 :: Assertion -case01 = expected @=? testStep (step 80 Global) input - where - expected = unlines - [ "module Herp where" - , "" - , "import Control.Monad" - , "import Data.Map (Map, insert, lookup, (!))" - , "import qualified Data.Map as M" - , "" - , "import Foo (Bar (..))" - , "import Herp.Derp.Internals hiding (foo)" - , "" - , "herp = putStrLn \"import Hello world\"" - ] - - --------------------------------------------------------------------------------- -case02 :: Assertion -case02 = expected @=? testStep (step 80 Group) input - where - expected = unlines - [ "module Herp where" - , "" - , "import Control.Monad" - , "import Data.Map (Map, insert, lookup, (!))" - , "import qualified Data.Map as M" - , "" - , "import Foo (Bar (..))" - , "import Herp.Derp.Internals hiding (foo)" - , "" - , "herp = putStrLn \"import Hello world\"" - ] - - --------------------------------------------------------------------------------- -case03 :: Assertion -case03 = expected @=? testStep (step 80 None) input - where - expected = unlines - [ "module Herp where" - , "" - , "import Control.Monad" - , "import Data.Map (Map, insert, lookup, (!))" - , "import qualified Data.Map as M" - , "" - , "import Foo (Bar (..))" - , "import Herp.Derp.Internals hiding (foo)" - , "" - , "herp = putStrLn \"import Hello world\"" - ] - - --------------------------------------------------------------------------------- -case04 :: Assertion -case04 = expected @=? testStep (step 80 Global) input' - where - input' = - "import Data.Aeson.Types (object, typeMismatch, FromJSON(..)," ++ - "ToJSON(..), Value(..), parseEither, (.!=), (.:), (.:?), (.=))" - - expected = unlines - [ "import Data.Aeson.Types (FromJSON (..), ToJSON (..), Value (..)," - , " object, parseEither, typeMismatch, (.!=)," - , " (.:), (.:?), (.=))" - ] diff --git a/tests/StylishHaskell/Step/LanguagePragmas/Tests.hs b/tests/StylishHaskell/Step/LanguagePragmas/Tests.hs deleted file mode 100644 --- a/tests/StylishHaskell/Step/LanguagePragmas/Tests.hs +++ /dev/null @@ -1,93 +0,0 @@ --------------------------------------------------------------------------------- -module StylishHaskell.Step.LanguagePragmas.Tests - ( tests - ) where - - --------------------------------------------------------------------------------- -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, (@=?)) - - --------------------------------------------------------------------------------- -import StylishHaskell.Step.LanguagePragmas -import StylishHaskell.Tests.Util - - --------------------------------------------------------------------------------- -tests :: Test -tests = testGroup "StylishHaskell.Step.LanguagePragmas.Tests" - [ testCase "case 01" case01 - , testCase "case 02" case02 - , testCase "case 03" case03 - , testCase "case 04" case04 - ] - - --------------------------------------------------------------------------------- -case01 :: Assertion -case01 = expected @=? testStep (step 80 Vertical False) input - where - input = unlines - [ "{-# LANGUAGE ViewPatterns #-}" - , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" - , "{-# LANGUAGE ScopedTypeVariables #-}" - , "module Main where" - ] - - expected = unlines - [ "{-# LANGUAGE ScopedTypeVariables #-}" - , "{-# LANGUAGE TemplateHaskell #-}" - , "{-# LANGUAGE ViewPatterns #-}" - , "module Main where" - ] - - --------------------------------------------------------------------------------- -case02 :: Assertion -case02 = expected @=? testStep (step 80 Vertical True) input - where - input = unlines - [ "{-# LANGUAGE BangPatterns #-}" - , "{-# LANGUAGE ViewPatterns #-}" - , "increment ((+ 1) -> x) = x" - ] - - expected = unlines - [ "{-# LANGUAGE ViewPatterns #-}" - , "increment ((+ 1) -> x) = x" - ] - - --------------------------------------------------------------------------------- -case03 :: Assertion -case03 = expected @=? testStep (step 80 Vertical True) input - where - input = unlines - [ "{-# LANGUAGE BangPatterns #-}" - , "{-# LANGUAGE ViewPatterns #-}" - , "increment x = case x of !_ -> x + 1" - ] - - expected = unlines - [ "{-# LANGUAGE BangPatterns #-}" - , "increment x = case x of !_ -> x + 1" - ] - - --------------------------------------------------------------------------------- -case04 :: Assertion -case04 = expected @=? testStep (step 80 Compact False) input - where - input = unlines - [ "{-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable," - , " TemplateHaskell #-}" - , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" - ] - - expected = unlines - [ "{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, " ++ - "TemplateHaskell," - , " TypeOperators, ViewPatterns #-}" - ] diff --git a/tests/StylishHaskell/Step/Records/Tests.hs b/tests/StylishHaskell/Step/Records/Tests.hs deleted file mode 100644 --- a/tests/StylishHaskell/Step/Records/Tests.hs +++ /dev/null @@ -1,41 +0,0 @@ --------------------------------------------------------------------------------- -module StylishHaskell.Step.Records.Tests - ( tests - ) where - - --------------------------------------------------------------------------------- -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, (@=?)) - - --------------------------------------------------------------------------------- -import StylishHaskell.Step.Records -import StylishHaskell.Tests.Util - - --------------------------------------------------------------------------------- -tests :: Test -tests = testGroup "StylishHaskell.Step.Records.Tests" - [ testCase "case 01" case01 - ] - - --------------------------------------------------------------------------------- -case01 :: Assertion -case01 = expected @=? testStep step input - where - input = unlines - [ "data Foo = Foo" - , " { foo :: Int" - , " , barqux :: String" - , " } deriving (Show)" - ] - - expected = unlines - [ "data Foo = Foo" - , " { foo :: Int" - , " , barqux :: String" - , " } deriving (Show)" - ] diff --git a/tests/StylishHaskell/Step/Tabs/Tests.hs b/tests/StylishHaskell/Step/Tabs/Tests.hs deleted file mode 100644 --- a/tests/StylishHaskell/Step/Tabs/Tests.hs +++ /dev/null @@ -1,43 +0,0 @@ --------------------------------------------------------------------------------- -module StylishHaskell.Step.Tabs.Tests - ( tests - ) where - - --------------------------------------------------------------------------------- -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, (@=?)) - - --------------------------------------------------------------------------------- -import StylishHaskell.Step.Tabs -import StylishHaskell.Tests.Util - - --------------------------------------------------------------------------------- -tests :: Test -tests = testGroup "StylishHaskell.Step.Tabs.Tests" - [ testCase "case 01" case01 - ] - - --------------------------------------------------------------------------------- -case01 :: Assertion -case01 = expected @=? testStep (step 4) input - where - input = unlines - [ "module Main" - , "\t\twhere" - , "data Foo" - , "\t= Bar" - , " | Qux" - ] - - expected = unlines - [ "module Main" - , " where" - , "data Foo" - , " = Bar" - , " | Qux" - ] diff --git a/tests/StylishHaskell/Step/TrailingWhitespace/Tests.hs b/tests/StylishHaskell/Step/TrailingWhitespace/Tests.hs deleted file mode 100644 --- a/tests/StylishHaskell/Step/TrailingWhitespace/Tests.hs +++ /dev/null @@ -1,39 +0,0 @@ --------------------------------------------------------------------------------- -module StylishHaskell.Step.TrailingWhitespace.Tests - ( tests - ) where - - --------------------------------------------------------------------------------- -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, (@=?)) - - --------------------------------------------------------------------------------- -import StylishHaskell.Step.TrailingWhitespace -import StylishHaskell.Tests.Util - - --------------------------------------------------------------------------------- -tests :: Test -tests = testGroup "StylishHaskell.Step.TrailingWhitespace.Tests" - [ testCase "case 01" case01 - ] - - --------------------------------------------------------------------------------- -case01 :: Assertion -case01 = expected @=? testStep step input - where - input = unlines - [ "module Main where" - , " " - , "data Foo = Bar | Qux\t " - ] - - expected = unlines - [ "module Main where" - , "" - , "data Foo = Bar | Qux" - ] diff --git a/tests/StylishHaskell/Step/UnicodeSyntax/Tests.hs b/tests/StylishHaskell/Step/UnicodeSyntax/Tests.hs deleted file mode 100644 --- a/tests/StylishHaskell/Step/UnicodeSyntax/Tests.hs +++ /dev/null @@ -1,38 +0,0 @@ --------------------------------------------------------------------------------- -module StylishHaskell.Step.UnicodeSyntax.Tests - ( tests - ) where - - --------------------------------------------------------------------------------- -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, (@=?)) - - --------------------------------------------------------------------------------- -import StylishHaskell.Step.UnicodeSyntax -import StylishHaskell.Tests.Util - - --------------------------------------------------------------------------------- -tests :: Test -tests = testGroup "StylishHaskell.Step.UnicodeSyntax.Tests" - [ testCase "case 01" case01 - ] - - --------------------------------------------------------------------------------- -case01 :: Assertion -case01 = expected @=? testStep (step True) input - where - input = unlines - [ "sort :: Ord a => [a] -> [a]" - , "sort _ = []" - ] - - expected = unlines - [ "{-# LANGUAGE UnicodeSyntax #-}" - , "sort ∷ Ord a ⇒ [a] → [a]" - , "sort _ = []" - ] diff --git a/tests/StylishHaskell/Tests/Util.hs b/tests/StylishHaskell/Tests/Util.hs deleted file mode 100644 --- a/tests/StylishHaskell/Tests/Util.hs +++ /dev/null @@ -1,17 +0,0 @@ -module StylishHaskell.Tests.Util - ( testStep - ) where - - --------------------------------------------------------------------------------- -import StylishHaskell.Parse -import StylishHaskell.Step - - --------------------------------------------------------------------------------- -testStep :: Step -> String -> String -testStep step str = case parseModule [] Nothing str of - Left err -> error err - Right module' -> unlines $ stepFilter step ls module' - where - ls = lines str diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs --- a/tests/TestSuite.hs +++ b/tests/TestSuite.hs @@ -9,23 +9,23 @@ -------------------------------------------------------------------------------- -import qualified StylishHaskell.Parse.Tests -import qualified StylishHaskell.Step.Imports.Tests -import qualified StylishHaskell.Step.LanguagePragmas.Tests -import qualified StylishHaskell.Step.Records.Tests -import qualified StylishHaskell.Step.Tabs.Tests -import qualified StylishHaskell.Step.TrailingWhitespace.Tests -import qualified StylishHaskell.Step.UnicodeSyntax.Tests +import qualified Language.Haskell.Stylish.Parse.Tests +import qualified Language.Haskell.Stylish.Step.Imports.Tests +import qualified Language.Haskell.Stylish.Step.LanguagePragmas.Tests +import qualified Language.Haskell.Stylish.Step.Records.Tests +import qualified Language.Haskell.Stylish.Step.Tabs.Tests +import qualified Language.Haskell.Stylish.Step.TrailingWhitespace.Tests +import qualified Language.Haskell.Stylish.Step.UnicodeSyntax.Tests -------------------------------------------------------------------------------- main :: IO () main = defaultMain - [ StylishHaskell.Parse.Tests.tests - , StylishHaskell.Step.Imports.Tests.tests - , StylishHaskell.Step.LanguagePragmas.Tests.tests - , StylishHaskell.Step.Records.Tests.tests - , StylishHaskell.Step.Tabs.Tests.tests - , StylishHaskell.Step.TrailingWhitespace.Tests.tests - , StylishHaskell.Step.UnicodeSyntax.Tests.tests + [ Language.Haskell.Stylish.Parse.Tests.tests + , Language.Haskell.Stylish.Step.Imports.Tests.tests + , Language.Haskell.Stylish.Step.LanguagePragmas.Tests.tests + , Language.Haskell.Stylish.Step.Records.Tests.tests + , Language.Haskell.Stylish.Step.Tabs.Tests.tests + , Language.Haskell.Stylish.Step.TrailingWhitespace.Tests.tests + , Language.Haskell.Stylish.Step.UnicodeSyntax.Tests.tests ]