atl-15310.92: Control/Arrow/Abort.hs

module Control.Arrow.Abort (module Control.Arrow.Abort.Class, AbortT (..), runAbortT) where

import Prelude hiding ((.), id);

import Control.Monad;
import Control.Category;
import Control.Arrow;
import Control.Arrow.Trans;
import Control.Arrow.Abort.Class;

newtype AbortT v r a b = AbortT { unwrapAbortT :: r a (Either v b) };

runAbortT :: Arrow r => AbortT v r a v -> r a v;
runAbortT = (>>> arr (either id id)) . unwrapAbortT;

instance ArrowTrans (AbortT v) where {
  lift = AbortT . (>>> arr Right);
  tmap f = AbortT . f . unwrapAbortT;
};

instance (ArrowChoice r) => Category (AbortT v r) where {
  id = AbortT (arr Right);
  AbortT f . AbortT g = AbortT (right f . g >>> arr join);
};

instance (ArrowChoice r) => Arrow (AbortT v r) where {
  arr = AbortT . arr . liftM Right;
  first  = AbortT . (>>> arr (uncurry (liftM2 (,)))) . (*** arr Right) . unwrapAbortT;
  second = AbortT . (>>> arr (uncurry (liftM2 (,)))) . (arr Right ***) . unwrapAbortT;
};

instance (ArrowChoice r) => ArrowAbort v (AbortT v r) where {
  abort = AbortT $ arr Left;
};

instance (ArrowChoice r, ArrowTrans xT, Arrow (xT (AbortT v r))) => ArrowAbort v (xT (AbortT v r)) where {
  abort = lift abort;
};