{-# 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 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)

-- | 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 = 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

-- | Read all records from the given 'Handle'.
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)

-- | Write records to the given 'Handle'.
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

-- | Read all records from the given file.
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

-- | Write records to the given file.
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

-- | 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 = 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

-- | 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 forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> ByteString
Aeson.encode ReportFileContents
payload