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
|
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE 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)
import Data.Binary.Get (runGetOrFail)
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)
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
-- | 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
|
