monad-timing 0.1.0.0 → 0.1.0.1

raw patch · 3 files changed

+70/−32 lines, 3 filesdep +hspecdep +monad-timingdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: hspec, monad-timing

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• monad-timing.cabal +9/−1
• src/Control/Monad/Timing.hs +26/−31
• test/sanity.hs +35/−0

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                monad-timing-version:             0.1.0.0+version:             0.1.0.1 synopsis:            Monad transformer for recording timing events description:         Monad transformer for recording timing events homepage:            https://github.com/pikajude/monad-timing@@ -36,6 +36,14 @@   type:                exitcode-stdio-1.0   main-is:             hlint.hs   build-depends:       base, hlint+  hs-source-dirs:      test+  default-language:    Haskell2010+  ghc-options:         -w -threaded -rtsopts -with-rtsopts=-N++test-suite sanity+  type:                exitcode-stdio-1.0+  main-is:             sanity.hs+  build-depends:       base, containers, hspec, monad-timing, transformers   hs-source-dirs:      test   default-language:    Haskell2010   ghc-options:         -w -threaded -rtsopts -with-rtsopts=-N

@@ -13,7 +13,7 @@       MonadTiming(..), TimingTree, Tag,        -- * @TimingT@, general timing handler-      TimingT(..), runTimingT, execTimingT,+      TimingT(..), execTimingT, timingAll,        -- * @NoTimingT@, a no-timing handler       NoTimingT (..)@@ -46,32 +46,21 @@ type Tag = String  -- | A monad transformer that records timing events.------ Note that this module exports both '_runTimingT' and 'runTimingT'.------ * '_runTimingT' returns the timing events verbatim without sanitization.--- * 'runTimingT' combines trees with the same 'Tag' and tags the duration--- of the entire computation with the special tag @\<all\>@.-newtype TimingT m a = TimingT { _runTimingT :: m (a, [TimingTree]) }+newtype TimingT m a = TimingT {+    -- | Run the giving @TimingT@ computation, recording timing events.+    runTimingT :: m (a, [TimingTree]) } +-- | Wrap an entire @TimingT@ computation in a timing event.+timingAll :: MonadIO m => TimingT m a -> m (a, TimingTree)+timingAll = fmap (second head) . runTimingT . timeGroup "<all>"+ evalTimingT :: Functor f => TimingT f b -> f b-evalTimingT = fmap fst . _runTimingT+evalTimingT = fmap fst . runTimingT  -- | Run a @TimingT@ computation, discarding the result.-execTimingT :: MonadIO m => TimingT m b -> m TimingTree+execTimingT :: MonadIO m => TimingT m b -> m [TimingTree] execTimingT = fmap snd . runTimingT --- | Run the giving @TimingT@ computation, recording timing events.-runTimingT :: MonadIO m => TimingT m a -> m (a, TimingTree)-runTimingT = fmap (second (head . condenseTree)) . _runTimingT . timeGroup "<all>"--condenseTree :: [TimingTree] -> [TimingTree]-condenseTree = map (foldl collapseNodes emptyNode)-             . groupBy ((==) `on` (fst . rootLabel)) where-    collapseNodes (Node (_, x) sub) (Node (t, x1) sub2)-        = Node (t, x + x1) (condenseTree $ sub ++ sub2)-    emptyNode = Node ("", 0) []- liftTimingT :: Functor m => m a -> TimingT m a liftTimingT = TimingT . fmap (\ x -> (x, [])) @@ -85,13 +74,19 @@  instance Alternative m => Alternative (TimingT m) where     empty = liftTimingT empty-    a <|> b = TimingT $ _runTimingT a <|> _runTimingT b+    a <|> b = TimingT $ runTimingT a <|> runTimingT b  instance Monad m => Monad (TimingT m) where     TimingT a >>= f = TimingT $ do         (thing1, b) <- a-        (thing2, c) <- _runTimingT $ f thing1-        return (thing2, b ++ c)+        (thing2, c) <- runTimingT $ f thing1+        return (thing2, condenseTree $ b ++ c)+        where+            condenseTree = map (foldl collapseNodes emptyNode)+                         . groupBy ((==) `on` (fst . rootLabel)) where+                collapseNodes (Node (_, x) sub) (Node (t, x1) sub2)+                    = Node (t, x + x1) (condenseTree $ sub ++ sub2)+                emptyNode = Node ("", 0) []  instance MonadTrans TimingT where     lift = liftTimingT@@ -102,16 +97,16 @@ instance MonadPlus m => MonadPlus (TimingT m) where  instance MonadReader r m => MonadReader r (TimingT m) where-    local f m = TimingT $ local f $ _runTimingT m+    local f m = TimingT $ local f $ runTimingT m     ask = lift ask  instance MonadWriter w m => MonadWriter w (TimingT m) where     tell = lift . tell     listen m = TimingT $ do-        ~((a, b), c) <- listen (_runTimingT m)+        ~((a, b), c) <- listen (runTimingT m)         return ((a, c), b)     pass m = TimingT $ pass $ do-        ~((a, b), c) <- _runTimingT m+        ~((a, b), c) <- runTimingT m         return ((a, c), b)  instance MonadState s m => MonadState s (TimingT m) where@@ -127,17 +122,17 @@     throwM e = TimingT $ throwM e  instance MonadCatch m => MonadCatch (TimingT m) where-    TimingT a `catch` f = TimingT $ a `catch` (_runTimingT . f)+    TimingT a `catch` f = TimingT $ a `catch` (runTimingT . f)  instance MonadMask m => MonadMask (TimingT m) where-    mask a = TimingT $ mask $ \ u -> _runTimingT (a $ q u) where+    mask a = TimingT $ mask $ \ u -> runTimingT (a $ q u) where         q u (TimingT m) = TimingT (u m)-    uninterruptibleMask a = TimingT $ uninterruptibleMask $ \ u -> _runTimingT (a $ q u) where+    uninterruptibleMask a = TimingT $ uninterruptibleMask $ \ u -> runTimingT (a $ q u) where         q u (TimingT m) = TimingT (u m)  instance MonadError e m => MonadError e (TimingT m) where     throwError = TimingT . throwError-    TimingT a `catchError` f = TimingT $ a `catchError` (_runTimingT . f)+    TimingT a `catchError` f = TimingT $ a `catchError` (runTimingT . f)  instance MonadBase b m => MonadBase b (TimingT m) where     liftBase = lift . liftBase

