diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Anchor Engineering + +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 Anchor Engineering nor the names of other + 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 +OWNER 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,141 @@ +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) + +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 +checking code quality and some supporting plugins. + +Currently, *git-vogue* ships with the following plugins: + +* [cabal][6] +* [hlint][2] +* [stylish-haskell][4] with automatic fixing +* [ghc-mod][5] + +[1]: https://www.youtube.com/watch?v=GuJQSAiODqI +[2]: http://hackage.haskell.org/package/hlint +[4]: https://hackage.haskell.org/package/stylish-haskell +[5]: https://hackage.haskell.org/package/ghc-mod +[6]: https://hackage.haskell.org/package/Cabal + +Quickstart +---------- + +```bash +cabal install git-vogue +``` + +If you wish to set up pre-commit hooks (recommended): + +```bash +git vogue init +``` + +With pre-commit hooks set up, `git vogue check` will be run before every +commit. If you wish to check the whole repository, run `git vogue check --all`. + +You can attempt to automatically rectify any problems discovered via `git vogue +fix` and `git vogue fix --all`. The only plugin that currently supports this +auto-fixing is stylish-haskell. + +# 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 by setting it +non-executable: + +```bash +chmod -x .cabal/libexec/git-vogue/git-vogue-stylish +``` + +A more sophisticated interface to plugin manipulation is planned. + +# Plugins + +## cabal + +Checks your .cabal file for packaging problems. Can not fix problems +automatically. + +## hlint + +Checks .hs files for linting issues, respects `HLint.hs` in the top level of +the repository. Can not fix problems automatically. + +## ghc-mod + +Checks .hs files (excluding `HLint.hs` and `Setup.hs`) as per ghc-mod check. +ghc-mod can be temperamental, so if this fails to run the plugin will allow the +commit to pass. Can not fix problems automatically. + +## stylish-haskell + +Checks if .hs files would have been modified by stylish-haskell. Respects +`.stylish-haskell.yaml`. Can fix problems automatically. + +Uninstalling +------------ + +To remove a `git-vogue init` configured pre-commit hook, run: + +```bash +rm .git/hooks/pre-commit +``` + +[Here are instructions](https://www.youtube.com/watch?v=4qXD5l-ZlfA) for +uninstalling a cabal package. + +Philosophy +--------- + +At Anchor Engineering, we're pretty un-dogmatic about using one editor or even +one OS for development. As such, we've found ourselves in need of a common +benchmark for linting, formatting and code quality checks. + +We wanted a tool that would: + +* Install in one command +* Require nothing to be learned for a new developer +* Tell that developer what they need to fix in the code that they modify and + that code only. + +git-vogue aims to satisfy these needs, whilst saving developers from the +drudgery of installing, configuring and running each of these tools +independently. + +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 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. + +## Invariants for well-behaved plugin commands + +* `name` will return a human-readable name one line +* `check` will not modify any files +* `check` will exit with a return code of: + * No errors - 0 + * Errors need fixing - 1 + * Catastrophic failure to check - 2 +* `fix` is idempotent +* `fix` will exit with a return code of: + * The code is now good (changes may or may not have been made) - 0 + * Some errors remain - 1 + * Catastrophic failure to check - 2 +* If `fix` returns "success" (return code 0), `check` must no longer fail diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,105 @@ +module Main where + +import Control.Monad +import Data.List +import Distribution.PackageDescription (PackageDescription (..)) +import Distribution.Simple +import Distribution.Simple.Install +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Setup +import Distribution.Simple.Utils +import System.FilePath + +-- | Run cabal with custom copyHook which puts our extra executables in the +-- libexec directory. +main :: IO () +main = defaultMainWithHooks $ simpleUserHooks + { copyHook = copyThings + } + +-- | Copy "extra" executables to $PREFIX/libexec/git-vogue/ instead of +-- $PREFIX/bin. +copyThings + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> CopyFlags + -> IO () +copyThings pkg lbi _ flags = do + -- First install only the "main" components with the default settings. + let (main_pkg, main_lbi) = tweakMainInstall pkg lbi + install main_pkg main_lbi flags + + -- Then install the "secondary" executables and plugin scripts with the + -- special settings. + let (sub_pkg, sub_lbi) = tweakSubcommandInstall pkg lbi + install sub_pkg sub_lbi flags + + -- Install shell scripts from plugins/. + -- + -- This was stolen from "Distribution.Simple.Install" and hacked. Why is + -- cabal so terrible compared to make and friends? + let scripts = fmap stripPluginPrefix . filter isPlugin $ dataFiles pkg + verbosity = fromFlag (copyVerbosity flags) + src_data_dir = dataDir sub_pkg + dest_data_dir = datadir . absoluteInstallDirs sub_pkg sub_lbi $ + fromFlag (copyDest flags) + forM_ scripts $ \ file -> do + let dir = takeDirectory file + files <- matchDirFileGlob src_data_dir file + createDirectoryIfMissingVerbose verbosity True (dest_data_dir dir) + forM_ files $ \file' -> + installExecutableFile verbosity (src_data_dir file') + (dest_data_dir file') + +-- | Directory our plugin scripts are kept in. +pluginPrefix :: FilePath +pluginPrefix = "plugins/" + +-- | Strip the 'pluginPrefix' off the front of a 'FilePath'. +stripPluginPrefix :: FilePath -> FilePath +stripPluginPrefix = dropWhile (== '/') . dropWhile (/= '/') + +-- | A data file is in the plugins directory. +isPlugin :: FilePath -> Bool +isPlugin = (pluginPrefix `isPrefixOf`) + +-- | Tweak parameters for install of main components (i.e. library and first +-- executable) only. +tweakMainInstall + :: PackageDescription + -> LocalBuildInfo + -> (PackageDescription, LocalBuildInfo) +tweakMainInstall pkg lbi = + let pkg' = pkg { executables = take 1 $ executables pkg + , dataFiles = filter (not . isPlugin) $ dataFiles pkg + } + in (pkg', lbi) + +-- | Tweak parameters for install of secondary components (i.e. executables +-- other than the first. +tweakSubcommandInstall + :: PackageDescription + -> LocalBuildInfo + -> (PackageDescription, LocalBuildInfo) +tweakSubcommandInstall pkg lbi = + let dest = suffixIt . libexecdir $ installDirTemplates lbi + pkg' = pkg { executables = tail $ executables pkg + , dataFiles = [] + , dataDir = dataDir pkg pluginPrefix + , library = Nothing + , testSuites = [] + , benchmarks = [] + , extraSrcFiles = [] + , extraTmpFiles = [] + , extraDocFiles = [] + } + lbi' = lbi { installDirTemplates = (installDirTemplates lbi) + { bindir = dest + , datadir = dest + , datasubdir = toPathTemplate "" + } + } + in (pkg', lbi') + where + suffixIt = toPathTemplate . ( "git-vogue") . fromPathTemplate diff --git a/git-vogue.cabal b/git-vogue.cabal new file mode 100644 --- /dev/null +++ b/git-vogue.cabal @@ -0,0 +1,139 @@ +name: git-vogue +version: 0.1.0.0 +synopsis: A framework for pre-commit checks. +description: Make your Haskell git repositories fashionable. +homepage: https://github.com/anchor/git-vogue +license: BSD3 +license-file: LICENSE +author: Anchor Engineering +maintainer: Anchor Engineering +copyright: (c) 2015 Anchor Systems, Pty Ltd and Others +category: Development +build-type: Custom +extra-source-files: README.md +cabal-version: >=1.10 +data-files: templates/pre-commit + +source-repository HEAD + type: git + location: https://github.com/anchor/git-vogue + +flag gpl + default: True + description: Use GPL libraries, specifically hscolour + +library + default-language: Haskell2010 + hs-source-dirs: lib + exposed-modules: Git.Vogue + Git.Vogue.Types + Git.Vogue.Plugins + other-modules: Paths_git_vogue + build-depends: base >=4.7 && <4.8 + , MissingH + , directory + , filepath + , process + , formatting + , split + , text + , transformers + , mtl + , unix + -- To fix depedencies + , hlint >= 1.9 && < 1.10 + , stylish-haskell >= 0.5.11 && < 0.5.12 + , ghc-mod >= 5.2 && < 5.3 + +executable git-vogue + default-language: Haskell2010 + hs-source-dirs: src + main-is: git-vogue.hs + build-depends: base >=4.7 && <4.8 + , filepath + , directory + , git-vogue + , optparse-applicative >= 0.11 + , split + +executable git-vogue-cabal + default-language: Haskell2010 + hs-source-dirs: src + main-is: git-vogue-cabal.hs + build-depends: base >=4.7 && <4.8 + , Cabal + , optparse-applicative >= 0.11 + , 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 + , directory + , filepath + , hlint + , cpphs + , bifunctors + , haskell-src-exts + , optparse-applicative >= 0.11 + , hscolour + , process + if !flag(gpl) + cpp-options: -DGPL_SCARES_ME + +executable git-vogue-stylish + default-language: Haskell2010 + hs-source-dirs: src + main-is: git-vogue-stylish.hs + build-depends: base >=4.7 && <4.8 + , Diff + , directory + , filepath + , optparse-applicative >= 0.11 + , process + , strict + , stylish-haskell + +executable git-vogue-ghc-mod + default-language: Haskell2010 + hs-source-dirs: src + main-is: git-vogue-ghc-mod.hs + build-depends: base >=4.7 && <4.8 + , Diff + , directory + , filepath + , optparse-applicative >= 0.11 + , process + , strict + , ghc-mod + +test-suite test-git-setup + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: tests + main-is: git-setup.hs + build-depends: base >=4.7 && <4.8 + , 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 + , git-vogue + , hspec + , process + , transformers + , transformers-base + , unix + +-- vim: set tabstop=21 expandtab: diff --git a/lib/Git/Vogue.hs b/lib/Git/Vogue.hs new file mode 100644 --- /dev/null +++ b/lib/Git/Vogue.hs @@ -0,0 +1,192 @@ +-- +-- 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 FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + +module Git.Vogue where + +import Control.Applicative +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Reader +import Data.List +import Data.Monoid +import Data.String.Utils +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) + +-- | 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) + +-- | Plugins that git-vogue knows about. +-- FIXME: this will become the fix/check modules + +newtype Vogue m x = Vogue { vogue :: ReaderT [Plugin] m x } + deriving ( Functor, Applicative, Monad + , MonadTrans, MonadIO, MonadReader [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 + +-- | 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 + +-- | 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 + +--- | Command string to insert into pre-commit hooks. +preCommitCommand :: String +preCommitCommand = "git-vogue check" + +-- | 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." + +-- | 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 } + +-- | 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 + +-- | Check that a script seems to run git vogue. +runsVogue + :: FilePath + -> IO Bool +runsVogue path = do + c <- readFile path + return $ preCommitCommand `isInfixOf` c + +-- | 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) diff --git a/lib/Git/Vogue/Plugins.hs b/lib/Git/Vogue/Plugins.hs new file mode 100644 --- /dev/null +++ b/lib/Git/Vogue/Plugins.hs @@ -0,0 +1,111 @@ +-- +-- 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 new file mode 100644 --- /dev/null +++ b/lib/Git/Vogue/Types.hs @@ -0,0 +1,50 @@ +-- +-- 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 EmptyDataDecls #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Git.Vogue.Types where + +import Data.Monoid +import Data.String +import Data.Text.Lazy (Text) + +-- | 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 + deriving (Show, Ord, Eq) + +-- | Absolute path to an executable +newtype Plugin = Plugin { + unPlugin :: FilePath +} deriving (Show, Ord, Eq, IsString) + +-- | Nice, human readable name of a plugin +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 + 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) +} diff --git a/src/git-vogue-cabal.hs b/src/git-vogue-cabal.hs new file mode 100644 --- /dev/null +++ b/src/git-vogue-cabal.hs @@ -0,0 +1,72 @@ +-- +-- 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. +-- + +-- | Description: Check with "cabal check". +module Main where + +import Common +import Control.Monad (unless, when) +import Data.Monoid +import Distribution.PackageDescription.Check +import Distribution.PackageDescription.Configuration (flattenPackageDescription) +import Distribution.PackageDescription.Parse (readPackageDescription) +import Distribution.Simple.Utils (defaultPackageDesc, + toUTF8, + wrapText) +import Distribution.Verbosity (Verbosity, + silent) +import System.Exit + +main :: IO () +main = f =<< getPluginCommand + "Check your Haskell project for cabal-related problems." + "git-vogue-cabal - check for cabal problems" + where + f CmdName = putStrLn "cabal" + f CmdCheck = do + ok <- check silent + unless ok exitFailure + f CmdFix = 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 + let pkg_desc = flattenPackageDescription ppd + ioChecks <- checkPackageFiles pkg_desc "." + let packageChecks = ioChecks <> checkPackage ppd (Just pkg_desc) + buildImpossible = [ x | x@PackageBuildImpossible {} <- packageChecks ] + buildWarning = [ x | x@PackageBuildWarning {} <- 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:" + printCheckMessages buildImpossible + unless (null buildWarning) $ do + putStrLn "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:" + printCheckMessages distSuspicious + unless (null distInexusable) $ do + putStrLn "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." + when (null packageChecks) $ + putStrLn "Checked cabal file" + return (null packageChecks) + where + printCheckMessages = mapM_ (putStrLn . format . explanation) + format = toUTF8 . wrapText . ("* "++) diff --git a/src/git-vogue-ghc-mod.hs b/src/git-vogue-ghc-mod.hs new file mode 100644 --- /dev/null +++ b/src/git-vogue-ghc-mod.hs @@ -0,0 +1,93 @@ +-- +-- 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. +-- + +-- | Description: Check with "cabal check". +module Main where + +import Common +import Control.Applicative +import Data.Char +import Data.Foldable +import Data.List hiding (elem) +import Data.Maybe +import Data.Monoid +import Data.Traversable +import Language.Haskell.GhcMod +import Prelude hiding (elem) +import System.Exit + +main :: IO () +main = + f =<< getPluginCommand + "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 "you need to fix ghc-mod check failures" + exitFailure + +-- | Try to help the user out with some munging of error messages +explain :: String -> String +explain s + -- A terrible heuristic, but it may help some people + | "test" `isInfixOf` fmap toLower s && "hidden package" `isInfixOf` s = + s <> "\n\tSuggestion: cabal configure --enable-tests\n" + | "bench" `isInfixOf` fmap toLower s && "hidden package" `isInfixOf` s = + 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 + + -- We can't actually check all at once, or ghc-mod gets confused, so we + -- traverse + (r,_) <- runGhcModT defaultOptions (traverse (check . return) 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 + 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. + maybe_ws <- for warn_errs $ \warn_err -> + case warn_err of + -- Errors in files + Left e -> do + putStrLn (explain e) + return Nothing + -- Warnings, sometimes empty strings + Right warn -> + return $ if null warn then Nothing else Just warn + + let warns = catMaybes maybe_ws + if null warns + then do + putStrLn $ "Checked " <> show (length files) <> " file(s)" + exitSuccess + else do + traverse_ putStrLn warns + exitFailure diff --git a/src/git-vogue-hlint.hs b/src/git-vogue-hlint.hs new file mode 100644 --- /dev/null +++ b/src/git-vogue-hlint.hs @@ -0,0 +1,117 @@ +-- +-- 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 CPP #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Description: Check with "cabal check". +module Main where + +import Common +import Control.Applicative +import Data.Bifunctor +import Data.List +import Data.Monoid +import Data.Traversable +import Language.Haskell.Exts.SrcLoc +import Language.Haskell.HLint3 +import Language.Preprocessor.Cpphs +import System.Directory +import System.Exit + +#ifndef GPL_SCARES_ME +import Language.Haskell.HsColour.Colourise +import Language.Haskell.HsColour.TTY +#endif + +main :: IO () +main = + f =<< getPluginCommand + "Check your Haskell project for hlint-related problems." + "git-vogue-hlint - check for hlint problems" + where + f CmdName = putStrLn "hlint" + f CmdCheck = lint + f CmdFix = putStrLn "you need to fix hlint failures" >> exitFailure + +-- | Lint all of the .hs files from stdin +lint :: IO () +lint = do + files <- hsFiles + (flags, classify, hint) <- autoSettings' + + -- 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 + + + let ideas = concat [ x | Right x <- parsed] + let errors = [ x | Left x <- parsed ] + let out = unlines errors <> "\n" <> ideas + + 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 + where + f x = parseErrorMessage x <> show (parseErrorLocation x) + g x = showANSI $ applyHints classify hint [x] + +-- | 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) +autoSettings' = do + local_hlint <- doesFileExist "HLint.hs" + let start_at = if local_hlint then Just "HLint" else Nothing + (fixities, classify, hints) <- findSettings (readSettingsFile Nothing) + start_at + return (parseFlagsAddFixities fixities defaultParseFlags, classify, resolveHints hints) + +#ifdef GPL_SCARES_ME +format :: String -> String +format s = "\x1b[36m" <> s <> "\x1b[0m" +#else +format :: String -> String +format = hscolour defaultColourPrefs +#endif + +-- All of the code below is more or less salvaged from hlint internals. + +-- | Pretty print and Idea with colouring +showANSI :: [Idea] -> String +showANSI = + (>>= \i -> showEx format i <> "\n") + +-- | Show an idea with a function that highlights. +showEx :: (String -> String) -> Idea -> String +showEx tt Idea{..} = unlines $ + ["\x1b[33m" <> showSrcLoc (getPointLoc ideaSpan) <> "\x1b[0m " <> (if ideaHint == "" then "" else show ideaSeverity <> ": " <> ideaHint)] <> + f "Found" (Just ideaFrom) <> f "Why not" ideaTo <> + ["Note: " <> n | let n = showNotes ideaNote, n /= ""] + where + f _ Nothing = [] + f msg (Just x) | null xs = [msg <> " remove it."] + | otherwise = (msg <> ":") : fmap (" "<>) xs + where xs = lines $ tt x + +showSrcLoc :: SrcLoc -> String +showSrcLoc (SrcLoc file line col) = file <> ":" <> show line <> ":" <> show col <> ":" + +showNotes :: [Note] -> String +showNotes = intercalate ", " . fmap show . filter use + where use ValidInstance{} = False -- Not important enough to tell an end user + use _ = True + diff --git a/src/git-vogue-stylish.hs b/src/git-vogue-stylish.hs new file mode 100644 --- /dev/null +++ b/src/git-vogue-stylish.hs @@ -0,0 +1,140 @@ +-- +-- 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. +-- + +-- | Description: Check and fix style differences with stylish-haskell +module Main where + +import Common +import Control.Monad +import Data.Algorithm.Diff +import Data.Algorithm.DiffOutput +import Data.Foldable +import Data.List hiding (and) +import Data.Monoid hiding (First) +import Data.Traversable +import Language.Haskell.Stylish +import Prelude hiding (and) +import System.Exit +import System.IO hiding (hGetContents) +import System.IO.Strict (hGetContents) + +main :: IO () +main = do + cmd <- getPluginCommand + "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 + where + f _ _ CmdName = putStrLn "stylish" + f files cfg CmdCheck = do + rs <- traverse (stylishCheckFile cfg) files + if and rs + then do + putStrLn $ "Checked " <> show (length rs) <> " file(s)" + exitSuccess + else + exitFailure + + f files cfg CmdFix = do + -- Fix all of the things first + traverse_ (stylishRunFile cfg) files + -- Now double check they are fixed + rs <- traverse (stylishCheckFile cfg) files + if and rs + then + putStrLn "Style converged" + else do + putStrLn "Style did not converge, bailing" + exitFailure + +-- | Try various configuration locations as per stylish-haskell binary +getConfig + :: IO Config +getConfig = + -- Don't spew every file checked to stdout + let v = makeVerbose False + in configFilePath v Nothing >>= loadConfig v + +-- | Checks whether running Stylish over a given file produces any differences. +-- Returns TRUE if there's nothing left to change. +-- Prints results and returns FALSE if there are things left to change. +stylishCheckFile + :: Config -- ^ Stylish Haskell config + -> FilePath -- ^ File to run through Stylish + -> IO Bool +stylishCheckFile cfg fp = stylishFile fp cfg (\original stylish -> + case getStyleDiffs original stylish of + [] -> return True + x -> do + putStrLn $ "\x1b[33m" <> fp <> "\x1b[0m" + <> " has differing style:\n" <> ppDiff x + return False + ) + +-- | Runs Stylish over a given file. If there are changes, write them. +stylishRunFile + :: Config -- ^ Stylish Haskell config + -> FilePath -- ^ File to run through Stylish + -> IO () +stylishRunFile cfg fp = stylishFile fp cfg $ \original stylish -> + unless (null $ getStyleDiffs original stylish) (writeFile fp stylish) + +-- | Get diffs and filter out equivalent ones +getStyleDiffs + :: String + -> String + -> [Diff [String]] +getStyleDiffs original stylish = filter filterDiff $ + getGroupedDiff (lines original) (lines stylish) + +-- | Filters out equal diffs +filterDiff + :: (Eq a) + => Diff a + -> Bool +filterDiff (Both a b) = a /= b +filterDiff _ = True + +-- | Takes an original file, the Stylish version of the file, and does something +-- depending on the outcome of the Stylish transformation. +stylishFile + :: FilePath -- ^ File to run through Stylish + -> Config -- ^ Stylish Haskell config + -> (String -> String -> IO a) + -> IO a +stylishFile fp cfg fn = do + original <- readUTF8File fp + stylish <- stylishFile' (Just fp) cfg + fn original stylish + +-- | Processes a single file, or stdin if no filepath is given +stylishFile' + :: Maybe FilePath -- ^ File to run through Stylish + -> Config -- ^ Stylish Haskell config + -> IO String +stylishFile' mfp conf = do + contents <- maybe getContents readUTF8File mfp + let result = runSteps (configLanguageExtensions conf) + mfp (configSteps conf) $ lines contents + case result of + Left err -> do + hPutStrLn stderr err + return contents + Right ok -> return $ unlines ok + +-- | Loads a UTF8 file. +readUTF8File + :: FilePath -- ^ Filepath to read + -> IO String -- ^ File data +readUTF8File fp = + withFile fp ReadMode $ \h -> do + hSetEncoding h utf8 + hGetContents h diff --git a/src/git-vogue.hs b/src/git-vogue.hs new file mode 100644 --- /dev/null +++ b/src/git-vogue.hs @@ -0,0 +1,101 @@ +-- +-- 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 Main where + +import Control.Monad +import Data.List.Split +import Data.Maybe +import Data.String +import Data.Traversable +import Options.Applicative +import Options.Applicative.Types +import System.Directory +import System.Environment +import System.FilePath + +import Git.Vogue +import Git.Vogue.Types + +import Common +import qualified Paths_git_vogue as Paths + +-- | Parse command-line options. +optionsParser :: Parser VogueOptions +optionsParser = Options + <$> 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" + CmdVerify + "Check git-vogue support is all legit" + <> pCommand "plugins" + CmdPlugins + "List installed plugins." + <> pCommand "check" + CmdRunCheck + "Run check plugins on files in a git repo" + <> pCommand "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. + (fmap . fmap) fromString + (traverse ls directories >>= filterM isExecutable . concat) + 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 + +-- | Parse the command line and run the command. +main :: IO () +main = do + opt <- execParser opts + plugins <- discoverPlugins + runVogue plugins (runCommand (optCommand opt) (optSearch opt)) + where + opts = info (helper <*> optionsParser) + ( fullDesc + <> progDesc "Make your Haskell git repository fashionable" + <> header "git-vogue - git integration for fashionable Haskell" ) diff --git a/templates/pre-commit b/templates/pre-commit new file mode 100644 --- /dev/null +++ b/templates/pre-commit @@ -0,0 +1,3 @@ +#!/bin/sh + +git-vogue check diff --git a/tests/git-setup.hs b/tests/git-setup.hs new file mode 100644 --- /dev/null +++ b/tests/git-setup.hs @@ -0,0 +1,106 @@ +-- +-- 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 new file mode 100644 --- /dev/null +++ b/tests/plugins.hs @@ -0,0 +1,88 @@ +-- +-- 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)