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