{-# LANGUAGE Trustworthy #-}
-- |
-- Module      : Criterion.IO.Printf
-- Copyright   : (c) 2009-2014 Bryan O'Sullivan
--
-- License     : BSD-style
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : GHC
--
-- Input and output actions.

{-# LANGUAGE FlexibleInstances, Rank2Types, TypeSynonymInstances #-}
module Criterion.IO.Printf
    (
      CritHPrintfType
    , note
    , printError
    , prolix
    , writeCsv
    ) where

import Control.Monad (when)
import Control.Monad.Reader (ask, asks)
import Control.Monad.Trans (liftIO)
import Criterion.Monad (Criterion)
import Criterion.Types (Config(csvFile, verbosity), Verbosity(..))
import Data.Foldable (forM_)
import System.IO (Handle, hFlush, stderr, stdout)
import Text.Printf (PrintfArg)
import qualified Data.ByteString.Lazy as B
import qualified Data.Csv as Csv
import qualified Text.Printf (HPrintfType, hPrintf)

-- First item is the action to print now, given all the arguments
-- gathered together so far.  The second item is the function that
-- will take a further argument and give back a new PrintfCont.
data PrintfCont = PrintfCont (IO ()) (forall a . PrintfArg a => a -> PrintfCont)

-- | An internal class that acts like Printf/HPrintf.
--
-- The implementation is visible to the rest of the program, but the
-- details of the class are not.
class CritHPrintfType a where
  chPrintfImpl :: (Config -> Bool) -> PrintfCont -> a


instance CritHPrintfType (Criterion a) where
  chPrintfImpl :: (Config -> Bool) -> PrintfCont -> Criterion a
chPrintfImpl Config -> Bool
check (PrintfCont IO ()
final forall a. PrintfArg a => a -> PrintfCont
_)
    = do Config
x <- Criterion Config
forall r (m :: * -> *). MonadReader r m => m r
ask
         Bool -> Criterion () -> Criterion ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
check Config
x) (IO () -> Criterion ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ()
final IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stderr IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout))
         a -> Criterion a
forall (m :: * -> *) a. Monad m => a -> m a
return a
forall a. HasCallStack => a
undefined

instance CritHPrintfType (IO a) where
  chPrintfImpl :: (Config -> Bool) -> PrintfCont -> IO a
chPrintfImpl Config -> Bool
_ (PrintfCont IO ()
final forall a. PrintfArg a => a -> PrintfCont
_)
    = IO ()
final IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stderr IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout IO () -> IO a -> IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
forall a. HasCallStack => a
undefined

instance (CritHPrintfType r, PrintfArg a) => CritHPrintfType (a -> r) where
  chPrintfImpl :: (Config -> Bool) -> PrintfCont -> a -> r
chPrintfImpl Config -> Bool
check (PrintfCont IO ()
_ forall a. PrintfArg a => a -> PrintfCont
anotherArg) a
x
    = (Config -> Bool) -> PrintfCont -> r
forall a. CritHPrintfType a => (Config -> Bool) -> PrintfCont -> a
chPrintfImpl Config -> Bool
check (a -> PrintfCont
forall a. PrintfArg a => a -> PrintfCont
anotherArg a
x)

chPrintf :: CritHPrintfType r => (Config -> Bool) -> Handle -> String -> r
chPrintf :: (Config -> Bool) -> Handle -> String -> r
chPrintf Config -> Bool
shouldPrint Handle
h String
s
  = (Config -> Bool) -> PrintfCont -> r
forall a. CritHPrintfType a => (Config -> Bool) -> PrintfCont -> a
chPrintfImpl Config -> Bool
shouldPrint (IO ()
-> (forall a r. (PrintfArg a, HPrintfType r) => a -> r)
-> PrintfCont
make (Handle -> String -> IO ()
forall r. HPrintfType r => Handle -> String -> r
Text.Printf.hPrintf Handle
h String
s)
                                   (Handle -> String -> a -> r
forall r. HPrintfType r => Handle -> String -> r
Text.Printf.hPrintf Handle
h String
s))
  where
    make :: IO () -> (forall a r. (PrintfArg a, Text.Printf.HPrintfType r) =>
                      a -> r) -> PrintfCont
    make :: IO ()
