packages feed

git-fmt (empty) → 0.1.0.0

raw patch · 13 files changed

+592/−0 lines, 13 filesdep +basedep +bytestringdep +directorysetup-changed

Dependencies added: base, bytestring, directory, exceptions, extra, fast-logger, filepath, git-fmt, json, monad-logger, mtl, optparse-applicative, parsec, pretty, process, tasty, tasty-golden, text, time, transformers

Files

+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2015, Henry J. Wylde+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+  list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+  this list of conditions and the following disclaimer in the documentation+  and/or other materials provided with the distribution.++* Neither the name of git-fmt nor the names of its+  contributors may be used to endorse or promote products derived from+  this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,65 @@++{-|+Module      : Main++Copyright   : (c) Henry J. Wylde, 2015+License     : BSD3+Maintainer  : public@hjwylde.com+-}++{-# OPTIONS_HADDOCK hide, prune #-}++{-# LANGUAGE OverloadedStrings #-}++module Main (+    main,+) where++import Control.Monad.Logger++import              Data.ByteString.Char8   (ByteString)+import qualified    Data.ByteString.Char8   as BS+import              Data.List.Extra         (lower)+import              Data.Time               (getZonedTime)++import Git.Fmt+import Git.Fmt.Options.Applicative.Parser++import Options.Applicative++import Prelude hiding (filter, log)++import System.IO+import System.Log.FastLogger+++main :: IO ()+main = customExecParser gitFmtPrefs gitFmtInfo >>= \options ->+    runLoggingT (filter options (handle options)) (if optVerbose options 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++-- 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)+    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 ++ "]"++    BS.hPutStrLn h (BS.unwords [timestamp, formatLevel level, fromLogStr msg])+    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+
+ git-fmt.cabal view
@@ -0,0 +1,91 @@+name:           git-fmt+version:        0.1.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.+                The idea was taken from gofmt, just with a bit of expansion to more languages.++license:        BSD3+license-file:   LICENSE++cabal-version:  >= 1.10+category:       Development+build-type:     Simple++source-repository head+    type:       git+    location:   git@github.com:hjwylde/git-fmt++executable git-fmt+    main-is:        Main.hs+    hs-source-dirs: app/+    ghc-options:    -Wall -fno-warn-name-shadowing++    default-language: Haskell2010+    build-depends:+        base == 4.8.*,+        bytestring == 0.10.*,+        extra == 1.4.*,+        fast-logger == 2.4.*,+        git-fmt,+        monad-logger == 0.3.*,+        optparse-applicative == 0.11.*,+        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.Process,+        Git.Fmt.Version,+        Paths_git_fmt++    default-language: Haskell2010+    other-extensions:+        TemplateHaskell+    build-depends:+        base == 4.8.*,+        directory == 1.2.*,+        exceptions == 0.8.*,+        extra == 1.4.*,+        filepath == 1.4.*,+        json == 0.9.*,+        monad-logger == 0.3.*,+        mtl == 2.2.*,+        optparse-applicative == 0.11.*,+        parsec == 3.1.*,+        pretty == 1.1.*,+        process == 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.*+
+ src/Git/Fmt.hs view
@@ -0,0 +1,79 @@++{-|+Module      : Git.Fmt+Description : Options and handler for the git-fmt command.++Copyright   : (c) Henry J. Wylde, 2015+License     : BSD3+Maintainer  : public@hjwylde.com++Options and handler for the git-fmt command.+-}++{-# LANGUAGE TemplateHaskell #-}++module Git.Fmt (+    -- * Options+    Options(..),++    -- * Handle+    handle,+) where++import Control.Monad+import Control.Monad.Catch      (MonadMask, bracket)+import Control.Monad.IO.Class+import Control.Monad.Logger++import Data.Text (pack)++import Git.Fmt.Language+import Git.Fmt.Process++import System.Directory+import System.FilePath++import Text.Parsec+++-- | Options.+data Options = Options {+        optQuiet        :: Bool,+        optVerbose      :: Bool,+        optDryRun       :: Bool,+        optListUgly     :: Bool,+        argFilePaths    :: [FilePath]+    }+    deriving (Eq, Show)++-- | Builds the files according to the options.+handle :: (MonadIO m, MonadLogger m, MonadMask m) => Options -> m ()+handle options = run "git" ["rev-parse", "--show-toplevel"] >>= \dir -> withCurrentDirectory (init dir) $ do+    filePaths <- if null (argFilePaths options) then lines <$> run "git" ["ls-files"] else return (argFilePaths options)++    filterM (liftIO . doesFileExist) filePaths >>= mapM_ (\filePath ->+        maybe (return ()) (fmt options filePath) (languageOf $ takeExtension filePath))+++fmt :: (MonadIO m, MonadLogger m) => Options -> FilePath -> Language -> m ()+fmt options filePath language = do+    input <- liftIO $ readFile filePath++    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++            if input == output+                then+                    $(logDebug) $ pack (filePath ++ ": pretty")+                else do+                    $(logInfo) $ pack (filePath ++ ": ugly" ++ if optDryRun options then "" else " (-> pretty)")++                    unless (optDryRun options) $ liftIO (writeFile filePath output)++withCurrentDirectory :: (MonadIO m, MonadMask m) => FilePath -> m a -> m a+withCurrentDirectory dir action = bracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory) $ \_ -> liftIO (setCurrentDirectory dir) >> action+
+ src/Git/Fmt/Language.hs view
@@ -0,0 +1,55 @@++{-|+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+
+ src/Git/Fmt/Language/Json/Parser.hs view
@@ -0,0 +1,27 @@++{-|+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"+
+ src/Git/Fmt/Language/Json/Pretty.hs view
@@ -0,0 +1,35 @@++{-|+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 Data.List.Extra (lower)++import Text.JSON.Types+import Text.PrettyPrint.HughesPJClass+++instance Pretty JSValue where+    pPrint (JSArray values)     = cat [char '[', nest 1 (sep $ punctuate (char ',') (map pPrint values)), char ']']+    pPrint (JSBool bool)        = text $ lower (show bool)+    pPrint (JSNull)             = text "null"+    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 (JSRational _ rat)   = text $ show (fromRational rat :: Double)+    pPrint (JSString str)       = char '"' <> text (fromJSString str) <> char '"'+
+ src/Git/Fmt/Options/Applicative/Parser.hs view
@@ -0,0 +1,68 @@++{-|+Module      : Git.Fmt.Options.Applicative.Parser+Description : Optparse utilities for the git-fmt command.++Copyright   : (c) Henry J. Wylde, 2015+License     : BSD3+Maintainer  : public@hjwylde.com++Optparse utilities for the git-fmt command.+-}++module Git.Fmt.Options.Applicative.Parser (+    -- * Optparse for GitFmt+    gitFmtPrefs, gitFmtInfo, gitFmt,+) where++import Data.List    (nub)+import Data.Version (showVersion)++import Options.Applicative++import Git.Fmt+import Git.Fmt.Version as This+++-- | The default preferences.+--   Limits the help output to 100 columns.+gitFmtPrefs :: ParserPrefs+gitFmtPrefs = prefs $ columns 100++-- | An optparse parser of a git-fmt command.+gitFmtInfo :: ParserInfo Options+gitFmtInfo = info (infoOptions <*> gitFmt) fullDesc+    where+        infoOptions = helper <*> version <*> numericVersion+        version = infoOption ("Version " ++ showVersion This.version) $ mconcat [+            long "version", short 'V', hidden,+            help "Show this binary's version"+            ]+        numericVersion = infoOption (showVersion This.version) $ mconcat [+            long "numeric-version", hidden,+            help "Show this binary's version (without the prefix)"+            ]++-- | An options parser.+gitFmt :: Parser Options+gitFmt = Options+    <$> switch (mconcat [+        long "quiet", short 'q',+        help "Be quiet"+        ])+    <*> switch (mconcat [+        long "verbose", short 'v',+        help "Be verbose"+        ])+    <*> switch (mconcat [+        long "dry-run", short 'n',+        help "Doesn't perform any writes (useful with --list-ugly)"+        ])+    <*> switch (mconcat [+        long "list-ugly", short 'l',+        help "List all ugly files formatted"+        ])+    <*> fmap nub (many $ strArgument (mconcat [+        metavar "-- FILES..."+        ]))+
+ src/Git/Fmt/Process.hs view
@@ -0,0 +1,40 @@++{-|+Module      : Git.Fmt.Process+Description : System process utilities.++Copyright   : (c) Henry J. Wylde, 2015+License     : BSD3+Maintainer  : public@hjwylde.com++System process utilities.+-}++{-# LANGUAGE TemplateHaskell #-}++module Git.Fmt.Process (+    -- * Run+    run,+) where++import Control.Monad.IO.Class+import Control.Monad.Logger++import Data.Text hiding (unwords)++import System.Exit+import System.Process as System+++-- | 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)++    (exitCode, stdout, stderr) <- liftIO $ System.readProcessWithExitCode cmd args ""++    if exitCode == ExitSuccess+        then return stdout+        else $(logError) (pack stderr) >> liftIO (exitWith $ ExitFailure 1)+
+ src/Git/Fmt/Version.hs view
@@ -0,0 +1,20 @@++{-|+Module      : Git.Fmt.Version+Description : Haskell constant of the binary version.++Copyright   : (c) Henry J. Wylde, 2015+License     : BSD3+Maintainer  : public@hjwylde.com++Haskell constant of the binary version.+-}++module Git.Fmt.Version (+    -- * Version+    -- | The binary version.+    version,+) where++import Paths_git_fmt (version)+
+ test/json/app/Main.hs view
@@ -0,0 +1,24 @@++{-|+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+
+ test/shared/src/Git/Fmt/Test.hs view
@@ -0,0 +1,59 @@++{-|+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+