{-# 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 :: ByteString
header = Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ do
  ByteString -> Put
putByteString (String -> ByteString
B.pack String
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)

-- | The magic string we expect to start off the header.
headerRoot :: String
headerRoot :: String
headerRoot = String
"criterion"

-- | The current version of criterion, encoded into a string that is
-- used in files.
critVersion :: String
critVersion :: String
critVersion = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Int -> String
forall a. Show a => a -> String
show ([Int] -> [String]) -> [Int] -> [String]
forall a b. (a -> b) -> a -> b
$ Version -> [Int]
versionBranch Version
version

-- | Read all records from the given 'Handle'.
hGetRecords :: Binary a => Handle -> IO (Either String [a])
hGetRecords :: Handle -> IO (Either String [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 String [a]
forall a b. b -> Either a b
Right ([a] -> Either String [a]) -> IO [a] -> IO (Either String [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 String [a] -> IO (Either String [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String [a] -> IO (Either String [a]))
-> Either String [a] -> IO (Either String [a])
forall a b. (a -> b) -> a -> b
$ String -> Either String [a]
forall a b. a -> Either a b
Left (String -> Either String [a]) -> String -> Either String [a]
forall a b. (a -> b) -> a -> b
$ String
"unexpected header, expected criterion version: "String -> String -> String
forall a. [a] -> [a] -> [a]
++[Int] -> String
forall a. Show a => a -> String
show (Version -> [Int]
versionBranch Version
version)

-- | Write records to the given 'Handle'.
hPutRecords :: Binary a => Handle -> [a] -> IO ()
hPutRecords :: 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

-- | Read all records from the given file.
readRecords :: Binary a => FilePath -> IO (Either String [a])
readRecords :: String -> IO (Either String [a])
readRecords String
path = String
-> IOMode
-> (Handle -> IO (Either String [a]))
-> IO (Either String [a])
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
path IOMode
ReadMode Handle -> IO (Either String [a])
forall a. Binary a => Handle -> IO (Either String [a])
hGetRecords

-- | Write records to the given file.
writeRecords :: Binary a => FilePath -> [a] -> IO ()
writeRecords :: String -> [a] -> IO ()
writeRecords String
path [a]
rs = String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
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 :: 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, String) (ByteString, Int64, a)
forall a.
Get a
-> ByteString
-> Either (ByteString, Int64, String) (ByteString, Int64, a)
runGetOrFail Get a
forall t. Binary t => Get t
get ByteString
bs of
                         Left (ByteString
_, Int64
_, String
err) -> String -> m [a]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
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

-- | 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 :: String -> IO (Either String ReportFileContents)
readJSONReports String
path =
  do ByteString
bstr <- String -> IO ByteString
L.readFile String
path
     let res :: Either String ReportFileContents
res = ByteString -> Either String ReportFileContents
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecode ByteString
bstr
     case Either String ReportFileContents
res of
       Left String
_ -> Either String ReportFileContents
-> IO (Either String ReportFileContents)
forall (m :: * -> *) a. Monad m => a -> m a
return Either String ReportFileContents
res
       Right (String
tg,String
vers,[Report]
_)
         | String
tg String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
headerRoot Bool -> Bool -> Bool
&& String
vers String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
critVersion -> Either String ReportFileContents
-> IO (Either String ReportFileContents)
forall (m :: * -> *) a. Monad m => a -> m a
return Either String ReportFileContents
res
         | Bool
otherwise ->
            do Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Warning, readJSONReports: mismatched header, expected "
                                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String, String) -> String
forall a. Show a => a -> String
show (String
headerRoot,String
critVersion) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" received " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String, String) -> String
forall a. Show a => a -> String
show (String
tg,String
vers)
               Either String ReportFileContents
-> IO (Either String ReportFileContents)
forall (m :: * -> *) a. Monad m => a -> m a
return Either String ReportFileContents
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 :: 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 (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ReportFileContents -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode ReportFileContents
payload