gdritter repos bricoleur / master src / Bricoleur / Commands / Test.hs
master

Tree @master (Download .tar.gz)

Test.hs @masterraw · history · blame

{-# LANGUAGE OverloadedStrings #-}

module Bricoleur.Commands.Test (runTest) where

import Bricoleur.Config
import Bricoleur.Opts
import Bricoleur.Utils
import Control.Monad (forM_)
import qualified Data.ByteString.Lazy.Char8 as B
import qualified GHC.IO.Exception as Exn
import System.FilePath ((</>))
import qualified System.FilePath as Sys
import qualified System.Process as Sys

runTest :: Config -> Options -> IO ()
runTest conf opts = do
  let root = Sys.takeDirectory (optFile opts)
  cDebug ("running tests for " % shown) (confDocument conf)
  forM_ (confSources conf) $ \samp -> do
    cDebug ("- running test for " % stext) (sourceName samp)
    runCommand root samp

runCommand :: FilePath -> Source -> IO ()
runCommand root src = do
  forM_ (sourceCommands src) $ \ln -> do
    let dir = root </> sourceDir src
    cDebug ("  $ " % string % " (in '" % string % "')") ln dir
    (outH, inH) <- Sys.createPipe
    let process =
          (Sys.shell ln)
            { Sys.cwd = Just (root </> sourceDir src),
              Sys.std_out = Sys.UseHandle inH,
              Sys.std_err = Sys.UseHandle inH
            }
    (_, _, _, p) <- Sys.createProcess process
    bufOutput <- B.hGetContents outH
    code <- Sys.waitForProcess p
    case code of
      Exn.ExitSuccess -> return ()
      Exn.ExitFailure n -> do
        let idtext = map (B.append "  - ") (B.lines bufOutput)
        cError
          ( "\nCommand '" % string
              % "' exited with error ("
              % shown
              % ")"
          )
          ln
          n
        mapM_ bsErrorLn idtext