    {-# 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 :: 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 :: forall a. Binary a => Handle -> IO (Either String [a])
    hGetRecords Handle
    handle = do
      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 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 :: 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

    -- | 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 = 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 :: forall a. Binary a => 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)

    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 a. 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 a. 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 a b. (a -> b) -> m a -> m b
    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

    -- | 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 bstr <- String -> IO ByteString
    L.readFile String
    path
         let res = ByteString -> Either String ReportFileContents
    forall a. FromJSON a => ByteString -> Either String a
    Aeson.eitherDecode ByteString
    bstr
         case res of
           Left String
    _ -> Either String ReportFileContents
    -> IO (Either String ReportFileContents)
    forall a. a -> IO a
    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 a. a -> IO a
    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 a. a -> IO a
    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