git-fmt 0.1.0.3 → 0.2.0.0

raw patch · 13 files changed

+358/−307 lines, 13 filesdep +aesondep +exceptionsdep +monad-paralleldep −bytestringdep −jsondep −parsecPVP ok

version bump matches the API change (PVP)

Dependencies added: aeson, exceptions, monad-parallel, temporary, unordered-containers, yaml

Dependencies removed: bytestring, json, parsec, pretty, tasty, tasty-golden

API changes (from Hackage documentation)

Files

• app/Main.hs +24/−16
• git-fmt.cabal +20/−33
• src/Git/Fmt.hs +102/−36
• src/Git/Fmt/Config.hs +82/−0
• src/Git/Fmt/Language.hs +0/−55
• src/Git/Fmt/Language/Json/Parser.hs +0/−27
• src/Git/Fmt/Language/Json/Pretty.hs +0/−30
• src/Git/Fmt/Options/Applicative/Parser.hs +24/−17
• src/Git/Fmt/Process.hs +40/−10
• src/System/Directory/Extra'.hs +27/−0
• src/System/IO/Extra'.hs +39/−0
• test/json/app/Main.hs +0/−24
• test/shared/src/Git/Fmt/Test.hs +0/−59

@@ -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 

@@ -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.* 

@@ -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)+        ] 

@@ -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"+

@@ -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-

@@ -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"-

@@ -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 ""-

@@ -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 ++ "'" 

@@ -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 

@@ -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+

@@ -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)+

@@ -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-

@@ -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-