{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP, OverloadedStrings #-}
module Criterion.IO
(
header
, headerRoot
, critVersion
, hGetRecords
, hPutRecords
, readRecords
, writeRecords
, ReportFileContents
, readJSONReports
, writeJSONReports
) where
import qualified Data.Aeson as Aeson
import Data.Binary (Binary(..), encode)
#if MIN_VERSION_binary(0, 6, 3)
import Data.Binary.Get (runGetOrFail)
#else
import Data.Binary.Get (runGetState)
#endif
import Data.Binary.Put (putByteString, putWord16be, runPut)
import qualified Data.ByteString.Char8 as B
import Criterion.Types (Report(..))
import Data.List (intercalate)
import Data.Version (Version(..))
import Paths_criterion (version)
import System.IO (Handle, IOMode(..), withFile, hPutStrLn, stderr)
import qualified Data.ByteString.Lazy as L
header :: L.ByteString
= Put -> ByteString
runPut forall a b. (a -> b) -> a -> b
$ do
ByteString -> Put
putByteString (String -> ByteString
B.pack String
headerRoot)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Word16 -> Put
putWord16be forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral) (Version -> [Int]
versionBranch Version
version)
headerRoot :: String
= String
"criterion"
critVersion :: String
critVersion :: String
critVersion = forall a. [a] -> [[a]] -> [a]
intercalate String
"." forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Version -> [Int]
versionBranch Version
version
hGetRecords :: Binary a => Handle -> IO (Either String [a])
hGetRecords :: forall a. Binary a => Handle -> IO (Either String [a])
hGetRecords Handle
handle = do
ByteString
bs <- Handle -> Int -> IO ByteString
L.hGet Handle
handle (forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int64
L.length ByteString
header))
if ByteString
bs forall a. Eq a => a -> a -> Bool
== ByteString
header
then forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall a. Binary a => Handle -> IO [a]
readAll Handle
handle
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"unexpected header, expected criterion version: "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show (Version -> [Int]
versionBranch Version
version)
hPutRecords :: Binary a => Handle -> [a] -> IO ()
hPutRecords :: forall a. Binary a => Handle -> [a] -> IO ()
hPutRecords Handle
handle [a]
rs = do
Handle -> ByteString -> IO ()
L.hPut Handle
handle ByteString
header
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> ByteString -> IO ()
L.hPut Handle
handle forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Binary a => a -> ByteString
encode) [a]
rs
readRecords :: Binary a => FilePath -> IO (Either String [a])
readRecords :: forall a. Binary a => String -> IO (Either String [a])
readRecords String
path = forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
path IOMode
ReadMode forall a. Binary a => Handle -> IO (Either String [a])
hGetRecords
writeRecords :: Binary a => FilePath -> [a] -> IO ()
writeRecords :: forall a. Binary a => String -> [a] -> IO ()
writeRecords String
path [a]
rs = forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
path IOMode
WriteMode (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Binary a => Handle -> [a] -> IO ()
hPutRecords [a]
rs)
#if MIN_VERSION_binary(0, 6, 3)
readAll :: Binary a => Handle -> IO [a]
readAll :: forall a. Binary a => Handle -> IO [a]
readAll Handle
handle = do
let go :: ByteString -> m [a]
go ByteString
bs
| ByteString -> Bool
L.null ByteString
bs = forall (m :: * -> *) a. Monad m => a -> m a
return []
| Bool
otherwise = case forall a.
Get a
-> ByteString
-> Either (ByteString, Int64, String) (ByteString, Int64, a)
runGetOrFail forall t. Binary t => Get t
get ByteString
bs of
Left (ByteString
_, Int64
_, String
err) -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
Right (ByteString
bs', Int64
_, a
a) -> (a
aforall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ByteString -> m [a]
go ByteString
bs'
forall {m :: * -> *} {a}.
(Binary a, MonadFail m) =>
ByteString -> m [a]
go forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Handle -> IO ByteString
L.hGetContents Handle
handle
#else
readAll :: Binary a => Handle -> IO [a]
readAll handle = do
let go i bs
| L.null bs = return []
| otherwise =
let (a, bs', i') = runGetState get bs i
in (a:) `fmap` go i' bs'
go 0 =<< L.hGetContents handle
#endif
type ReportFileContents = (String,String,[Report])
readJSONReports :: FilePath -> IO (Either String ReportFileContents)
readJSONReports :: String -> IO (Either String ReportFileContents)
readJSONReports String
path =
do ByteString
bstr <- String -> IO ByteString
L.readFile String
path
let res :: Either String ReportFileContents
res = forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecode ByteString
bstr
case Either String ReportFileContents
res of
Left String
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Either String ReportFileContents
res
Right (String
tg,String
vers,[Report]
_)
| String
tg forall a. Eq a => a -> a -> Bool
== String
headerRoot Bool -> Bool -> Bool
&& String
vers forall a. Eq a => a -> a -> Bool
== String
critVersion -> forall (m :: * -> *) a. Monad m => a -> m a
return Either String ReportFileContents
res
| Bool
otherwise ->
do Handle -> String -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ String
"Warning, readJSONReports: mismatched header, expected "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (String
headerRoot,String
critVersion) forall a. [a] -> [a] -> [a]
++ String
" received " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (String
tg,String
vers)
forall (m :: * -> *) a. Monad m => a -> m a
return Either String ReportFileContents
res
writeJSONReports :: FilePath -> [Report] -> IO ()
writeJSONReports :: String -> [Report] -> IO ()
writeJSONReports String
fn [Report]
rs =
let payload :: ReportFileContents
payload :: ReportFileContents
payload = (String
headerRoot, String
critVersion, [Report]
rs)
in String -> ByteString -> IO ()
L.writeFile String
fn forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> ByteString
Aeson.encode ReportFileContents
payload