-> (forall a r. (PrintfArg a, HPrintfType r) => a -> r)
-> PrintfCont
make IO ()
curCall forall a r. (PrintfArg a, HPrintfType r) => a -> r
curCall' = IO () -> (forall a. PrintfArg a => a -> PrintfCont) -> PrintfCont
PrintfCont IO ()
curCall (\a
x -> IO ()
-> (forall a r. (PrintfArg a, HPrintfType r) => a -> r)
-> PrintfCont
make (a -> IO ()
forall a r. (PrintfArg a, HPrintfType r) => a -> r
curCall' a
x)
                                                      (a -> a -> r
forall a r. (PrintfArg a, HPrintfType r) => a -> r
curCall' a
x))

{- A demonstration of how to write printf in this style, in case it is
ever needed
  in fututre:

cPrintf :: CritHPrintfType r => (Config -> Bool) -> String -> r
cPrintf shouldPrint s
  = chPrintfImpl shouldPrint (make (Text.Printf.printf s)
  (Text.Printf.printf s))
  where
    make :: IO () -> (forall a r. (PrintfArg a, Text.Printf.PrintfType r) => a -> r) -> PrintfCont
    make curCall curCall' = PrintfCont curCall (\x -> make (curCall' x) (curCall' x))
-}

-- | Print a \"normal\" note.
note :: (CritHPrintfType r) => String -> r
note :: String -> r
note = (Config -> Bool) -> Handle -> String -> r
forall r.
CritHPrintfType r =>
(Config -> Bool) -> Handle -> String -> r
chPrintf ((Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
> Verbosity
Quiet) (Verbosity -> Bool) -> (Config -> Verbosity) -> Config -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Verbosity
verbosity) Handle
stdout

-- | Print verbose output.
prolix :: (CritHPrintfType r) => String -> r
prolix :: String -> r
prolix = (Config -> Bool) -> Handle -> String -> r
forall r.
CritHPrintfType r =>
(Config -> Bool) -> Handle -> String -> r
chPrintf ((Verbosity -> Verbosity -> Bool
forall a. Eq a => a -> a -> Bool
== Verbosity
Verbose) (Verbosity -> Bool) -> (Config -> Verbosity) -> Config -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Verbosity
verbosity) Handle
stdout

-- | Print an error message.
printError :: (CritHPrintfType r) => String -> r
printError :: String -> r
printError = (Config -> Bool) -> Handle -> String -> r
forall r.
CritHPrintfType r =>
(Config -> Bool) -> Handle -> String -> r
chPrintf (Bool -> Config -> Bool
forall a b. a -> b -> a
const Bool
True) Handle
stderr

-- | Write a record to a CSV file.
writeCsv :: Csv.ToRecord a => a -> Criterion ()
writeCsv :: a -> Criterion ()
writeCsv a
val = do
  Maybe String
csv <- (Config -> Maybe String) -> Criterion (Maybe String)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Config -> Maybe String
csvFile
  Maybe String -> (String -> Criterion ()) -> Criterion ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe String
csv ((String -> Criterion ()) -> Criterion ())
-> (String -> Criterion ()) -> Criterion ()
forall a b. (a -> b) -> a -> b
$ \String
fn ->
    IO () -> Criterion ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Criterion ()) -> ([a] -> IO ()) -> [a] -> Criterion ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString -> IO ()
B.appendFile String
fn (ByteString -> IO ()) -> ([a] -> ByteString) -> [a] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> ByteString
forall a. ToRecord a => [a] -> ByteString
Csv.encode ([a] -> Criterion ()) -> [a] -> Criterion ()
forall a b. (a -> b) -> a -> b
$ [a
val]