git-vogue 0.1.0.4 → 0.2.0.0

raw patch · 16 files changed

+988/−709 lines, 16 filesdep +containersdep +list-triesdep +temporarydep −MissingHdep −transformers-basedep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: containers, list-tries, temporary

Dependencies removed: MissingH, transformers-base

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• README.md +17/−27
• git-vogue.cabal +21/−26
• lib/Git/Vogue.hs +131/−167
• lib/Git/Vogue/PluginCommon.hs +182/−18
• lib/Git/Vogue/PluginDiscoverer/Libexec.hs +157/−0
• lib/Git/Vogue/Plugins.hs +0/−111
• lib/Git/Vogue/Types.hs +74/−15
• lib/Git/Vogue/VCS/Git.hs +115/−0
• src/git-vogue-cabal.hs +30/−20
• src/git-vogue-ghc-mod.hs +37/−30
• src/git-vogue-hlint.hs +31/−29
• src/git-vogue-stylish.hs +13/−12
• src/git-vogue.hs +31/−60
• tests/git-setup.hs +0/−106
• tests/plugins.hs +0/−88
• tests/unit.hs +149/−0

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

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

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

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

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

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

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

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

@@ -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 . ("* "++)

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

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

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

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

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

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

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