gauge 0.1.2 → 0.1.3

raw patch · 10 files changed

+112/−161 lines, 10 filesdep −foundationPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: foundation

API changes (from Hackage documentation)

Files

• Gauge/Analysis.hs +48/−48
• Gauge/IO/Printf.hs +3/−5
• Gauge/Internal.hs +9/−12
• Gauge/Main.hs +2/−3
• Gauge/Monad.hs +10/−9
• Gauge/Monad/ExceptT.hs +0/−56
• Gauge/Monad/Internal.hs +32/−20
• changelog.md +4/−0
• gauge.cabal +1/−4
• tests/Cleanup.hs +3/−4

@@ -36,12 +36,9 @@  import Control.Arrow (second) import Control.Monad (unless, when)-import Foundation.Monad.Reader-import Foundation.Monad import Gauge.IO.Printf (note, prolix) import Gauge.Measurement (secs, threshold)-import Gauge.Monad (Gauge, getGen, getOverhead)-import Gauge.Monad.ExceptT+import Gauge.Monad (Gauge, getGen, getOverhead, askConfig, gaugeIO) import Gauge.Types import Data.Int (Int64) import Data.Maybe (fromJust)@@ -142,10 +139,10 @@ analyseSample :: Int            -- ^ Experiment number.               -> String         -- ^ Experiment name.               -> V.Vector Measured -- ^ Sample data.-              -> ExceptT String Gauge Report+              -> Gauge (Either String Report) analyseSample i name meas = do-  Config{..} <- ask-  overhead <- lift getOverhead+  Config{..} <- askConfig+  overhead <- getOverhead   let ests      = [Mean,StdDev]       -- The use of filter here throws away very-low-quality       -- measurements when bootstrapping the mean and standard@@ -157,32 +154,34 @@       fixTime m = m { measTime = measTime m - overhead / 2 }       n         = G.length meas       s         = G.length stime-  _ <- lift $ prolix "bootstrapping with %d of %d samples (%d%%)\n"-              s n ((s * 100) `quot` n)-  gen <- lift getGen-  rs <- mapM (\(ps,r) -> regress gen ps r meas) $-        ((["iters"],"time"):regressions)-  resamps <- liftIO $ resample gen ests resamples stime-  let [estMean,estStdDev] = B.bootstrapBCA confInterval stime resamps-      ov = outlierVariance estMean estStdDev (fromIntegral n)-      an = SampleAnalysis {-               anRegress    = rs-             , anOverhead   = overhead-             , anMean       = estMean-             , anStdDev     = estStdDev-             , anOutlierVar = ov-             }-  return Report {-      reportNumber   = i-    , reportName     = name-    , reportKeys     = measureKeys-    , reportMeasured = meas-    , reportAnalysis = an-    , reportOutliers = classifyOutliers stime-    , reportKDEs     = [uncurry (KDE "time") (kde 128 stime)]-    }+  _ <- prolix "bootstrapping with %d of %d samples (%d%%)\n" s n ((s * 100) `quot` n) +  gen <- getGen+  ers <- (sequence <$>) . mapM (\(ps,r) -> regress gen ps r meas) $ ((["iters"],"time"):regressions)+  case ers of+    Left err -> pure $ Left err+    Right rs -> do+      resamps <- gaugeIO $ resample gen ests resamples stime+      let [estMean,estStdDev] = B.bootstrapBCA confInterval stime resamps+          ov = outlierVariance estMean estStdDev (fromIntegral n)+          an = SampleAnalysis+                 { anRegress    = rs+                 , anOverhead   = overhead+                 , anMean       = estMean+                 , anStdDev     = estStdDev+                 , anOutlierVar = ov+                 }+      return $ Right $ Report+        { reportNumber   = i+        , reportName     = name+        , reportKeys     = measureKeys+        , reportMeasured = meas+        , reportAnalysis = an+        , reportOutliers = classifyOutliers stime+        , reportKDEs     = [uncurry (KDE "time") (kde 128 stime)]+        } + -- | Regress the given predictors against the responder. -- -- Errors may be returned under various circumstances, such as invalid@@ -193,23 +192,24 @@         -> [String]             -- ^ Predictor names.         -> String               -- ^ Responder name.         -> V.Vector Measured-        -> ExceptT String Gauge Regression-regress gen predNames respName meas = do-  when (G.null meas) $-    mFail "no measurements"-  accs <- ExceptT . return $ validateAccessors predNames respName-  let unmeasured = [n | (n, Nothing) <- map (second ($ G.head meas)) accs]-  unless (null unmeasured) $-    mFail $ "no data available for " ++ renderNames unmeasured-  let (r:ps)      = map ((`measure` meas) . (fromJust .) . snd) accs-  Config{..} <- ask-  (coeffs,r2) <- liftIO $-                 bootstrapRegress gen resamples confInterval olsRegress ps r-  return Regression {-      regResponder = respName-    , regCoeffs    = Map.fromList (zip (predNames ++ ["y"]) (G.toList coeffs))-    , regRSquare   = r2-    }+        -> Gauge (Either String Regression)+regress gen predNames respName meas+    | G.null meas = pure $ Left "no measurements"+    | otherwise   = case validateAccessors predNames respName of+        Left err   -> pure $ Left err+        Right accs -> do+            let unmeasured = [n | (n, Nothing) <- map (second ($ G.head meas)) accs]+            if not (null unmeasured)+                then pure $ Left $ "no data available for " ++ renderNames unmeasured+                else do+                    let (r:ps) = map ((`measure` meas) . (fromJust .) . snd) accs+                    Config{..} <- askConfig+                    (coeffs,r2) <- gaugeIO $ bootstrapRegress gen resamples confInterval olsRegress ps r+                    pure $ Right $ Regression+                        { regResponder = respName+                        , regCoeffs    = Map.fromList (zip (predNames ++ ["y"]) (G.toList coeffs))+                        , regRSquare   = r2+                        }  singleton :: [a] -> Bool singleton [_] = True

