kit-0.7.10: Kit/Util.hs

module Kit.Util(
  module Kit.Util,
  module Exported,
  Color(..),
  (</>), takeFileName, takeDirectory,
  tryJust
  ) where
  
  import Control.Applicative as Exported
  import Control.Monad.Trans as Exported
  import Control.Monad as Exported
  import System.Directory as Exported

  import System.FilePath.Posix ((</>), takeFileName, takeDirectory)
  import System.FilePath.Glob (globDir1, compile)

  import System.Environment (getEnv)

  import Control.Error

  import Data.List
  import Data.Monoid
  import Data.Traversable as T

  import System.Cmd

  import Kit.AbsolutePath

  import System.Console.ANSI

  import Control.Monad.State as S

  popS :: S.State [a] a
  popS = do
    (x:t) <- S.get
    S.put t
    return x

  shell :: String -> IO ()
  shell = void . system

  when' :: Monad m => m Bool -> m () -> m ()
  when' a b = a >>= flip when b

  puts :: MonadIO m => String -> m ()
  puts = liftIO . putStrLn

  ifTrue :: MonadPlus m => Bool -> a -> m a
  ifTrue p a = if p then return a else mzero

  mkdirP :: MonadIO m => FilePath -> m ()
  mkdirP = liftIO . createDirectoryIfMissing True

  cleanOrCreate :: MonadIO m => FilePath -> m ()
  cleanOrCreate directory = liftIO $ do
    exists <- doesDirectoryExist directory
    when exists $ removeDirectoryRecursive directory
    mkdirP directory
    
  inDirectory :: MonadIO m => FilePath -> m a -> m a
  inDirectory fp actions = do
    cwd <- liftIO getCurrentDirectory
    liftIO $ setCurrentDirectory fp
    v <- actions
    liftIO $ setCurrentDirectory cwd
    return v

  inDirectoryM :: (MonadIO m) => m FilePath -> m a -> m a
  inDirectoryM m a = do
    v <- m
    inDirectory v a

  findFiles :: MonadIO m => FilePath -> FilePath -> String -> m [AbsolutePath]
  findFiles kitDir dir tpe = liftIO $ inDirectory kitDir $ do
                                files <- glob (dir </> "**/*" ++ tpe)
                                T.mapM absolutePath files

  glob :: String -> IO [String]
  glob pattern = globDir1 (compile pattern) ""

  stringJoin :: Monoid a => a -> [a] -> a
  stringJoin x = mconcat . intersperse x
  
  -- | Lifting bind into a monad. Often denoted /concatMapM/. From TM
  (.=<<.) ::
    (Monad q, Monad m, Traversable m) =>
    (a -> q (m b))
    -> m a
    -> q (m b)
  (.=<<.) f =
    liftM join . T.mapM f

  getEnv' :: String -> IO (Maybe String)
  getEnv' = fmap hush . runEitherT . tryIO . getEnv

  isSet :: String -> IO Bool
  isSet = fmap isJust . getEnv'
    
  say :: MonadIO m => Color -> String -> m ()
  say color msg = do
    colorize <- liftIO $ isSet "PS1"
    if colorize
      then do
        liftIO $ setSGR [SetColor Foreground Vivid color]
        puts msg
        liftIO $ setSGR []
      else
        puts msg

  sayError :: MonadIO m => String -> m ()
  sayError = say Red

  sayWarn :: MonadIO m => String -> m ()
  sayWarn = say Yellow

  readFile' :: (MonadPlus t, T.Traversable t) => FilePath -> IO (t String)
  readFile' fp = do
      exists <- doesFileExist fp
      T.sequence (fmap readFile $ ifTrue exists fp)