diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -7,6 +7,7 @@ Maintainer : public@hjwylde.com -} +{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide, prune #-} {-# LANGUAGE OverloadedStrings #-} @@ -15,12 +16,16 @@ main, ) where +import Control.Monad import Control.Monad.Logger +import Control.Monad.Parallel (MonadParallel(..)) -import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as BS -import Data.List.Extra (lower) -import Data.Time (getZonedTime) +import Data.List.Extra (dropEnd, lower) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.IO as T +import Data.Time (getZonedTime, formatTime, defaultTimeLocale) import Git.Fmt import Git.Fmt.Options.Applicative.Parser @@ -32,34 +37,37 @@ import System.IO import System.Log.FastLogger +instance MonadParallel m => MonadParallel (LoggingT m) where + bindM2 f ma mb = LoggingT $ \g -> bindM2 (f' g) (runLoggingT ma g) (runLoggingT mb g) + where + f' g a b = runLoggingT (f a b) g main :: IO () main = customExecParser gitFmtPrefs gitFmtInfo >>= \options -> - runLoggingT (filter options (handle options)) (if optVerbose options then verboseLog else log) + runLoggingT (filter options (handle options)) (if optChatty options == Verbose then verboseLog else log) filter :: Options -> LoggingT m a -> LoggingT m a filter options = filterLogger (\_ level -> level >= minLevel) where - minLevel - | optQuiet options = LevelError - | optVerbose options = LevelDebug - | optListUgly options = LevelInfo - | otherwise = LevelWarn + minLevel = case optChatty options of + Quiet -> LevelError + Default -> LevelInfo + Verbose -> LevelDebug --- TODO (hjw): find out why there are extra quote marks here log :: Loc -> LogSource -> LogLevel -> LogStr -> IO () -log _ _ level msg = BS.hPutStrLn h (fromLogStr msg) +log _ _ level msg = forM_ (T.lines . T.decodeUtf8 $ fromLogStr msg) (T.hPutStrLn h) where h = if level == LevelError then stderr else stdout verboseLog :: Loc -> LogSource -> LogLevel -> LogStr -> IO () verboseLog _ _ level msg = do - timestamp <- getZonedTime >>= \time -> return . BS.pack $ "[" ++ show time ++ "]" + timestamp <- formatTime defaultTimeLocale "%F %T.%q" <$> getZonedTime - BS.hPutStrLn h (BS.unwords [timestamp, formatLevel level, fromLogStr msg]) + forM_ (T.lines . T.decodeUtf8 $ fromLogStr msg) $ \line -> + T.hPutStrLn h (T.unwords [T.pack $ "[" ++ dropEnd 6 timestamp ++ "]", formatLevel level, line]) where h = if level == LevelError then stderr else stdout -formatLevel :: LogLevel -> ByteString -formatLevel = BS.take 6 . BS.drop 5 . (`BS.append` " ") . BS.pack . lower . show +formatLevel :: LogLevel -> Text +formatLevel = T.take 6 . (`T.append` " ") . T.drop 5 . T.pack . lower . show diff --git a/git-fmt.cabal b/git-fmt.cabal --- a/git-fmt.cabal +++ b/git-fmt.cabal @@ -1,12 +1,13 @@ name: git-fmt -version: 0.1.0.3 +version: 0.2.0.0 author: Henry J. Wylde maintainer: public@hjwylde.com homepage: https://github.com/hjwylde/git-fmt synopsis: Custom git command for formatting code. -description: git-fmt adds a custom command to Git that automatically formats code. +description: git-fmt adds a custom command to Git that automatically formats code by using + external pretty-printers. The idea was taken from gofmt, just with a bit of expansion to more languages. license: BSD3 @@ -23,68 +24,54 @@ executable git-fmt main-is: Main.hs hs-source-dirs: app/ - ghc-options: -Wall -fno-warn-name-shadowing default-language: Haskell2010 + other-extensions: + OverloadedStrings build-depends: base == 4.8.*, - bytestring == 0.10.*, extra == 1.4.*, fast-logger == 2.4.*, git-fmt, monad-logger == 0.3.*, + monad-parallel == 0.7.*, optparse-applicative == 0.11.*, + text == 1.2.*, time == 1.5.* library hs-source-dirs: src/ - ghc-options: -Wall -fno-warn-name-shadowing exposed-modules: Git.Fmt, - Git.Fmt.Language, Git.Fmt.Options.Applicative.Parser other-modules: - Git.Fmt.Language.Json.Parser, - Git.Fmt.Language.Json.Pretty, + Git.Fmt.Config, Git.Fmt.Process, Git.Fmt.Version, - Paths_git_fmt + Paths_git_fmt, + System.Directory.Extra' + System.IO.Extra' default-language: Haskell2010 other-extensions: + FlexibleContexts + OverloadedStrings TemplateHaskell build-depends: + aeson == 0.8.*, base == 4.8.*, directory == 1.2.*, + exceptions == 0.8.*, extra == 1.4.*, filepath == 1.4.*, - json == 0.9.*, monad-logger == 0.3.*, + monad-parallel == 0.7.*, mtl == 2.2.*, optparse-applicative == 0.11.*, - parsec == 3.1.*, - pretty == 1.1.*, process == 1.2.*, + temporary == 1.2.*, text == 1.2.*, - transformers == 0.4.* - -test-suite git-fmt-test-json - type: exitcode-stdio-1.0 - main-is: Main.hs - hs-source-dirs: test/json/app/, test/shared/src/ - ghc-options: -threaded -Wall -fno-warn-name-shadowing - other-modules: - Git.Fmt.Test - - default-language: Haskell2010 - build-depends: - base == 4.8.*, - bytestring == 0.10.*, - directory == 1.2.*, - extra == 1.4.*, - filepath == 1.4.*, - git-fmt, - parsec == 3.1.*, - tasty >= 0.10 && < 0.12, - tasty-golden == 2.3.* + transformers == 0.4.*, + unordered-containers == 0.2.*, + yaml == 0.8.* diff --git a/src/Git/Fmt.hs b/src/Git/Fmt.hs --- a/src/Git/Fmt.hs +++ b/src/Git/Fmt.hs @@ -10,67 +10,133 @@ Options and handler for the git-fmt command. -} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} module Git.Fmt ( -- * Options - Options(..), + Options(..), Chatty(..), Mode(..), -- * Handle handle, ) where -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Logger +import Control.Monad.Catch (MonadMask) +import Control.Monad.Extra +import Control.Monad.IO.Class +import Control.Monad.Logger +import Control.Monad.Parallel (MonadParallel) +import qualified Control.Monad.Parallel as Parallel +import Control.Monad.Reader -import Data.Text (pack) +import Data.List.Extra (chunksOf, linesBy, lower, nub, replace) +import qualified Data.Text as T +import Data.Yaml (prettyPrintParseException) +import Data.Yaml.Include (decodeFileEither) -import Git.Fmt.Language +import Git.Fmt.Config as Config import Git.Fmt.Process -import System.Directory -import System.FilePath - -import Text.Parsec +import Prelude hiding (read) +import System.Directory.Extra hiding (withCurrentDirectory) +import System.Directory.Extra' +import System.Exit +import System.FilePath +import System.IO.Temp +import System.IO.Extra' -- | Options. data Options = Options { - optQuiet :: Bool, - optVerbose :: Bool, - optDryRun :: Bool, - optListUgly :: Bool, - argFilePaths :: [FilePath] + optChatty :: Chatty, + optNull :: Bool, + optMode :: Mode, + argPaths :: [FilePath] } deriving (Eq, Show) +-- | Chattyness level. +data Chatty = Default | Quiet | Verbose + deriving (Eq, Show) + +-- | Run mode. +data Mode = Normal | DryRun + deriving (Eq, Show) + -- | Builds the files according to the options. -handle :: (MonadIO m, MonadLogger m) => Options -> m () -handle options = do - gitDir <- init <$> run "git" ["rev-parse", "--show-toplevel"] - filePaths <- if null (argFilePaths options) then lines <$> run "git" ["ls-files", gitDir] else return (argFilePaths options) +handle :: (MonadIO m, MonadLogger m, MonadMask m, MonadParallel m) => Options -> m () +handle options = findTopLevelGitDirectory >>= \dir -> withCurrentDirectory (init dir) $ do + filePaths <- fmap (nub . concat) $ paths >>= mapM + (\path -> ifM (liftIO $ doesDirectoryExist path) + (liftIO $ listFilesRecursive path) + (return [path]) + ) - filterM (liftIO . doesFileExist) filePaths >>= mapM_ (\filePath -> - maybe (return ()) (fmt options filePath) (languageOf $ takeExtension filePath)) + unlessM (liftIO $ doesFileExist Config.fileName) $ panic (Config.fileName ++ ": not found") + config <- liftIO (decodeFileEither Config.fileName) >>= \ethr -> case ethr of + Left error -> panic $ Config.fileName ++ ": error\n" ++ prettyPrintParseException error + Right config -> return config -fmt :: (MonadIO m, MonadLogger m) => Options -> FilePath -> Language -> m () -fmt options filePath language = do - input <- liftIO $ readFile filePath + let supportedFilePaths = filter (supported config . T.pack . drop 1 . lower . takeExtension) filePaths - case runParser (parser language) () filePath input of - Left error -> do - $(logWarn) $ pack (filePath ++ ": parse error") - $(logDebug) $ pack (show error) - Right doc -> do - let output = renderWithTabs doc + flip runReaderT config . withSystemTempDirectory "git-fmt" $ \tmpDir -> + Parallel.sequence_ . map sequence . nChunks 8 . flip map supportedFilePaths $ \filePath -> ifM (liftIO $ doesFileExist filePath) + (fmt options filePath (tmpDir filePath)) + ($(logWarn) $ T.pack (filePath ++ ": not found")) + where + paths + | null (argPaths options) = linesBy (== '\0') <$> runProcess_ "git" ["ls-files", "-z"] + | optNull options = return $ concatMap (linesBy (== '\0')) (argPaths options) + | otherwise = return $ argPaths options + nChunks n xs = chunksOf (maximum [1, length xs `div` n]) xs - if input == output - then - $(logDebug) $ pack (filePath ++ ": pretty") - else do - $(logInfo) $ pack (filePath ++ ": ugly" ++ if optDryRun options then "" else " (-> pretty)") +fmt :: (MonadIO m, MonadLogger m, MonadReader Config m) => Options -> FilePath -> FilePath -> m () +fmt options filePath tmpFilePath = do + config <- ask + let program = unsafeProgramFor config (T.pack . drop 1 $ takeExtension filePath) - unless (optDryRun options) $ liftIO (writeFile filePath output) + (exitCode, _, stderr) <- runProgram program filePath tmpFilePath + if exitCode == ExitSuccess + then diff options filePath tmpFilePath + else $(logWarn) (T.pack $ filePath ++ ": error") >> + $(logDebug) (T.pack stderr) + +diff :: (MonadIO m, MonadLogger m) => Options -> FilePath -> FilePath -> m () +diff options filePath tmpFilePath = do + (exitCode, _, stderr) <- runProcess "diff" [filePath, tmpFilePath] + case exitCode of + ExitSuccess -> $(logDebug) $ T.pack (filePath ++ ": pretty") + ExitFailure 1 -> action filePath tmpFilePath + _ -> $(logWarn) $ T.pack stderr + where + action = case optMode options of + Normal -> normal + DryRun -> dryRun + +normal :: (MonadIO m, MonadLogger m) => FilePath -> FilePath -> m () +normal filePath tmpFilePath = do + $(logInfo) $ T.pack (filePath ++ ": prettified") + + liftIO $ renameFile tmpFilePath filePath + +dryRun :: (MonadIO m, MonadLogger m) => FilePath -> FilePath -> m () +dryRun filePath _ = $(logInfo) $ T.pack (filePath ++ ": ugly") + +findTopLevelGitDirectory :: (MonadIO m, MonadLogger m) => m String +findTopLevelGitDirectory = do + (exitCode, stdout, _) <- runProcess "git" ["rev-parse", "--show-toplevel"] + + if exitCode == ExitSuccess + then return stdout + else panic ".git/: not found" + +runProgram :: (MonadIO m, MonadLogger m) => Program -> FilePath -> FilePath -> m (ExitCode, String, String) +runProgram program inputFilePath tmpFilePath = do + liftIO $ createDirectoryIfMissing True (takeDirectory tmpFilePath) + + runCommand $ foldr (uncurry replace) (T.unpack $ command program) [ + ("{{input}}", inputFilePath), + ("{{output}}", tmpFilePath) + ] diff --git a/src/Git/Fmt/Config.hs b/src/Git/Fmt/Config.hs new file mode 100644 --- /dev/null +++ b/src/Git/Fmt/Config.hs @@ -0,0 +1,82 @@ + +{-| +Module : Git.Fmt.Config +Description : Configuration data structures. + +Copyright : (c) Henry J. Wylde, 2015 +License : BSD3 +Maintainer : public@hjwylde.com + +Configuration data structures. +-} + +{-# LANGUAGE OverloadedStrings #-} + +module Git.Fmt.Config ( + -- * Config + Config(..), + emptyConfig, + + -- * Program + Program(..), + emptyProgram, programFor, unsafeProgramFor, supported, + + -- * Helper functions + fileName, +) where + +import Data.Aeson.Types +import Data.HashMap.Lazy (toList) +import Data.List (find) +import Data.Maybe (fromJust, isJust) +import Data.Text (Text) + +-- | A list of programs. +data Config = Config { + programs :: [Program] + } + deriving (Eq, Show) + +instance FromJSON Config where + parseJSON (Object obj) = Config <$> mapM (\(key, value) -> + parseJSON value >>= \program -> return program { name = key } + ) (toList obj) + parseJSON value = typeMismatch "Config" value + +-- | The empty config (no programs). +emptyConfig :: Config +emptyConfig = Config [] + +-- | A program has a semantic name, associated extensions and command. +-- The command string may contain variables to be replaced by surrounding them with '{{..}}'. +data Program = Program { + name :: Text, + extensions :: [Text], + command :: Text + } + deriving (Eq, Show) + +instance FromJSON Program where + parseJSON (Object obj) = Program "" <$> obj .: "extensions" <*> obj .: "command" + parseJSON value = typeMismatch "Program" value + +-- | The empty program (the command fails). +emptyProgram :: Program +emptyProgram = Program "" [] "false" + +-- | Attempts to find a program for the given extension. +programFor :: Config -> Text -> Maybe Program +programFor config ext = find (\program -> ext `elem` extensions program) (programs config) + +-- | Finds a program for the given extension or errors. +unsafeProgramFor :: Config -> Text -> Program +unsafeProgramFor config = fromJust . programFor config + +-- | Checks if the given extension is supported (e.g., there is a program for it). +supported :: Config -> Text -> Bool +supported config = isJust . programFor config + +-- | The file name of the default config file. +fileName :: String +fileName = ".omnifmt.yaml" + diff --git a/src/Git/Fmt/Language.hs b/src/Git/Fmt/Language.hs deleted file mode 100644 --- a/src/Git/Fmt/Language.hs +++ /dev/null @@ -1,55 +0,0 @@ - -{-| -Module : Git.Fmt.Language -Description : Utilities for working with a general language. - -Copyright : (c) Henry J. Wylde, 2015 -License : BSD3 -Maintainer : public@hjwylde.com - -Utilities for working with a general language. --} - -module Git.Fmt.Language ( - -- * Languages - Language(..), - languages, languageOf, extension, parser, renderWithTabs, -) where - -import Git.Fmt.Language.Json.Parser as Json -import Git.Fmt.Language.Json.Pretty () - -import Text.Parsec.String -import Text.PrettyPrint.HughesPJClass - - --- | Supported languages. -data Language = Json - deriving (Eq, Ord, Show) - - --- | Array of supported languages. -languages :: [Language] -languages = [Json] - --- | Gets the language of an extension. -languageOf :: String -> Maybe Language -languageOf ext - | ext `elem` [".json"] = Just Json - | otherwise = Nothing - --- | Gets the default extension of a language. -extension :: Language -> String -extension Json = "json" - --- | Gets the parser for a language. -parser :: Language -> Parser Doc -parser Json = pPrint <$> Json.topLevelValue - --- | Renders the document using the default "style" and replaces any prefixed spaces with tabs. -renderWithTabs :: Doc -> String -renderWithTabs doc = unlines $ map withTabs (lines $ render doc) - where - withTabs (' ':xs) = '\t':withTabs xs - withTabs line = line - diff --git a/src/Git/Fmt/Language/Json/Parser.hs b/src/Git/Fmt/Language/Json/Parser.hs deleted file mode 100644 --- a/src/Git/Fmt/Language/Json/Parser.hs +++ /dev/null @@ -1,27 +0,0 @@ - -{-| -Module : Git.Fmt.Language.Json.Parser -Description : Parser for the JSON language. - -Copyright : (c) Henry J. Wylde, 2015 -License : BSD3 -Maintainer : public@hjwylde.com - -Parser for the JSON language. --} - -module Git.Fmt.Language.Json.Parser ( - -- * Parser - topLevelValue, -) where - -import Text.JSON.Parsec -import Text.JSON.Types - - --- | Parser for a top level JSON value (either an array or object). -topLevelValue :: Parser JSValue -topLevelValue = spaces >> topLevelValue' - where - topLevelValue' = choice [JSArray <$> p_array, JSObject <$> p_js_object] "top level JSON value" - diff --git a/src/Git/Fmt/Language/Json/Pretty.hs b/src/Git/Fmt/Language/Json/Pretty.hs deleted file mode 100644 --- a/src/Git/Fmt/Language/Json/Pretty.hs +++ /dev/null @@ -1,30 +0,0 @@ - -{-| -Module : Git.Fmt.Language.Json.Pretty -Description : Pretty instances for the JSON language. - -Copyright : (c) Henry J. Wylde, 2015 -License : BSD3 -Maintainer : public@hjwylde.com - -Pretty instances for the JSON language. --} - -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Git.Fmt.Language.Json.Pretty where - -import Text.JSON -import Text.PrettyPrint.HughesPJClass - - -instance Pretty JSValue where - pPrint (JSArray values) = cat [char '[', nest 1 (sep $ punctuate (char ',') (map pPrint values)), char ']'] - pPrint (JSObject obj) - | null keyValues = text "{}" - | otherwise = char '{' $+$ nest 1 (vcat $ punctuate (char ',') keyValueDocs) $+$ char '}' - where - keyValueDocs = map (\(key, value) -> char '"' <> text key <> text "\":" <+> pPrint value) keyValues - keyValues = fromJSObject obj - pPrint value = text $ showJSValue value "" - diff --git a/src/Git/Fmt/Options/Applicative/Parser.hs b/src/Git/Fmt/Options/Applicative/Parser.hs --- a/src/Git/Fmt/Options/Applicative/Parser.hs +++ b/src/Git/Fmt/Options/Applicative/Parser.hs @@ -15,15 +15,14 @@ gitFmtPrefs, gitFmtInfo, gitFmt, ) where -import Data.List (nub) import Data.Version (showVersion) import Options.Applicative +import Options.Applicative.Types (readerAsk) import Git.Fmt import Git.Fmt.Version as This - -- | The default preferences. -- Limits the help output to 100 columns. gitFmtPrefs :: ParserPrefs @@ -46,23 +45,31 @@ -- | An options parser. gitFmt :: Parser Options gitFmt = Options - <$> switch (mconcat [ - long "quiet", short 'q', - help "Be quiet" - ]) + <$> ( + flag' Quiet (mconcat [ + long "quiet", short 'q', hidden, + help "Be quiet" + ]) + <|> flag Default Verbose (mconcat [ + long "verbose", short 'v', hidden, + help "Be verbose" + ]) + ) <*> switch (mconcat [ - long "verbose", short 'v', - help "Be verbose" + long "null", short '0', + help "Input files are delimited by a null terminator instead of white space" ]) - <*> switch (mconcat [ - long "dry-run", short 'n', - help "Doesn't perform any writes (useful with --list-ugly)" + <*> modeOption (mconcat [ + long "mode", short 'm', metavar "MODE", + value Normal, showDefaultWith $ const "normal", + help "Specify the mode as either `normal' or `dry-run'" ]) - <*> switch (mconcat [ - long "list-ugly", short 'l', - help "List all ugly files formatted" + <*> many (strArgument $ mconcat [ + metavar "-- PATHS..." ]) - <*> fmap nub (many $ strArgument (mconcat [ - metavar "-- FILES..." - ])) + where + modeOption = option $ readerAsk >>= \opt -> case opt of + "normal" -> return Normal + "dry-run" -> return DryRun + _ -> readerError $ "unrecognised mode `" ++ opt ++ "'" diff --git a/src/Git/Fmt/Process.hs b/src/Git/Fmt/Process.hs --- a/src/Git/Fmt/Process.hs +++ b/src/Git/Fmt/Process.hs @@ -14,7 +14,7 @@ module Git.Fmt.Process ( -- * Run - run, + runProcess, runProcess_, runCommand, runCommand_, runCreateProcess, runCreateProcess_, ) where import Control.Monad.IO.Class @@ -22,19 +22,49 @@ import Data.Text hiding (unwords) -import System.Exit -import System.Process as System +import System.Exit +import System.IO.Extra' +import System.Process (CreateProcess, CmdSpec(..)) +import qualified System.Process as System +-- | Runs the given executable with the arguments. +-- Returns the exit code, stdout and stderr. +runProcess :: (MonadIO m, MonadLogger m) => FilePath -> [String] -> m (ExitCode, String, String) +runProcess cmd args = runCreateProcess (System.proc cmd args) "" --- | Runs the given command with the arguments. --- Depending on the exit code, either logs the stderr and exits fast or returns the stdout. -run :: (MonadIO m, MonadLogger m) => FilePath -> [String] -> m String -run cmd args = do - $(logDebug) $ pack (unwords $ cmd:args) +-- | Runs the given executable with the arguments. +-- Depending on the exit code, either logs the stderr and exits fast (128) or returns the stdout. +runProcess_ :: (MonadIO m, MonadLogger m) => FilePath -> [String] -> m String +runProcess_ cmd args = runCreateProcess_ (System.proc cmd args) "" - (exitCode, stdout, stderr) <- liftIO $ System.readProcessWithExitCode cmd args "" +-- | Runs the given command. +-- Returns the exit code, stdout and stderr. +runCommand :: (MonadIO m, MonadLogger m) => String -> m (ExitCode, String, String) +runCommand cmd = runCreateProcess (System.shell cmd) "" +-- | Runs the given command. +-- Depending on the exit code, either logs the stderr and exits fast (128) or returns the stdout. +runCommand_ :: (MonadIO m, MonadLogger m) => String -> m String +runCommand_ cmd = runCreateProcess_ (System.shell cmd) "" + +-- | Runs the given 'CreateProcess'. +-- Returns the exit code, stdout and stderr. +runCreateProcess :: (MonadIO m, MonadLogger m) => CreateProcess -> String -> m (ExitCode, String, String) +runCreateProcess process stdin = do + $(logDebug) $ pack (case System.cmdspec process of + ShellCommand cmd -> cmd + RawCommand cmd args -> unwords (cmd:args) + ) + + liftIO $ System.readCreateProcessWithExitCode process stdin + +-- | Runs the given 'CreateProcess'. +-- Depending on the exit code, either logs the stderr and exits fast (128) or returns the stdout. +runCreateProcess_ :: (MonadIO m, MonadLogger m) => CreateProcess -> String -> m String +runCreateProcess_ process stdin = do + (exitCode, stdout, stderr) <- runCreateProcess process stdin + if exitCode == ExitSuccess then return stdout - else $(logError) (pack stderr) >> liftIO (exitWith $ ExitFailure 1) + else panic stderr diff --git a/src/System/Directory/Extra'.hs b/src/System/Directory/Extra'.hs new file mode 100644 --- /dev/null +++ b/src/System/Directory/Extra'.hs @@ -0,0 +1,27 @@ + +{-| +Module : System.Directory.Extra' +Description : Extra extra directory utilities. + +Copyright : (c) Henry J. Wylde, 2015 +License : BSD3 +Maintainer : public@hjwylde.com + +Extra extra directory utilities. +-} + +module System.Directory.Extra' ( + -- * Changing directories + withCurrentDirectory, +) where + +import Control.Monad.Catch (MonadMask, bracket) +import Control.Monad.IO.Class + +import System.Directory + +-- | @withCurrentDirectory dir action@ performs @action@ with the current directory set to @dir@. +-- The current directory is reset back to what it was afterwards. +withCurrentDirectory :: (MonadIO m, MonadMask m) => FilePath -> m a -> m a +withCurrentDirectory dir action = bracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory) $ \_ -> liftIO (setCurrentDirectory dir) >> action + diff --git a/src/System/IO/Extra'.hs b/src/System/IO/Extra'.hs new file mode 100644 --- /dev/null +++ b/src/System/IO/Extra'.hs @@ -0,0 +1,39 @@ + +{-| +Module : System.IO.Extra' +Description : Extra extra IO utilities. + +Copyright : (c) Henry J. Wylde, 2015 +License : BSD3 +Maintainer : public@hjwylde.com + +Extra extra IO utilities. +-} + +{-# LANGUAGE TemplateHaskell #-} + +module System.IO.Extra' ( + -- * Exiting + panicWith, panic, exitFast, +) where + +import Control.Monad.IO.Class +import Control.Monad.Logger + +import Data.Text (pack) + +import System.Exit + +-- | Panics, logging the error to stderr and exiting fast with the code. +panicWith :: (MonadIO m, MonadLogger m) => String -> Int -> m a +panicWith error code = $(logError) (pack error) >> exitFast code + +-- | Panics, logging the error to stderr and exiting fast with 128. +panic :: (MonadIO m, MonadLogger m) => String -> m a +panic error = panicWith error 128 + +-- | Exits fast with the given code (may be 0 for success!). +exitFast :: (MonadIO m) => Int -> m a +exitFast 0 = liftIO exitSuccess +exitFast code = liftIO $ exitWith (ExitFailure code) + diff --git a/test/json/app/Main.hs b/test/json/app/Main.hs deleted file mode 100644 --- a/test/json/app/Main.hs +++ /dev/null @@ -1,24 +0,0 @@ - -{-| -Module : Main - -Copyright : (c) Henry J. Wylde, 2015 -License : BSD3 -Maintainer : public@hjwylde.com --} - -{-# OPTIONS_HADDOCK hide, prune #-} - -module Main ( - main, -) where - -import Git.Fmt.Language -import Git.Fmt.Test - -import Test.Tasty - - -main :: IO () -main = defaultMain =<< tests Json - diff --git a/test/shared/src/Git/Fmt/Test.hs b/test/shared/src/Git/Fmt/Test.hs deleted file mode 100644 --- a/test/shared/src/Git/Fmt/Test.hs +++ /dev/null @@ -1,59 +0,0 @@ - -{-| -Module : Git.Fmt.Test - -Copyright : (c) Henry J. Wylde, 2015 -License : BSD3 -Maintainer : public@hjwylde.com --} - -{-# OPTIONS_HADDOCK hide, prune #-} - -module Git.Fmt.Test ( - tests, -) where - -import Control.Exception - -import Data.ByteString.Lazy.Char8 (ByteString, pack) -import Data.List.Extra (lower) - -import Git.Fmt.Language - -import System.Directory -import System.FilePath - -import Test.Tasty -import Test.Tasty.Golden -import Text.Parsec hiding (lower) - - -tests :: Language -> IO TestTree -tests language = do - testsDir <- getCurrentDirectory >>= \dir -> return $ dir "test" language' "tests" - testDirs <- filter ((/= '.') . head) <$> getDirectoryContents testsDir - testTrees <- mapM (test language . combine testsDir) testDirs - - return $ testGroup (language' ++ "tests") testTrees - where - language' = lower $ show language - - -test :: Language -> String -> IO TestTree -test language dir = return $ goldenVsString (takeFileName dir) - (dir "expected-output" <.> extension language) - (withCurrentDirectory dir $ fmt language) - -fmt :: Language -> IO ByteString -fmt language = do - input <- readFile inputFileName - - return . pack $ case runParser (parser language) () inputFileName input of - Left error -> show error ++ "\n" - Right doc -> renderWithTabs doc - where - inputFileName = "input" <.> extension language - -withCurrentDirectory :: FilePath -> IO a -> IO a -withCurrentDirectory dir action = bracket getCurrentDirectory setCurrentDirectory $ \_ -> setCurrentDirectory dir >> action -