diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,7 +1,7 @@ git-vogue - A framework for pre-commit checks ========================================================= -[![Travis Status](http://travis-ci.org/anchor/git-vogue.png?branch=master)](https://travis-ci.org/anchor/git-vogue) +[![Travis Status](http://travis-ci.org/christian-marie/git-vogue.png?branch=master)](https://travis-ci.org/christian-marie/git-vogue) Intended to be used as a git pre-commit hook, *git-vogue* encourages developers to keep their Haskell code ["en vogue"][1] by providing a framework for @@ -12,7 +12,7 @@ * [cabal][6] * [hlint][2] * [stylish-haskell][4] with automatic fixing -* [ghc-mod][5] +* [ghc-mod][5] (not with ghc8 , yet) [1]: https://www.youtube.com/watch?v=GuJQSAiODqI [2]: http://hackage.haskell.org/package/hlint diff --git a/changelog.txt b/changelog.txt --- a/changelog.txt +++ b/changelog.txt @@ -1,3 +1,9 @@ +2017-08-14 v0.2.0.1 Christian Marie + * dependencies: Bump ghc-mod, hlint and stylish-haskell to be inline + with latest stack-9.0 lts + * plugins: ghc-mod will only work with >=5.8 now due CPP allergy + * plugins: packunused plugin now vacuously succeeds if binary not found + 2015-01-30 v0.2.0.1 Christian Marie * dependencies: Drop list-tries dependency diff --git a/git-vogue.cabal b/git-vogue.cabal --- a/git-vogue.cabal +++ b/git-vogue.cabal @@ -1,22 +1,27 @@ name: git-vogue -version: 0.2.1.1 +version: 0.2.2.1 synopsis: A framework for pre-commit checks. description: Make your Haskell git repositories fashionable. -homepage: https://github.com/oswynb/git-vogue +homepage: https://github.com/christian-marie/git-vogue license: BSD3 license-file: LICENSE -author: Anchor Engineering -maintainer: Oswyn Brent -copyright: (c) 2015 Anchor Systems, Pty Ltd and Others +author: Anchor Engineering (defunct) +maintainer: Christian Marie , Oswyn Brent +copyright: (c) 2017 Christian Marie, Anchor Systems, Pty Ltd and Others category: Development build-type: Custom extra-source-files: README.md, changelog.txt -cabal-version: >=1.10 +cabal-version: >=1.23 data-files: templates/pre-commit +custom-setup + setup-depends: base + , filepath + , Cabal + source-repository HEAD type: git - location: https://github.com/oswynb/git-vogue + location: https://github.com/christian-marie/git-vogue flag gpl default: True @@ -28,15 +33,17 @@ exposed-modules: Git.Vogue Git.Vogue.Types Git.Vogue.VCS.Git + Git.Vogue.VCS.Null Git.Vogue.PluginDiscoverer.Libexec Git.Vogue.PluginCommon other-modules: Paths_git_vogue - build-depends: base >=4.6 && <5 + build-depends: base >=4.8 && <5 , containers , directory + , extra >= 1.4 && < 1.6 , filepath , formatting - , optparse-applicative >= 0.11 + , optparse-applicative >= 0.11 && < 0.14 , process , split , text @@ -70,11 +77,19 @@ , directory , git-vogue , haskell-src-exts - , hlint >= 1.9.27 && < 1.10 + , hlint >= 2 , hscolour if !flag(gpl) cpp-options: -DGPL_SCARES_ME +executable git-vogue-packunused + default-language: Haskell2010 + hs-source-dirs: src + main-is: git-vogue-packunused.hs + build-depends: base + , git-vogue + , process + executable git-vogue-stylish default-language: Haskell2010 hs-source-dirs: src @@ -83,15 +98,22 @@ , Diff , git-vogue , strict - , stylish-haskell >= 0.5.16 && < 0.6 + , stylish-haskell >= 0.7 +Flag ghc-mod + Description: build ghc-mod plugin + Default: True + executable git-vogue-ghc-mod + if flag(ghc-mod) + build-depends: base + , ghc-mod >= 5.8 + , git-vogue + else + buildable: False default-language: Haskell2010 hs-source-dirs: src main-is: git-vogue-ghc-mod.hs - build-depends: base - , ghc-mod >= 5.2 && < 5.6 - , git-vogue test-suite unit type: exitcode-stdio-1.0 diff --git a/lib/Git/Vogue.hs b/lib/Git/Vogue.hs --- a/lib/Git/Vogue.hs +++ b/lib/Git/Vogue.hs @@ -9,12 +9,10 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} module Git.Vogue where @@ -28,7 +26,7 @@ import qualified Data.Text.Lazy.IO as T import Data.Traversable hiding (sequence) import Formatting -import Prelude hiding (elem, maximum) +import Prelude hiding (elem, maximum, notElem) import System.Directory import System.Exit @@ -39,10 +37,13 @@ :: forall m. (Applicative m, MonadIO m, Functor m) => VogueCommand -> SearchMode + -> [PluginName] + -- ^ Disabled plugins -> VCS m -> PluginDiscoverer m -> m () -runCommand cmd search_mode VCS{..} PluginDiscoverer{..} = go cmd +runCommand cmd search_mode disabled_plugins VCS{..} PluginDiscoverer{..} = + go cmd where cd = getTopLevel >>= liftIO . setCurrentDirectory go CmdInit = do @@ -121,7 +122,9 @@ check_fs <- getFiles search_mode when (null check_fs) (success "Vacuous success - Nothing to check") - plugins <- filter enabled <$> discoverPlugins + plugins <- filter ((`notElem` disabled_plugins) . pluginName) + . filter enabled + <$> discoverPlugins when (null check_fs) (success "Vacuous success - No plugins enabled") all_fs <- getFiles FindAll diff --git a/lib/Git/Vogue/PluginCommon.hs b/lib/Git/Vogue/PluginCommon.hs --- a/lib/Git/Vogue/PluginCommon.hs +++ b/lib/Git/Vogue/PluginCommon.hs @@ -7,8 +7,6 @@ -- the 3-clause BSD licence. -- -{-# LANGUAGE TupleSections #-} - -- | Common helpers for git vogue plugins module Git.Vogue.PluginCommon ( @@ -175,13 +173,13 @@ -- Helper for plugin commands that take [FilePath]s fpCommand :: String - -> ([FilePath] -> [FilePath] -> a) + -> (FilePath -> FilePath -> a) -> String -> Mod CommandFields a fpCommand name ctor desc = command name (info parser (progDesc desc)) where - parser = ctor <$> argument (lines <$> str) (metavar "CHECKABLE_FILES") - <*> argument (lines <$> str) (metavar "ALL_FILES") + parser = ctor <$> argument str (metavar "CHECKABLE_FILES_LIST") + <*> argument str (metavar "ALL_FILES_LIST") -- | Sub-command helper pureSubCommand :: String -> a -> String -> Mod CommandFields a @@ -199,9 +197,9 @@ -- | Arguments to the plugin data PluginCommand -- | Check the project for problems. - = CmdCheck [FilePath] [FilePath] + = CmdCheck FilePath FilePath -- | Fix problems in the project. - | CmdFix [FilePath] [FilePath] + | CmdFix FilePath FilePath -- | Report details. | CmdName diff --git a/lib/Git/Vogue/PluginDiscoverer/Libexec.hs b/lib/Git/Vogue/PluginDiscoverer/Libexec.hs --- a/lib/Git/Vogue/PluginDiscoverer/Libexec.hs +++ b/lib/Git/Vogue/PluginDiscoverer/Libexec.hs @@ -26,6 +26,7 @@ import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as T import Data.Traversable +import Extra (withTempFile) import System.Directory import System.Environment import System.Exit @@ -133,9 +134,13 @@ -> [FilePath] -> m Result runPlugin plugin cmd check_fs all_fs = liftIO $ do - (status, out, err) <- readProcessWithExitCode plugin [ cmd - , unlines check_fs - , unlines all_fs] "" + (status, out, err) <- withTempFile (\checkFileListPath -> + withTempFile (\allFileListPath -> do + writeFile checkFileListPath (show check_fs) + writeFile allFileListPath (show all_fs) + readProcessWithExitCode plugin [cmd, checkFileListPath, allFileListPath] "" + ) + ) let glommed = fromString $ out <> err return $ case status of ExitSuccess -> Success glommed diff --git a/lib/Git/Vogue/Types.hs b/lib/Git/Vogue/Types.hs --- a/lib/Git/Vogue/Types.hs +++ b/lib/Git/Vogue/Types.hs @@ -24,7 +24,12 @@ data VogueOptions = Options { optSearch :: SearchMode , optCommand :: VogueCommand + , optDisable :: [PluginName] + , optVCS :: VCSType } + deriving (Eq, Show) + +data VCSType = Git | Null deriving (Eq, Show) -- | Commands, with parameters, to be executed. diff --git a/lib/Git/Vogue/VCS/Git.hs b/lib/Git/Vogue/VCS/Git.hs --- a/lib/Git/Vogue/VCS/Git.hs +++ b/lib/Git/Vogue/VCS/Git.hs @@ -42,8 +42,8 @@ => SearchMode -> m [FilePath] gitGetFiles mode = liftIO . existantFiles $ - case mode of FindChanged -> git ["diff", "--cached", "--name-only"] - FindAll -> git ["ls-files"] + case mode of FindChanged -> git ["diff", "--cached", "--name-only"] + FindAll -> git ["ls-files"] FindSpecific fs -> pure $ unlines fs where existantFiles f = lines <$> f >>= filterM doesFileExist diff --git a/lib/Git/Vogue/VCS/Null.hs b/lib/Git/Vogue/VCS/Null.hs new file mode 100644 --- /dev/null +++ b/lib/Git/Vogue/VCS/Null.hs @@ -0,0 +1,56 @@ +-- | Provide a VCS implementation for directories not under version control +module Git.Vogue.VCS.Null +( nullVCS, +) where + +import Control.Monad (filterM) +import Control.Monad.IO.Class +import Git.Vogue.Types +import System.Directory +import System.FilePath + +nullVCS :: MonadIO m => VCS m +nullVCS = VCS + { getFiles = nullGetFiles + , installHook = nullInstallHook + , removeHook = nullRemoveHook + , checkHook = nullCheckHook + , getTopLevel = nullGetTopLevel + } + +nullGetFiles :: MonadIO m => SearchMode -> m [FilePath] +nullGetFiles mode = case mode of + FindSpecific fs -> existantFiles fs + _ -> liftIO getAllFiles + where + existantFiles = filterM (liftIO . doesFileExist) + +nullInstallHook :: MonadIO m => m () +nullInstallHook = + liftIO $ putStrLn "Warning, hooks can't be installed with the null VCS backend" + +nullRemoveHook :: MonadIO m => m () +nullRemoveHook = + liftIO $ putStrLn "Warning, hooks can't be removed with the null VCS backend" + +nullCheckHook :: Applicative m => m Bool +nullCheckHook = pure False + +nullGetTopLevel :: MonadIO m => m FilePath +nullGetTopLevel = liftIO getCurrentDirectory + +getAllFiles :: IO [FilePath] +getAllFiles = do + currentDirectory <- getCurrentDirectory + fs <- go currentDirectory + pure (makeRelative currentDirectory <$> fs) + where + go dir = do + (dirs, files) <- getFilesAndDirectories dir + (files ++) . concat <$> mapM go dirs + +getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) +getFilesAndDirectories dir = do + c <- fmap (dir ) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir + (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c + diff --git a/src/git-vogue-cabal.hs b/src/git-vogue-cabal.hs --- a/src/git-vogue-cabal.hs +++ b/src/git-vogue-cabal.hs @@ -33,7 +33,9 @@ where f CmdName = putStrLn "cabal" - f (CmdCheck check_fs all_fs) = do + f (CmdCheck check_fs_list all_fs_list) = do + check_fs <- read <$> readFile check_fs_list + all_fs <- read <$> readFile all_fs_list -- Grab all the projects dirs we want to traverse through rs <- forProjects (hsProjects check_fs all_fs) (const check) unless (and rs) exitFailure @@ -71,8 +73,9 @@ let isDistError PackageDistSuspicious {} = False isDistError _ = True errors = filter isDistError packageChecks - unless (null errors) $ + unless (null errors) $ do outputBad "Hackage would reject this package." + printCheckMessages errors when (null packageChecks) $ outputGood "Checked cabal file" return (null packageChecks) diff --git a/src/git-vogue-ghc-mod.hs b/src/git-vogue-ghc-mod.hs --- a/src/git-vogue-ghc-mod.hs +++ b/src/git-vogue-ghc-mod.hs @@ -14,14 +14,14 @@ import Control.Monad import Data.Char import Data.Foldable -import Data.List hiding (and, notElem) +import Data.List hiding (and, notElem) import Data.Maybe import Data.Monoid import Data.Traversable +import GhcMod +import GhcMod.Monad import Git.Vogue.PluginCommon -import Language.Haskell.GhcMod -import Language.Haskell.GhcMod.Monad -import Prelude hiding (and, notElem) +import Prelude hiding (and, notElem) import System.Exit main :: IO () @@ -31,7 +31,9 @@ "git-vogue-ghc-mod - check for ghc-mod problems" where f CmdName = putStrLn "ghc-mod" - f (CmdCheck check_fs all_fs) = do + f (CmdCheck check_fs_list all_fs_list) = do + check_fs <- read <$> readFile check_fs_list + all_fs <- read <$> readFile all_fs_list -- Have to change to the project directory for each ghc-mod run or it -- will be sad. -- diff --git a/src/git-vogue-hlint.hs b/src/git-vogue-hlint.hs --- a/src/git-vogue-hlint.hs +++ b/src/git-vogue-hlint.hs @@ -40,7 +40,9 @@ "git-vogue-hlint - check for hlint problems" where f CmdName = putStrLn "hlint" - f (CmdCheck check_fs all_fs) = do + f (CmdCheck check_fs_list all_fs_list) = do + check_fs <- read <$> readFile check_fs_list + all_fs <- read <$> readFile all_fs_list -- Traverse the files, parsing and processing as we go for efficiency rs <- forProjects (hsProjects check_fs all_fs) $ \fs -> do let hss = filter (isSuffixOf ".hs") fs @@ -119,5 +121,5 @@ showNotes :: [Note] -> String showNotes = intercalate ", " . fmap show . filter use where use ValidInstance{} = False -- Not important enough to tell an end user - use _ = True + use _ = True diff --git a/src/git-vogue-packunused.hs b/src/git-vogue-packunused.hs new file mode 100644 --- /dev/null +++ b/src/git-vogue-packunused.hs @@ -0,0 +1,61 @@ +-- +-- Copyright © 2013-2015 Anchor Systems, Pty Ltd and Others +-- +-- The code in this file, and the program it is a part of, is +-- made available to you by its authors as open source software: +-- you can redistribute it and/or modify it under the terms of +-- the 3-clause BSD licence. +-- + +{-# LANGUAGE ViewPatterns #-} + +-- | Description: Check with "packunused". +module Main where + +import Control.Exception +import Control.Monad (unless) +import Data.Foldable +import Data.Monoid +import Git.Vogue.PluginCommon +import Prelude hiding (and, mapM_) +import System.Exit +import System.IO.Error +import System.Process + +main :: IO () +main = f =<< getPluginCommand + "Check your Haskell project for redundant dependencies." + "git-vogue-packunused - check for redundant dependencies" + where + f CmdName = putStrLn "packunused" + + f (CmdCheck check_fs_list all_fs_list) = do + check_fs <- read <$> readFile check_fs_list + all_fs <- read <$> readFile all_fs_list + -- Grab all the projects dirs we want to traverse through + rs <- forProjects (hsProjects check_fs all_fs) (const check) + unless (and rs) exitFailure + + f CmdFix{} = do + outputBad $ "There are redundant dependencies, you need to fix these " + <> "manually and then re-run check" + exitFailure + +-- | Runs the @packunused@ command, assuming that the build is current. +check :: IO Bool +check = do + r <- try $ readProcessWithExitCode "packunused" + [ "--ignore-empty-imports" + , "--ignore-package", "base" + ] "" + case r of + Right (ExitSuccess, _, _) -> do + outputGood "No unused dependencies. " + return True + Right (ExitFailure e, sout, _serr) -> do + outputBad sout + return False + Left (isDoesNotExistError -> True) -> do + outputUnfortunate "Could not find packunused, vacuously succeeding." + return True + Left e -> throwIO e diff --git a/src/git-vogue-stylish.hs b/src/git-vogue-stylish.hs --- a/src/git-vogue-stylish.hs +++ b/src/git-vogue-stylish.hs @@ -34,7 +34,8 @@ where hsFiles = filter (isSuffixOf ".hs") f _ CmdName = putStrLn "stylish" - f cfg (CmdCheck files _) = do + f cfg (CmdCheck check_fs_list _) = do + files <- read <$> readFile check_fs_list rs <- traverse (stylishCheckFile cfg) (hsFiles files) if and rs then do @@ -43,7 +44,8 @@ else exitFailure - f cfg (CmdFix files _) = do + f cfg (CmdFix check_fs_list _) = do + files <- read <$> readFile check_fs_list let files' = hsFiles files -- Fix all of the things first traverse_ (stylishRunFile cfg) files' diff --git a/src/git-vogue.hs b/src/git-vogue.hs --- a/src/git-vogue.hs +++ b/src/git-vogue.hs @@ -11,9 +11,12 @@ module Main where +import Data.Monoid ((<>)) +import Data.String (fromString) import qualified Data.Text.Lazy as T import Git.Vogue.PluginDiscoverer.Libexec import Git.Vogue.VCS.Git +import Git.Vogue.VCS.Null import Options.Applicative import Git.Vogue @@ -27,6 +30,8 @@ optionsParser = flip Options <$> commandParser <*> searchP + <*> many disableP + <*> vcsP where searchP :: Parser SearchMode searchP = fileList <|> allFlag @@ -34,9 +39,24 @@ allFlag = flag FindChanged FindAll ( long "all" <> short 'A' + <> short 'a' <> help "Apply to all files, not just changed files." ) + vcsP :: Parser VCSType + vcsP = flag Git Null + ( long "nogit" + <> help "Don't require a .git directory. Some functionality is disabled" + ) + + disableP :: Parser PluginName + disableP = fromString <$> strOption + ( long "disable" + <> short 'd' + <> help "Disable the plugin" + <> metavar "PLUGIN_NAME" + ) + commandParser :: Parser VogueCommand commandParser = subparser ( pureSubCommand "init" @@ -68,10 +88,14 @@ main :: IO () main = do opt <- execParser opts + let vcs = case optVCS opt of + Git -> gitVCS + Null -> nullVCS libexec_path <- getLibexecDir runCommand (optCommand opt) (optSearch opt) - gitVCS + (optDisable opt) + vcs (libExecDiscoverer libexec_path) where opts = info (helper <*> optionsParser) diff --git a/tests/unit.hs b/tests/unit.hs --- a/tests/unit.hs +++ b/tests/unit.hs @@ -18,6 +18,7 @@ import Control.Applicative import Control.Monad +import Data.Foldable (traverse_) import Data.Map (fromList) import System.Directory import System.FilePath @@ -142,8 +143,14 @@ withSystemTempDirectory "git-setup-test." $ \temp_dir -> do -- For some unknown reason, setting the current directory appears to do -- strange things with a bracket, so we don't bracket. + canonical_dir <- canonicalizePath temp_dir before_dir <- getCurrentDirectory - void $ git ["init", temp_dir] - setCurrentDirectory temp_dir - f temp_dir + let setup = [ ["init", canonical_dir] + , ["config", "--local", "user.email", "test"] + , ["config", "--local", "user.name", "test2"] + ] :: [[String]] + + setCurrentDirectory canonical_dir + traverse_ git setup + f canonical_dir setCurrentDirectory before_dir