module Criterion.IO
(
CritHPrintfType
, note
, printError
, prolix
, summary
) where
import Control.Monad (when)
import Control.Monad.Trans (liftIO)
import Criterion.Config (Config, Verbosity(..), cfgSummaryFile, cfgVerbosity, fromLJ)
import Criterion.Monad (Criterion, getConfig, getConfigItem)
import Data.Monoid (getLast)
import System.IO (Handle, stderr, stdout)
import qualified Text.Printf (HPrintfType, hPrintf)
import Text.Printf (PrintfArg)
data PrintfCont = PrintfCont (IO ()) (PrintfArg a => a -> PrintfCont)
class CritHPrintfType a where
chPrintfImpl :: (Config -> Bool) -> PrintfCont -> a
instance CritHPrintfType (Criterion a) where
chPrintfImpl check (PrintfCont final _)
= do x <- getConfig
when (check x) (liftIO final)
return undefined
instance CritHPrintfType (IO a) where
chPrintfImpl _ (PrintfCont final _)
= final >> return undefined
instance (CritHPrintfType r, PrintfArg a) => CritHPrintfType (a -> r) where
chPrintfImpl check (PrintfCont _ anotherArg) x
= chPrintfImpl check (anotherArg x)
chPrintf :: CritHPrintfType r => (Config -> Bool) -> Handle -> String -> r
chPrintf shouldPrint h s
= chPrintfImpl shouldPrint (make (Text.Printf.hPrintf h s)
(Text.Printf.hPrintf h s))
where
make :: IO () -> (forall a r. (PrintfArg a, Text.Printf.HPrintfType r) =>
a -> r) -> PrintfCont
make curCall curCall' = PrintfCont curCall (\x -> make (curCall' x)
(curCall' x))
note :: (CritHPrintfType r) => String -> r
note = chPrintf ((> Quiet) . fromLJ cfgVerbosity) stdout
prolix :: (CritHPrintfType r) => String -> r
prolix = chPrintf ((== Verbose) . fromLJ cfgVerbosity) stdout
printError :: (CritHPrintfType r) => String -> r
printError = chPrintf (const True) stderr
summary :: String -> Criterion ()
summary msg
= do sumOpt <- getConfigItem (getLast . cfgSummaryFile)
case sumOpt of
Just fn -> liftIO $ appendFile fn msg
Nothing -> return ()