@@ -0,0 +1,35 @@+module Main where++import Control.Concurrent+import Control.Exception      (PatternMatchFail (..), catch)+import Control.Monad.IO.Class+import Control.Monad.Timing+import Data.Tree+import Test.Hspec++main :: IO ()+main = hspec $ do+    describe "TimingT" $ do+        it "records timing" $ do+            (_, tree) <- runTimingT $+                timeGroup "foo" $ liftIO $ threadDelay 1000+            tree `shouldMatchPattern`+                (\ [ Node ("foo", x) [] ] -> x >= 0.001)++        it "condenses multiple groups into one" $ do+            (_, tree) <- runTimingT $ do+                timeGroup "foo" $ liftIO $ threadDelay 1000+                timeGroup "foo" $ liftIO $ threadDelay 2000+            tree `shouldMatchPattern`+                (\ [ Node ("foo", x) [] ] -> x >= 0.003)++        it "preserves subgroups" $ do+            (_, tree) <- runTimingT $ do+                timeGroup "foo" $ timeGroup "bar" $ liftIO $ threadDelay 1000+                timeGroup "foo" $ timeGroup "bar" $ liftIO $ threadDelay 2000+            tree `shouldMatchPattern`+                (\ [ Node ("foo", x) [ Node ("bar", y) [] ] ] -> x >= 0.003 && y >= 0.003)++shouldMatchPattern n f = catch+    (f n `shouldBe` True)+    (\ (PatternMatchFail s) -> expectationFailure $ "pattern did not match: " ++ show n)