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)](https://travis-ci.org/anchor/git-vogue) +[![Travis Status](http://travis-ci.org/anchor/git-vogue.png?branch=master)](https://travis-ci.org/anchor/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 @@ -42,27 +42,17 @@ # Plugin discovery/disabling -Running `git-vogue plugins` will show you the libexec directory in which -git-vogue will discover plugins. - -Should one or more plugins annoy you, you may disable it globally by setting it -non-executable: - -```bash -chmod -x .cabal/libexec/git-vogue/git-vogue-stylish -``` +Running `git-vogue plugins` will show you which plugins are currently detected +and enabled. This set can be tweaked on a per-repository basis with git-vogue +enable and git-vogue disable. -Alternatively you can disable plugins on a per-repository, per-user, or -per-system basis by adding the file name to the `vogue.disable` key in your git -configuration: +Alternatively you can disable plugins on a per-system basis by adding the file +name to the `vogue.disable` key in your git global configuration: ````bash -git config --local --add vogue.disable git-vogue-a-plugin -git config --global --add vogue.disable git-vogue-another-plugin +git config --global --add vogue.disable cabal ```` -A more sophisticated interface to plugin manipulation is planned. - # Plugins ## cabal @@ -119,20 +109,20 @@ Plugin specification ------------------- -**The interface** for an executable (to be called by git-vogue) is a single -command line argument, one of: - -* check -* fix -* name +**The interface** for an executable (to be called by git-vogue) is a command +line argument, one of {check,fix,name}, followed by a list of files that are to +be checked, and then a list of all the files in the repository that are not +ignored. These lists are newline separated. The plugin can assume that the CWD will be set to the top-level directory of the package. -The plugin will receive a list of all files in the current repository that may -be looked at via STDIN when running in "check" or "fix" mode. These file paths -will be absolute and newline separated. The plugin is expected to filter them -appropriate to its needs. +Here's how you might run stylish-haskell on all files in the current directory: + +``` +cd dir-to-check; +path-to-libexec/git-vogue-stylish check "$(find .)" "$(find .)" +``` ## Invariants for well-behaved plugin commands diff --git a/git-vogue.cabal b/git-vogue.cabal --- a/git-vogue.cabal +++ b/git-vogue.cabal @@ -1,5 +1,5 @@ name: git-vogue -version: 0.1.0.4 +version: 0.2.0.0 synopsis: A framework for pre-commit checks. description: Make your Haskell git repositories fashionable. homepage: https://github.com/anchor/git-vogue @@ -27,14 +27,16 @@ hs-source-dirs: lib exposed-modules: Git.Vogue Git.Vogue.Types - Git.Vogue.Plugins + Git.Vogue.VCS.Git + Git.Vogue.PluginDiscoverer.Libexec Git.Vogue.PluginCommon other-modules: Paths_git_vogue - build-depends: base >=4.7 && <4.8 - , MissingH + build-depends: base >=4.6 && <5 , directory , filepath , process + , containers + , list-tries , formatting , split , text @@ -51,9 +53,10 @@ default-language: Haskell2010 hs-source-dirs: src main-is: git-vogue.hs - build-depends: base >=4.7 && <4.8 + build-depends: base , filepath , directory + , text , git-vogue , optparse-applicative , split @@ -62,16 +65,19 @@ default-language: Haskell2010 hs-source-dirs: src main-is: git-vogue-cabal.hs - build-depends: base >=4.7 && <4.8 + build-depends: base , Cabal + , containers , git-vogue + , directory + , filepath , process executable git-vogue-hlint default-language: Haskell2010 hs-source-dirs: src main-is: git-vogue-hlint.hs - build-depends: base >=4.7 && <4.8 + build-depends: base , directory , filepath , hlint @@ -88,7 +94,7 @@ default-language: Haskell2010 hs-source-dirs: src main-is: git-vogue-stylish.hs - build-depends: base >=4.7 && <4.8 + build-depends: base , Diff , directory , filepath @@ -101,41 +107,30 @@ default-language: Haskell2010 hs-source-dirs: src main-is: git-vogue-ghc-mod.hs - build-depends: base >=4.7 && <4.8 + build-depends: base , Diff , directory + , containers , filepath , git-vogue , process , strict , ghc-mod -test-suite test-git-setup +test-suite unit type: exitcode-stdio-1.0 default-language: Haskell2010 hs-source-dirs: tests - main-is: git-setup.hs - build-depends: base >=4.7 && <4.8 + main-is: unit.hs + build-depends: base , directory , filepath - , git-vogue - , hspec - , process - , transformers - , unix - -test-suite test-plugins - type: exitcode-stdio-1.0 - default-language: Haskell2010 - hs-source-dirs: tests - main-is: plugins.hs - build-depends: base >=4.7 && <4.8 - , filepath + , containers , git-vogue , hspec + , temporary , process , transformers - , transformers-base , unix -- vim: set tabstop=21 expandtab: diff --git a/lib/Git/Vogue.hs b/lib/Git/Vogue.hs --- a/lib/Git/Vogue.hs +++ b/lib/Git/Vogue.hs @@ -7,196 +7,160 @@ -- the 3-clause BSD licence. -- -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} module Git.Vogue where import Control.Applicative -import Control.Exception import Control.Monad import Control.Monad.IO.Class -import Control.Monad.Reader -import Data.List -import Data.Monoid -import Data.String.Utils +import Data.Foldable +import Data.Maybe +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy.IO as T +import Data.Traversable hiding (sequence) +import Formatting +import Prelude hiding (elem, maximum) import System.Directory import System.Exit -import System.FilePath -import System.IO -import System.Posix.Files -import System.Process -import Git.Vogue.Plugins import Git.Vogue.Types -import Paths_git_vogue --- | Options parsed from the command-line. -data VogueOptions = Options - { optSearch :: SearchMode - , optCommand :: VogueCommand - } - deriving (Eq, Show) +-- | Execute a git-vogue command. +runCommand + :: forall m. (Applicative m, MonadIO m, Functor m) + => VogueCommand + -> SearchMode + -> VCS m + -> PluginDiscoverer m + -> m () +runCommand cmd search_mode VCS{..} PluginDiscoverer{..} = go cmd + where + cd = getTopLevel >>= liftIO . setCurrentDirectory + go CmdInit = do + cd + already_there <- checkHook + if already_there + then success "Pre-commit hook is already installed" + else do + installHook + installed <- checkHook + if installed + then success "Successfully installed hook" + else failure "Hook failed to install" --- | Commands, with parameters, to be executed. -data VogueCommand - -- | Add git-vogue support to a git repository. - = CmdInit { templatePath :: Maybe FilePath } - -- | Verify that support is installed and plugins happen. - | CmdVerify - -- | List the plugins that git-vogue knows about. - | CmdPlugins - -- | Run check plugins on files in a git repository. - | CmdRunCheck - -- | Run fix plugins on files in a git repository. - | CmdRunFix - deriving (Eq, Show) + go CmdVerify = do + cd + installed <- checkHook + if installed + then success "Pre-commit hook currently installed" + else failure "Pre-commit hook not installed" --- | Plugins that git-vogue knows about. --- FIXME: this will become the fix/check modules + go CmdPlugins = do + liftIO $ T.putStrLn "git-vogue knows about the following plugins:\n" + discoverPlugins >>= liftIO . traverse_ print -newtype Vogue m x = Vogue { vogue :: ReaderT [Plugin] m x } - deriving ( Functor, Applicative, Monad - , MonadTrans, MonadIO, MonadReader [Plugin] ) + go (CmdDisable plugin) = do + plugins <- discoverPlugins + if plugin `elem` fmap pluginName (filter (not . enabled) plugins) + then success "Plugin already disabled" + else + if plugin `elem` fmap pluginName plugins + then do + disablePlugin plugin + success "Disabled plugin" + else + failure "Unknown plugin" --- | Execute a Vogue program -runVogue - :: [Plugin] - -> Vogue m a - -> m a -runVogue ps (Vogue act) = runReaderT act ps --- | Execute a git-vogue command. -runCommand - :: (MonadIO m, Functor m) - => VogueCommand - -> SearchMode - -> Vogue m () -runCommand CmdInit{..} _ = runWithRepoPath (gitAddHook templatePath) -runCommand CmdVerify _ = runWithRepoPath (gitCheckHook runsVogue) -runCommand CmdPlugins _ = listPlugins -runCommand CmdRunCheck search = runCheck search -runCommand CmdRunFix search = runFix search + go (CmdEnable plugin) = do + ps <- discoverPlugins + if plugin `elem` fmap pluginName ps + then + if plugin `elem` (pluginName <$> filter (not . enabled) ps) + then do + enablePlugin plugin + success "Enabled plugin" + else + success "Plugin already enabled" + else + failure "Unknown plugin" --- | Try to fix the broken things. We first do one pass to check what's broken, --- then only run fix on those. -runFix :: (MonadIO m, Functor m) => SearchMode -> Vogue m () -runFix sm = do - -- See which plugins failed first - rs <- ask >>= mapM (\x -> (x,) <$> executeCheck ioPluginExecutorImpl sm x) - -- Now fix the failed ones only - getWorst (executeFix ioPluginExecutorImpl sm) [ x | (x, Failure{}) <- rs ] - >>= outputStatusAndExit + go CmdRunCheck = do + (check_fs, all_fs, plugins) <- things + rs <- for plugins $ \p -> do + r <- runCheck p check_fs all_fs + liftIO . T.putStrLn $ colorize p r + return r + exitWithWorst rs --- | Check for broken things. -runCheck :: MonadIO m => SearchMode -> Vogue m () -runCheck sm = - ask - >>= getWorst (executeCheck ioPluginExecutorImpl sm) - >>= outputStatusAndExit --- | Find the git repository path and pass it to an action. --- --- Throws an error if the PWD is not in a git repo. -runWithRepoPath - :: MonadIO m - => (FilePath -> m a) - -> m a -runWithRepoPath action = - -- Get the path to the git repo top-level directory. - liftIO (readProcess "git" ["rev-parse", "--show-toplevel"] "") - >>= action . strip + go CmdRunFix = do + cd + (check_fs, all_fs, plugins) <- things + rs <- for plugins $ \p -> do + r <- runCheck p check_fs all_fs + case r of + Failure{} -> do + r' <- runFix p check_fs all_fs + liftIO . T.putStrLn $ colorize p r' + return $ Just r' + _ -> return Nothing ---- | Command string to insert into pre-commit hooks. -preCommitCommand :: String -preCommitCommand = "git-vogue check" + exitWithWorst (catMaybes rs) --- | Add the git pre-commit hook. -gitAddHook - :: MonadIO m - => Maybe FilePath -- ^ Template path - -> FilePath -- ^ Hook path - -> Vogue m () -gitAddHook template path = liftIO $ do - let hook = path ".git" "hooks" "pre-commit" - exists <- fileExist hook - if exists - then updateHook hook - else createHook hook - where - createHook = copyHookTemplateTo template - updateHook hook = do - content <- readFile hook - unless (preCommitCommand `isInfixOf` content) $ do - putStrLn $ "A pre-commit hook already exists at \n\t" - <> hook - <> "\nbut it does not contain the command\n\t" - <> preCommitCommand - <> "\nPlease edit the hook and add this command yourself!" - exitFailure - putStrLn "Your commit hook is already in place." + things = do + check_fs <- getFiles search_mode + when (null check_fs) (success "Vacuous success - Nothing to check") --- | Copy the template pre-commit hook to a git repo. -copyHookTemplateTo - :: Maybe FilePath - -> FilePath - -> IO () -copyHookTemplateTo maybe_t hook = do - template <- maybe (getDataFileName "templates/pre-commit") return maybe_t - copyFile template hook - perm <- getPermissions hook - setPermissions hook $ perm { executable = True } + plugins <- filter enabled <$> discoverPlugins + when (null check_fs) (success "Vacuous success - No plugins enabled") --- | Use a predicate to check a git commit hook. -gitCheckHook - :: MonadIO m - => (FilePath -> IO Bool) - -> FilePath - -> Vogue m () -gitCheckHook p path = do - let hook = path ".git" "hooks" "pre-commit" - -- Check it exists (so openFile doesn't explode). - exists <- liftIO . fileExist $ hook - if exists - then checkPredicate hook - else failWith $ "Missing file " <> hook - liftIO exitSuccess - where - checkPredicate hook = liftIO $ do - pass <- p hook - unless pass $ failWith "Invalid configuration." - failWith msg = liftIO $ do - hPutStrLn stderr msg - exitFailure + all_fs <- getFiles FindAll + return (check_fs, all_fs, plugins) --- | Check that a script seems to run git vogue. -runsVogue - :: FilePath - -> IO Bool -runsVogue path = do - c <- readFile path - return $ preCommitCommand `isInfixOf` c +success, failure :: MonadIO m => Text -> m a +success msg = liftIO (T.putStrLn msg >> exitSuccess) +failure msg = liftIO (T.putStrLn msg >> exitFailure) --- | Print a list of all plugins. -listPlugins :: MonadIO m => Vogue m () -listPlugins = do - dir <- liftIO (( "git-vogue") <$> getLibexecDir) - liftIO . putStrLn $ "git-vogue looks for plugins in:\n\n\t" <> dir <> "\n" - plugins <- ask - liftIO . putStr - $ "git-vogue knows about the following plugins:\n\n" - <> unlines (fmap (('\t':) . unPlugin) plugins) +-- | Output the results of a run and exit with an appropriate return code +exitWithWorst + :: MonadIO m + => [Result] + -> m () +exitWithWorst [] = liftIO exitSuccess +exitWithWorst rs = liftIO $ + case maximum rs of + Success{} -> exitSuccess + Failure{} -> exitWith $ ExitFailure 1 + Catastrophe{} -> exitWith $ ExitFailure 2 --- | Get list of disabled plugins from git configuration. -disabledPlugins - :: (Monad m, Functor m, MonadIO m) - => m [String] -disabledPlugins = lines <$> liftIO (readConfig `catch` none) - where - readConfig = readProcess "git" ["config", "--get-all", "vogue.disable"] "" - none (SomeException _) = return [] +colorize + :: Plugin a + -> Result + -> Text +colorize Plugin{..} (Success txt) = + format ("\x1b[32m" + % text + % " succeeded\x1b[0m with:\n" + % text) (unPluginName pluginName) txt +colorize Plugin{..} (Failure txt) = + format ("\x1b[31m" + % text + % " failed\x1b[0m with:\n" + % text) (unPluginName pluginName) txt +colorize Plugin{..} (Catastrophe txt ret) = + format ("\x1b[31m" + % text + % " exploded \x1b[0m with exit code " + % int + %":\n" + % text) (unPluginName pluginName) txt ret 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,43 +7,197 @@ -- the 3-clause BSD licence. -- +{-# LANGUAGE TupleSections #-} + -- | Common helpers for git vogue plugins module Git.Vogue.PluginCommon ( - hsFiles, + -- * Output + outputGood, + outputUnfortunate, + outputBad, + lineWrap, + + -- * FilePath handling + hsProjects, + forProjects, + + -- * Command line parsing getPluginCommand, - pCommand, + pureSubCommand, PluginCommand(..), + + -- * Utility + forWithKey_, + forWithKey, ) where import Control.Applicative +import Control.Monad.IO.Class +import Data.Char +import Data.Functor import Data.List +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Maybe +import Data.Monoid import Options.Applicative +import System.Directory +import System.FilePath --- | Filter the incoming file list by .hs files. -hsFiles :: IO [FilePath] -hsFiles = filter (isSuffixOf ".hs") . lines <$> getContents +import Data.ListTrie.Patricia.Map.Eq (TrieMap, deleteSuffixes, + fromList, lookupPrefix, toList) +import Data.Ord --- | Arguments to the plugin -data PluginCommand - -- | Check the project for problems. - = CmdCheck - -- | Fix problems in the project. - | CmdFix - -- | Report details. - | CmdName +-- | The check went or is going well, this should make the developer happy +outputGood :: MonadIO m => String -> m () +outputGood = outputWithIcon " \x1b[32m[+]\x1b[0m " +-- | A non-fatal warning of some sort. The developer should be able to ignore +-- this. +outputUnfortunate :: MonadIO m => String -> m () +outputUnfortunate = outputWithIcon " \x1b[33m[*]\x1b[0m " + +-- | If any of these appear, you should probably be exploding and the developer +-- will be sad. +outputBad :: MonadIO m => String -> m () +outputBad = outputWithIcon " \x1b[31m[-]\x1b[0m " + +outputWithIcon :: MonadIO m => String -> String -> m () +outputWithIcon icon = liftIO . putStrLn . (icon <>) . prependWS + +-- | Prepend some whitespace to every line but the first so that subsequent +-- lines line up below a [+] or [-]. +prependWS :: String -> String +prependWS "" = "" +prependWS input = + let (x:xs) = lines input + in intercalate "\n" $ x : fmap (" " <>) xs + +-- | Convenience for line wrapping long lines. +lineWrap :: Int -> String -> String +lineWrap line_len = + intercalate "\n" . fmap (intercalate "\n" . unfoldr f) . lines + where + f [] = Nothing + f xs = Just . fmap lstrip $ splitAt line_len xs + lstrip = dropWhile isSpace + +-- | Helper for traversing a Map with keys +forWithKey_ :: Applicative f => Map k v -> (k -> v -> f ()) -> f () +forWithKey_ m a = void $ M.traverseWithKey a m + +forWithKey :: Applicative f => Map k v -> (k -> v -> f a) -> f (Map k a) +forWithKey = flip M.traverseWithKey + +-- | Find .cabal files in hsFiles and arrange children underneath these +-- "headings". +hsProjects + :: [FilePath] -- ^ Files to be checked + -> [FilePath] -- ^ All files + -> Map FilePath [FilePath] +hsProjects check_fs all_fs = + -- We want to stick the subset of files to be checked under the same + -- project headings as we would if we were checking all files. So we mush + -- them together. + -- + -- Discard the remainder, the user probably doesn't know what to do with + -- it. + let (complete_proj_map, _) = findProjects (isSuffixOf ".cabal") all_fs + -- Now do the awesome quadratic thing and traverse lists. + proj_map = fmap (filter (`elem` check_fs)) complete_proj_map + -- And finally strip the prefixes of the dirs, so that this looks a bit + -- like a one level trie. + bug = error "BUG: hsProjects: A key was not a prefix of its elements" + in M.mapWithKey (\k -> fmap (fromMaybe bug . stripPrefix k)) proj_map + +-- | For the given projects, perform the supplied action on each given relative +-- URLS and having set the current directory to the project. +-- +-- This will also take care of printing out a "Checking project in: " message. +forProjects + :: (MonadIO m, Applicative m) + => Map FilePath [FilePath] + -> ([FilePath] -> m a) + -> m (Map FilePath a) +forProjects projs f = do + cwd <- liftIO $ getCurrentDirectory >>= canonicalizePath + forWithKey projs $ \dir fs -> do + let pdir = "." dir + liftIO $ do + putStrLn $ "Checking project in: " <> pdir + setCurrentDirectory pdir + x <- f fs + liftIO $ setCurrentDirectory cwd + return x + +-- | Given a predicate to identify a file as being in the "root" of a +-- directory and a bunch of FilePaths, figure out which file paths belong under +-- these roots and "compartmentalize" them. The remainder of possibly +-- un-accounted-for files are the second element returned. +-- +-- This is useful for finding files belonging to distinct projects within a +-- repository. +findProjects + :: (FilePath -> Bool) + -> [FilePath] + -> (Map FilePath [FilePath], [FilePath]) +findProjects p xs = + -- We start out by putting all of the files in a trie. + -- + -- Note that we tack on a / for everything so that they share a common + -- root node. + let all_trie = unFlatten (fmap (splitPath . ('/':)) xs) + + -- Now we find all of the project roots. Again tacking on the root so + -- that init is safe and everything lines up. + roots = sortBy (comparing length) . fmap (init . splitPath . ('/':)) $ + filter p xs + + -- Now iterate over the project roots, taking the chunks of the tree + -- out that belong under that as we go. It's simpler than it looks. + f x (rs, t) = + (M.insertWith (<>) + (joinPath $ tail x) + ((fmap (joinPath . tail) . flatten) (lookupPrefix x t)) + rs + , deleteSuffixes x t) + (projects,remainder) = foldr f (mempty, all_trie) roots + + -- Now put the broken up paths back together and take the roots off. + in (projects + ,fmap (joinPath . tail) . flatten $ remainder) + where + -- Stuff a list of keys into a trie with dummy values. + unFlatten :: Eq k => [[k]] -> TrieMap k () + unFlatten = fromList . fmap (,()) + + -- Extract a list of keys from a trie, throwing away the values. + flatten :: Eq k => TrieMap k a -> [[k]] + flatten = fmap fst . toList + -- | Parser for plugin arguments pluginCommandParser :: Parser PluginCommand pluginCommandParser = subparser - ( pCommand "name" CmdName "Get name of plugin" - <> pCommand "check" CmdCheck "Check for problems" - <> pCommand "fix" CmdFix "Try to fix problems" + ( pureSubCommand "name" CmdName "Get name of plugin" + <> fpCommand "check" CmdCheck "Check for problems" + <> fpCommand "fix" CmdFix "Try to fix problems" ) +-- Helper for plugin commands that take [FilePath]s +fpCommand + :: String + -> ([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") + -- | Sub-command helper -pCommand :: String -> a -> String -> Mod CommandFields a -pCommand name ctor desc = command name (info (pure ctor) (progDesc desc)) +pureSubCommand :: String -> a -> String -> Mod CommandFields a +pureSubCommand name ctor desc = command name (info (pure ctor) (progDesc desc)) -- | Get the plugin command requested given a header and a description getPluginCommand :: String -> String -> IO PluginCommand @@ -53,4 +207,14 @@ ( fullDesc <> progDesc desc <> header hdr) + +-- | Arguments to the plugin +data PluginCommand + -- | Check the project for problems. + = CmdCheck [FilePath] [FilePath] + -- | Fix problems in the project. + | CmdFix [FilePath] [FilePath] + -- | Report details. + | CmdName + diff --git a/lib/Git/Vogue/PluginDiscoverer/Libexec.hs b/lib/Git/Vogue/PluginDiscoverer/Libexec.hs new file mode 100644 --- /dev/null +++ b/lib/Git/Vogue/PluginDiscoverer/Libexec.hs @@ -0,0 +1,157 @@ +-- +-- 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 OverloadedStrings #-} + +module Git.Vogue.PluginDiscoverer.Libexec +( + libExecDiscoverer +) where + +import Control.Applicative +import Control.Exception +import Control.Monad +import Control.Monad.IO.Class +import Data.List +import Data.List.Split +import Data.Maybe +import Data.Monoid +import Data.String +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as T +import Data.Traversable +import System.Directory +import System.Environment +import System.Exit +import System.FilePath +import System.Process + +import Git.Vogue.Types +import Git.Vogue.VCS.Git (git) + +libExecDiscoverer :: (Functor m, Applicative m, MonadIO m) + => FilePath + -> PluginDiscoverer m +libExecDiscoverer libexec_dir = + PluginDiscoverer (discover libexec_dir) disable enable + +-- | Find all plugins within the libexec dir. +-- +-- This function inspects the $PREFIX/libexec/git-vogue directory and the +-- directories listed in the $GIT_VOGUE_PATH environmental variable (if +-- defined) and builds a 'Plugin' for the executables found. +-- +-- Files that are set non executable are a corner case, this is not the +-- recommended way of disabling things. +-- +-- Files that are in the git config's vogue.disable list are set disabled. +discover + :: (Functor m, Applicative m, MonadIO m) + => FilePath + -> m [Plugin m] +discover libexec_dir = do + -- Use the environmental variable and $libexec/git-vogue/ directories as + -- the search path. + path <- fromMaybe "" <$> liftIO (lookupEnv "GIT_VOGUE_PATH") + let directories = splitOn ":" path <> [libexec_dir "git-vogue"] + + -- Disable plugins by the name that they present, so that the user does not + -- need to know how the backend works. + disabled <- gitDisabled + ps <- (concat <$> traverse ls directories) >>= traverse (load disabled) + return $ sort ps + where + load :: (Functor m, MonadIO m) => [Text] -> FilePath -> m (Plugin m) + load disabled fp = do + is_x <- executable <$> liftIO (getPermissions fp) + if is_x + then do + -- Extract the plugin name + name <- T.strip . T.pack <$> run fp "name" + if name `elem` disabled + then return $ disabledPlugin name + else return $ enabledPlugin fp name + else + -- Corner case, if it's not executable we should just give it + -- the name of the path and show it as a disabled plugin. + return . disabledPlugin $ "(non-executable) " <> T.pack fp + + run :: MonadIO m => FilePath -> String -> m String + run fp cmd = liftIO $ readProcess fp [cmd] "" + + -- | Build a Plugin that is ready to be executed. + enabledPlugin :: MonadIO m => FilePath -> Text -> Plugin m + enabledPlugin fp name = + Plugin { pluginName = PluginName name + , enabled = True + , runCheck = runPlugin fp "check" + , runFix = runPlugin fp "fix" + } + + disabledPlugin :: Text -> Plugin m + disabledPlugin txt = + Plugin { pluginName = PluginName txt + , enabled = False + , runCheck = error "disabled plugin ran check" + , runFix = error "disabled plugin ran fix" + } + + ls :: (Functor m, MonadIO m) => FilePath -> m [FilePath] + ls p = do + exists <- liftIO $ doesDirectoryExist p + if exists + then (fmap . fmap) (p ) (liftIO $ getDirectoryContents p) + >>= liftIO . filterM doesFileExist + else return [] + +-- Given a path to the plugin, the appropriate sub-command (check or fix), +-- provide a function from list of files to status. +-- +-- This involves the interface described in README under "Plugin design". +runPlugin + :: MonadIO m + => FilePath + -> String + -> [FilePath] + -> [FilePath] + -> m Result +runPlugin plugin cmd check_fs all_fs = liftIO $ do + (status, out, err) <- readProcessWithExitCode plugin [ cmd + , unlines check_fs + , unlines all_fs] "" + let glommed = fromString $ out <> err + return $ case status of + ExitSuccess -> Success glommed + ExitFailure 1 -> Failure glommed + ExitFailure n -> Catastrophe n glommed + +-- | Get list of disabled plugins from git configuration. +gitDisabled + :: (Monad m, Functor m, MonadIO m) + => m [Text] +gitDisabled = T.lines . T.pack <$> liftIO (readConfig `catch` none) + where + readConfig = git ["config", "--get-all", "vogue.disable"] + none (SomeException _) = return [] + +-- | Disable a given plugin within the libexec dir. +disable + :: (Functor m, MonadIO m) + => PluginName + -> m () +disable (PluginName name) = + void $ git ["config", "--add", "vogue.disable", T.unpack name] + +-- | Enable a given plugin within the libexec dir. +enable + :: (Functor m, MonadIO m) + => PluginName + -> m () +enable (PluginName name) = + void $ git ["config", "--unset", "vogue.disable", T.unpack name] diff --git a/lib/Git/Vogue/Plugins.hs b/lib/Git/Vogue/Plugins.hs deleted file mode 100644 --- a/lib/Git/Vogue/Plugins.hs +++ /dev/null @@ -1,111 +0,0 @@ --- --- 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 OverloadedStrings #-} - -module Git.Vogue.Plugins where - -import Git.Vogue.Types - -import Control.Applicative -import Control.Monad -import Control.Monad.IO.Class -import Data.Foldable -import Data.Monoid -import Data.String -import Data.String.Utils -import Data.Text.Lazy (Text) -import qualified Data.Text.Lazy as T -import qualified Data.Text.Lazy.IO as T -import Formatting -import Prelude hiding (maximum) -import System.Directory -import System.Exit -import System.Process - --- | Execute a plugin in IO -ioPluginExecutorImpl :: MonadIO m => PluginExecutorImpl m -ioPluginExecutorImpl = - PluginExecutorImpl (f "fix") (f "check") - where - -- | Given the command sub-type, and the path to the plugin, execute it - -- appropriately. - -- - -- This involves the interface described in README under "Plugin design". - f :: MonadIO m => String -> SearchMode -> Plugin -> m (Status a) - f arg sm (Plugin path) = liftIO $ do - name <- getName path - fs <- unlines <$> (lines <$> paths sm >>= filterM doesFileExist) - (status, out, err) <- readProcessWithExitCode path [arg] fs - let glommed = fromString $ out <> err - - return $ case status of - ExitSuccess -> Success name glommed - ExitFailure 1 -> Failure name glommed - ExitFailure n -> Catastrophe n name glommed - - paths FindChanged = git ["diff", "--cached", "--name-only"] - paths FindAll = git ["ls-files"] - - git args = readProcess "git" args "" - - getName path = do - (status, name, _) <- readProcessWithExitCode path ["name"] mempty - return . PluginName . fromString . strip $ case status of - ExitSuccess -> if null name then path else name - ExitFailure _ -> path - -colorize :: Status a -> Text -colorize (Success (PluginName x) y) = - format ("\x1b[32m" % text % " succeeded\x1b[0m with:\n" % text) x y -colorize (Failure (PluginName x) y) = - format ("\x1b[33m" % text % " failed\x1b[0m with:\n" % text) x y -colorize (Catastrophe n (PluginName x) y) = - format ("\x1b[31m" - % text - % " exploded \x1b[0m with exit code " - % int - %":\n" - % text) x n y - --- | Output the result of a Plugin and exit with an appropriate return code -outputStatusAndExit - :: MonadIO m - => Status a - -> m () -outputStatusAndExit status = liftIO $ - case status of - Success _ output -> do - T.putStrLn output - exitSuccess - Failure _ output -> do - T.putStrLn output - exitWith $ ExitFailure 1 - Catastrophe _ _ output -> do - T.putStrLn output - exitWith $ ExitFailure 2 - --- | Run a bunch of plugin actions, mush the statuses together and stick them --- all under the header of the worst. -getWorst - :: Monad m - => (Plugin -> m (Status a)) - -> [Plugin] - -> m (Status a) -getWorst f ps = do - rs <- mapM f ps - return $ insertMax rs (T.unlines $ fmap colorize rs) - -insertMax :: [Status a] -> Text -> Status a -insertMax [] _ = Success mempty "No plugins to run, vacuous success." -insertMax rs txt = - case maximum rs of - Success{} -> Success mempty txt - Failure{} -> Failure mempty txt - Catastrophe{} -> Catastrophe 0 mempty txt 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 @@ -9,42 +9,101 @@ {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RecordWildCards #-} module Git.Vogue.Types where +import Data.Function import Data.Monoid +import Data.Ord import Data.String import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as T +-- | Options parsed from the command-line. +data VogueOptions = Options + { optSearch :: SearchMode + , optCommand :: VogueCommand + } + deriving (Eq, Show) + +-- | Commands, with parameters, to be executed. +data VogueCommand + -- | Add git-vogue support to a git repository. + = CmdInit + -- | Verify that support is installed and plugins happen. + | CmdVerify + -- | List the plugins that git-vogue knows about. + | CmdPlugins + -- | Disable a plugin + | CmdDisable PluginName + -- | Enable a plugin + | CmdEnable PluginName + -- | Run check plugins on files in a git repository. + | CmdRunCheck + -- | Run fix plugins on files in a git repository. + | CmdRunFix + deriving (Eq, Show) + + -- | Phantom type for Statuses related to checking data Check -- | Phantom type for Statuses related to fixing data Fix -- | Result of running a Plugin -data Status a - = Success PluginName Text - | Failure PluginName Text - | Catastrophe Int PluginName Text +data Result + = Success Text + | Failure Text + | Catastrophe Int Text deriving (Show, Ord, Eq) --- | Absolute path to an executable -newtype Plugin = Plugin { - unPlugin :: FilePath -} deriving (Show, Ord, Eq, IsString) +-- | A plugin that can be told to check or fix a list of files +data Plugin m = Plugin + { pluginName :: PluginName + , enabled :: Bool + , runCheck :: [FilePath] -> [FilePath] -> m Result + , runFix :: [FilePath] -> [FilePath] -> m Result + } --- | Nice, human readable name of a plugin +instance Show (Plugin m) where + show Plugin{..} = + T.unpack (unPluginName pluginName) + <> if enabled then mempty else " (disabled)" + +instance Eq (Plugin m) where + (==) = (==) `on` pluginName + +instance Ord (Plugin m) where + compare = comparing pluginName + newtype PluginName = PluginName { unPluginName :: Text } deriving (Show, Ord, Eq, IsString, Monoid) -- | We want the flexibility of just checking changed files, or maybe checking -- all of them. -data SearchMode = FindAll | FindChanged +data SearchMode + = FindAll + | FindChanged + | FindSpecific [FilePath] deriving (Eq, Show) --- | An implementation of a "runner" of plugins. Mostly for easy testing. -data PluginExecutorImpl m = PluginExecutorImpl{ - executeFix :: SearchMode -> Plugin -> m (Status Fix), - executeCheck :: SearchMode -> Plugin -> m (Status Check) -} +-- | A thing that can find plugins, for example we might search through the +-- libexec directory for executables. +data PluginDiscoverer m = PluginDiscoverer + { discoverPlugins :: m [Plugin m] + , disablePlugin :: PluginName -> m () + , enablePlugin :: PluginName -> m () + } + +-- | A VCS backend, such as git. +data VCS m = VCS + { getFiles :: SearchMode -> m [FilePath] -- ^ Find all staged files + , installHook :: m () -- ^ Install pre-commit hook, + -- will only be called if + -- checkHook returns False + , removeHook :: m () -- ^ Remove pre-commit hook + , checkHook :: m Bool -- ^ Check pre-commit hook + , getTopLevel :: m FilePath -- ^ Find the / of the repo + } diff --git a/lib/Git/Vogue/VCS/Git.hs b/lib/Git/Vogue/VCS/Git.hs new file mode 100644 --- /dev/null +++ b/lib/Git/Vogue/VCS/Git.hs @@ -0,0 +1,115 @@ +-- +-- 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. +-- + + -- | Provide a VCS implementation for git repositories +module Git.Vogue.VCS.Git +( + gitVCS, + git +) where + +import Control.Applicative +import Control.Monad +import Control.Monad.IO.Class +import Data.Char (isSpace) +import Data.List +import Data.Monoid +import System.Directory +import System.FilePath +import System.Posix.Files +import System.Process + +import Git.Vogue.Types +import Paths_git_vogue + +gitVCS :: (Functor m, MonadIO m) => VCS m +gitVCS = VCS + { getFiles = gitGetFiles + , installHook = gitAddHook + , removeHook = gitRemoveHook + , checkHook = gitCheckHook + , getTopLevel = gitTopLevel + } + +gitGetFiles + :: MonadIO m + => SearchMode + -> m [FilePath] +gitGetFiles mode = liftIO . existantFiles $ + 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 + +git :: MonadIO m => [String] -> m String +git args = liftIO $ readProcess "git" args "" + +--- | Command string to insert into pre-commit hooks. +preCommitCommand :: String +preCommitCommand = "git-vogue check" + +-- | Add the git pre-commit hook. +gitAddHook + :: MonadIO m + => m () +gitAddHook = liftIO $ do + template <- getDataFileName "templates/pre-commit" + hook <- gitHookFile + copyFile template hook + perm <- getPermissions hook + setPermissions hook $ perm { executable = True } + +-- | Remove the hook iff it is precicely the same as the template. +gitRemoveHook + :: MonadIO m + => m () +gitRemoveHook = liftIO $ do + template_contents <- getDataFileName "templates/pre-commit" >>= readFile + hook <- gitHookFile + hook_contents <- readFile hook + if template_contents == hook_contents then + removeFile hook + else + putStrLn $ "Your pre-commit hook appears to be modified. \n" + <> "Please manually remove:" <> hook + +-- | Use a predicate to check a git commit hook. +gitCheckHook + :: MonadIO m + => m Bool +gitCheckHook = liftIO $ do + hook <- gitHookFile + exists <- fileExist hook + if exists + then do + c <- readFile hook + unless (preCommitCommand `isInfixOf` c) . + putStrLn $ "A pre-commit hook already exists at \n\t" + <> hook + <> "\nbut it does not contain the command\n\t" + <> preCommitCommand + <> "\nPlease edit the hook and add this command yourself!" + return True + else return False + +-- | Where the pre-commit hook lives +gitHookFile + :: MonadIO m + => m FilePath +gitHookFile = liftIO $ do + dir <- gitTopLevel + return $ dir ".git" "hooks" "pre-commit" + +gitTopLevel + :: MonadIO m + => m FilePath +gitTopLevel = liftIO $ do + let strip = join fmap (reverse . dropWhile isSpace) + strip <$> git ["rev-parse", "--show-toplevel"] 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 @@ -11,6 +11,8 @@ module Main where import Control.Monad (unless, when) +import Data.Foldable +import Data.List hiding (and) import Data.Monoid import Distribution.PackageDescription.Check import Distribution.PackageDescription.Configuration (flattenPackageDescription) @@ -18,9 +20,10 @@ import Distribution.Simple.Utils (defaultPackageDesc, toUTF8, wrapText) -import Distribution.Verbosity (Verbosity, - silent) +import Distribution.Verbosity (silent) import Git.Vogue.PluginCommon +import Prelude hiding (and, + mapM_) import System.Exit main :: IO () @@ -29,47 +32,54 @@ "git-vogue-cabal - check for cabal problems" where f CmdName = putStrLn "cabal" - f CmdCheck = do - ok <- check silent - unless ok exitFailure - f CmdFix = do - putStrLn $ "There are outstanding cabal failures, you need to fix this " + + f (CmdCheck check_fs all_fs) = do + -- 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 outstanding cabal failures, you need to fix this " <> "manually and then re-run check" exitFailure -- | Runs the same thing as cabal check. -- See also "Distribution.Client.Check" in cabal-install. -check :: Verbosity -> IO Bool -check verbosity = do - pdfile <- defaultPackageDesc verbosity - ppd <- readPackageDescription verbosity pdfile +check :: IO Bool +check = do + pdfile <- defaultPackageDesc silent + ppd <- readPackageDescription silent pdfile let pkg_desc = flattenPackageDescription ppd ioChecks <- checkPackageFiles pkg_desc "." - let packageChecks = ioChecks <> checkPackage ppd (Just pkg_desc) + let packageChecks = filter goodCheck $ ioChecks <> checkPackage ppd (Just pkg_desc) buildImpossible = [ x | x@PackageBuildImpossible {} <- packageChecks ] buildWarning = [ x | x@PackageBuildWarning {} <- packageChecks ] - distSuspicious = [ x | x@PackageDistSuspicious {} <- packageChecks ] + distSuspicious = [ x | x@PackageDistSuspicious{} <- packageChecks ] distInexusable = [ x | x@PackageDistInexcusable {} <- packageChecks ] unless (null buildImpossible) $ do - putStrLn "The package will not build sanely due to these errors:" + outputBad "The package will not build sanely due to these errors:" printCheckMessages buildImpossible unless (null buildWarning) $ do - putStrLn "The following warnings are likely affect your build negatively:" + outputBad "The following warnings are likely affect your build negatively:" printCheckMessages buildWarning unless (null distSuspicious) $ do - putStrLn "These warnings may cause trouble when distributing the package:" + outputBad "These warnings may cause trouble when distributing the package:" printCheckMessages distSuspicious unless (null distInexusable) $ do - putStrLn "The following errors will cause portability problems on other environments:" + outputBad "The following errors will cause portability problems on other environments:" printCheckMessages distInexusable let isDistError (PackageDistSuspicious {}) = False isDistError _ = True errors = filter isDistError packageChecks unless (null errors) $ - putStrLn "Hackage would reject this package." + outputBad "Hackage would reject this package." when (null packageChecks) $ - putStrLn "Checked cabal file" + outputGood "Checked cabal file" return (null packageChecks) where - printCheckMessages = mapM_ (putStrLn . format . explanation) + goodCheck (PackageDistSuspicious msg) = + not $ "ghc-options: -O2" `isInfixOf` msg + goodCheck _ = True + + printCheckMessages = mapM_ (outputBad . format . explanation) format = toUTF8 . wrapText . ("* "++) 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 @@ -11,15 +11,16 @@ module Main where import Control.Applicative +import Control.Monad import Data.Char import Data.Foldable -import Data.List hiding (elem) +import Data.List hiding (and, notElem) import Data.Maybe import Data.Monoid import Data.Traversable import Git.Vogue.PluginCommon import Language.Haskell.GhcMod -import Prelude hiding (elem) +import Prelude hiding (and, notElem) import System.Exit main :: IO () @@ -28,10 +29,26 @@ "Check your Haskell project for ghc-mod problems." "git-vogue-ghc-mod - check for ghc-mod problems" where - f CmdName = putStrLn "ghc-mod check" - f CmdCheck = ghcModCheck - f CmdFix = do - putStrLn $ "There are outstanding ghc-mod failures, you need to fix this " + f CmdName = putStrLn "ghc-mod" + f (CmdCheck check_fs all_fs) = do + -- Have to change to the project directory for each ghc-mod run or it + -- will be sad. + -- + -- We run ghcModCheck in each, which will exit on the first failure. + rs <- forProjects (hsProjects check_fs all_fs) $ \fs -> + -- HLint.hs is weird and more of a config file than a source file, so + -- ghc-mod doesn't like it. + -- + -- Setup.hs can import cabal things magically, without requiring it to + -- be mentioned in cabal (which ghc-mod hates) + ghcModCheck $ filter (\x -> not ("HLint.hs" `isSuffixOf` x) + && not ("Setup.hs" `isSuffixOf` x) + && ".hs" `isSuffixOf` x) fs + + unless (and rs) exitFailure + + f CmdFix{} = do + outputBad $ "There are outstanding ghc-mod failures, you need to fix this " <> "manually and then re-run check" exitFailure @@ -45,41 +62,31 @@ s <> "\n\tSuggestion: cabal configure --enable-benchmarks\n" | otherwise = s --- | ghc-mod check all of the .hs files from stdin -ghcModCheck :: IO () -ghcModCheck = do - -- HLint.hs is weird and more of a config file than a source file, so - -- ghc-mod doesn't like it. - -- - -- Setup.hs can import cabal things magically, without requiring it to be - -- mentioned in cabal (which ghc-mod hates) - -- - -- This is ugly, and should be replaced in favor of a git-vogue ignoring - -- mechanism. - files <- filter (not . (`elem` ["HLint.hs", "Setup.hs"])) <$> hsFiles - +-- | ghc-mod check all of the given files from the current directory +-- +-- This will print out output, and return a bool representing success. +ghcModCheck :: [FilePath] -> IO Bool +ghcModCheck files = do -- We can't actually check all at once, or ghc-mod gets confused, so we -- traverse - (r,_) <- runGhcModT defaultOptions (traverse (check . return) files) + (r,_) <- runGhcModT defaultOptions (traverse (check . pure) files) -- Seriously guys? Eithers within eithers? warn_errs <- case r of -- This is some kind of outer-error, we don't fail on it. Left e -> do - print e + outputUnfortunate . lineWrap 74 $ show e return [] -- And these are the warnings and errors. Right rs -> return rs - -- Traverse the errors, picking the warnings out. We don't fail on errors - -- but do warn about them. + -- Traverse the errors, picking errors and warnings out maybe_ws <- for warn_errs $ \warn_err -> case warn_err of -- Errors in files - Left e -> do - putStrLn (explain e) - return Nothing + Left e -> + return . Just $ explain e -- Warnings, sometimes empty strings Right warn -> return $ if null warn then Nothing else Just warn @@ -87,8 +94,8 @@ let warns = catMaybes maybe_ws if null warns then do - putStrLn $ "Checked " <> show (length files) <> " file(s)" - exitSuccess + outputGood $ "Checked " <> show (length files) <> " file(s)" + return True else do - traverse_ putStrLn warns - exitFailure + traverse_ outputBad warns + return False 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 @@ -14,14 +14,17 @@ module Main where import Control.Applicative +import Control.Monad import Data.Bifunctor -import Data.List +import Data.Foldable +import Data.List hiding (and, concat) import Data.Monoid import Data.Traversable import Git.Vogue.PluginCommon import Language.Haskell.Exts.SrcLoc import Language.Haskell.HLint3 import Language.Preprocessor.Cpphs +import Prelude hiding (and, concat) import System.Directory import System.Exit @@ -37,42 +40,41 @@ "git-vogue-hlint - check for hlint problems" where f CmdName = putStrLn "hlint" - f CmdCheck = lint - f CmdFix = do - putStrLn $ "There are outstanding hlint failures, you need to fix this " - <> "manually and then re-run check" - exitFailure + f (CmdCheck check_fs all_fs) = do + -- 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 --- | Lint all of the .hs files from stdin -lint :: IO () -lint = do - files <- hsFiles - (flags, classify, hint) <- autoSettings' + (flags, classify, hint) <- autoSettings' + -- Cpphs is off by default + let flags' = flags { cppFlags = Cpphs defaultCpphsOptions } - -- Cpphs is off by default - let flags' = flags { cppFlags = Cpphs defaultCpphsOptions } - -- Traverse the files, parsing and processing as we go for efficiency - parsed <- for files $ \f -> - process classify hint <$> parseModuleEx flags' f Nothing + parsed <- for hss $ \file -> + process classify hint <$> parseModuleEx flags' file Nothing + let ideas = concat [ x | Right x <- parsed ] + let errors = [ x | Left x <- parsed ] + let out = unlines errors <> "\n" <> ideas - let ideas = concat [ x | Right x <- parsed] - let errors = [ x | Left x <- parsed ] - let out = unlines errors <> "\n" <> ideas + let ok = null ideas && null errors + unless ok (outputBad out) + outputGood $ "Checked " <> show (length hss) <> " file(s)" + return ok - if null ideas && null errors - then do - putStrLn ("Checked " <> show (length files) <> " file(s)") - exitSuccess - else putStrLn out >> exitFailure - where - process classify hint = - bimap f g + unless (and rs) exitFailure where - f x = parseErrorMessage x <> show (parseErrorLocation x) - g x = showANSI $ applyHints classify hint [x] + process classify hint = + bimap (\x -> parseErrorMessage x <> show (parseErrorLocation x)) + (\x -> showANSI . filter g $ applyHints classify hint [x]) + g x = case ideaSeverity x of Ignore -> False + Warning -> True + Error -> True + f CmdFix{} = do + outputBad $ "There are outstanding hlint failures, you need to fix this " + <> "manually and then re-run check" + exitFailure -- | The default autoSettings form HLint3 does not handle custom HLint.hs files -- in the current directory. So we define our own. autoSettings' :: IO (ParseFlags, [Classify], Hint) 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 @@ -30,29 +30,30 @@ "Check your Haskell project for stylish-haskell-related problems." "git-vogue-stylish - check for stylish-haskell problems" cfg <- getConfig - files <- hsFiles - f files cfg cmd + f cfg cmd where - f _ _ CmdName = putStrLn "stylish" - f files cfg CmdCheck = do - rs <- traverse (stylishCheckFile cfg) files + hsFiles = filter (isSuffixOf ".hs") + f _ CmdName = putStrLn "stylish" + f cfg (CmdCheck files _) = do + rs <- traverse (stylishCheckFile cfg) (hsFiles files) if and rs then do - putStrLn $ "Checked " <> show (length rs) <> " file(s)" + outputGood $ "Checked " <> show (length rs) <> " file(s)" exitSuccess else exitFailure - f files cfg CmdFix = do + f cfg (CmdFix files _) = do + let files' = hsFiles files -- Fix all of the things first - traverse_ (stylishRunFile cfg) files + traverse_ (stylishRunFile cfg) files' -- Now double check they are fixed - rs <- traverse (stylishCheckFile cfg) files + rs <- traverse (stylishCheckFile cfg) files' if and rs then - putStrLn "Style converged" + outputGood "Style converged" else do - putStrLn "Style did not converge, bailing" + outputBad "Style did not converge, bailing" exitFailure -- | Try various configuration locations as per stylish-haskell binary @@ -74,7 +75,7 @@ case getStyleDiffs original stylish of [] -> return True x -> do - putStrLn $ "\x1b[33m" <> fp <> "\x1b[0m" + outputBad $ "\x1b[33m" <> fp <> "\x1b[0m" <> " has differing style:\n" <> ppDiff x return False ) diff --git a/src/git-vogue.hs b/src/git-vogue.hs --- a/src/git-vogue.hs +++ b/src/git-vogue.hs @@ -11,97 +11,68 @@ module Main where -import Control.Monad -import Data.List.Split -import Data.Maybe -import Data.String -import Data.Traversable +import qualified Data.Text.Lazy as T +import Git.Vogue.PluginDiscoverer.Libexec +import Git.Vogue.VCS.Git import Options.Applicative -import Options.Applicative.Types -import System.Directory -import System.Environment -import System.FilePath import Git.Vogue import Git.Vogue.Types import Git.Vogue.PluginCommon -import qualified Paths_git_vogue as Paths +import Paths_git_vogue -- | Parse command-line options. optionsParser :: Parser VogueOptions -optionsParser = Options - <$> flag FindChanged FindAll +optionsParser = flip Options + <$> commandParser + <*> searchP + where + searchP :: Parser SearchMode + searchP = fileList <|> allFlag + fileList = FindSpecific <$> some (argument str (metavar "FILE")) + allFlag = flag FindChanged FindAll ( long "all" <> short 'A' <> help "Apply to all files, not just changed files." ) - <*> commandParser commandParser :: Parser VogueCommand commandParser = subparser - ( command "init" (info pInit - (progDesc "Initialise git-vogue support in a git repo")) - <> pCommand "verify" + ( pureSubCommand "init" + CmdInit + "Initialise git-vogue support in a git repo" + <> pureSubCommand "verify" CmdVerify "Check git-vogue support is all legit" - <> pCommand "plugins" + <> pureSubCommand "plugins" CmdPlugins "List installed plugins." - <> pCommand "check" + <> command "disable" (info (parseEnableDisable CmdDisable) + (progDesc "Disable a plugin")) + <> command "enable" (info (parseEnableDisable CmdEnable) + (progDesc "Enable a plugin")) + <> pureSubCommand "check" CmdRunCheck "Run check plugins on files in a git repo" - <> pCommand "fix" + <> pureSubCommand "fix" CmdRunFix "Run fix plugins on files a git repo" ) - where - pInit = CmdInit <$> option (Just <$> readerAsk) - ( long "template" - <> value Nothing - ) --- | Discover all available plugins. --- --- This function inspects the $PREFIX/libexec/git-vogue directory and the --- directories listed in the $GIT_VOGUE_PATH environmental variable (if --- defined) and builds a 'Plugin' for the executables found. -discoverPlugins :: IO [Plugin] -discoverPlugins = do - -- Use the environmental variable and $libexec/git-vogue/ directories as - -- the search path. - path <- fromMaybe "" <$> lookupEnv "GIT_VOGUE_PATH" - libexec <- ( "git-vogue") <$> Paths.getLibexecDir - let directories = splitOn ":" path <> [libexec] - - -- Find all executables in the directories in path. - plugins <- (fmap . fmap) fromString - (traverse ls directories >>= filterM isExecutable . concat) - - -- Filter out disabled plugins. - disabled_plugins <- disabledPlugins - return . filter (not . pluginIn disabled_plugins) $ plugins - where - ls :: FilePath -> IO [FilePath] - ls p = do - exists <- doesDirectoryExist p - if exists - then fmap (p ) <$> getDirectoryContents p - else return [] - - isExecutable :: FilePath -> IO Bool - isExecutable = fmap executable . getPermissions - - pluginIn :: [String] -> Plugin -> Bool - pluginIn disabled_plugins p = - (takeBaseName . unPlugin $ p) `elem` disabled_plugins +parseEnableDisable :: (PluginName -> VogueCommand) -> Parser VogueCommand +parseEnableDisable ctor = ctor <$> argument (PluginName . T.pack <$> str) + (metavar "PLUGIN") -- | Parse the command line and run the command. main :: IO () main = do opt <- execParser opts - plugins <- discoverPlugins - runVogue plugins (runCommand (optCommand opt) (optSearch opt)) + libexec_path <- getLibexecDir + runCommand (optCommand opt) + (optSearch opt) + gitVCS + (libExecDiscoverer libexec_path) where opts = info (helper <*> optionsParser) ( fullDesc diff --git a/tests/git-setup.hs b/tests/git-setup.hs deleted file mode 100644 --- a/tests/git-setup.hs +++ /dev/null @@ -1,106 +0,0 @@ --- --- 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 FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} --- | Description: Test git repository setup. -module Main where - -import Control.Exception -import Control.Monad -import Data.List -import Data.Monoid -import System.Directory -import System.Exit -import System.FilePath -import System.Posix.Files -import System.Posix.Temp -import System.Process -import Test.Hspec - -import Git.Vogue - -main :: IO () -main = hspec . describe "Git repository setup" $ do - it "should install a new pre-commit hook" . withGitRepo $ \path -> do - let hook = path ".git" "hooks" "pre-commit" - - shouldInstallWorking path hook - - it "should skip a correct pre-commit hook" . withGitRepo $ \path -> do - let hook = path ".git" "hooks" "pre-commit" - - -- Create an existing hook to update. - copyHookTemplateTo (Just "templates/pre-commit") hook - - shouldInstallWorking path hook - - it "should report a conflict pre-commit hook" . withGitRepo $ \path -> do - let hook = path ".git" "hooks" "pre-commit" - - -- Create an existing hook to update. - writeFile hook "echo YAY\n" - setPermissions hook $ emptyPermissions - { readable = True - , executable = True - } - - -- Run the setup program. - code <- runInRepo path - code `shouldBe` ExitFailure 1 - --- | Run "git-vogue init" and check we wind up with a working pre-commit hook. -shouldInstallWorking :: FilePath -> FilePath -> IO () -shouldInstallWorking path hook = do - code <- runInRepo path - code `shouldBe` ExitSuccess - checkPreCommitHook hook - --- | Execute the setup command in a git repository. -runInRepo - :: FilePath - -> IO ExitCode -runInRepo path = do - pwd <- getCurrentDirectory - let exe = pwd "dist/build/git-vogue/git-vogue" - let tpl = pwd "templates/pre-commit" - ps <- spawnCommand $ - "cd " <> path <> " && " <> exe <> " init --template=" <> tpl - waitForProcess ps - --- | Check that a pre-commit hook script is "correct". -checkPreCommitHook - :: FilePath - -> IO () -checkPreCommitHook hook = do - -- Check the hook exists. - exists <- fileExist hook - unless exists $ error "Commit hook missing" - - -- Check the hook is executable. - perm <- getPermissions hook - unless (executable perm) $ error "Commit hook is not executable" - - -- Check it has our command in it. - content <- readFile hook - unless ("git-vogue check" `isInfixOf` content) $ - error "Commit hook does not contain command" - --- | Create a git repository and run an action with it. -withGitRepo - :: (FilePath -> IO ()) - -> IO () -withGitRepo = bracket createRepo deleteRepo - where - createRepo = do - path <- mkdtemp "/tmp/git-setup-test." - callProcess "git" ["init", path] - return path - deleteRepo path = - callProcess "rm" ["-rf", path] diff --git a/tests/plugins.hs b/tests/plugins.hs deleted file mode 100644 --- a/tests/plugins.hs +++ /dev/null @@ -1,88 +0,0 @@ --- --- 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 FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} - --- | Description: Test git repository setup. -module Main where - -import Control.Monad.IO.Class () -import Data.Monoid -import System.FilePath -import Test.Hspec - -import Git.Vogue.Plugins -import Git.Vogue.Types - -failingExecutor, succeedingExecutor :: b -> IO (Status a) -failingExecutor = const . return $ Failure mempty mempty -succeedingExecutor = const . return $ Success mempty mempty - -main :: IO () -main = hspec $ do - describe "module collation" $ do - it "maximum of statuses is failure" $ - maximum [Success mempty mempty, Failure mempty mempty] - `shouldBe` Failure mempty mempty - - it "fails if one module fails" $ do - getWorst failingExecutor ["a", "b"] - >>= (`shouldBe` Failure mempty "\ESC[33m failed\ESC[0m with:\n\n\ESC[33m failed\ESC[0m with:\n\n") - getWorst failingExecutor ["monkey"] - >>= (`shouldBe` Failure mempty "\ESC[33m failed\ESC[0m with:\n\n") - - it "succeeds if all modules succeed" $ do - getWorst succeedingExecutor ["a", "b"] - >>= (`shouldBe` Success mempty "\ESC[32m succeeded\ESC[0m with:\n\n\ESC[32m succeeded\ESC[0m with:\n\n") - getWorst succeedingExecutor ["monkey"] - >>= (`shouldBe` Success mempty "\ESC[32m succeeded\ESC[0m with:\n\n") - - describe "IO module executor" $ do - describe "check" $ do - it "fails on failing module" $ - runCheckExecutor FindAll "failing" - (Failure "failing" "ohnoes\n") - - it "fails on succeeding module" $ - runCheckExecutor FindAll "succeeding" - (Success "succeeding" "yay\n") - - it "fails on exploding module" $ - runCheckExecutor FindAll "exploding" - (Catastrophe 3 "exploding" "something broke\n") - - describe "fix" $ do - it "fails on failing module" $ - runFixExecutor FindAll "failing" - (Failure "failing" "ohnoes\n") - - it "fails on succeeding module" $ - runFixExecutor FindAll "succeeding" - (Success "succeeding" "yay\n") - - it "fails on exploding module" $ - runFixExecutor FindAll "exploding" - (Catastrophe 3 "exploding" "something broke\n") - -runCheckExecutor :: SearchMode -> FilePath -> Status Check -> Expectation -runCheckExecutor = runTestExecutor executeCheck - -runFixExecutor :: SearchMode -> FilePath -> Status Fix -> Expectation -runFixExecutor = runTestExecutor executeFix - -runTestExecutor - :: (PluginExecutorImpl IO -> SearchMode -> Plugin -> IO (Status a)) - -> SearchMode - -> FilePath - -> Status a - -> Expectation -runTestExecutor act search_mode file expected = - act ioPluginExecutorImpl search_mode (Plugin ("fixtures" file)) - >>= (`shouldBe` expected) diff --git a/tests/unit.hs b/tests/unit.hs new file mode 100644 --- /dev/null +++ b/tests/unit.hs @@ -0,0 +1,149 @@ +-- +-- 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 FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Description: Test git repository setup. +module Main where + +import Control.Applicative +import Control.Monad +import Data.Map (fromList) +import System.Directory +import System.FilePath +import System.IO.Temp +import System.Process +import Test.Hspec + +import Git.Vogue.PluginCommon +import Git.Vogue.PluginDiscoverer.Libexec +import Git.Vogue.Types +import Git.Vogue.VCS.Git + +main :: IO () +main = do + abs_fixtures <- canonicalizePath "fixtures" + hspec $ do + describe "Git VCS implementation" $ + testGitVCS gitVCS + describe "Libexec plugin discovery" $ + testLEDiscovery abs_fixtures (libExecDiscoverer "./plugins") + describe "Plugin helpers" . + it "finds hs projects" $ do + hsProjects ["a.hs"] ["a.cabal", "a.hs"] `shouldBe` + fromList [("", ["a.hs"])] + + let nested = ["a.cabal", "a.hs", "b/b.cabal", "b/b.hs"] + join hsProjects nested `shouldBe` + fromList [ ("",["a.cabal","a.hs"]) + , ("b/",["b.hs","b.cabal"]) ] + +testLEDiscovery :: FilePath -> PluginDiscoverer IO -> Spec +testLEDiscovery fixtures PluginDiscoverer{..} = do + it "discovers plugins in the libexec dir" . withSetup $ do + ps <- discoverPlugins + fmap pluginName ps `shouldBe` + ["(non-executable) ./plugins/git-vogue/non-executable" + ,"exploding" + ,"failing" + ,"succeeding" + ] + fmap enabled ps `shouldBe` [False, True, True, True] + + it "disables and re-enables plugins" . withSetup $ do + disablePlugin "exploding" + ps <- filter enabled <$> discoverPlugins + fmap pluginName ps `shouldBe` ["failing", "succeeding"] + + enablePlugin "exploding" + ps' <- filter enabled <$> discoverPlugins + fmap pluginName ps' `shouldBe` ["exploding", "failing", "succeeding"] + + + it "provides check methods that do the expected things" . withSetup $ do + ps <- filter enabled <$> discoverPlugins + rs <- sequence $ fmap (\Plugin{..} -> runCheck ["a"] ["a"]) ps + rs `shouldBe` [ Catastrophe 3 "something broke\n" + , Failure "ohnoes\n" + , Success "yay\n"] + + it "provides fix methods that do the expected things" . withSetup $ do + ps <- filter enabled <$> discoverPlugins + rs <- sequence $ fmap (\Plugin{..} -> runFix ["a"] ["a"]) ps + rs `shouldBe` [ Catastrophe 3 "something broke\n" + , Failure "ohnoes\n" + , Success "yay\n"] + where + withSetup = + withGitRepo + . withCopy (fixtures "plugins") ("plugins" "git-vogue") + +testGitVCS :: VCS IO -> Spec +testGitVCS VCS{..} = do + it "should install and remove a pre-commit hook" . withGitRepo $ do + checkHook >>= (`shouldBe` False) + installHook + checkHook >>= (`shouldBe` True) + removeHook + checkHook >>= (`shouldBe` False) + + it "should list files correctly" . withGitRepo $ do + getFiles FindChanged >>= (`shouldBe` []) + getFiles FindAll >>= (`shouldBe` []) + + writeFile "hi" "there" + getFiles FindChanged >>= (`shouldBe` []) + getFiles FindAll >>= (`shouldBe` []) + + void $ git ["add", "hi"] + getFiles FindChanged >>= (`shouldBe` ["hi"]) + getFiles FindAll >>= (`shouldBe` ["hi"]) + + void $ git ["commit", "-m", "add hi", "hi"] + getFiles FindChanged >>= (`shouldBe` []) + getFiles FindAll >>= (`shouldBe` ["hi"]) + + it "should list root dir correctly" . withGitRepo' $ \dir -> + getTopLevel >>= (`shouldBe` dir) + +-- | Copy a dir and continue along +withCopy :: FilePath + -> FilePath + -> IO () + -> IO () +withCopy src dst f = do + void $ rawSystem "mkdir" ["plugins"] + void $ rawSystem "cp" ["-r", src, dst] + f + +withGitRepo + :: IO () + -> IO () +withGitRepo = withGitRepo' . const + +-- | Create a git repository and run an action with it, after changing to that +-- directory. +-- +-- Restores current dir on completion +withGitRepo' + :: (String -> IO ()) + -> IO () +withGitRepo' f = + 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. + before_dir <- getCurrentDirectory + void $ git ["init", temp_dir] + setCurrentDirectory temp_dir + f temp_dir + setCurrentDirectory before_dir