content: {-|
  Module      : Control.TracerA.Arrow
  Copyright   : (c) Alexander Vieth, 2019
  Licence     : Apache-2.0
  Maintainer  : aovieth@gmail.com
  -}
  
  {-# LANGUAGE GADTs #-}
  {-# LANGUAGE RankNTypes #-}
  
  module Control.Tracer.Arrow
    ( TracerA (..)
    , runTracerA
    , compute
    , emit
    , effect
    , squelch
    , nat
    ) where
  
  import           Prelude hiding (id, (.))
  
  import           Control.Arrow
  import           Control.Category
  
  -- | Formal representation of a tracer arrow as a Kleisli arrow over some
  -- monad, but tagged so that we know whether it has any effects which will emit
  -- a trace.
  data TracerA m a b where
    -- | An emitting part, followed by a non-emitting part.
    -- The non-emitting part is there so that later emitting parts can be
    -- tacked-on later.
    Emitting   :: Kleisli m a x -> Kleisli m x b -> TracerA m a b
    -- | No emitting. There may be side-effects, but they are assumed to be
    -- benign and will be discarded by 'runTracerA'.
    Squelching :: Kleisli m a b                  -> TracerA m a b
  
  -- | The resulting Kleisli arrow includes all of the effects required to do
  -- the emitting part.
  {-# INLINE runTracerA #-}
  runTracerA :: Monad m => TracerA m a () -> Kleisli m a ()
  runTracerA (Emitting emits _noEmits) = emits >>> arr (const ())
  runTracerA (Squelching     _       ) =           arr (const ())
  
  -- | Ignore the input and do not emit. The name is intended to lead to clear
  -- and suggestive arrow expressions.
  squelch :: Applicative m => TracerA m a ()
  squelch = compute (const ())
  
  -- | Do an emitting effect. Contrast with 'effect' which does not make the
  -- tracer an emitting tracer.
  {-# INLINE emit #-}
  emit :: Applicative m => (a -> m ()) -> TracerA m a ()
  emit f = Emitting (Kleisli f) (Kleisli (const (pure ())))
  
  -- | Do a non-emitting effect. This effect will only be run if some part of
  -- the tracer downstream emits (see 'emit').
  {-# INLINE effect #-}
  effect :: (a -> m b) -> TracerA m a b
  effect = Squelching . Kleisli
  
  -- | Pure computation in a tracer: no side effects or emits.
  {-# INLINE compute #-}
  compute :: Applicative m => (a -> b) -> TracerA m a b
  compute f = effect (pure . f)
  
  instance Monad m => Category (TracerA m) where
    id = compute id
    Squelching l     . Squelching r     = Squelching (l  . r)
    -- Crucial: the squelching parts stay together. Could also have written
    --                                  = Emitting   (rp . re)      l
    -- but that would miss opportunities to skip doing work.
    Squelching l     . Emitting   re rp = Emitting   re             (l . rp)
    -- Contrast with the above clause: here the emitting part comes _after_ the
    -- squelching part, so the squelching part becomes part of the emitting part.
    Emitting   le lp . Squelching r     = Emitting   (le . r)       lp
    Emitting   le lp . Emitting   re rp = Emitting   (le . rp . re) lp
  
  instance Monad m => Arrow (TracerA m) where
    arr = compute
    Squelching l     *** Squelching r     = Squelching (l  *** r )
    Squelching l     *** Emitting   re rp = Emitting   (second re) (l  *** rp)
    Emitting   le lp *** Squelching r     = Emitting   (first  le) (lp *** r )
    Emitting   le lp *** Emitting   re rp = Emitting   (le *** re) (lp *** rp)
  
  instance Monad m => ArrowChoice (TracerA m) where
    Squelching l     +++ Squelching r     = Squelching (l +++ r)
    Squelching l     +++ Emitting   re rp = Emitting   (id +++ re) (l  +++ rp)
    Emitting   le lp +++ Squelching r     = Emitting   (le +++ id) (lp +++ r )
    Emitting   le lp +++ Emitting   re rp = Emitting   (le +++ re) (lp +++ rp)
  
  -- | Use a natural transformation to change the underlying monad.
  nat :: (forall x . m x -> n x) -> TracerA m a b -> TracerA n a b
  nat h (Squelching (Kleisli k))             = Squelching (Kleisli (h . k))
  nat h (Emitting   (Kleisli k) (Kleisli l)) = Emitting   (Kleisli (h . k)) (Kleisli (h . l))
  