gdo-0.1.2: Main.hs

import           Control.Exception
import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Except
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
  defaultDirs <- getDefaultDirs
  either exitWith (const exitSuccess) =<< 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 ()
    )

redo :: (MonadIO m) =>
        [FilePath] -> FilePath -> ExceptT ExitCode m ()
redo mDefaultsDir target = do
  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 target
               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 target)
      =<< getRecipeFile mDefaultsDir target

redoIfCreated :: (MonadIO m) =>
                 [FilePath]     -- ^ directory path of defaults
              -> FilePath       -- ^ build target
              -> FilePath       -- ^ path of the dependency
              -> ExceptT ExitCode 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
              -> ExceptT ExitCode 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