Commits

Bryan O'Sullivan committed be2685e

Switch to a newtype-based monad, and get rid of doIO.

  • Participants
  • Parent commits 49b2b63

Comments (0)

Files changed (6)

File Criterion.hs

     ) where
 
 import Control.Monad ((<=<), forM_, replicateM_, when)
+import Control.Monad.Trans (liftIO)
 import Criterion.Analysis (OutlierVariance(..), classifyOutliers,
                            outlierVariance, noteOutliers)
 import Criterion.Config (Config(..), Plot(..), fromLJ)
 import Criterion.Environment (Environment(..))
 import Criterion.IO (note, prolix, summary)
 import Criterion.Measurement (getTime, runForAtLeast, secs, time_)
-import Criterion.Monad (ConfigM, getConfig, getConfigItem, doIO)
+import Criterion.Monad (ConfigM, getConfig, getConfigItem)
 import Criterion.Plot (plotWith, plotKDE, plotTiming)
 import Criterion.Types (Benchmarkable(..), Benchmark(..), B(..), bench, bgroup)
 import Data.Array.Vector ((:*:)(..), concatU, lengthU, mapU)
 -- executing it.
 runBenchmark :: Benchmarkable b => Environment -> b -> ConfigM Sample
 runBenchmark env b = do
-  doIO $ runForAtLeast 0.1 10000 (`replicateM_` getTime)
+  liftIO $ runForAtLeast 0.1 10000 (`replicateM_` getTime)
   let minTime = envClockResolution env * 1000
-  (testTime :*: testIters :*: _) <- doIO $ runForAtLeast (min minTime 0.1) 1 (run b)
+  (testTime :*: testIters :*: _) <-
+      liftIO $ runForAtLeast (min minTime 0.1) 1 (run b)
   prolix "ran %d iterations in %s\n" testIters (secs testTime)
   cfg <- getConfig
   let newIters    = ceiling $ minTime * testItersD / testTime
   note "collecting %d samples, %d iterations each, in estimated %s\n"
        sampleCount newIters (secs (fromIntegral sampleCount * newItersD *
                                    testTime / testItersD))
-  times <- doIO $ fmap (mapU ((/ newItersD) . subtract (envClockCost env))) .
+  times <- liftIO . fmap (mapU ((/ newItersD) . subtract (envClockCost env))) .
            createIO sampleCount . const $ do
              when (fromLJ cfgPerformGC cfg) $ performGC
              time_ (run b newIters)
   let ests = [mean,stdDev]
   numResamples <- getConfigItem $ fromLJ cfgResamples
   note "bootstrapping with %d resamples\n" numResamples
-  res <- doIO $ withSystemRandom (\gen -> resample gen ests numResamples times)
+  res <- liftIO $ withSystemRandom (\gen -> resample gen ests numResamples times)
   ci <- getConfigItem $ fromLJ cfgConfInterval
   let [em,es] = bootstrapBCA ci times ests res
       (effect, v) = outlierVariance em es (fromIntegral $ numSamples)

File Criterion/Environment.hs

     ) where
 
 import Control.Monad (replicateM_)
+import Control.Monad.Trans (liftIO)
 import Criterion.Analysis (analyseMean)
 import Criterion.IO (note)
 import Criterion.Measurement (getTime, runForAtLeast, time_)
-import Criterion.Monad (ConfigM, doIO)
+import Criterion.Monad (ConfigM)
 import Data.Array.Vector
 import Data.Typeable (Typeable)
 import Statistics.Function (createIO)
 measureEnvironment :: ConfigM Environment
 measureEnvironment = do
   note "warming up\n"
-  (_ :*: seed :*: _) <- doIO $ runForAtLeast 0.1 10000 resolution
+  (_ :*: seed :*: _) <- liftIO $ runForAtLeast 0.1 10000 resolution
   note "estimating clock resolution...\n"
-  clockRes <- thd3 `fmap` doIO (runForAtLeast 0.5 seed resolution) >>=
+  clockRes <- thd3 `fmap` liftIO (runForAtLeast 0.5 seed resolution) >>=
               uncurry analyseMean
   note "estimating cost of a clock call...\n"
   clockCost <- cost (min (100000 * clockRes) 1) >>= uncurry analyseMean
       times <- createIO (k+1) (const getTime)
       return (tailU . filterU (>=0) . zipWithU (-) (tailU times) $ times,
               lengthU times)
