-- | -- Module : Gauge.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 CPP, FlexibleInstances, Rank2Types, TypeSynonymInstances #-} module Gauge.IO.Printf ( CritHPrintfType , note , printError , prolix , rewindClearLine ) where import Control.Monad (when) import Foundation.Monad.Reader (ask) import Foundation.Monad (liftIO) import Gauge.Monad (Gauge) import Gauge.Types (Config(verbosity), Verbosity(..)) import System.IO (Handle, hFlush, stderr, stdout) import Text.Printf (PrintfArg) 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 (Gauge a) where chPrintfImpl check (PrintfCont final _) = do x <- ask when (check x) (liftIO (final >> hFlush stderr >> hFlush stdout)) return undefined instance CritHPrintfType (IO a) where chPrintfImpl _ (PrintfCont final _) = final >> hFlush stderr >> hFlush stdout >> 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)) {- 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 = chPrintf ((> Quiet) . verbosity) stdout -- | Print verbose output. prolix :: (CritHPrintfType r) => String -> r prolix = chPrintf ((== Verbose) . verbosity) stdout -- | Print an error message. printError :: (CritHPrintfType r) => String -> r printError = chPrintf (const True) stderr -- | ansi escape on unix to rewind and clear the line to the end rewindClearLine :: String #ifdef mingw32_HOST_OS rewindClearLine = "\n" #else rewindClearLine = "\r\ESC[0K" #endif