module BuildBox.Build.Base where
import BuildBox.Pretty
import Control.Monad.Error
import Control.Monad.Reader
import System.IO
import System.IO.Error
import System.Exit
import BuildBox.Data.Log (Log)
import qualified BuildBox.Data.Log as Log
type Build a = ErrorT BuildError (ReaderT BuildConfig IO) a
data BuildError
= ErrorOther String
| ErrorSystemCmdFailed
{ buildErrorCmd :: String
, buildErrorCode :: ExitCode
, buildErrorStdout :: Log
, buildErrorStderr :: Log }
| ErrorIOError IOError
| forall prop. Show prop => ErrorCheckFailed Bool prop
instance Error BuildError where
strMsg s = ErrorOther s
instance Pretty BuildError where
ppr err
= case err of
ErrorOther str
-> text "Other error: " <> text str
ErrorSystemCmdFailed{}
-> vcat
[ text "System command failure."
, text " command: " <> (text $ buildErrorCmd err)
, text " exit code: " <> (text $ show $ buildErrorCode err)
, blank
, if (not $ Log.null $ buildErrorStdout err)
then vcat [ text "-- stdout (last 10 lines) ------------------------------------------------------"
, text $ Log.toString $ Log.lastLines 10 $ buildErrorStdout err]
else text ""
, blank
, if (not $ Log.null $ buildErrorStderr err)
then vcat [ text "-- stderr (last 10 lines) ------------------------------------------------------"
, text $ Log.toString $ Log.lastLines 10 $ buildErrorStderr err]
else text ""
, text "--------------------------------------------------------------------------------" ]
ErrorIOError ioerr
-> text "IO error: " <> (text $ show ioerr)
ErrorCheckFailed expected prop
-> text "Check failure: " <> (text $ show prop) <> (text " expected ") <> (text $ show expected)
instance Show BuildError where
show err = render $ ppr err
data BuildConfig
= BuildConfig
{
buildConfigLogSystem :: Maybe Handle }
buildConfigDefault :: BuildConfig
buildConfigDefault
= BuildConfig
{ buildConfigLogSystem = Nothing }
logSystem :: String -> Build ()
logSystem cmd
= do mHandle <- asks buildConfigLogSystem
case mHandle of
Nothing -> return ()
Just handle
-> do io $ hPutStr handle "buildbox system: "
io $ hPutStrLn handle cmd
return ()
throw :: BuildError -> Build a
throw = throwError
runBuild :: Build a -> IO (Either BuildError a)
runBuild build
= runReaderT (runErrorT build) buildConfigDefault
runBuildPrint :: Build a -> IO (Maybe a)
runBuildPrint
= runBuildPrintWithConfig buildConfigDefault
runBuildPrintWithConfig :: BuildConfig -> Build a -> IO (Maybe a)
runBuildPrintWithConfig config build
= do result <- runReaderT (runErrorT build) config
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
io :: IO a -> Build a
io x
= do
result <- liftIO $ try x
case result of
Left err -> throw $ ErrorIOError err
Right res -> return res
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")
whenM :: Monad m => m Bool -> m () -> m ()
whenM cb cx
= do b <- cb
if b then cx else return ()