CriterionWrapper.hs

{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE UndecidableInstances #-}

--
-- Copyright (c) 2011   Stefan Wehr - http://www.stefanwehr.de
--
-- This library is free software; you can redistribute it and/or
-- modify it under the terms of the GNU Lesser General Public
-- License as published by the Free Software Foundation; either
-- version 2.1 of the License, or (at your option) any later version.
--
-- This library is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- Lesser General Public License for more details.
--
-- You should have received a copy of the GNU Lesser General Public
-- License along with this library; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA
--

module Test.Framework.CriterionWrapper (

    HtfBenchmark, ComparisonBenchmark
  , mkComparison, mkComparisonWithMargin
  , simpleBenchmark, withBenchmarkConfig
  , withBenchmarkComparison, withBenchmarkComparisonAndConfig
  , IsHtfBenchmark, asHtfBenchmark, prepareHtfBenchmark
  , defaultBenchmarkConfig

) where

--import qualified Data.Vector.Unboxed as V
--import Control.Monad.Trans

import Data.Maybe (isJust)

import Criterion
import Criterion.Monad
import Criterion.Environment
import Criterion.Config

import Test.Framework.TestConfig

data AnyBenchmarkable = forall b . Benchmarkable b => AnyBenchmarkable b

instance Benchmarkable AnyBenchmarkable where
    run (AnyBenchmarkable b) n = run b n

data HtfBenchmark
    = HtfBenchmark
      { htfb_benchmarkable :: AnyBenchmarkable
      , htfb_config :: Config
      , htfb_comparison :: Maybe ComparisonBenchmark
      , htfb_pending :: Bool
      }

instance Benchmarkable HtfBenchmark where
    run b n = run (htfb_benchmarkable b) n

data ComparisonBenchmark
    = ComparisonBenchmark
      { cb_benchmarkable :: AnyBenchmarkable
      , cb_factor :: Double
      , cb_margin :: Double
      }

defaultBenchmarkConfig :: Config
defaultBenchmarkConfig = defaultConfig

mkComparison :: Benchmarkable b => b -> Double -> ComparisonBenchmark
mkComparison b f = mkComparisonWithMargin b f 0.1

mkComparisonWithMargin :: Benchmarkable b => b -> Double -> Double -> ComparisonBenchmark
mkComparisonWithMargin b f m = ComparisonBenchmark (AnyBenchmarkable b) f m

simpleBenchmark :: Benchmarkable b => b -> HtfBenchmark
simpleBenchmark b =
    HtfBenchmark
    {
      htfb_benchmarkable = AnyBenchmarkable b
    , htfb_config = defaultConfig
    , htfb_comparison = Nothing
    , htfb_pending = False
    }

withBenchmarkConfig :: Benchmarkable b => Config -> b -> HtfBenchmark
withBenchmarkConfig cfg b =
    HtfBenchmark
    {
      htfb_benchmarkable = AnyBenchmarkable b
    , htfb_config = cfg
    , htfb_comparison = Nothing
    , htfb_pending = False
    }

withBenchmarkComparison :: Benchmarkable b => ComparisonBenchmark -> b -> HtfBenchmark
withBenchmarkComparison cmp b =
    HtfBenchmark
    {
      htfb_benchmarkable = AnyBenchmarkable b
    , htfb_config = defaultConfig
    , htfb_comparison = Just cmp
    , htfb_pending = False
    }

withBenchmarkComparisonAndConfig ::
    Benchmarkable b => ComparisonBenchmark -> Config -> b -> HtfBenchmark
withBenchmarkComparisonAndConfig cmp cfg b =
    HtfBenchmark
    {
      htfb_benchmarkable = AnyBenchmarkable b
    , htfb_config = cfg
    , htfb_comparison = Just cmp
    , htfb_pending = False
    }

{-
getSamples :: Benchmarkable b => b -> IO [Double]
getSamples b =
    do samples <- withConfig defaultConfig $ do env <- measureEnvironment
                                                liftIO $ putStrLn "running benchmark"
                                                runBenchmark env b
       return $ V.toList samples
-}

class IsHtfBenchmark a where
    isHtfBenchmark :: a -> Maybe HtfBenchmark

instance IsHtfBenchmark HtfBenchmark where
    isHtfBenchmark = Just

instance Benchmarkable b => IsHtfBenchmark b where
    isHtfBenchmark = Just . simpleBenchmark

asHtfBenchmark :: (Benchmarkable b, IsHtfBenchmark b) => b -> HtfBenchmark
asHtfBenchmark b =
    case isHtfBenchmark b of
      Nothing -> simpleBenchmark b
      Just h -> h

prepareHtfBenchmark :: HtfBenchmark -> (TestConfig -> Bool, IO ())
prepareHtfBenchmark bench =
    (\tc -> tc_benchmarks tc || isJust (htfb_comparison bench),
     putStrLn "running benchmarks not yet implemented")

benchmarkPending :: (Benchmarkable b, IsHtfBenchmark b) => b -> HtfBenchmark
benchmarkPending x =
    (asHtfBenchmark x) { htfb_pending = True }