module Git.Vogue.PluginCommon
(
outputGood,
outputUnfortunate,
outputBad,
lineWrap,
hsProjects,
forProjects,
getPluginCommand,
pureSubCommand,
PluginCommand(..),
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 Data.Ord
import Options.Applicative
import System.Directory
import System.FilePath
outputGood :: MonadIO m => String -> m ()
outputGood = outputWithIcon " \x1b[32m[+]\x1b[0m "
outputUnfortunate :: MonadIO m => String -> m ()
outputUnfortunate = outputWithIcon " \x1b[33m[*]\x1b[0m "
outputBad :: MonadIO m => String -> m ()
outputBad = outputWithIcon " \x1b[31m[-]\x1b[0m "
outputWithIcon :: MonadIO m => String -> String -> m ()
outputWithIcon icon = liftIO . putStrLn . (icon <>) . prependWS
prependWS :: String -> String
prependWS "" = ""
prependWS input =
let (x:xs) = lines input
in intercalate "\n" $ x : fmap (" " <>) xs
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
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
hsProjects
:: [FilePath]
-> [FilePath]
-> Map FilePath [FilePath]
hsProjects check_fs all_fs =
let (complete_proj_map, _) = findProjects (isSuffixOf ".cabal") all_fs
proj_map = fmap (filter (`elem` check_fs)) complete_proj_map
bug = error "BUG: hsProjects: A key was not a prefix of its elements"
in M.mapWithKey (\k -> fmap (fromMaybe bug . stripPrefix k)) proj_map
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
findProjects
:: (FilePath -> Bool)
-> [FilePath]
-> (Map FilePath [FilePath], [FilePath])
findProjects p xs =
let all_paths = fmap (splitPath . ('/':)) xs
roots = sortBy (comparing length) . fmap (init . splitPath . ('/':)) $
filter p xs
f current_root (result, remaining) =
let included = isPrefixOf current_root
to_take = filter included remaining
to_leave = filter (not . included) remaining
in ( M.insert (joinPath $ tail current_root) to_take result
, to_leave)
(projects, remainder) = foldr f (mempty, all_paths) roots
in ((fmap . fmap) (joinPath . tail) projects
, fmap (joinPath . tail) remainder)
pluginCommandParser :: Parser PluginCommand
pluginCommandParser = subparser
( pureSubCommand "name" CmdName "Get name of plugin"
<> fpCommand "check" CmdCheck "Check for problems"
<> fpCommand "fix" CmdFix "Try to fix problems"
)
fpCommand
:: String
-> (FilePath -> FilePath -> a)
-> String
-> Mod CommandFields a
fpCommand name ctor desc = command name (info parser (progDesc desc))
where
parser = ctor <$> argument str (metavar "CHECKABLE_FILES_LIST")
<*> argument str (metavar "ALL_FILES_LIST")
pureSubCommand :: String -> a -> String -> Mod CommandFields a
pureSubCommand name ctor desc = command name (info (pure ctor) (progDesc desc))
getPluginCommand :: String -> String -> IO PluginCommand
getPluginCommand hdr desc = execParser parser
where
parser = info (helper <*> pluginCommandParser)
( fullDesc
<> progDesc desc
<> header hdr)
data PluginCommand
= CmdCheck FilePath FilePath
| CmdFix FilePath FilePath
| CmdName