11{-# LANGUAGE CPP #-}
2+
23--------------------------------------------------------------------------------
34module Main
4- ( main
5- ) where
6-
5+ ( main
6+ ) where
77
88--------------------------------------------------------------------------------
99import Control.Monad (forM_ , unless , when )
@@ -15,119 +15,111 @@ import qualified System.IO as IO
1515import qualified System.IO.Strict as IO.Strict
1616
1717--------------------------------------------------------------------------------
18- #if __GLASGOW_HASKELL__ < 808
19- import Data.Monoid ((<>) )
20- #endif
21-
2218--------------------------------------------------------------------------------
2319import Language.Haskell.Stylish
2420
25-
2621--------------------------------------------------------------------------------
2722data StylishArgs = StylishArgs
28- { saVersion :: Bool
29- , saConfig :: Maybe FilePath
30- , saRecursive :: Bool
31- , saVerbose :: Bool
32- , saDefaults :: Bool
33- , saInPlace :: Bool
34- , saNoUtf8 :: Bool
35- , saFiles :: [FilePath ]
36- } deriving (Show )
37-
23+ { saVersion :: Bool
24+ , saConfig :: Maybe FilePath
25+ , saRecursive :: Bool
26+ , saVerbose :: Bool
27+ , saDefaults :: Bool
28+ , saInPlace :: Bool
29+ , saNoUtf8 :: Bool
30+ , saFiles :: [FilePath ]
31+ } deriving (Show )
3832
3933--------------------------------------------------------------------------------
4034parseStylishArgs :: OA. Parser StylishArgs
41- parseStylishArgs = StylishArgs
42- <$> OA. switch (
43- OA. help " Show version information" <>
44- OA. long " version" <>
45- OA. hidden)
46- <*> OA. optional (OA. strOption $
47- OA. metavar " CONFIG" <>
48- OA. help " Configuration file" <>
49- OA. long " config" <>
50- OA. short ' c' <>
51- OA. hidden)
52- <*> OA. switch (
53- OA. help " Recursive file search" <>
54- OA. long " recursive" <>
55- OA. short ' r' <>
56- OA. hidden)
57- <*> OA. switch (
58- OA. help " Run in verbose mode" <>
59- OA. long " verbose" <>
60- OA. short ' v' <>
61- OA. hidden)
62- <*> OA. switch (
63- OA. help " Dump default config and exit" <>
64- OA. long " defaults" <>
65- OA. short ' d' <>
66- OA. hidden)
67- <*> OA. switch (
68- OA. help " Overwrite the given files in place" <>
69- OA. long " inplace" <>
70- OA. short ' i' <>
71- OA. hidden)
72- <*> OA. switch (
73- OA. help " Don't force UTF-8 stdin/stdout" <>
74- OA. long " no-utf8" <>
75- OA. hidden)
76- <*> OA. many (OA. strArgument $
77- OA. metavar " FILENAME" <>
78- OA. help " Input file(s)" )
79-
35+ parseStylishArgs =
36+ StylishArgs
37+ <$> OA. switch
38+ (OA. help " Show version information" <> OA. long " version" <> OA. hidden)
39+ <*> OA. optional
40+ (OA. strOption
41+ $ OA. metavar " CONFIG"
42+ <> OA. help " Configuration file"
43+ <> OA. long " config"
44+ <> OA. short ' c'
45+ <> OA. hidden)
46+ <*> OA. switch
47+ (OA. help " Recursive file search"
48+ <> OA. long " recursive"
49+ <> OA. short ' r'
50+ <> OA. hidden)
51+ <*> OA. switch
52+ (OA. help " Run in verbose mode"
53+ <> OA. long " verbose"
54+ <> OA. short ' v'
55+ <> OA. hidden)
56+ <*> OA. switch
57+ (OA. help " Dump default config and exit"
58+ <> OA. long " defaults"
59+ <> OA. short ' d'
60+ <> OA. hidden)
61+ <*> OA. switch
62+ (OA. help " Overwrite the given files in place"
63+ <> OA. long " inplace"
64+ <> OA. short ' i'
65+ <> OA. hidden)
66+ <*> OA. switch
67+ (OA. help " Don't force UTF-8 stdin/stdout"
68+ <> OA. long " no-utf8"
69+ <> OA. hidden)
70+ <*> OA. many
71+ (OA. strArgument $ OA. metavar " FILENAME" <> OA. help " Input file(s)" )
8072
8173--------------------------------------------------------------------------------
8274stylishHaskellVersion :: String
8375stylishHaskellVersion = " stylish-haskell " <> showVersion version
8476
85-
8677--------------------------------------------------------------------------------
8778parserInfo :: OA. ParserInfo StylishArgs
88- parserInfo = OA. info (OA. helper <*> parseStylishArgs) $
89- OA. fullDesc <>
90- OA. header stylishHaskellVersion
91-
79+ parserInfo =
80+ OA. info (OA. helper <*> parseStylishArgs)
81+ $ OA. fullDesc <> OA. header stylishHaskellVersion
9282
9383--------------------------------------------------------------------------------
9484main :: IO ()
9585main = OA. execParser parserInfo >>= stylishHaskell
9686
97-
9887--------------------------------------------------------------------------------
9988stylishHaskell :: StylishArgs -> IO ()
10089stylishHaskell sa = do
101- unless (saNoUtf8 sa) $
102- mapM_ (`IO.hSetEncoding` IO. utf8) [IO. stdin, IO. stdout]
103- if saVersion sa then
104- putStrLn stylishHaskellVersion
105-
106- else if saDefaults sa then do
107- verbose' " Dumping embedded config..."
108- BC8. putStr defaultConfigBytes
109-
110- else do
111- conf <- loadConfig verbose' $ case saConfig sa of
112- Nothing -> SearchFromCurrentDirectory
113- Just fp -> UseConfig fp
114- filesR <- case (saRecursive sa) of
115- True -> findHaskellFiles (saVerbose sa) (saFiles sa)
116- _ -> return $ saFiles sa
117- let steps = configSteps conf
118- forM_ steps $ \ s -> verbose' $ " Enabled " ++ stepName s ++ " step"
119- verbose' $ " Extra language extensions: " ++
120- show (configLanguageExtensions conf)
121- res <- foldMap (file sa conf) (files' filesR)
122-
123- verbose' $ " Exit code behavior: " ++ show (configExitCode conf)
124- when (configExitCode conf == ErrorOnFormatExitBehavior && res == DidFormat ) exitFailure
90+ unless (saNoUtf8 sa) $ mapM_ (`IO.hSetEncoding` IO. utf8) [IO. stdin, IO. stdout]
91+ if saVersion sa
92+ then putStrLn stylishHaskellVersion
93+ else if saDefaults sa
94+ then do
95+ verbose' " Dumping embedded config..."
96+ BC8. putStr defaultConfigBytes
97+ else do
98+ conf <-
99+ loadConfig verbose'
100+ $ maybe SearchFromCurrentDirectory UseConfig (saConfig sa)
101+ filesR <-
102+ (if saRecursive sa
103+ then findHaskellFiles (saVerbose sa) (saFiles sa)
104+ else return $ saFiles sa)
105+ let steps = configSteps conf
106+ forM_ steps $ \ s -> verbose' $ " Enabled " ++ stepName s ++ " step"
107+ verbose'
108+ $ " Extra language extensions: "
109+ ++ show (configLanguageExtensions conf)
110+ res <- foldMap (file sa conf) (files' filesR)
111+ verbose' $ " Exit code behavior: " ++ show (configExitCode conf)
112+ when
113+ (configExitCode conf == ErrorOnFormatExitBehavior
114+ && res == DidFormat )
115+ exitFailure
125116 where
126117 verbose' = makeVerbose (saVerbose sa)
127- files' x = case (saRecursive sa, null x) of
128- (True ,True ) -> [] -- No file to format and recursive enabled.
129- (_,True ) -> [Nothing ] -- Involving IO.stdin.
130- (_,False ) -> map Just x -- Process available files.
118+ files' x =
119+ case (saRecursive sa, null x) of
120+ (True , True ) -> [] -- No file to format and recursive enabled.
121+ (_, True ) -> [Nothing ] -- Involving IO.stdin.
122+ (_, False ) -> map Just x -- Process available files.
131123
132124data FormattingResult
133125 = DidFormat
@@ -137,7 +129,7 @@ data FormattingResult
137129instance Semigroup FormattingResult where
138130 _ <> DidFormat = DidFormat
139131 DidFormat <> _ = DidFormat
140- _ <> _ = NoChange
132+ _ <> _ = NoChange
141133
142134instance Monoid FormattingResult where
143135 mempty = NoChange
@@ -146,28 +138,36 @@ instance Monoid FormattingResult where
146138-- | Processes a single file, or stdin if no filepath is given
147139file :: StylishArgs -> Config -> Maybe FilePath -> IO FormattingResult
148140file sa conf mfp = do
149- contents <- maybe getContents readUTF8File mfp
150- let
151- inputLines =
152- lines contents
141+ contents <- maybe getContents readUTF8File mfp
142+ let inputLines = lines contents
153143 result =
154- runSteps (configLanguageExtensions conf) mfp (configSteps conf) inputLines
155- case result of
156- Right ok -> do
157- write contents (unlines ok)
158- pure $ if ok /= inputLines then DidFormat else NoChange
159- Left err -> do
160- IO. hPutStrLn IO. stderr err
161- exitFailure
144+ runSteps
145+ (configLanguageExtensions conf)
146+ mfp
147+ (configSteps conf)
148+ inputLines
149+ case result of
150+ Right ok -> do
151+ write contents (unlines ok)
152+ pure
153+ $ if ok /= inputLines
154+ then DidFormat
155+ else NoChange
156+ Left err -> do
157+ IO. hPutStrLn IO. stderr err
158+ exitFailure
162159 where
163- write old new = case mfp of
164- Nothing -> putStrNewline new
165- Just _ | not (saInPlace sa) -> putStrNewline new
166- Just path | not (null new) && old /= new ->
167- IO. withFile path IO. WriteMode $ \ h -> do
168- setNewlineMode h
169- IO. hPutStr h new
170- _ -> return ()
160+ write old new =
161+ case mfp of
162+ Nothing -> putStrNewline new
163+ Just _
164+ | not (saInPlace sa) -> putStrNewline new
165+ Just path
166+ | not (null new) && old /= new ->
167+ IO. withFile path IO. WriteMode $ \ h -> do
168+ setNewlineMode h
169+ IO. hPutStr h new
170+ _ -> return ()
171171 setNewlineMode h = do
172172 let nl = configNewline conf
173173 let mode = IO. NewlineMode IO. nativeNewline nl
@@ -176,6 +176,6 @@ file sa conf mfp = do
176176
177177readUTF8File :: FilePath -> IO String
178178readUTF8File fp =
179- IO. withFile fp IO. ReadMode $ \ h -> do
180- IO. hSetEncoding h IO. utf8
181- IO.Strict. hGetContents h
179+ IO. withFile fp IO. ReadMode $ \ h -> do
180+ IO. hSetEncoding h IO. utf8
181+ IO.Strict. hGetContents h
0 commit comments