Tracer using `Arrow` categories

Control.Cateogory.Tracer.hs

{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

import Prelude hiding (filter, (.))

import Control.Arrow
import Control.Category

data TracerC c a where
     Tracer :: Arrow c => c a () -> TracerC c a

type Tracer m a = TracerC (Kleisli m) a

withTracerC :: forall c a.
               ArrowApply c
            => TracerC c a
            -> a
            -> c () ()
withTracerC (Tracer tr) a = apply . f
  where
    apply :: c (c a (), a) ()
    apply = app

    f :: c () (c a (), a)
    f = arr (const tr) &&& arr (const a)


withTracer :: Monad m
           => Tracer m a
           -> a
           -> m ()
withTracer tr a = case withTracerC tr a of
  Kleisli f -> f ()

contramap :: (a -> b)
          -> TracerC c b
          -> TracerC c a
contramap ab tr@Tracer{} = contramapM (arr ab) tr

contramapM :: c a b
           -> TracerC c b
           -> TracerC c a
contramapM cab (Tracer tr) = Tracer (tr . cab)

stdoutTracer :: Tracer IO String
stdoutTracer = Tracer (Kleisli putStrLn)

showTracing :: Show a
            => TracerC c String
            -> TracerC c a
showTracing tr@Tracer{} = contramap show tr

nullTracer :: Arrow c => TracerC c a
nullTracer = Tracer (arr $ const ())

select :: ArrowChoice c
       => c x (Either y z)
       -> TracerC c y
       -> TracerC c z
       -> TracerC c x
select choice (Tracer y) (Tracer z) = Tracer $ (y ||| z) . choice

condTracing :: ArrowChoice c
            => (a -> Bool)
            -> TracerC c a
            -> TracerC c a
condTracing p tr = select arrowP nullTracer tr
  where
    arrowP = arr $ \a -> if p a then Right a else Left ()

prod  :: c x y
      -> c x z
      -> TracerC c (y, z)
      -> TracerC c x
prod f g tr@Tracer{} = contramapM (f &&& g) tr

natTracer :: Arrow d
          => (forall x y. c x y -> d x y)
          -> TracerC c a
          -> TracerC d a
natTracer nat (Tracer tr) = Tracer (nat tr)

instance ArrowPlus c => Semigroup (TracerC c a) where
    Tracer a <> Tracer a' = Tracer $ a <+> a'

instance ArrowPlus c => Monoid (TracerC c a) where
    mempty = Tracer zeroArrow