    {-# 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 x <- Criterion Config
    forall r (m :: * -> *). MonadReader r m => m r
    ask
             when (check x) (liftIO (final >> hFlush stderr >> hFlush stdout))
             return 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 a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Handle -> IO ()
    hFlush Handle
    stderr IO () -> IO () -> IO ()
    forall a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Handle -> IO ()
    hFlush Handle
    stdout IO () -> IO a -> IO a
    forall a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> a -> IO a
    forall a. 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 :: forall r.
    CritHPrintfType r =>
    (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 :: forall r. CritHPrintfType r => 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 :: forall r. CritHPrintfType r => 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 :: forall r. CritHPrintfType r => 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 :: forall a. ToRecord a => a -> Criterion ()
    writeCsv a
    val = do
      csv <- (Config -> Maybe String) -> Criterion (Maybe String)
    forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
    asks Config -> Maybe String
    csvFile
      forM_ csv $ \String
    fn ->
        IO () -> Criterion ()
    forall a. IO a -> Criterion a
    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]