Try to generalize `newtype LogAction m msg = LogAction {run:: msg -> m ()}` from `co-log` to Arrows

ArrowLogAction.hs

{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE QuantifiedConstraints #-}

module ArrowLogAction where

import Control.Arrow
import Data.Functor.Contravariant
import Data.Functor.Contravariant.Divisible
import Data.Void


newtype LogActionA arr msg = LogActionA {unLogAction :: arr msg ()}


-- There are nontrivial instances of Arrow and Plus that are not an instance of ArrowPlus
-- After all, the third type parameter is just unit, that is a rather easy type to work with

-- requires associativity law
class Plus arrow where
    (<++>) :: arrow a () -> arrow a () -> arrow a ()

instance (ArrowPlus arr) => Plus arr where
    (<++>) = (<+>)

instance Plus (->) where
    (<++>) :: (a -> ()) -> (a -> ()) -> a -> ()
    f <++> g = f <> g

-- Notice that for a `Kleisli m` to be an instance of `ArrowPlus` we need a constraint `MonadPlus m`
-- Here `Applicative m` suffices
instance (Applicative m) => Plus (Kleisli m) where
    -- (<++>) :: (a -> m ()) -> (a -> m ()) -> a -> m ()
    (Kleisli f) <++> (Kleisli g) = Kleisli $ \a -> f a *> g a


instance Plus arr => Semigroup (LogActionA arr msg) where
    LogActionA l <> LogActionA r = LogActionA $ l <++> r

-- Plus is only required to recover the underlying Semigroup
instance (Arrow arrow, Plus arrow) => Monoid (LogActionA arrow msg) where
    mempty = LogActionA $ arr mempty
    -- or
    -- mempty = LogActionA $ arr $ const ()

    -- or if we require ArrowPlus
    -- mempty = LogAction zeroArrow

-- we get this for free
instance Arrow arrow => Contravariant (LogActionA arrow) where
    contramap :: (a -> b) -> LogActionA arrow b -> LogActionA arrow a
    contramap fn (LogActionA action) = LogActionA $ fn ^>> action

-- also for free
cmapA :: Arrow arrow => arrow a b -> LogActionA arrow b -> LogActionA arrow a
cmapA afn (LogActionA action) = LogActionA $ afn >>> action

-- Arrow and Plus give us a Monoid and a Contravariant instance among other things
instance (Arrow arrow, Plus arrow) => Divisible (LogActionA arrow) where
-- even though I want
-- instance (Contravariant (LogActionA arrow), forall a. Monoid (LogActionA arrow a)) => Divisible (LogActionA arrow) where

    divide :: (a -> (b, c)) -> LogActionA arrow b -> LogActionA arrow c -> LogActionA arrow a
    divide fn actionB actionC = ((fst . fn) >$< actionB) <> ((snd . fn) >$< actionC)
    -- or if we expand the definitions
    -- divide fn (LogActionA b) (LogActionA c) = LogActionA $ (arr (fst . fn) >>> b) <++> (arr (snd . fn) >>> c)

    conquer :: LogActionA arrow a
    conquer = mempty

instance (Divisible (LogActionA arrow), ArrowChoice arrow) => Decidable (LogActionA arrow) where
    lose :: (a -> Void) -> LogActionA arrow a
    lose f = LogActionA $ arr (absurd . f)
    -- lose f = LogAction $ arr $ const () -- this compiles, too

    choose :: (a -> Either b c) -> LogActionA arrow b -> LogActionA arrow c -> LogActionA arrow a
    choose f (LogActionA b) (LogActionA c) = LogActionA $ f ^>> (b ||| c)