gdo-0.1.5: Main.hs

import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import Control.Monad.Trans.Reader
import Data.List
import Data.Maybe
import Data.Monoid
import System.Console.GetOpt
import System.Directory
import System.Environment
import System.Exit
import System.FilePath
import System.IO.Error

import Lib

data Flag = Changed | Created | Help
          deriving (Show,Read,Eq)

clOption :: [OptDescr Flag]
clOption = [ Option "" ["if"] (ReqArg read "MODE")
             "Redo mode, valid modes are: Changed, Created"
           , Option "h" ["help"] (NoArg Help)
             "Print usage info"
           ]

variableInfo :: String
variableInfo =
  unlines $
  "Environment variables:" :
  map ('\t':)
  [ "GDO_DEFAULTS : List of paths to directories containing default do files"
  ]

usageHeader :: String
usageHeader =
  unlines
  [ "gdo" ]

printUsage :: IO ()
printUsage = do
  putStrErr $ usageInfo usageHeader clOption
  putStrLn ""
  putStrLn variableInfo

getCliOpts :: (MonadIO m) => ExceptT ExitCode m ([Flag],[FilePath])
getCliOpts = do
  args <- liftIO getArgs
  case getOpt RequireOrder clOption args of
    (_,_,_:_) -> do liftIO printUsage
                    throwE (ExitFailure 1)
    (opts,deps,_) -> return (opts,deps)

optsToMode :: [Flag] -> Maybe Flag
optsToMode flags =
  getFirst . mconcat . map (First . ($flags)) $
  [ find (==Help)
  , listToMaybe . reverse
  ]

withTarget :: (MonadIO m) =>
              FilePath -> (FilePath -> m a) -> m a
withTarget target fun = do
  dir <- liftIO getCurrentDirectory
  let (targetDir,file) = splitFileName target
  liftIO $ setCurrentDirectory targetDir
  result <- fun file
  liftIO $ setCurrentDirectory dir
  return result
         
main :: IO ()
main = do
  invocationDir <-
    fromMaybeM
    (setInvocationDir >> getCurrentDirectory)
    getInvocationDir
  defaultDirs <- getDefaultDirs
  either exitWith (const exitSuccess) =<<
    (flip runReaderT invocationDir . runExceptT)
    (do (mMode,deps) <- getCliOpts
        case optsToMode mMode of
         Just Changed -> do
           buildTarget <- getBuildTarget
           mapM_ (redoIfChanged defaultDirs buildTarget) deps
         Just Created -> do
           buildTarget <- getBuildTarget
           mapM_ (redoIfCreated defaultDirs buildTarget) deps
         Just Help -> liftIO printUsage
         Nothing -> mapM_ (`withTarget` redo defaultDirs) deps
        return ()
    )

type Redo m = ExceptT ExitCode (ReaderT FilePath m)

redo :: (MonadIO m) =>
        [FilePath] -> FilePath -> Redo m ()
redo mDefaultsDir target = do
  invocationDir <- lift $ ask
  targetRelativePath <- makeRelative invocationDir <$>
    liftIO (makeAbsolute target)
  targetDoesExist <- liftIO $ doesFileExist target
  isUpToDate <- upToDate mDefaultsDir target
  unless (isUpToDate && targetDoesExist) $ do
    void . liftIO . tryJust (guard . isDoesNotExistError) $
      purgeRecordedDependencies target
    maybe (do targetExists <- liftIO $ doesFileExist target
              unless targetExists $ do
                (liftIO . putStrLnErr)
                  ("Neither target nor do file found for "++show target)
                throwE (ExitFailure 1))
          (\recipe ->
            do liftIO $ putStrLnErr $ "redo "++show targetRelativePath
               redoIfCreated mDefaultsDir target (target++".do")
               redoIfChanged mDefaultsDir target recipe
               buildResult <- liftIO $ executeRecipe target recipe
               when (buildResult /= ExitSuccess)
                 (do liftIO $ purgeRecordedDependencies target
                     throwE buildResult)
               liftIO $ putStrLnErr $ "redone "++show targetRelativePath)
      =<< getRecipeFile mDefaultsDir target

fromMaybeM :: (Monad m) => m a -> m (Maybe a) -> m a
fromMaybeM fallback action = do
  mValue <- action
  case mValue of
    Just value -> return value
    Nothing -> fallback

redoIfCreated :: (MonadIO m) =>
                 [FilePath]     -- ^ directory path of defaults
              -> FilePath       -- ^ build target
              -> FilePath       -- ^ path of the dependency
              -> Redo m ()
redoIfCreated mDefaultsDir buildTarget dep = do
  depExists <- liftIO $ doesFileExist dep
  if depExists
    then redoIfChanged mDefaultsDir buildTarget dep
    else liftIO $ recordMissingDependency buildTarget dep

redoIfChanged :: MonadIO m =>
                 [FilePath]     -- ^ directory of defaults
              -> FilePath       -- ^ build target
              -> FilePath       -- ^ path of the dependency
              -> Redo m ()
redoIfChanged mDefaultsDir buildTarget dep = do
  (`withTarget` redo mDefaultsDir) dep
  liftIO $ recordDependency buildTarget dep

getBuildTarget :: (MonadIO m) => ExceptT ExitCode m FilePath
getBuildTarget = do
  mTarget <- liftIO $ lookupEnv "REDO_TARGET"
  case mTarget of
    Nothing -> do putStrLnErr "Could not detect build target"
                  throwE $ ExitFailure 1
    Just target -> return target