Commit b97f9a8d authored by Sven Keidel's avatar Sven Keidel

fix (***) and (&&&) implementations

parent 509fd75c
......@@ -10,7 +10,6 @@ module Control.Arrow.Transformer.Abstract.Except(ExceptT(..)) where
import Prelude hiding (id,lookup,(.),read,fail)
import Control.Applicative
import Control.Arrow
import Control.Arrow.Const
import Control.Arrow.Deduplicate
......@@ -22,6 +21,7 @@ import Control.Arrow.State
import Control.Arrow.Store as Store
import Control.Arrow.Except
import Control.Arrow.Fix
import Control.Arrow.Utils (duplicate)
import Control.Arrow.Abstract.Join
import Control.Category
......@@ -83,14 +83,14 @@ instance (ArrowChoice c, ArrowJoin c, Complete e) => Arrow (ExceptT e c) where
arr f = lift' (arr f)
first f = lift $ rmap strength1 (first (unlift f))
second f = lift $ rmap strength2 (second (unlift f))
f &&& g = lift $ rmap mstrength (unlift f &&& unlift g)
f *** g = lift $ rmap mstrength (unlift f *** unlift g)
f &&& g = lmap duplicate (f *** g)
f *** g = first f >>> second g
instance (Complete e, ArrowJoin c, ArrowChoice c) => ArrowChoice (ExceptT e c) where
left f = lift $ rmap strength1 (left (unlift f))
right f = lift $ rmap strength2 (right (unlift f))
f ||| g = lift $ unlift f ||| unlift g
f +++ g = lift $ rmap mstrength $ unlift f +++ unlift g
f +++ g = left f >>> right g
instance (Complete e, ArrowJoin c, ArrowApply c, ArrowChoice c) => ArrowApply (ExceptT e c) where
app = lift $ lmap (first unlift) app
......
......@@ -22,6 +22,7 @@ import Control.Arrow.Reader
import Control.Arrow.State
import Control.Arrow.Store as Store
import Control.Arrow.Except as Exc
import Control.Arrow.Utils(duplicate)
import Control.Arrow.Abstract.Join
import Control.Category
......@@ -60,14 +61,14 @@ instance (ArrowChoice c,Profunctor c) => Arrow (FailureT r c) where
arr f = lift' (arr f)
first f = lift $ rmap strength1 (first (unlift f))
second f = lift $ rmap strength2 (second (unlift f))
f &&& g = lift $ rmap mstrength (unlift f &&& unlift g)
f *** g = lift $ rmap mstrength (unlift f *** unlift g)
f &&& g = lmap duplicate (f *** g)
f *** g = first f >>> second g
instance (ArrowChoice c, Profunctor c) => ArrowChoice (FailureT r c) where
left f = lift $ rmap strength1 $ left (unlift f)
right f = lift $ rmap strength2 $ right (unlift f)
f ||| g = lift $ unlift f ||| unlift g
f +++ g = lift $ rmap mstrength (unlift f +++ unlift g)
f +++ g = left f >>> right g
instance (ArrowChoice c, Profunctor c, ArrowApply c) => ArrowApply (FailureT e c) where
app = lift $ lmap (first unlift) app
......
......@@ -15,6 +15,7 @@ import Control.Arrow.Trans
import Control.Arrow.State
import Control.Arrow.Reader
import Control.Arrow.Fix
import Control.Arrow.Utils(duplicate)
import Control.Arrow.Abstract.Terminating
import Control.Category
......@@ -52,14 +53,14 @@ instance (ArrowChoice c, Profunctor c) => Arrow (TerminatingT c) where
arr f = lift' (arr f)
first f = lift $ rmap strength1 (first (unlift f))
second f = lift $ rmap strength2 (second (unlift f))
f &&& g = lift $ rmap mstrength (unlift f &&& unlift g)
f *** g = lift $ rmap mstrength (unlift f *** unlift g)
f &&& g = lmap duplicate (f *** g)
f *** g = first f >>> second g
instance (ArrowChoice c, Profunctor c) => ArrowChoice (TerminatingT c) where
left f = lift $ rmap strength1 $ left (unlift f)
right f = lift $ rmap strength2 $ right (unlift f)
f ||| g = lift $ unlift f ||| unlift g
f +++ g = lift $ rmap mstrength (unlift f +++ unlift g)
f +++ g = left f >>> right g
instance (ArrowChoice c, Profunctor c, ArrowApply c) => ArrowApply (TerminatingT c) where
app = lift $ lmap (first unlift) app
......
......@@ -20,6 +20,7 @@ import Control.Arrow.Reader
import Control.Arrow.Store as Store
import Control.Arrow.State
import Control.Arrow.Except
import Control.Arrow.Utils
import Control.Category
import Data.Concrete.Error
......@@ -58,25 +59,27 @@ instance ArrowTrans (ExceptT e) where
unlift = runExceptT
instance ArrowLift (ExceptT e) where
lift' f = ExceptT (f >>> arr Success)
lift' f = lift (rmap Success f)
instance (ArrowChoice c, Profunctor c) => Category (ExceptT r c) where
id = lift' id
f . g = lift $ unlift g >>> toEither ^>> arr Fail ||| unlift f
f . g = lift $ unlift g >>> lmap toEither (arr Fail ||| unlift f)
instance (ArrowChoice c, Profunctor c) => Arrow (ExceptT r c) where
arr f = lift' (arr f)
first f = lift $ first (unlift f) >>^ strength1
second f = lift $ second (unlift f) >>^ strength2
first f = lift $ rmap strength1 (first (unlift f))
second f = lift $ rmap strength2 (second (unlift f))
f *** g = first f >>> second g
f &&& g = lmap duplicate (f *** g)
instance (ArrowChoice c, Profunctor c) => ArrowChoice (ExceptT r c) where
left f = lift $ left (unlift f) >>^ strength1
right f = lift $ right (unlift f) >>^ strength2
f ||| g = lift (unlift f ||| unlift g)
f +++ g = lift $ unlift f +++ unlift g >>^ from distribute
f ||| g = lift $ unlift f ||| unlift g
f +++ g = lift $ rmap distribute2 (unlift f +++ unlift g)
instance (ArrowChoice c, ArrowApply c, Profunctor c) => ArrowApply (ExceptT e c) where
app = lift $ first unlift ^>> app
app = lift $ lmap (first unlift) app
instance (ArrowChoice c, ArrowState s c) => ArrowState s (ExceptT e c) where
get = lift' get
......
......@@ -20,6 +20,7 @@ import Control.Arrow.Reader
import Control.Arrow.Store as Store
import Control.Arrow.State
import Control.Arrow.Except as Exc
import Control.Arrow.Utils
import Control.Category
import Data.Profunctor
......@@ -53,17 +54,19 @@ instance (ArrowChoice c, Profunctor c) => Category (FailureT r c) where
instance (ArrowChoice c, Profunctor c) => Arrow (FailureT r c) where
arr f = lift' (arr f)
first f = lift $ first (unlift f) >>^ strength1
second f = lift $ second (unlift f) >>^ strength2
first f = lift $ rmap strength1 (first (unlift f))
second f = lift $ rmap strength2 (second (unlift f))
f *** g = first f >>> second g
f &&& g = lmap duplicate (f *** g)
instance (ArrowChoice c, Profunctor c) => ArrowChoice (FailureT r c) where
left f = lift $ left (unlift f) >>^ strength1
right f = lift $ right (unlift f) >>^ strength2
f ||| g = lift (unlift f ||| unlift g)
f +++ g = lift $ unlift f +++ unlift g >>^ from distribute
f +++ g = lift $ unlift f +++ unlift g >>^ distribute2
instance (ArrowChoice c, ArrowApply c, Profunctor c) => ArrowApply (FailureT e c) where
app = FailureT $ first runFailureT ^>> app
app = FailureT $ lmap (first runFailureT) app
instance (ArrowChoice c, ArrowState s c) => ArrowState s (FailureT e c) where
get = lift' get
......
......@@ -6,6 +6,7 @@
{-# LANGUAGE Arrows #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module Control.Arrow.Transformer.Reader(ReaderT(..)) where
import Prelude hiding (id,(.),lookup,read,fail)
......@@ -47,7 +48,7 @@ instance ArrowTrans (ReaderT r) where
unlift = runReaderT
instance ArrowLift (ReaderT r) where
lift' f = ReaderT (pi2 >>> f)
lift' f = lift $ lmap snd f
instance (Arrow c, Profunctor c) => Category (ReaderT r c) where
id = lift' id
......@@ -61,10 +62,10 @@ instance (Arrow c, Profunctor c) => Arrow (ReaderT r c) where
f *** g = lift $ lmap (\(r,(b,d)) -> ((r,b),(r,d))) $ unlift f *** unlift g
instance (ArrowChoice c, Profunctor c) => ArrowChoice (ReaderT r c) where
left f = lift $ lmap (to distribute >>> mmap id pi2) $ left (unlift f)
right f = lift $ lmap (to distribute >>> mmap pi2 id) $ right (unlift f)
f +++ g = lift $ lmap (to distribute) $ unlift f +++ unlift g
f ||| g = lift $ lmap (to distribute) $ unlift f ||| unlift g
left f = lift $ lmap (\(r,e) -> left (r,) e) $ left (unlift f)
right f = lift $ lmap (\(r,e) -> right (r,) e) $ right (unlift f)
f +++ g = lift $ lmap distribute1 $ unlift f +++ unlift g
f ||| g = lift $ lmap distribute1 $ unlift f ||| unlift g
instance (ArrowApply c, Profunctor c) => ArrowApply (ReaderT r c) where
app = lift $ lmap (\(r,(f,b)) -> (unlift f,(r,b))) app
......@@ -108,7 +109,7 @@ instance ArrowFix (Dom (ReaderT r) x y) (Cod (ReaderT r) x y) c => ArrowFix x y
instance ArrowExcept e c => ArrowExcept e (ReaderT r c) where
type instance Join (ReaderT r c) (x,(x,e)) y = Exc.Join c (Dom (ReaderT r) x y,(Dom (ReaderT r) x y,e)) (Cod (ReaderT r) x y)
throw = lift' throw
catch f g = lift $ catch (unlift f) (lmap (from assoc) (unlift g))
catch f g = lift $ catch (unlift f) (lmap assoc2 (unlift g))
finally f g = lift $ finally (unlift f) (unlift g)
instance ArrowDeduplicate (r, x) y c => ArrowDeduplicate x y (ReaderT r c) where
......@@ -125,7 +126,6 @@ instance ArrowCond v c => ArrowCond v (ReaderT r c) where
if_ f g = lift $ lmap (\(r,(v,(x,y))) -> (v,((r,x),(r,y))))
$ if_ (unlift f) (unlift g)
deriving instance PreOrd (c (r,x) y) => PreOrd (ReaderT r c x y)
deriving instance LowerBounded (c (r,x) y) => LowerBounded (ReaderT r c x y)
deriving instance Complete (c (r,x) y) => Complete (ReaderT r c x y)
......
......@@ -38,11 +38,11 @@ import Data.Profunctor
-- Due to "Generalising Monads to Arrows", by John Hughes, in Science of Computer Programming 37.
newtype StateT s c x y = StateT { runStateT :: c (s,x) (s,y) }
evalStateT :: Arrow c => StateT s c x y -> c (s,x) y
evalStateT f = runStateT f >>> pi2
evalStateT :: (Arrow c, Profunctor c) => StateT s c x y -> c (s,x) y
evalStateT f = rmap snd $ runStateT f
execStateT :: Arrow c => StateT s c x y -> c (s,x) s
execStateT f = runStateT f >>> pi1
execStateT :: (Arrow c, Profunctor c) => StateT s c x y -> c (s,x) s
execStateT f = rmap fst $ runStateT f
instance (Profunctor c, Arrow c) => Profunctor (StateT s c) where
dimap f g h = lift $ dimap (second f) (second g) (unlift h)
......@@ -66,23 +66,21 @@ instance (Arrow c, Profunctor c) => Arrow (StateT s c) where
arr f = lift' (arr f)
first f = lift $ dimap (\(s,(b,c)) -> ((s,b),c)) strength1 (first (unlift f))
second f = lift $ dimap (\(s,(a,b)) -> (a,(s,b))) strength2 (second (unlift f))
f &&& g = lift $ dimap (\(s,x) -> ((s,x),x)) (\((s,y),x) -> ((s,x),y)) (first (unlift f))
>>> rmap (\((s,z),y) -> (s,(y,z))) (first (unlift g))
f *** g = lift $ dimap (\(s,(x,y)) -> ((s,x),y)) (\((s,y),x) -> ((s,x),y)) (first (unlift f))
>>> rmap (\((s,z),y) -> (s,(y,z))) (first (unlift g))
f &&& g = lmap duplicate (f *** g)
f *** g = first f >>> second g
instance (ArrowChoice c, Profunctor c) => ArrowChoice (StateT s c) where
left f = lift $ dimap (to distribute) (from distribute) (left (unlift f))
right f = lift $ dimap (to distribute) (from distribute) (right (unlift f))
f +++ g = lift $ dimap (to distribute) (from distribute) (unlift f +++ unlift g)
f ||| g = lift $ lmap (to distribute) (unlift f ||| unlift g)
left f = lift $ dimap distribute1 distribute2 (left (unlift f))
right f = lift $ dimap distribute1 distribute2 (right (unlift f))
f +++ g = lift $ dimap distribute1 distribute2 (unlift f +++ unlift g)
f ||| g = lift $ lmap distribute1 (unlift f ||| unlift g)
instance (ArrowApply c, Profunctor c) => ArrowApply (StateT s c) where
app = StateT $ lmap (\(s,(StateT f,b)) -> (f,(s,b))) app
app = lift $ lmap (\(s,(f,b)) -> (unlift f,(s,b))) app
instance (Arrow c, Profunctor c) => ArrowState s (StateT s c) where
get = StateT (arr (\(a,()) -> (a,a)))
put = StateT (arr (\(_,s) -> (s,())))
get = lift (arr (\(a,()) -> (a,a)))
put = lift (arr (\(_,s) -> (s,())))
instance (ArrowFail e c, Profunctor c) => ArrowFail e (StateT s c) where
......@@ -118,7 +116,7 @@ instance ArrowFix (s,x) (s,y) c => ArrowFix x y (StateT s c) where
instance (ArrowExcept e c) => ArrowExcept e (StateT s c) where
type instance Join (StateT s c) (x,(x,e)) y = Exc.Join c (Dom (StateT s) x y,(Dom (StateT s) x y,e)) (Cod (StateT s) x y)
throw = lift' throw
catch f g = lift $ catch (unlift f) (lmap (from assoc) (unlift g))
catch f g = lift $ catch (unlift f) (lmap assoc2 (unlift g))
finally f g = lift $ finally (unlift f) (unlift g)
instance (Eq s, Hashable s, ArrowDeduplicate (Dom (StateT s) x y) (Cod (StateT s) x y) c) => ArrowDeduplicate x y (StateT s c) where
......
......@@ -43,10 +43,10 @@ instance ArrowTrans (WriterT w) where
unlift = runWriterT
instance Monoid w => ArrowLift (WriterT w) where
lift' f = lift (arr (const mempty) &&& f)
lift' f = lift (rmap (\y -> (mempty,y)) f)
instance (Monoid w, Arrow c, Profunctor c) => Category (WriterT w c) where
id = lift (arr mempty &&& id)
id = lift' id
g . f = lift $ rmap (\(w1,(w2,z)) -> (w1 <> w2,z)) (unlift f >>> second (unlift g))
-- proc x -> do
-- (w1,y) <- f -< x
......@@ -54,7 +54,7 @@ instance (Monoid w, Arrow c, Profunctor c) => Category (WriterT w c) where
-- returnA -< (w1 <> w2,z)
instance (Monoid w, Arrow c, Profunctor c) => Arrow (WriterT w c) where
arr f = lift (arr mempty &&& arr f)
arr f = lift' (arr f)
first f = lift $ rmap (\((w,b),d) -> (w,(b,d))) (first (unlift f))
second g = lift $ rmap (\(d,(w,b)) -> (w,(d,b))) (second (unlift g))
f *** g = lift $ rmap (\((w1,b),(w2,d)) -> (w1 <> w2,(b,d))) (unlift f *** unlift g)
......@@ -64,10 +64,10 @@ instance (Monoid w, ArrowChoice c, Profunctor c) => ArrowChoice (WriterT w c) wh
left f = lift $ rmap (\e -> case e of Left (w,x) -> (w,Left x); Right y -> (mempty,Right y)) (left (unlift f))
right f = lift $ rmap (\e -> case e of Left x -> (mempty,Left x); Right (w,y) -> (w,Right y)) (right (unlift f))
f ||| g = lift $ unlift f ||| unlift g
f +++ g = lift $ rmap (from distribute) (unlift f +++ unlift g)
f +++ g = lift $ rmap distribute2 (unlift f +++ unlift g)
instance (Monoid w, ArrowApply c, Profunctor c) => ArrowApply (WriterT w c) where
app = lift $ lmap (\(f,x) -> (unlift f,x)) app
app = lift $ lmap (first runWriterT) app
instance (Monoid w, ArrowState s c) => ArrowState s (WriterT w c) where
get = lift' get
......
......@@ -115,18 +115,18 @@ instance Traversable (Error e) where
traverse _ (Fail e) = pure (Fail e)
traverse f (SuccessOrFail e x) = SuccessOrFail e <$> f x
instance Complete e => StrongMonad (Error e) (,) where
mstrength (Success _,Fail e) = Fail e
mstrength (Fail e,Fail e') = Fail (e e')
mstrength (SuccessOrFail e _,Fail e') = Fail (e e')
mstrength (Success x,Success y) = Success (x,y)
mstrength (Fail e,Success _) = Fail e
mstrength (SuccessOrFail e x,Success y) = SuccessOrFail e (x,y)
mstrength (Success x,SuccessOrFail e y) = SuccessOrFail e (x,y)
mstrength (Fail e,SuccessOrFail e' _) = Fail (e e')
mstrength (SuccessOrFail e x,SuccessOrFail e' y) = SuccessOrFail (e e') (x,y)
-- instance Complete e => StrongMonad (Error e) (,) where
-- mstrength (Success _,Fail e) = Fail e
-- mstrength (Fail e,Fail e') = Fail (e ⊔ e')
-- mstrength (SuccessOrFail e _,Fail e') = Fail (e ⊔ e')
-- mstrength (Success x,Success y) = Success (x,y)
-- mstrength (Fail e,Success _) = Fail e
-- mstrength (SuccessOrFail e x,Success y) = SuccessOrFail e (x,y)
-- mstrength (Success x,SuccessOrFail e y) = SuccessOrFail e (x,y)
-- mstrength (Fail e,SuccessOrFail e' _) = Fail (e ⊔ e')
-- mstrength (SuccessOrFail e x,SuccessOrFail e' y) = SuccessOrFail (e ⊔ e') (x,y)
fromMaybe :: Maybe a -> Error () a
......
......@@ -106,17 +106,13 @@ instance Monoidal Failure where
mmap f _ (Fail x) = Fail (f x)
mmap _ g (Success y) = Success (g y)
assoc = Iso assocTo assocFrom
where
assocTo :: Failure a (Failure b c) -> Failure (Failure a b) c
assocTo (Fail a) = Fail (Fail a)
assocTo (Success (Fail b)) = Fail (Success b)
assocTo (Success (Success c)) = Success c
assocFrom :: Failure (Failure a b) c -> Failure a (Failure b c)
assocFrom (Fail (Fail a)) = Fail a
assocFrom (Fail (Success b)) = Success (Fail b)
assocFrom (Success c) = Success (Success c)
assoc1 (Fail a) = Fail (Fail a)
assoc1 (Success (Fail b)) = Fail (Success b)
assoc1 (Success (Success c)) = Success c
assoc2 (Fail (Fail a)) = Fail a
assoc2 (Fail (Success b)) = Success (Fail b)
assoc2 (Success c) = Success (Success c)
instance Symmetric Failure where
commute (Fail a) = Success a
......@@ -125,17 +121,18 @@ instance Symmetric Failure where
instance Applicative f => Strong f Failure where
strength1 (Success a) = pure $ Success a
strength1 (Fail a) = Fail <$> a
strength2 (Success a) = Success <$> a
strength2 (Fail a) = pure $ Fail a
instance Applicative f => StrongMonad f Failure where
mstrength (Success a) = fmap Success a
mstrength (Fail a) = fmap Fail a
-- instance Applicative f => StrongMonad f Failure where
-- mstrength (Success a) = fmap Success a
-- mstrength (Fail a) = fmap Fail a
instance StrongMonad (Failure e) (,) where
mstrength (Success a,Success b) = Success (a,b)
mstrength (Fail e,_) = Fail e
mstrength (_,Fail e) = Fail e
-- instance StrongMonad (Failure e) (,) where
-- mstrength (Success a,Success b) = Success (a,b)
-- mstrength (Fail e,_) = Fail e
-- mstrength (_,Fail e) = Fail e
-- instance Distributive (,) Failure where
-- distribute = Iso distTo distFrom
......
......@@ -10,7 +10,7 @@ import Control.DeepSeq
import Data.Order
import Data.Abstract.Widening
import Data.Monoidal
-- import Data.Monoidal
import GHC.Generics
......@@ -57,11 +57,8 @@ instance Complete a => Complete (Terminating a) where
x NonTerminating = x
NonTerminating y = y
instance PreOrd a => CoComplete (Terminating a) where
Terminating a Terminating b
| a b = Terminating a
| b a = Terminating b
| otherwise = NonTerminating
instance CoComplete a => CoComplete (Terminating a) where
Terminating a Terminating b = Terminating (a b)
NonTerminating _ = NonTerminating
_ NonTerminating = NonTerminating
......@@ -77,10 +74,10 @@ widening _ (Terminating a) NonTerminating = (Terminating a)
widening _ NonTerminating (Terminating b) = (Terminating b)
widening w (Terminating a) (Terminating b) = Terminating (w a b)
instance StrongMonad Terminating (,) where
mstrength (NonTerminating,_) = NonTerminating
mstrength (_,NonTerminating) = NonTerminating
mstrength (Terminating a,Terminating b) = Terminating (a,b)
-- instance StrongMonad Terminating (,) where
-- mstrength (NonTerminating,_) = NonTerminating
-- mstrength (_,NonTerminating) = NonTerminating
-- mstrength (Terminating a,Terminating b) = Terminating (a,b)
instance Num a => Num (Terminating a) where
(+) = liftA2 (+)
......
......@@ -36,57 +36,41 @@ instance Monoidal Error where
mmap f _ (Fail x) = Fail (f x)
mmap _ g (Success y) = Success (g y)
assoc = Iso assocTo assocFrom
where
assocTo :: Error a (Error b c) -> Error (Error a b) c
assocTo (Fail a) = Fail (Fail a)
assocTo (Success (Fail b)) = Fail (Success b)
assocTo (Success (Success c)) = Success c
assocFrom :: Error (Error a b) c -> Error a (Error b c)
assocFrom (Fail (Fail a)) = Fail a
assocFrom (Fail (Success b)) = Success (Fail b)
assocFrom (Success c) = Success (Success c)
assoc1 (Fail a) = Fail (Fail a)
assoc1 (Success (Fail b)) = Fail (Success b)
assoc1 (Success (Success c)) = Success c
assoc2 (Fail (Fail a)) = Fail a
assoc2 (Fail (Success b)) = Success (Fail b)
assoc2 (Success c) = Success (Success c)
instance Symmetric Error where
commute (Fail a) = Success a
commute (Success a) = Fail a
instance Distributive (,) Error where
distribute = Iso distTo distFrom
where
distTo :: (a,Error b c) -> Error (a,b) (a,c)
distTo (a,Fail b) = Fail (a,b)
distTo (a,Success c) = Success (a,c)
distribute1 (a,Fail b) = Fail (a,b)
distribute1 (a,Success c) = Success (a,c)
distFrom :: Error (a,b) (a,c) -> (a,Error b c)
distFrom (Fail (a,b)) = (a,Fail b)
distFrom (Success (a,c)) = (a,Success c)
distribute2 (Fail (a,b)) = (a,Fail b)
distribute2 (Success (a,c)) = (a,Success c)
instance Distributive Either Error where
distribute = Iso distTo distFrom
where
distTo :: Either a (Error b c) -> Error (Either a b) (Either a c)
distTo (Left a) = Fail (Left a)
distTo (Right (Fail b)) = Fail (Right b)
distTo (Right (Success c)) = Success (Right c)
distFrom :: Error (Either a b) (Either a c) -> Either a (Error b c)
distFrom (Fail (Left a)) = Left a
distFrom (Fail (Right b)) = Right (Fail b)
distFrom (Success (Left a)) = Left a
distFrom (Success (Right c)) = Right (Success c)
distribute1 (Left a) = Fail (Left a)
distribute1 (Right (Fail b)) = Fail (Right b)
distribute1 (Right (Success c)) = Success (Right c)
distribute2 (Fail (Left a)) = Left a
distribute2 (Fail (Right b)) = Right (Fail b)
distribute2 (Success (Left a)) = Left a
distribute2 (Success (Right c)) = Right (Success c)
instance Distributive Error Either where
distribute = Iso distTo distFrom
where
distTo :: Error a (Either b c) -> Either (Error a b) (Error a c)
distTo (Fail a) = Right (Fail a)
distTo (Success (Left b)) = Left (Success b)
distTo (Success (Right c)) = Right (Success c)
distFrom :: Either (Error a b) (Error a c) -> Error a (Either b c)
distFrom (Left (Fail a)) = Fail a
distFrom (Left (Success b)) = Success (Left b)
distFrom (Right (Fail a)) = Fail a
distFrom (Right (Success c)) = Success (Right c)
distribute1 (Fail a) = Right (Fail a)
distribute1 (Success (Left b)) = Left (Success b)
distribute1 (Success (Right c)) = Right (Success c)
distribute2 (Left (Fail a)) = Fail a
distribute2 (Left (Success b)) = Success (Left b)
distribute2 (Right (Fail a)) = Fail a
distribute2 (Right (Success c)) = Success (Right c)
......@@ -36,57 +36,41 @@ instance Monoidal Failure where
mmap f _ (Fail x) = Fail (f x)
mmap _ g (Success y) = Success (g y)
assoc = Iso assocTo assocFrom
where
assocTo :: Failure a (Failure b c) -> Failure (Failure a b) c
assocTo (Fail a) = Fail (Fail a)
assocTo (Success (Fail b)) = Fail (Success b)
assocTo (Success (Success c)) = Success c
assocFrom :: Failure (Failure a b) c -> Failure a (Failure b c)
assocFrom (Fail (Fail a)) = Fail a
assocFrom (Fail (Success b)) = Success (Fail b)
assocFrom (Success c) = Success (Success c)
assoc1 (Fail a) = Fail (Fail a)
assoc1 (Success (Fail b)) = Fail (Success b)
assoc1 (Success (Success c)) = Success c
assoc2 (Fail (Fail a)) = Fail a
assoc2 (Fail (Success b)) = Success (Fail b)
assoc2 (Success c) = Success (Success c)
instance Symmetric Failure where
commute (Fail a) = Success a
commute (Success a) = Fail a
instance Distributive (,) Failure where
distribute = Iso distTo distFrom
where
distTo :: (a,Failure b c) -> Failure (a,b) (a,c)
distTo (a,Fail b) = Fail (a,b)
distTo (a,Success c) = Success (a,c)
distribute1 (a,Fail b) = Fail (a,b)
distribute1 (a,Success c) = Success (a,c)
distFrom :: Failure (a,b) (a,c) -> (a,Failure b c)
distFrom (Fail (a,b)) = (a,Fail b)
distFrom (Success (a,c)) = (a,Success c)
distribute2 (Fail (a,b)) = (a,Fail b)
distribute2 (Success (a,c)) = (a,Success c)
instance Distributive Either Failure where
distribute = Iso distTo distFrom
where
distTo :: Either a (Failure b c) -> Failure (Either a b) (Either a c)
distTo (Left a) = Fail (Left a)
distTo (Right (Fail b)) = Fail (Right b)
distTo (Right (Success c)) = Success (Right c)
distFrom :: Failure (Either a b) (Either a c) -> Either a (Failure b c)
distFrom (Fail (Left a)) = Left a
distFrom (Fail (Right b)) = Right (Fail b)
distFrom (Success (Left a)) = Left a
distFrom (Success (Right c)) = Right (Success c)
distribute1 (Left a) = Fail (Left a)
distribute1 (Right (Fail b)) = Fail (Right b)
distribute1 (Right (Success c)) = Success (Right c)
distribute2 (Fail (Left a)) = Left a
distribute2 (Fail (Right b)) = Right (Fail b)
distribute2 (Success (Left a)) = Left a
distribute2 (Success (Right c)) = Right (Success c)
instance Distributive Failure Either where
distribute = Iso distTo distFrom
where
distTo :: Failure a (Either b c) -> Either (Failure a b) (Failure a c)
distTo (Fail a) = Right (Fail a)
distTo (Success (Left b)) = Left (Success b)
distTo (Success (Right c)) = Right (Success c)
distFrom :: Either (Failure a b) (Failure a c) -> Failure a (Either b c)
distFrom (Left (Fail a)) = Fail a
distFrom (Left (Success b)) = Success (Left b)
distFrom (Right (Fail a)) = Fail a
distFrom (Right (Success c)) = Success (Right c)
distribute1 (Fail a) = Right (Fail a)
distribute1 (Success (Left b)) = Left (Success b)
distribute1 (Success (Right c)) = Right (Success c)
distribute2 (Left (Fail a)) = Fail a
distribute2 (Left (Success b)) = Success (Left b)
distribute2 (Right (Fail a)) = Fail a
distribute2 (Right (Success c)) = Success (Right c)
......@@ -7,27 +7,25 @@ data Iso a b = Iso { to :: a -> b, from :: b -> a}
class Monoidal m where
mmap :: (a -> a') -> (b -> b') -> a `m` b -> a' `m` b'
assoc :: Iso (a `m` (b `m` c)) ((a `m` b) `m` c)
assoc1 :: (a `m` (b `m` c)) -> ((a `m` b) `m` c)
assoc2 :: ((a `m` b) `m` c) -> (a `m` (b `m` c))
instance Monoidal (,) where
mmap f g (x,y) = (f x,g y)
assoc = Iso (\(a,(b,c)) -> ((a,b),c)) (\((a,b),c) -> (a,(b,c)))
mmap f g ~(x,y) = (f x,g y)
assoc1 ~(a,(b,c)) = ((a,b),c)
assoc2 ~((a,b),c) = (a,(b,c))