-    cost timeLimit = doIO $ do
+    cost timeLimit = liftIO $ do
       let timeClock k = time_ (replicateM_ k getTime)
       timeClock 1
       (_ :*: iters :*: elapsed) <- runForAtLeast 0.01 10000 timeClock

File Criterion/IO.hs

 import Control.Monad (when)
 import Control.Monad.Trans (liftIO)
 import Criterion.Config (Config, Verbosity(..), cfgSummaryFile, cfgVerbosity, fromLJ)
-import Criterion.Monad (ConfigM, getConfig, getConfigItem, doIO)
+import Criterion.Monad (ConfigM, getConfig, getConfigItem)
 import Data.Monoid (getLast)
 import System.IO (Handle, stderr, stdout)
 import qualified Text.Printf (HPrintfType, hPrintf)
 summary msg
   = do sumOpt <- getConfigItem (getLast . cfgSummaryFile)
        case sumOpt of
-         Just fn -> doIO $ appendFile fn msg
+         Just fn -> liftIO $ appendFile fn msg
          Nothing -> return ()
 

File Criterion/Main.hs

     ) where
 
 import Control.Monad (MonadPlus(..))
+import Control.Monad.Trans (liftIO)
 import Criterion (runAndAnalyse)
 import Criterion.Config
 import Criterion.Environment (measureEnvironment)
 import Criterion.IO (note, printError)
 import Criterion.MultiMap (singleton)
-import Criterion.Monad (doIO, withConfig)
+import Criterion.Monad (withConfig)
 import Criterion.Types (Benchmarkable(..), Benchmark(..), B(..), bench,
                         benchNames, bgroup)
 import Data.List (isPrefixOf, sort)
       mapM_ (note "  %s\n") (sort $ concatMap benchNames bs)
     else do
       case getLast $ cfgSummaryFile cfg of
-        Just fn -> doIO $ writeFile fn "Name,Mean,MeanLB,MeanUB,Stddev,StddevLB,StddevUB\n"
+        Just fn -> liftIO $ writeFile fn "Name,Mean,MeanLB,MeanUB,Stddev,StddevLB,StddevUB\n"
         Nothing -> return ()
       env <- measureEnvironment
       let shouldRun b = null args || any (`isPrefixOf` b) args

File Criterion/Monad.hs

+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 -- |
 -- Module      : Criterion.Monad
 -- Copyright   : (c) Neil Brown 2009
 -- Stability   : experimental
 -- Portability : GHC
 --
-module Criterion.Monad (ConfigM, getConfig, getConfigItem, doIO, withConfig) where
+-- The environment in which most criterion code executes.
+module Criterion.Monad
+    (
+      ConfigM
+    , getConfig
+    , getConfigItem
+    , withConfig
+    ) where
 
-import Control.Monad.Reader (ReaderT, ask, runReaderT)
-import Control.Monad.Trans (lift)
+import Control.Monad.Reader (MonadReader, ReaderT, ask, runReaderT)
+import Control.Monad.Trans (MonadIO)
 import Criterion.Config (Config)
 
-type ConfigM = ReaderT Config IO
+-- | The monad in which most criterion code executes.
+newtype ConfigM a = ConfigM {
+      runConfigM :: ReaderT Config IO a
+    } deriving (Functor, Monad, MonadReader Config, MonadIO)
 
 getConfig :: ConfigM Config
 getConfig = ask
 getConfigItem :: (Config -> a) -> ConfigM a
 getConfigItem f = f `fmap` getConfig
 
-doIO :: IO a -> ConfigM a
-doIO = lift
-
 withConfig :: Config -> ConfigM a -> IO a
-withConfig = flip runReaderT
+withConfig = flip (runReaderT . runConfigM)

File Criterion/Plot.hs

     , plotWith
     ) where
 
+import Control.Monad.Trans (liftIO)
 import Criterion.Config
-import Criterion.Monad (ConfigM, doIO, getConfigItem)
+import Criterion.Monad (ConfigM, getConfigItem)
 import Data.Array.Vector
 import Data.Char (isSpace, toLower)
 import Data.Foldable (forM_)
 
 plotWith :: Plot -> (PlotOutput -> IO ()) -> ConfigM ()
 plotWith p plot = getConfigItem (M.lookup p . cfgPlot)
-                    >>= maybe (return ()) (flip forM_ (doIO . plot))
+                    >>= maybe (return ()) (liftIO . flip forM_ plot)
 
 -- | Plot timing data.
 plotTiming :: PlotOutput        -- ^ The kind of output desired.