@@ -20,9 +20,7 @@     ) where  import Control.Monad (when)-import Foundation.Monad.Reader (ask)-import Foundation.Monad (liftIO)-import Gauge.Monad (Gauge)+import Gauge.Monad (Gauge, askConfig, gaugeIO) import Gauge.Types (Config(verbosity), Verbosity(..)) import System.IO (Handle, hFlush, stderr, stdout) import Text.Printf (PrintfArg)@@ -43,8 +41,8 @@  instance CritHPrintfType (Gauge a) where   chPrintfImpl check (PrintfCont final _)-    = do x <- ask-         when (check x) (liftIO (final >> hFlush stderr >> hFlush stdout))+    = do x <- askConfig+         when (check x) (gaugeIO (final >> hFlush stderr >> hFlush stdout))          return undefined  instance CritHPrintfType (IO a) where

@@ -20,14 +20,11 @@ import Control.DeepSeq (rnf) import Control.Exception (evaluate) import Control.Monad (foldM, forM_, void, when)-import Foundation.Monad-import Foundation.Monad.Reader (ask) import Data.Int (Int64) import Gauge.Analysis (analyseSample, noteOutliers) import Gauge.IO.Printf (note, printError, prolix, rewindClearLine) import Gauge.Measurement (runBenchmark, runBenchmarkable_, secs)-import Gauge.Monad (Gauge)-import Gauge.Monad.ExceptT+import Gauge.Monad (Gauge, finallyGauge, askConfig, gaugeIO) import Gauge.Types hiding (measure) import qualified Data.Map as Map import qualified Data.Vector as V@@ -38,8 +35,8 @@ -- | Run a single benchmark. runOne :: Int -> String -> Benchmarkable -> Gauge DataRecord runOne i desc bm = do-  Config{..} <- ask-  (meas,timeTaken) <- liftIO $ runBenchmark bm timeLimit+  Config{..} <- askConfig+  (meas,timeTaken) <- gaugeIO $ runBenchmark bm timeLimit   when (timeTaken > timeLimit * 1.25) .     void $ prolix "measurement took %s\n" (secs timeTaken)   return (Measurement i desc meas)@@ -47,9 +44,9 @@ -- | Analyse a single benchmark. analyseOne :: Int -> String -> V.Vector Measured -> Gauge DataRecord analyseOne i desc meas = do-  Config{..} <- ask+  Config{..} <- askConfig   _ <- prolix "analysing with %d resamples\n" resamples-  erp <- runExceptT $ analyseSample i desc meas+  erp <- analyseSample i desc meas   case erp of     Left err -> printError "*** Error: %s\n" err     Right rpt@Report{..} -> do@@ -130,7 +127,7 @@   --liftIO $ hPutStr handle $ "[ \"" ++ headerRoot ++ "\", " ++   --                           "\"" ++ critVersion ++ "\", [ " -  liftIO $ hSetBuffering stdout NoBuffering+  gaugeIO $ hSetBuffering stdout NoBuffering   for select bs $ \idx desc bm -> do     _ <- note "benchmarking %s" desc     Analysed _ <- runAndAnalyseOne idx desc bm@@ -172,7 +169,7 @@ runFixedIters iters select bs =   for select bs $ \_idx desc bm -> do     _ <- note "benchmarking %s\r" desc-    liftIO $ runBenchmarkable_ bm iters+    gaugeIO $ runBenchmarkable_ bm iters  -- | Iterate over benchmarks. for :: (String -> Bool)@@ -183,11 +180,11 @@   where     go !idx (pfx, Environment mkenv cleanenv mkbench)       | shouldRun pfx mkbench = do-        e <- liftIO $ do+        e <- gaugeIO $ do           ee <- mkenv           evaluate (rnf ee)           return ee-        go idx (pfx, mkbench e) `finally` liftIO (cleanenv e)+        go idx (pfx, mkbench e) `finallyGauge` gaugeIO (cleanenv e)       | otherwise = return idx     go idx (pfx, Benchmark desc b)       | select desc' = do handle idx desc' b; return $! idx + 1

