contra-tracer 0.2.0.0 → 0.2.1.0

raw patch · 6 files changed

+173/−5 lines, 6 filesdep +contra-tracerPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: contra-tracer

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• README.md +1/−1
• contra-tracer.cabal +24/−1
• src/Control/Tracer.hs +47/−3
• src/Test/Control/Tracer/Properties.hs +56/−0
• test/Main.hs +38/−0

@@ -1,3 +1,10 @@+# 0.2.1.0++- `traceAll` and `traceTraversable` defined (https://github.com/avieth/contra-tracer/pull/9)+- `mkTracer`, `contramapM`, `traceMaybeM`, and `squelchUnlessM` defined (https://github.com/avieth/contra-tracer/pull/8)+- Re-export the `(>$<)` operator (https://github.com/avieth/contra-tracer/pull/5)+- Haddock and README fixes (https://github.com/avieth/contra-tracer/pull/4) (https://github.com/avieth/contra-tracer/pull/7)+ # 0.2.0.0  - Renamed `Control.Tracer.Arrow.Tracer` to `Control.Tracer.Arrow.TracerA`

@@ -29,7 +29,7 @@ -- Puts text to stdout. stdoutTracer :: Tracer IO Text --- A somain-specific event type.+-- A domain-specific event type. data Event = EventA | EventB Int  -- The log format for an Event.

@@ -1,5 +1,5 @@ name:                contra-tracer-version:             0.2.0.0+version:             0.2.1.0 synopsis:            Arrow and contravariant tracers description:         A simple interface for logging, tracing and monitoring license:             Apache-2.0@@ -25,3 +25,26 @@   build-depends:       base < 5   if impl(ghc < 8.5)     build-depends:     contravariant+  ghc-options:        -Wall+                      -Wincomplete-uni-patterns+                      -Wincomplete-record-updates+                      -Wpartial-fields+                      -Wredundant-constraints++test-suite contra-tracer-tests+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test, src+  main-is:             Main.hs+  other-modules:+      Test.Control.Tracer.Properties+      Control.Tracer+      Control.Tracer.Arrow+  default-language:    Haskell2010++  build-depends:+      base < 5+    , contra-tracer++  if impl(ghc < 8.5)+    build-depends:+      contravariant

