module BuildBox.Build.Base where
import BuildBox.Pretty
import BuildBox.Build.BuildError
import BuildBox.Build.BuildState
import Control.Monad.Error
import Control.Monad.State
import Control.Exception (try)
import System.IO
import System.Random
import System.Directory
type Build a = ErrorT BuildError (StateT BuildState IO) a
runBuild :: FilePath -> Build a -> IO (Either BuildError a)
runBuild scratchDir build
= do uid <- getUniqueId
let s = buildStateDefault uid scratchDir
evalStateT (runErrorT build) s
runBuildPrint :: FilePath -> Build a -> IO (Maybe a)
runBuildPrint scratchDir build
= do uid <- getUniqueId
let s = buildStateDefault uid scratchDir
runBuildPrintWithState s build
runBuildWithState :: BuildState -> Build a -> IO (Maybe a)
runBuildWithState s build
= do result <- evalStateT (runErrorT build) s
case result of
Left err
-> do putStrLn $ render $ ppr err
return $ Nothing
Right x
-> do return $ Just x
runBuildPrintWithState :: BuildState -> Build a -> IO (Maybe a)
runBuildPrintWithState s build
= do result <- evalStateT (runErrorT build) s
case result of
Left err
-> do putStrLn "\nBuild failed"
putStr " due to "
putStrLn $ render $ ppr err
return $ Nothing
Right x
-> do putStrLn "Build succeeded."
return $ Just x
successfully :: IO a -> IO ()
successfully f = f >> return ()
getUniqueId :: IO Integer
getUniqueId
= randomRIO (0, 1000000000)
throw :: BuildError -> Build a
throw = throwError
catch :: Build a -> (BuildError -> Build a) -> Build a
catch build handle
= do s <- get
(result, s') <- io $ runStateT (runErrorT build) s
case result of
Left err -> handle err
Right x
-> do put s'
return x
needs :: FilePath -> Build ()
needs filePath
= do isFile <- io $ doesFileExist filePath
isDir <- io $ doesDirectoryExist filePath
if isFile || isDir
then return ()
else throw $ ErrorNeeds filePath
io :: IO a -> Build a
io x
= do
result <- liftIO $ try x
case result of
Left err -> throw $ ErrorIOError err
Right res -> return res
whenM :: Monad m => m Bool -> m () -> m ()
whenM cb cx
= do b <- cb
if b then cx else return ()
out :: Pretty a => a -> Build ()
out str
= io
$ do putStr $ render $ ppr str
hFlush stdout
outLn :: Pretty a => a -> Build ()
outLn str = io $ putStrLn $ render $ ppr str
outBlank :: Build ()
outBlank = out $ text "\n"
outLine :: Build ()
outLine = io $ putStr (replicate 80 '-' ++ "\n")
outLINE :: Build ()
outLINE = io $ putStr (replicate 80 '=' ++ "\n")