@@ -54,12 +54,11 @@     ) where  import Control.Monad (unless)-import Foundation.Monad import Gauge.IO.Printf (printError) import Gauge.Internal (runAndAnalyse, runFixedIters) import Gauge.Main.Options (defaultConfig, versionInfo, parseWith, describe) import Gauge.Measurement (initializeTime)-import Gauge.Monad (withConfig)+import Gauge.Monad (withConfig, gaugeIO) import Gauge.Types import Data.Char (toLower) import Data.List (isInfixOf, isPrefixOf, sort)@@ -158,7 +157,7 @@                 withConfig cfg $ do                     --writeCsv ("Name","Mean","MeanLB","MeanUB","Stddev","StddevLB",                     --          "StddevUB")-                    liftIO initializeTime+                    gaugeIO initializeTime                     runAndAnalyse shouldRun bsgroup   where bsgroup = BenchGroup "" bs 

@@ -13,16 +13,17 @@ module Gauge.Monad     (       Gauge+    , askConfig+    , gaugeIO     , withConfig     , getGen     , getOverhead+    , finallyGauge     ) where -import Foundation.Monad-import Foundation.Monad.Reader import Control.Monad (when) import Gauge.Measurement (measure, runBenchmark, secs)-import Gauge.Monad.Internal (Gauge(..), Crit(..))+import Gauge.Monad.Internal (Gauge(..), Crit(..), finallyGauge, askConfig, askCrit, gaugeIO) import Gauge.Types hiding (measure) import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Statistics.Regression (olsRegress)@@ -31,10 +32,10 @@  -- | Run a 'Gauge' action with the given 'Config'. withConfig :: Config -> Gauge a -> IO a-withConfig cfg (Gauge act) = do+withConfig cfg act = do   g <- newIORef Nothing   o <- newIORef Nothing-  runReaderT act (Crit cfg g o)+  runGauge act (Crit cfg g o)  -- | Return a random number generator, creating one if necessary. --@@ -46,13 +47,13 @@ -- | Return an estimate of the measurement overhead. getOverhead :: Gauge Double getOverhead = do-  verbose <- ((== Verbose) . verbosity) <$> ask+  verbose <- ((== Verbose) . verbosity) <$> askConfig   memoise overhead $ do     (meas,_) <- runBenchmark (whnfIO $ measure (whnfIO $ return ()) 1) 1     let metric get = G.convert . G.map get $ meas     let o = G.head . fst $             olsRegress [metric (fromIntegral . measIters)] (metric measTime)-    when verbose . liftIO $+    when verbose $       putStrLn $ "measurement overhead " ++ secs o     return o @@ -64,8 +65,8 @@ -- multiple times safely. memoise :: (Crit -> IORef (Maybe a)) -> IO a -> Gauge a memoise ref generate = do-  r <- Gauge (ref <$> ask)-  liftIO $ do+  r <- ref <$> askCrit+  gaugeIO $ do     mv <- readIORef r     case mv of       Just rv -> return rv

@@ -1,56 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-module Gauge.Monad.ExceptT-    ( ExceptT(..)-    , finally-    -- , try-    ) where--import Foundation.Monad-import Foundation.Monad.Reader--newtype ExceptT e m a = ExceptT { runExceptT :: m (Either e a) }--instance (Functor m) => Functor (ExceptT e m) where-    fmap f = ExceptT . fmap (fmap f) . runExceptT--instance (Functor m, Monad m) => Applicative (ExceptT e m) where-    pure a = ExceptT $ return (Right a)-    ExceptT f <*> ExceptT v = ExceptT $ do-        mf <- f-        case mf of-            Left e -> return (Left e)-            Right k -> do-                mv <- v-                case mv of-                    Left e -> return (Left e)-                    Right x -> return (Right (k x))--instance Monad m => MonadFailure (ExceptT e m) where-    type Failure (ExceptT e m) = e-    mFail = ExceptT . pure . Left--instance (Monad m) => Monad (ExceptT e m) where-    return a = ExceptT $ return (Right a)-    m >>= k = ExceptT $ do-        a <- runExceptT m-        case a of-            Left e -> return (Left e)-            Right x -> runExceptT (k x)-    fail = ExceptT . fail--instance MonadReader m => MonadReader (ExceptT e m) where-    type ReaderContext (ExceptT e m) = ReaderContext m-    ask = ExceptT (Right <$> ask)--instance MonadTrans (ExceptT e) where-    lift f = ExceptT (Right <$> f)--instance MonadIO m => MonadIO (ExceptT e m) where-    liftIO f = ExceptT (Right <$> liftIO f)--finally :: MonadBracket m => m a -> m b -> m a-finally f g = generalBracket (pure ()) (\() a -> g >> pure a) (\() _ -> g) (const f)----try :: (MonadCatch, Exception e) => m a -> m (Either e a)---try a = catch (a >>= \ v -> return (Right v)) (\e -> return (Left e))-

