diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml new file mode 100644 --- /dev/null +++ b/.stylish-haskell.yaml @@ -0,0 +1,55 @@ +# 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 + + # 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: {} diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,48 +1,65 @@ -------------------------------------------------------------------------------- +{-# LANGUAGE DeriveDataTypeable #-} module Main ( main ) where -------------------------------------------------------------------------------- -import Control.Applicative ((<$>)) -import Data.Maybe (listToMaybe) -import System.Environment (getArgs) +import Control.Monad (forM_) +import Data.List (intercalate) +import Data.Maybe (listToMaybe) +import Data.Version (Version(..)) +import System.Console.CmdArgs -------------------------------------------------------------------------------- -import qualified StylishHaskell.Imports -import qualified StylishHaskell.LanguagePragmas -import StylishHaskell.Parse -import StylishHaskell.Stylish -import qualified StylishHaskell.TrailingWhitespace +import Paths_stylish_haskell (version) +import StylishHaskell +import StylishHaskell.Config +import StylishHaskell.Step +import StylishHaskell.Verbose -------------------------------------------------------------------------------- -runStylish :: Maybe FilePath -> Stylish -> Lines -> Lines -runStylish mfp f ls = case parseModule mfp (unlines ls) of - Left err -> error err -- TODO: maybe return original lines? - Right module' -> f ls module' +data StylishArgs = StylishArgs + { config :: Maybe FilePath + , verbose :: Bool + , defaults :: Bool + , files :: [FilePath] + } deriving (Data, Show, Typeable) -------------------------------------------------------------------------------- -chainStylish :: Maybe FilePath -> [Stylish] -> Lines -> Lines -chainStylish mfp filters = foldr (.) id filters' +stylishArgs :: StylishArgs +stylishArgs = StylishArgs + { config = Nothing &= typFile &= help "Configuration file" + , verbose = False &= help "Run in verbose mode" + , defaults = False &= help "Dump default config and exit" + , files = [] &= typFile &= args + } &= summary ("stylish-haskell-" ++ versionString version) where - filters' :: [Lines -> Lines] - filters' = map (runStylish mfp) filters + versionString = intercalate "." . map show . versionBranch -------------------------------------------------------------------------------- main :: IO () -main = do - filePath <- listToMaybe <$> getArgs - contents <- maybe getContents readFile filePath - putStr $ unlines $ chainStylish filePath filters $ lines contents +main = cmdArgs stylishArgs >>= stylishHaskell + + +-------------------------------------------------------------------------------- +stylishHaskell :: StylishArgs -> IO () +stylishHaskell sa + | defaults sa = do + fileName <- defaultConfigFilePath + verbose' $ "Dumping config from " ++ fileName + readFile fileName >>= putStr + | otherwise = do + conf <- loadConfig verbose' (config sa) + let steps = configSteps conf + forM_ steps $ \s -> verbose' $ "Enabled " ++ stepName s ++ " step" + contents <- maybe getContents readFile filePath + putStr $ unlines $ runSteps filePath steps $ lines contents where - filters = - [ StylishHaskell.Imports.stylish - , StylishHaskell.LanguagePragmas.stylish - -- , StylishHaskell.Tabs.stylish - , StylishHaskell.TrailingWhitespace.stylish - ] + verbose' = makeVerbose (verbose sa) + filePath = listToMaybe $ files sa diff --git a/src/StylishHaskell.hs b/src/StylishHaskell.hs new file mode 100644 --- /dev/null +++ b/src/StylishHaskell.hs @@ -0,0 +1,22 @@ +-------------------------------------------------------------------------------- +module StylishHaskell + ( runStep + , runSteps + ) where + + +-------------------------------------------------------------------------------- +import StylishHaskell.Parse +import StylishHaskell.Step + + +-------------------------------------------------------------------------------- +runStep :: Maybe FilePath -> Step -> Lines -> Lines +runStep mfp step ls = case parseModule mfp (unlines ls) of + Left err -> error err -- TODO: maybe return original lines? + Right module' -> stepFilter step ls module' + + +-------------------------------------------------------------------------------- +runSteps :: Maybe FilePath -> [Step] -> Lines -> Lines +runSteps mfp = foldr (flip (.)) id . map (runStep mfp) diff --git a/src/StylishHaskell/Block.hs b/src/StylishHaskell/Block.hs --- a/src/StylishHaskell/Block.hs +++ b/src/StylishHaskell/Block.hs @@ -1,8 +1,11 @@ -------------------------------------------------------------------------------- module StylishHaskell.Block ( Block (..) + , LineBlock + , SpanBlock , blockLength - , fromSrcSpanInfo + , linesFromSrcSpan + , spanFromSrcSpan , moveBlock , adjacent , merge @@ -17,43 +20,58 @@ -------------------------------------------------------------------------------- -- | Indicates a line span -data Block = Block +data Block a = Block { blockStart :: Int , blockEnd :: Int } deriving (Eq, Ord, Show) -------------------------------------------------------------------------------- -blockLength :: Block -> Int +type LineBlock = Block String + + +-------------------------------------------------------------------------------- +type SpanBlock = Block Char + + +-------------------------------------------------------------------------------- +blockLength :: Block a -> Int blockLength (Block start end) = end - start + 1 -------------------------------------------------------------------------------- -fromSrcSpanInfo :: H.SrcSpanInfo -> Block -fromSrcSpanInfo = H.srcInfoSpan >>> +linesFromSrcSpan :: H.SrcSpanInfo -> LineBlock +linesFromSrcSpan = H.srcInfoSpan >>> H.srcSpanStartLine &&& H.srcSpanEndLine >>> arr (uncurry Block) -------------------------------------------------------------------------------- -moveBlock :: Int -> Block -> 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 -> Block -> Bool +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 -> Block -> Block +merge :: Block a -> Block a -> Block a merge (Block s1 e1) (Block s2 e2) = Block (min s1 s2) (max e1 e2) -------------------------------------------------------------------------------- -overlapping :: [Block] -> Bool +overlapping :: [Block a] -> Bool overlapping blocks = any (uncurry overlapping') $ zip blocks (drop 1 blocks) where diff --git a/src/StylishHaskell/Config.hs b/src/StylishHaskell/Config.hs new file mode 100644 --- /dev/null +++ b/src/StylishHaskell/Config.hs @@ -0,0 +1,175 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} +module StylishHaskell.Config + ( Config (..) + , defaultConfigFilePath + , configFilePath + , loadConfig + ) where + + +-------------------------------------------------------------------------------- +import Control.Applicative ((<$>), (<*>)) +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.Tabs as Tabs +import qualified StylishHaskell.Step.TrailingWhitespace as TrailingWhitespace +import qualified StylishHaskell.Step.UnicodeSyntax as UnicodeSyntax +import StylishHaskell.Verbose + + +-------------------------------------------------------------------------------- +data Config = Config + { configSteps :: [Step] + } + + +-------------------------------------------------------------------------------- +instance FromJSON Config where + parseJSON = parseConfig + + +-------------------------------------------------------------------------------- +emptyConfig :: Config +emptyConfig = Config [] + + +-------------------------------------------------------------------------------- +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) = Config + <$> (o A..: "steps" >>= fmap concat . mapM parseSteps) +parseConfig _ = mzero + + +-------------------------------------------------------------------------------- +catalog :: Map String (A.Object -> A.Parser Step) +catalog = M.fromList + [ ("imports", parseImports) + , ("language_pragmas", parseLanguagePragmas) + , ("tabs", parseTabs) + , ("trailing_whitespace", parseTrailingWhitespace) + , ("unicode_syntax", parseUnicodeSyntax) + ] + + +-------------------------------------------------------------------------------- +parseSteps :: A.Value -> A.Parser [Step] +parseSteps 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 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 :: A.Object -> A.Parser Step +parseImports o = Imports.step + <$> (o A..:? "align" >>= parseEnum aligns Imports.Global) + where + aligns = + [ ("global", Imports.Global) + , ("group", Imports.Group) + , ("none", Imports.None) + ] + + +-------------------------------------------------------------------------------- +parseLanguagePragmas :: A.Object -> A.Parser Step +parseLanguagePragmas o = LanguagePragmas.step + <$> (o A..:? "style" >>= parseEnum styles LanguagePragmas.Vertical) + <*> o A..:? "remove_redundant" A..!= True + where + styles = + [ ("vertical", LanguagePragmas.Vertical) + , ("compact", LanguagePragmas.Compact) + ] + + +-------------------------------------------------------------------------------- +parseTabs :: A.Object -> A.Parser Step +parseTabs o = Tabs.step + <$> o A..:? "spaces" A..!= 8 + + +-------------------------------------------------------------------------------- +parseTrailingWhitespace :: A.Object -> A.Parser Step +parseTrailingWhitespace _ = return TrailingWhitespace.step + + +-------------------------------------------------------------------------------- +parseUnicodeSyntax :: 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 --- a/src/StylishHaskell/Editor.hs +++ b/src/StylishHaskell/Editor.hs @@ -20,30 +20,29 @@ -------------------------------------------------------------------------------- import StylishHaskell.Block -import StylishHaskell.Stylish -------------------------------------------------------------------------------- -- | Changes the lines indicated by the 'Block' into the given 'Lines' -data Change = Change - { changeBlock :: Block - , changeLines :: Lines +data Change a = Change + { changeBlock :: Block a + , changeLines :: [a] } deriving (Eq, Show) -------------------------------------------------------------------------------- -moveChange :: Int -> Change -> Change +moveChange :: Int -> Change a -> Change a moveChange offset (Change block ls) = Change (moveBlock offset block) ls -------------------------------------------------------------------------------- -- | Number of additional lines introduced when a change is made. -changeExtraLines :: Change -> Int +changeExtraLines :: Change a -> Int changeExtraLines (Change block ls) = length ls - blockLength block -------------------------------------------------------------------------------- -applyChanges :: [Change] -> Lines -> Lines +applyChanges :: [Change a] -> [a] -> [a] applyChanges changes | overlapping blocks = error $ "StylishHaskell.Editor.applyChanges: " ++ @@ -77,29 +76,29 @@ -------------------------------------------------------------------------------- -- | Change a block of lines for some other lines -change :: Block -> Lines -> Change +change :: Block a -> [a] -> Change a change = Change -------------------------------------------------------------------------------- -- | Change a single line for some other lines -changeLine :: Int -> Lines -> Change +changeLine :: Int -> [a] -> Change a changeLine start = change (Block start start) -------------------------------------------------------------------------------- -- | Delete a block of lines -delete :: Block -> Change +delete :: Block a -> Change a delete block = Change block [] -------------------------------------------------------------------------------- -- | Delete a single line -deleteLine :: Int -> Change +deleteLine :: Int -> Change a deleteLine start = delete (Block start start) -------------------------------------------------------------------------------- -- | Insert something /before/ the given lines -insert :: Int -> Lines -> Change +insert :: Int -> [a] -> Change a insert start = Change (Block start (start - 1)) diff --git a/src/StylishHaskell/Imports.hs b/src/StylishHaskell/Imports.hs deleted file mode 100644 --- a/src/StylishHaskell/Imports.hs +++ /dev/null @@ -1,110 +0,0 @@ --------------------------------------------------------------------------------- -module StylishHaskell.Imports - ( stylish - ) where - - --------------------------------------------------------------------------------- -import Control.Arrow ((&&&)) -import Data.Char (isAlpha) -import Data.List (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.Stylish -import StylishHaskell.Util - - --------------------------------------------------------------------------------- -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 Block] -> [(Block, [H.ImportDecl Block])] -groupAdjacent = foldr step [] - where - -- This code is ugly and not optimal, and no fucks were given. - step 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 (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 - - --------------------------------------------------------------------------------- -prettyImport :: Int -> H.ImportDecl l -> String -prettyImport longest imp = unwords $ concat - [ ["import"] - , [if H.importQualified imp then "qualified" else " "] - , [(if hasExtras then padRight longest else id) (importName imp)] - , ["as " ++ as | H.ModuleName _ as <- maybeToList $ H.importAs imp] - , [H.prettyPrint specs | specs <- maybeToList $ H.importSpecs imp] - ] - where - hasExtras = isJust (H.importAs imp) || isJust (H.importSpecs imp) - - --------------------------------------------------------------------------------- -prettyImportGroup :: Int -> [H.ImportDecl Block] -> Lines -prettyImportGroup longest = map (prettyImport longest) . sortBy compareImports - - --------------------------------------------------------------------------------- -stylish :: Stylish -stylish ls (module', _) = flip applyChanges ls - [ change block (prettyImportGroup longest importGroup) - | (block, importGroup) <- groups - ] - where - imps = map sortImportSpecs $ imports $ fmap fromSrcSpanInfo module' - longest = longestImport imps - groups = groupAdjacent imps diff --git a/src/StylishHaskell/LanguagePragmas.hs b/src/StylishHaskell/LanguagePragmas.hs deleted file mode 100644 --- a/src/StylishHaskell/LanguagePragmas.hs +++ /dev/null @@ -1,53 +0,0 @@ --------------------------------------------------------------------------------- -module StylishHaskell.LanguagePragmas - ( stylish - ) where - - --------------------------------------------------------------------------------- -import Data.List (nub, sort) -import qualified Language.Haskell.Exts.Annotated as H - - --------------------------------------------------------------------------------- -import StylishHaskell.Block -import StylishHaskell.Editor -import StylishHaskell.Stylish -import StylishHaskell.Util - - --------------------------------------------------------------------------------- -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, [String])] -> Int -firstLocation = minimum . map (blockStart . fst) - - --------------------------------------------------------------------------------- --- | TODO: multiple lines if longer than 80 columns -prettyPragmas :: [String] -> Lines -prettyPragmas pragmas' = - [ "{-# LANGUAGE " ++ padRight longest pragma ++ " #-}" - | pragma <- pragmas' - ] - where - longest = maximum $ map length pragmas' - - --------------------------------------------------------------------------------- -stylish :: Stylish -stylish ls (module', _) - | null pragmas' = ls - | otherwise = applyChanges changes ls - where - pragmas' = pragmas $ fmap fromSrcSpanInfo module' - deletes = map (delete . fst) pragmas' - uniques = nub $ sort $ concatMap snd pragmas' - loc = firstLocation pragmas' - changes = insert loc (prettyPragmas uniques) : deletes diff --git a/src/StylishHaskell/Parse.hs b/src/StylishHaskell/Parse.hs --- a/src/StylishHaskell/Parse.hs +++ b/src/StylishHaskell/Parse.hs @@ -10,7 +10,7 @@ -------------------------------------------------------------------------------- -import StylishHaskell.Stylish +import StylishHaskell.Step -------------------------------------------------------------------------------- diff --git a/src/StylishHaskell/Step.hs b/src/StylishHaskell/Step.hs new file mode 100644 --- /dev/null +++ b/src/StylishHaskell/Step.hs @@ -0,0 +1,32 @@ +-------------------------------------------------------------------------------- +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 new file mode 100644 --- /dev/null +++ b/src/StylishHaskell/Step/Imports.hs @@ -0,0 +1,142 @@ +-------------------------------------------------------------------------------- +module StylishHaskell.Step.Imports + ( Align (..) + , step + ) where + + +-------------------------------------------------------------------------------- +import Control.Arrow ((&&&)) +import Data.Char (isAlpha) +import Data.List (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 (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 + + +-------------------------------------------------------------------------------- +prettyImport :: Bool -> Bool -> Int -> H.ImportDecl l -> String +prettyImport padQualified padName longest imp = unwords $ concat + [ ["import"] + , qualified + , [(if hasExtras && padName then padRight longest else id) (importName imp)] + , ["as " ++ as | H.ModuleName _ as <- maybeToList $ H.importAs imp] + , [H.prettyPrint specs | specs <- maybeToList $ H.importSpecs imp] + ] + where + hasExtras = isJust (H.importAs imp) || isJust (H.importSpecs imp) + + qualified + | H.importQualified imp = ["qualified"] + | padQualified = [" "] + | otherwise = [] + + +-------------------------------------------------------------------------------- +prettyImportGroup :: Align -> Int -> [H.ImportDecl LineBlock] -> Lines +prettyImportGroup align longest imps = + map (prettyImport 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 :: Align -> Step +step = makeStep "Imports" . step' + + +-------------------------------------------------------------------------------- +step' :: Align -> Lines -> Module -> Lines +step' align ls (module', _) = flip applyChanges ls + [ change block (prettyImportGroup 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 new file mode 100644 --- /dev/null +++ b/src/StylishHaskell/Step/LanguagePragmas.hs @@ -0,0 +1,120 @@ +-------------------------------------------------------------------------------- +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) + + +-------------------------------------------------------------------------------- +-- | TODO: multiple lines if longer than 80 columns +verticalPragmas :: [String] -> Lines +verticalPragmas pragmas' = + [ "{-# LANGUAGE " ++ padRight longest pragma ++ " #-}" + | pragma <- pragmas' + ] + where + longest = maximum $ map length pragmas' + + +-------------------------------------------------------------------------------- +compactPragmas :: [String] -> Lines +compactPragmas pragmas' = wrap 80 "{-# LANGUAGE" 13 $ + map (++ ",") (init pragmas') ++ [last pragmas', "#-}"] + + +-------------------------------------------------------------------------------- +prettyPragmas :: Style -> [String] -> Lines +prettyPragmas Vertical = verticalPragmas +prettyPragmas Compact = compactPragmas + + +-------------------------------------------------------------------------------- +step :: Style -> Bool -> Step +step style = makeStep "LanguagePragmas" . step' style + + +-------------------------------------------------------------------------------- +step' :: Style -> Bool -> Lines -> Module -> Lines +step' 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 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/Tabs.hs b/src/StylishHaskell/Step/Tabs.hs new file mode 100644 --- /dev/null +++ b/src/StylishHaskell/Step/Tabs.hs @@ -0,0 +1,21 @@ +-------------------------------------------------------------------------------- +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 new file mode 100644 --- /dev/null +++ b/src/StylishHaskell/Step/TrailingWhitespace.hs @@ -0,0 +1,22 @@ +-------------------------------------------------------------------------------- +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 new file mode 100644 --- /dev/null +++ b/src/StylishHaskell/Step/UnicodeSyntax.hs @@ -0,0 +1,135 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE ViewPatterns #-} +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)])] -> Lines -> [Change String] +replaceAll positions ls = + zipWith changeLine' positions $ selectLines (map fst positions) ls + where + changeLine' (r, ns) str = changeLine r $ return $ flip applyChanges str + [ change (Block c ec) repl + | (c, needle) <- sort ns + , let ec = c + length needle - 1 + , repl <- maybeToList $ M.lookup needle unicodeReplacements + ] + + + +-------------------------------------------------------------------------------- +selectLines :: [Int] -> Lines -> [String] +selectLines = go 1 + where + go _ [] _ = [] + go _ _ [] = [] + go r (x : xs) (l : ls) + | r == x = l : go (r + 1) xs ls + | otherwise = go (r + 1) (x : xs) ls + + +-------------------------------------------------------------------------------- +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 + withHead _ [] = [] + withHead f (x : xs) = (f x) : xs + + withLast f [x] = [f x] + withLast f (x : xs) = x : withLast f xs + withLast _ [] = [] + + 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 ls + perLine = sort $ groupPerLine $ + typeSigs module' ls ++ + contexts module' ls ++ + typeFuns module' ls diff --git a/src/StylishHaskell/Stylish.hs b/src/StylishHaskell/Stylish.hs deleted file mode 100644 --- a/src/StylishHaskell/Stylish.hs +++ /dev/null @@ -1,23 +0,0 @@ --------------------------------------------------------------------------------- -module StylishHaskell.Stylish - ( Lines - , Module - , Stylish - ) where - - --------------------------------------------------------------------------------- -import qualified Language.Haskell.Exts.Annotated as H - - --------------------------------------------------------------------------------- -type Lines = [String] - - --------------------------------------------------------------------------------- --- | Concrete module type -type Module = (H.Module H.SrcSpanInfo, [H.Comment]) - - --------------------------------------------------------------------------------- -type Stylish = Lines -> Module -> Lines diff --git a/src/StylishHaskell/Tabs.hs b/src/StylishHaskell/Tabs.hs deleted file mode 100644 --- a/src/StylishHaskell/Tabs.hs +++ /dev/null @@ -1,21 +0,0 @@ --------------------------------------------------------------------------------- -module StylishHaskell.Tabs - ( stylish - ) where - - --------------------------------------------------------------------------------- -import StylishHaskell.Stylish - - --------------------------------------------------------------------------------- -removeTabs :: String -> String -removeTabs = concatMap removeTabs' - where - removeTabs' '\t' = " " - removeTabs' x = [x] - - --------------------------------------------------------------------------------- -stylish :: Stylish -stylish ls _ = map removeTabs ls diff --git a/src/StylishHaskell/TrailingWhitespace.hs b/src/StylishHaskell/TrailingWhitespace.hs deleted file mode 100644 --- a/src/StylishHaskell/TrailingWhitespace.hs +++ /dev/null @@ -1,22 +0,0 @@ --------------------------------------------------------------------------------- -module StylishHaskell.TrailingWhitespace - ( stylish - ) where - - --------------------------------------------------------------------------------- -import Data.Char (isSpace) - - --------------------------------------------------------------------------------- -import StylishHaskell.Stylish - - --------------------------------------------------------------------------------- -dropTrailingWhitespace :: String -> String -dropTrailingWhitespace = reverse . dropWhile isSpace . reverse - - --------------------------------------------------------------------------------- -stylish :: Stylish -stylish ls _ = map dropTrailingWhitespace ls diff --git a/src/StylishHaskell/Util.hs b/src/StylishHaskell/Util.hs --- a/src/StylishHaskell/Util.hs +++ b/src/StylishHaskell/Util.hs @@ -2,15 +2,26 @@ module StylishHaskell.Util ( nameToString , padRight + , everything + , infoPoints + , wrap ) 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 -------------------------------------------------------------------------------- --- | TODO: put this in utilities? +import StylishHaskell.Step + + +-------------------------------------------------------------------------------- nameToString :: H.Name l -> String nameToString (H.Ident _ str) = str nameToString (H.Symbol _ str) = str @@ -19,3 +30,35 @@ -------------------------------------------------------------------------------- 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 indent 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], spaces ++ str, indent + len) + | otherwise = (ls, curr ++ " " ++ str, width') + where + len = length str + width' = width + 1 + len + + spaces = replicate indent ' ' 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.1.1.0 +Version: 0.2.0.0 Synopsis: Haskell code prettifier Homepage: https://github.com/jaspervdj/stylish-haskell License: BSD3 @@ -18,25 +18,40 @@ +Data-files: + .stylish-haskell.yaml + Executable stylish-haskell Ghc-options: -Wall Hs-source-dirs: src Main-is: Main.hs Other-modules: + Paths_stylish_haskell + StylishHaskell StylishHaskell.Block + StylishHaskell.Config StylishHaskell.Editor - StylishHaskell.Imports - StylishHaskell.LanguagePragmas StylishHaskell.Parse - StylishHaskell.Stylish - StylishHaskell.Tabs - StylishHaskell.TrailingWhitespace + StylishHaskell.Step + StylishHaskell.Step.Imports + StylishHaskell.Step.LanguagePragmas + StylishHaskell.Step.Tabs + StylishHaskell.Step.TrailingWhitespace + StylishHaskell.Step.UnicodeSyntax StylishHaskell.Util Build-depends: + aeson >= 0.6 && < 0.7, base >= 4 && < 5, - haskell-src-exts >= 1.13 && < 1.14 + bytestring >= 0.9 && < 0.10, + cmdargs >= 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, + syb >= 0.3 && < 0.4, + yaml >= 0.7 && < 0.8 Test-suite stylish-haskell-tests Ghc-options: -Wall @@ -45,19 +60,28 @@ Type: exitcode-stdio-1.0 Other-modules: - StylishHaskell.Imports.Tests - StylishHaskell.LanguagePragmas.Tests + StylishHaskell.Step.Imports.Tests + StylishHaskell.Step.LanguagePragmas.Tests + StylishHaskell.Step.Tabs.Tests + StylishHaskell.Step.TrailingWhitespace.Tests + StylishHaskell.Step.UnicodeSyntax.Tests StylishHaskell.Tests.Util - StylishHaskell.Tabs.Tests - StylishHaskell.TrailingWhitespace.Tests Build-depends: HUnit >= 1.2 && < 1.3, test-framework >= 0.4 && < 0.7, test-framework-hunit >= 0.2 && < 0.3, -- Copied from regular dependencies... + aeson >= 0.6 && < 0.7, base >= 4 && < 5, - haskell-src-exts >= 1.13 && < 1.14 + bytestring >= 0.9 && < 0.10, + cmdargs >= 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, + syb >= 0.3 && < 0.4, + yaml >= 0.7 && < 0.8 Source-repository head Type: git diff --git a/tests/StylishHaskell/Imports/Tests.hs b/tests/StylishHaskell/Imports/Tests.hs deleted file mode 100644 --- a/tests/StylishHaskell/Imports/Tests.hs +++ /dev/null @@ -1,51 +0,0 @@ --------------------------------------------------------------------------------- -module StylishHaskell.Imports.Tests - ( tests - ) where - - --------------------------------------------------------------------------------- -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit ((@=?)) - - --------------------------------------------------------------------------------- -import StylishHaskell.Imports -import StylishHaskell.Tests.Util - - --------------------------------------------------------------------------------- -tests :: Test -tests = testGroup "StylishHaskell.Imports.Tests" - [ case01 - ] - - --------------------------------------------------------------------------------- -case01 :: Test -case01 = testCase "case 01" $ expected @=? testStylish stylish input - where - input = unlines - [ "module Herp where" - , "" - , "import qualified Data.Map as M" - , "import Control.Monad" - , "import Data.Map (lookup, (!), insert, Map)" - , "" - , "import Herp.Derp.Internals" - , "" - , "herp = putStrLn \"import Hello world\"" - ] - - expected = unlines - [ "module Herp where" - , "" - , "import Control.Monad" - , "import Data.Map (Map, insert, lookup, (!))" - , "import qualified Data.Map as M" - , "" - , "import Herp.Derp.Internals" - , "" - , "herp = putStrLn \"import Hello world\"" - ] diff --git a/tests/StylishHaskell/LanguagePragmas/Tests.hs b/tests/StylishHaskell/LanguagePragmas/Tests.hs deleted file mode 100644 --- a/tests/StylishHaskell/LanguagePragmas/Tests.hs +++ /dev/null @@ -1,41 +0,0 @@ --------------------------------------------------------------------------------- -module StylishHaskell.LanguagePragmas.Tests - ( tests - ) where - - --------------------------------------------------------------------------------- -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit ((@=?)) - - --------------------------------------------------------------------------------- -import StylishHaskell.LanguagePragmas -import StylishHaskell.Tests.Util - - --------------------------------------------------------------------------------- -tests :: Test -tests = testGroup "StylishHaskell.LanguagePragmas.Tests" - [ case01 - ] - - --------------------------------------------------------------------------------- -case01 :: Test -case01 = testCase "case 01" $ expected @=? testStylish stylish 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" - ] diff --git a/tests/StylishHaskell/Step/Imports/Tests.hs b/tests/StylishHaskell/Step/Imports/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/StylishHaskell/Step/Imports/Tests.hs @@ -0,0 +1,90 @@ +-------------------------------------------------------------------------------- +module StylishHaskell.Step.Imports.Tests + ( tests + ) where + + +-------------------------------------------------------------------------------- +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@=?)) + + +-------------------------------------------------------------------------------- +import StylishHaskell.Step.Imports +import StylishHaskell.Tests.Util + + +-------------------------------------------------------------------------------- +tests :: Test +tests = testGroup "StylishHaskell.Step.Imports.Tests" + [ case01 + , case02 + , case03 + ] + + +-------------------------------------------------------------------------------- +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)" + , "" + , "herp = putStrLn \"import Hello world\"" + ] + + +-------------------------------------------------------------------------------- +case01 :: Test +case01 = testCase "case 01" $ expected @=? testStep (step Global) input + where + expected = unlines + [ "module Herp where" + , "" + , "import Control.Monad" + , "import Data.Map (Map, insert, lookup, (!))" + , "import qualified Data.Map as M" + , "" + , "import Herp.Derp.Internals hiding (foo)" + , "" + , "herp = putStrLn \"import Hello world\"" + ] + + +-------------------------------------------------------------------------------- +case02 :: Test +case02 = testCase "case 02" $ expected @=? testStep (step Group) input + where + expected = unlines + [ "module Herp where" + , "" + , "import Control.Monad" + , "import Data.Map (Map, insert, lookup, (!))" + , "import qualified Data.Map as M" + , "" + , "import Herp.Derp.Internals hiding (foo)" + , "" + , "herp = putStrLn \"import Hello world\"" + ] + + +-------------------------------------------------------------------------------- +case03 :: Test +case03 = testCase "case 03" $ expected @=? testStep (step None) input + where + expected = unlines + [ "module Herp where" + , "" + , "import Control.Monad" + , "import Data.Map (Map, insert, lookup, (!))" + , "import qualified Data.Map as M" + , "" + , "import Herp.Derp.Internals hiding (foo)" + , "" + , "herp = putStrLn \"import Hello world\"" + ] diff --git a/tests/StylishHaskell/Step/LanguagePragmas/Tests.hs b/tests/StylishHaskell/Step/LanguagePragmas/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/StylishHaskell/Step/LanguagePragmas/Tests.hs @@ -0,0 +1,97 @@ +-------------------------------------------------------------------------------- +module StylishHaskell.Step.LanguagePragmas.Tests + ( tests + ) where + + +-------------------------------------------------------------------------------- +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@=?)) + + +-------------------------------------------------------------------------------- +import StylishHaskell.Step.LanguagePragmas +import StylishHaskell.Tests.Util + + +-------------------------------------------------------------------------------- +tests :: Test +tests = testGroup "StylishHaskell.Step.LanguagePragmas.Tests" + [ case01 + , case02 + , case03 + , case04 + ] + + +-------------------------------------------------------------------------------- +case01 :: Test +case01 = testCase "case 01" $ + expected @=? testStep (step 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 :: Test +case02 = testCase "case 02" $ + expected @=? testStep (step Vertical True) input + where + input = unlines + [ "{-# LANGUAGE BangPatterns #-}" + , "{-# LANGUAGE ViewPatterns #-}" + , "increment ((+ 1) -> x) = x" + ] + + expected = unlines + [ "{-# LANGUAGE ViewPatterns #-}" + , "increment ((+ 1) -> x) = x" + ] + + +-------------------------------------------------------------------------------- +case03 :: Test +case03 = testCase "case 03" $ + expected @=? testStep (step 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 :: Test +case04 = testCase "case 04" $ + expected @=? testStep (step 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/Tabs/Tests.hs b/tests/StylishHaskell/Step/Tabs/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/StylishHaskell/Step/Tabs/Tests.hs @@ -0,0 +1,42 @@ +-------------------------------------------------------------------------------- +module StylishHaskell.Step.Tabs.Tests + ( tests + ) where + + +-------------------------------------------------------------------------------- +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@=?)) + + +-------------------------------------------------------------------------------- +import StylishHaskell.Step.Tabs +import StylishHaskell.Tests.Util + + +-------------------------------------------------------------------------------- +tests :: Test +tests = testGroup "StylishHaskell.Step.Tabs.Tests" [case01] + + +-------------------------------------------------------------------------------- +case01 :: Test +case01 = testCase "case 01" $ 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 new file mode 100644 --- /dev/null +++ b/tests/StylishHaskell/Step/TrailingWhitespace/Tests.hs @@ -0,0 +1,37 @@ +-------------------------------------------------------------------------------- +module StylishHaskell.Step.TrailingWhitespace.Tests + ( tests + ) where + + +-------------------------------------------------------------------------------- +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@=?)) + + +-------------------------------------------------------------------------------- +import StylishHaskell.Step.TrailingWhitespace +import StylishHaskell.Tests.Util + + +-------------------------------------------------------------------------------- +tests :: Test +tests = testGroup "StylishHaskell.Step.TrailingWhitespace.Tests" [case01] + + +-------------------------------------------------------------------------------- +case01 :: Test +case01 = testCase "case 01" $ 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 new file mode 100644 --- /dev/null +++ b/tests/StylishHaskell/Step/UnicodeSyntax/Tests.hs @@ -0,0 +1,38 @@ +-------------------------------------------------------------------------------- +module StylishHaskell.Step.UnicodeSyntax.Tests + ( tests + ) where + + +-------------------------------------------------------------------------------- +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@=?)) + + +-------------------------------------------------------------------------------- +import StylishHaskell.Step.UnicodeSyntax +import StylishHaskell.Tests.Util + + +-------------------------------------------------------------------------------- +tests :: Test +tests = testGroup "StylishHaskell.Step.UnicodeSyntax.Tests" + [ case01 + ] + + +-------------------------------------------------------------------------------- +case01 :: Test +case01 = testCase "case 01" $ 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/Tabs/Tests.hs b/tests/StylishHaskell/Tabs/Tests.hs deleted file mode 100644 --- a/tests/StylishHaskell/Tabs/Tests.hs +++ /dev/null @@ -1,42 +0,0 @@ --------------------------------------------------------------------------------- -module StylishHaskell.Tabs.Tests - ( tests - ) where - - --------------------------------------------------------------------------------- -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit ((@=?)) - - --------------------------------------------------------------------------------- -import StylishHaskell.Tabs -import StylishHaskell.Tests.Util - - --------------------------------------------------------------------------------- -tests :: Test -tests = testGroup "StylishHaskell.Tabs.Tests" [case01] - - --------------------------------------------------------------------------------- -case01 :: Test -case01 = testCase "case 01" $ expected @=? testStylish stylish 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/Tests/Util.hs b/tests/StylishHaskell/Tests/Util.hs --- a/tests/StylishHaskell/Tests/Util.hs +++ b/tests/StylishHaskell/Tests/Util.hs @@ -1,17 +1,17 @@ module StylishHaskell.Tests.Util - ( testStylish + ( testStep ) where -------------------------------------------------------------------------------- import StylishHaskell.Parse -import StylishHaskell.Stylish +import StylishHaskell.Step -------------------------------------------------------------------------------- -testStylish :: Stylish -> String -> String -testStylish stylish str = case parseModule Nothing str of +testStep :: Step -> String -> String +testStep step str = case parseModule Nothing str of Left err -> error err - Right module' -> unlines $ stylish ls module' + Right module' -> unlines $ stepFilter step ls module' where ls = lines str diff --git a/tests/StylishHaskell/TrailingWhitespace/Tests.hs b/tests/StylishHaskell/TrailingWhitespace/Tests.hs deleted file mode 100644 --- a/tests/StylishHaskell/TrailingWhitespace/Tests.hs +++ /dev/null @@ -1,37 +0,0 @@ --------------------------------------------------------------------------------- -module StylishHaskell.TrailingWhitespace.Tests - ( tests - ) where - - --------------------------------------------------------------------------------- -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit ((@=?)) - - --------------------------------------------------------------------------------- -import StylishHaskell.TrailingWhitespace -import StylishHaskell.Tests.Util - - --------------------------------------------------------------------------------- -tests :: Test -tests = testGroup "StylishHaskell.TrailingWhitespace.Tests" [case01] - - --------------------------------------------------------------------------------- -case01 :: Test -case01 = testCase "case 01" $ expected @=? testStylish stylish 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/TestSuite.hs b/tests/TestSuite.hs --- a/tests/TestSuite.hs +++ b/tests/TestSuite.hs @@ -5,21 +5,23 @@ -------------------------------------------------------------------------------- -import Test.Framework (defaultMain) +import Test.Framework (defaultMain) -------------------------------------------------------------------------------- -import qualified StylishHaskell.Imports.Tests -import qualified StylishHaskell.LanguagePragmas.Tests -import qualified StylishHaskell.Tabs.Tests -import qualified StylishHaskell.TrailingWhitespace.Tests +import qualified StylishHaskell.Step.Imports.Tests +import qualified StylishHaskell.Step.LanguagePragmas.Tests +import qualified StylishHaskell.Step.Tabs.Tests +import qualified StylishHaskell.Step.TrailingWhitespace.Tests +import qualified StylishHaskell.Step.UnicodeSyntax.Tests -------------------------------------------------------------------------------- main :: IO () main = defaultMain - [ StylishHaskell.Imports.Tests.tests - , StylishHaskell.LanguagePragmas.Tests.tests - , StylishHaskell.Tabs.Tests.tests - , StylishHaskell.TrailingWhitespace.Tests.tests + [ StylishHaskell.Step.Imports.Tests.tests + , StylishHaskell.Step.LanguagePragmas.Tests.tests + , StylishHaskell.Step.Tabs.Tests.tests + , StylishHaskell.Step.TrailingWhitespace.Tests.tests + , StylishHaskell.Step.UnicodeSyntax.Tests.tests ]