1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
|
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP, OverloadedStrings #-}
-- |
-- Module : Criterion.IO
-- Copyright : (c) 2009-2014 Bryan O'Sullivan
--
-- License : BSD-style
-- Maintainer : bos@serpentine.com
-- Stability : experimental
-- Portability : GHC
--
-- Input and output actions.
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
-- | The header identifies a criterion data file. This contains
-- version information; there is no expectation of cross-version
-- compatibility.
header :: L.ByteString
header = runPut $ do
putByteString (B.pack headerRoot)
mapM_ (putWord16be . fromIntegral) (versionBranch version)
-- | The magic string we expect to start off the header.
headerRoot :: String
headerRoot = "criterion"
-- | The current version of criterion, encoded into a string that is
-- used in files.
critVersion :: String
critVersion = intercalate "." $ map show $ versionBranch version
-- | Read all records from the given 'Handle'.
hGetRecords :: Binary a => Handle -> IO (Either String [a])
hGetRecords handle = do
bs <- L.hGet handle (fromIntegral (L.length header))
if bs == header
then Right `fmap` readAll handle
else return $ Left $ "unexpected header, expected criterion version: "++show (versionBranch version)
-- | Write records to the given 'Handle'.
hPutRecords :: Binary a => Handle -> [a] -> IO ()
hPutRecords handle rs = do
L.hPut handle header
mapM_ (L.hPut handle . encode) rs
-- | Read all records from the given file.
readRecords :: Binary a => FilePath -> IO (Either String [a])
readRecords path = withFile path ReadMode hGetRecords
-- | Write records to the given file.
writeRecords :: Binary a => FilePath -> [a] -> IO ()
writeRecords path rs = withFile path WriteMode (flip hPutRecords rs)
#if MIN_VERSION_binary(0, 6, 3)
readAll :: Binary a => Handle -> IO [a]
readAll handle = do
let go bs
| L.null bs = return []
| otherwise = case runGetOrFail get bs of
Left (_, _, err) -> fail err
Right (bs', _, a) -> (a:) `fmap` go bs'
go =<< L.hGetContents 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
-- | On disk we store (name,version,reports), where
-- 'version' is the version of Criterion used to generate the file.
type ReportFileContents = (String,String,[Report])
-- | Alternative file IO with JSON instances. Read a list of reports
-- from a .json file produced by criterion.
--
-- If the version does not match exactly, this issues a warning.
readJSONReports :: FilePath -> IO (Either String ReportFileContents)
readJSONReports path =
do bstr <- L.readFile path
let res = Aeson.eitherDecode bstr
case res of
Left _ -> return res
Right (tg,vers,_)
| tg == headerRoot && vers == critVersion -> return res
| otherwise ->
do hPutStrLn stderr $ "Warning, readJSONReports: mismatched header, expected "
++ show (headerRoot,critVersion) ++ " received " ++ show (tg,vers)
return res
-- | Write a list of reports to a JSON file. Includes a header, which
-- includes the current Criterion version number. This should be
-- the inverse of `readJSONReports`.
writeJSONReports :: FilePath -> [Report] -> IO ()
writeJSONReports fn rs =
let payload :: ReportFileContents
payload = (headerRoot, critVersion, rs)
in L.writeFile fn $ Aeson.encode payload
|