@@ -15,38 +15,50 @@ module Gauge.Monad.Internal     (       Gauge(..)+    , gaugeIO+    , finallyGauge     , Crit(..)+    , askConfig+    , askCrit     ) where  -- Temporary: to support pre-AMP GHC 7.8.4: import Control.Applicative+import Control.Exception+import Control.Monad (ap) -import Foundation.Monad-import Foundation.Monad.Reader import Gauge.Types (Config) import Data.IORef (IORef) import System.Random.MWC (GenIO) import Prelude -data Crit = Crit {-    config   :: !Config-  , gen      :: !(IORef (Maybe GenIO))-  , overhead :: !(IORef (Maybe Double))-  }+data Crit = Crit+    { config   :: !Config+    , gen      :: !(IORef (Maybe GenIO))+    , overhead :: !(IORef (Maybe Double))+    }  -- | The monad in which most gauge code executes.-newtype Gauge a = Gauge {-      runGauge :: ReaderT Crit IO a-    } deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch) -- , MonadBracket)+newtype Gauge a = Gauge { runGauge :: Crit -> IO a } -instance MonadReader Gauge where-    type ReaderContext Gauge = Config-    ask = config `fmap` Gauge ask+instance Functor Gauge where+    fmap f a = Gauge $ \r -> f <$> runGauge a r+instance Applicative Gauge where+    pure = Gauge . const . pure+    (<*>) = ap+instance Monad Gauge where+    return    = pure+    ma >>= mb = Gauge $ \r -> runGauge ma r >>= \a -> runGauge (mb a) r -instance MonadBracket Gauge where-    generalBracket acq cleanup cleanupExcept innerAction = Gauge $ do-        c <- ask-        lift $ generalBracket (runReaderT (runGauge acq) c)-                              (\a b -> runReaderT (runGauge (cleanup a b)) c)-                              (\a exn -> runReaderT (runGauge (cleanupExcept a exn)) c)-                              (\a -> runReaderT (runGauge (innerAction a)) c)+askConfig :: Gauge Config+askConfig = Gauge (pure . config)++askCrit :: Gauge Crit+askCrit = Gauge pure++gaugeIO :: IO a -> Gauge a+gaugeIO = Gauge . const++finallyGauge :: Gauge a -> Gauge b -> Gauge a+finallyGauge f g = Gauge $ \crit -> do+    finally (runGauge f crit) (runGauge g crit)

@@ -1,3 +1,7 @@+# 0.1.3++* Simplify monad handling, remove foundation as dependency+ # 0.1.2  * condensed display with `--small`

@@ -1,5 +1,5 @@ name:           gauge-version:        0.1.2+version:        0.1.3 synopsis:       small framework for performance measurement and analysis license:        BSD3 license-file:   LICENSE@@ -36,7 +36,6 @@     Gauge.IO.Printf     Gauge.Internal     Gauge.Monad.Internal-    Gauge.Monad.ExceptT     Gauge.Main.Options     Gauge.Measurement     Gauge.Monad@@ -79,7 +78,6 @@   build-depends:     base >= 4.5 && < 5,     basement,-    foundation,     code-page,     containers,     deepseq >= 1.1.0.0,@@ -124,7 +122,6 @@     gauge,     deepseq,     directory,-    foundation,     tasty,     tasty-hunit 

@@ -8,9 +8,8 @@ import Gauge.Types (Config(..), Verbosity(Quiet)) import Control.Applicative (pure) import Control.DeepSeq (NFData(..))-import Control.Exception (Exception, try)+import Control.Exception (Exception, try, throwIO) import Control.Monad (when)-import Foundation.Monad import Data.Typeable (Typeable) import System.Directory (doesFileExist, removeFile) import System.Environment (withArgs)@@ -53,8 +52,8 @@     result <- runTest . withEnvClean name alloc clean $ \hnd -> do         result <- hFileSize hnd >>= BS.hGet hnd . fromIntegral         resetHandle hnd-        when (result /= testData) $ throw WrongData-        when shouldFail $ throw ShouldThrow+        when (result /= testData) $ throwIO WrongData+        when shouldFail $ throwIO ShouldThrow      case result of         Left WrongData -> failTest "Incorrect result read from file"