@@ -45,7 +45,7 @@ > main = do >   textTacer <- traceToLogFile "log.txt" >   let eventTracer :: Tracer IO Event->       eventTracer = contramap eventToText tracer+>       eventTracer = contramap eventToText textTracer >   actionWithTrace eventTracer -} @@ -54,6 +54,7 @@  module Control.Tracer     ( Tracer (..)+    , mkTracer     , traceWith     , arrow     , use@@ -68,14 +69,22 @@     , natTracer     , Arrow.nat     , traceMaybe+    , traceMaybeM+    , traceAll+    , traceTraversable     , squelchUnless+    , squelchUnlessM     -- * Re-export of Contravariant     , Contravariant(..)+    , (>$<)+    , contramapM     ) where  import           Control.Arrow ((|||), (&&&), arr, runKleisli) import           Control.Category ((>>>))-import           Data.Functor.Contravariant (Contravariant (..))+import           Data.Bool (bool)+import           Data.Foldable (traverse_)+import           Data.Functor.Contravariant (Contravariant (..), (>$<)) import           Debug.Trace (traceM)  import qualified Control.Tracer.Arrow as Arrow@@ -174,6 +183,11 @@     mappend = (<>)     mempty  = nullTracer +-- | Make an emitting tracer from a callback.+--+mkTracer :: Applicative m => (a -> m ()) -> Tracer m a+mkTracer = Tracer . Arrow.emit+ {-# INLINE traceWith #-} -- | Run a tracer with a given input. traceWith :: Monad m => Tracer m a -> a -> m ()@@ -219,10 +233,30 @@   where   classify = arr (maybe (Left ()) Right . k) +-- | A monadic version of `traceMaybe`.+--+traceMaybeM :: Monad m => (a -> m (Maybe b)) -> Tracer m b -> Tracer m a+traceMaybeM k tr = Tracer $ classify >>> (Arrow.squelch ||| use tr)+  where+  classify = Arrow.effect (fmap (maybe (Left ()) Right) . k)+ -- | Uses 'traceMaybe' to give a tracer which emits only if a predicate is true. squelchUnless :: Monad m => (a -> Bool) -> Tracer m a -> Tracer m a-squelchUnless p = traceMaybe (\a -> if p a then Just a else Nothing)+squelchUnless p = traceMaybe (\a -> bool Nothing (Just a) (p a)) +-- | A monadic version of `squelchUnless`.+squelchUnlessM :: Monad m => (a -> m Bool) -> Tracer m a -> Tracer m a+squelchUnlessM p = traceMaybeM (\a -> bool Nothing (Just a) <$> p a)++traceTraversable :: (Monad m, Foldable t) => Tracer m a -> Tracer m (t a)+traceTraversable tracer@(Tracer tr) =+  case tr of+    Arrow.Squelching _ -> nullTracer+    _                  -> emit (traverse_ (traceWith tracer))++traceAll :: (Monad m, Foldable t) => (b -> t a) -> Tracer m a -> Tracer m b+traceAll f = contramap f . traceTraversable+ -- | Use a natural transformation to change the @m@ type. This is useful, for -- instance, to use concrete IO tracers in monad transformer stacks that have -- IO as their base.@@ -238,3 +272,13 @@ -- documentation in "Debug.Trace" for more details. debugTracer :: Applicative m => Tracer m String debugTracer = emit traceM++-- | A contravariant transformation of a tracer using a Kleisli arrow.+--+contramapM+  :: Monad m+  => (a -> m b)+  -- ^ Kleisli arrow which is evaluated only if a downstream tracer emits+  -> Tracer m b+  -> Tracer m a+contramapM f tracer = arrow (Arrow.effect f >>> use tracer)

@@ -0,0 +1,56 @@+{-|+Module      : Test.Control.Tracer.Properties+Description : Various essential properties for Tracer+Copyright   : (c) Alexander Vieth, 2019+Licence     : BSD3+Maintainer  : aovieth@gmail.com+Stability   : experimental+Portability : non-portable (GHC only)+-}++{-# LANGUAGE Arrows #-}++module Test.Control.Tracer.Properties where++import Control.Arrow+import Control.Tracer++-- | Does not force the @error "failure"@ used within it, as it's not needed.+--+-- @traceWith laziness_1 anything = pure ()@+laziness_1 :: Monad m => Tracer m a+laziness_1 = arrow $ proc _ -> do+  _ <- arr not -< error "failure"+  returnA -< ()++-- | Simple choice: if both of 2 alternatives do not emit, nothing is forced.+-- +-- @traceWith laziness_2 anything = pure ()@+laziness_2 :: Monad m => Tracer m a+laziness_2 = arrow $ arr (error "failure") >>> (use nullTracer ||| use nullTracer)++-- | Nested choice: even though the first choice _could_ emit, the second+-- choice can't, so nothing after the first choice is forced.+--+-- @traceWith laziness_3 anything = pure ()@+laziness_3 :: Monad m => Tracer m Bool+laziness_3 = arrow $ proc b ->+  if b+  then emit (const (pure ())) -< ()+  else do+    _ <- effect (error "failure") -< error "failure"+    _ <- use nullTracer ||| use nullTracer -< error "failure"+    returnA -< ()++-- | If the inner tracer is null, traversing should not force the structure.+--+-- @traceWith traceTraversable_laziness anything = pure ()@+traceTraversable_laziness :: Monad m => Tracer m [a]+traceTraversable_laziness = traceTraversable nullTracer++-- | If the inner tracer is null, mapping into a foldable should not+-- force the mapped structure.+--+-- @traceWith traceAll_laziness anything = pure ()@+traceAll_laziness :: Monad m => Tracer m Bool+traceAll_laziness = traceAll (\_ -> (error "failure" :: [()])) nullTracer

@@ -0,0 +1,38 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Main where++import Control.Exception (SomeException, try)+import Control.Tracer (traceWith)+import Test.Control.Tracer.Properties+  ( laziness_1+  , laziness_2+  , laziness_3+  , traceTraversable_laziness+  , traceAll_laziness)++assertNoException :: String -> IO a -> IO ()+assertNoException name action = do+  result <- try action+  case result of+    Left (e :: SomeException) ->+      error ("FAILED: " ++ name ++ "\n  unexpected exception: " ++ show e)+    Right _ ->+      putStrLn ("PASS: " ++ name)++main :: IO ()+main = do+  assertNoException "laziness_1" $+    traceWith laziness_1 (error "failure")++  assertNoException "laziness_2" $+    traceWith laziness_2 (error "failure")++  assertNoException "laziness_3" $+    traceWith laziness_3 False++  assertNoException "traceTraversable_laziness" $+    traceWith traceTraversable_laziness (error "failure")++  assertNoException "traceAll_laziness" $+    traceWith traceAll_laziness True