{-# 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 (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ do
ByteString -> Put
putByteString ([Char] -> ByteString
B.pack [Char]
headerRoot)
(Int -> Put) -> [Int] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Word16 -> Put
putWord16be (Word16 -> Put) -> (Int -> Word16) -> Int -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (Version -> [Int]
versionBranch Version
version)
headerRoot :: String
= [Char]
"criterion"
critVersion :: String
critVersion :: [Char]
critVersion = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"." ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ (Int -> [Char]) -> [Int] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Int -> [Char]
forall a. Show a => a -> [Char]
show ([Int] -> [[Char]]) -> [Int] -> [[Char]]
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 [Char] [a])
hGetRecords Handle
handle = do
ByteString
bs <- Handle -> Int -> IO ByteString
L.hGet Handle
handle (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int64
L.length ByteString
header))
if ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
header
then [a] -> Either [Char] [a]
forall a b. b -> Either a b
Right ([a] -> Either [Char] [a]) -> IO [a] -> IO (Either [Char] [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Handle -> IO [a]
forall a. Binary a => Handle -> IO [a]
readAll Handle
handle
else Either [Char] [a] -> IO (Either [Char] [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Char] [a] -> IO (Either [Char] [a]))
-> Either [Char] [a] -> IO (Either [Char] [a])
forall a b. (a -> b) -> a -> b
$ [Char] -> Either [Char] [a]
forall a b. a -> Either a b
Left ([Char] -> Either [Char] [a]) -> [Char] -> Either [Char] [a]
forall a b. (a -> b) -> a -> b
$ [Char]
"unexpected header, expected criterion version: "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Int] -> [Char]
forall a. Show a => a -> [Char]
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
(a -> IO ()) -> [a] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> ByteString -> IO ()
L.hPut Handle
handle (ByteString -> IO ()) -> (a -> ByteString) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. Binary a => a -> ByteString
encode) [a]
rs
readRecords :: Binary a => FilePath -> IO (Either String [a])
readRecords :: forall a. Binary a => [Char] -> IO (Either [Char] [a])
readRecords [Char]
path = [Char]
-> IOMode
-> (Handle -> IO (Either [Char] [a]))
-> IO (Either [Char] [a])
forall r. [Char] -> IOMode -> (Handle -> IO r) -> IO r
withFile [Char]
path IOMode
ReadMode Handle -> IO (Either [Char] [a])
forall a. Binary a => Handle -> IO (Either [Char] [a])
hGetRecords
writeRecords :: Binary a => FilePath -> [a] -> IO ()
writeRecords :: forall a. Binary a => [Char] -> [a] -> IO ()
writeRecords [Char]
path [a]
rs = [Char] -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. [Char] -> IOMode -> (Handle -> IO r) -> IO r
withFile [Char]
path IOMode
WriteMode ((Handle -> [a] -> IO ()) -> [a] -> Handle -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Handle -> [a] -> IO ()
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 = [a] -> m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []
| Bool
otherwise = case Get a
-> ByteString
-> Either (ByteString, Int64, [Char]) (ByteString, Int64, a)
forall a.
Get a
-> ByteString
-> Either (ByteString, Int64, [Char]) (ByteString, Int64, a)
runGetOrFail Get a
forall t. Binary t => Get t
get ByteString
bs of
Left (ByteString
_, Int64
_, [Char]
err) -> [Char] -> m [a]
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
err
Right (ByteString
bs', Int64
_, a
a) -> (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a]) -> m [a] -> m [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ByteString -> m [a]
go ByteString
bs'
ByteString -> IO [a]
forall {m :: * -> *} {a}.
(Binary a, MonadFail m) =>
ByteString -> m [a]
go (ByteString -> IO [a]) -> IO ByteString -> IO [a]
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 :: [Char] -> IO (Either [Char] ReportFileContents)
readJSONReports [Char]
path =
do ByteString
bstr <- [Char] -> IO ByteString
L.readFile [Char]
path
let res :: Either [Char] ReportFileContents
res = ByteString -> Either [Char] ReportFileContents
forall a. FromJSON a => ByteString -> Either [Char] a
Aeson.eitherDecode ByteString
bstr
case Either [Char] ReportFileContents
res of
Left [Char]
_ -> Either [Char] ReportFileContents
-> IO (Either [Char] ReportFileContents)
forall (m :: * -> *) a. Monad m => a -> m a
return Either [Char] ReportFileContents
res
Right ([Char]
tg,[Char]
vers,[Report]
_)
| [Char]
tg [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
headerRoot Bool -> Bool -> Bool
&& [Char]
vers [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
critVersion -> Either [Char] ReportFileContents
-> IO (Either [Char] ReportFileContents)
forall (m :: * -> *) a. Monad m => a -> m a
return Either [Char] ReportFileContents
res
| Bool
otherwise ->
do Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Warning, readJSONReports: mismatched header, expected "
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ([Char], [Char]) -> [Char]
forall a. Show a => a -> [Char]
show ([Char]
headerRoot,[Char]
critVersion) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" received " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ([Char], [Char]) -> [Char]
forall a. Show a => a -> [Char]
show ([Char]
tg,[Char]
vers)
Either [Char] ReportFileContents
-> IO (Either [Char] ReportFileContents)
forall (m :: * -> *) a. Monad m => a -> m a
return Either [Char] ReportFileContents
res
writeJSONReports :: FilePath -> [Report] -> IO ()
writeJSONReports :: [Char] -> [Report] -> IO ()
writeJSONReports [Char]
fn [Report]
rs =
let payload :: ReportFileContents
payload :: ReportFileContents
payload = ([Char]
headerRoot, [Char]
critVersion, [Report]
rs)
in [Char] -> ByteString -> IO ()
L.writeFile [Char]
fn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ReportFileContents -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode ReportFileContents
payload