}
\maketitle
The great thing about {\tt Arrows} is you can write code that works for morphisms in different categories. For example, you can write code for functions and later use monad actions, or Kleisli arrows, instead. This is useful for error handling, and of course, adding {\tt IO}.
If the underlying category uses isomorphisms (things with inverses) exclusively then it is called a {\sl groupoid}. Groupoids cause cracks to show in the {\tt Arrow} abstraction. {\tt Arrow} assumes that you can lift any function into the category you are writing code for, by requiring a definition for @arr :: (b -> c) -> a b c@ function. This is out for groupoids, because not all functions are isomorphisms.
To remedy this, among other issues, Adam Megacz came up with. \href{http://arxiv.org/pdf/1007.2885v2.pdf}{Generalized Arrows.}.
In \href{https://www.cs.indiana.edu/~rpjames/papers/rc.pdf}{\sl Dagger Traced Symmetric Monoidal Categories and Reversible Programming} the authors show how to construct an reversible language out of the sum and product types along with related combinators to form a commutative semiring, at the type level. Both approaches are similar.
Error handling and \href{http://www.informatik.uni-marburg.de/~rendel/rendel10invertible.pdf}{\sl partial isomorphisms} are possible with Generalized Arrows. However, I find the algebraic approach of {\sl DTSMCRP} more elegant. So I am going to try to get the same combinators as {\sl DTSMCRP} but for an arbitrary category, as I would with Generalized Arrows.
This is a Literate Haskell file, which means it can be executed as Haskell code. First, I need to start with a simple Haskell preamble.
\begin{code}
module Data.Semiring (
Ctor(..)
, promote
, swap_promote
, Absorbs(..)
, Assocative(..)
, Commutative(..)
, Annihilates(..)
, Distributes(..)
, Monoidial
, CommutativeMonoidial
, Semiring
, first
, second
, left
, right
, Groupoid(..)
, Iso(..)
, biject_sum_absorb
, biject_sum_assoc
, biject_product_absorb
, biject_product_assoc
, biject_distributes
, kbiject_sum_absorb
, kbiject_sum_assoc
, kbiject_product_absorb
, kbiject_product_assoc
, kbiject_distributes
) where
import Prelude hiding ((.), id)
import Control.Category ((.), id, Category(..))
import Data.Void(Void)
import Control.Arrow (Kleisli(..))
import Generics.Pointless.MonadCombinators (mfuse)
import Control.Monad (liftM)
import Control.Newtype
\end{code}
\newpage
\noindent I start with an abstraction for both sum and product constructors.
\begin{code}
class Category k => Ctor k constr | constr -> k where
selfmap :: k a b -> k c d -> k (constr a c) (constr b d)
\end{code}
\noindent With Ctor I can write a generic {\tt first} or {\tt left}
\begin{code}
promote :: Ctor k op => k a b -> k (op a c) (op b c)
promote = flip selfmap id
swap_promote :: Ctor k op => k a b -> k (op c a) (op c b)
swap_promote = selfmap id
\end{code}
It is probably not clear at this point but depending on the type of {\sl op} we can get either the {\tt Arrow} $\ast\ast\ast$ or the {\tt ArrowChoice} $\interleave$ function. If we make a semiring we can get them both. That's what we are going to do.
I use type classes to encode the algebraic laws of semirings, with a class per law.
%format \<-\> = "\leftrightarrow "
\vskip 5pt
\begin{code}
class Ctor k op => Absorbs k op id | op -> k, op -> id where
absorb :: k (op id a) a
unabsorb :: k a (op id a)
\end{code}
\begin{code}
class Ctor k op => Commutative k op | op -> k where
commute :: k (op a b) (op b a)
\end{code}
\begin{code}
class Ctor k op => Assocative k op | op -> k where
assoc :: k (op (op a b) c) (op a (op b c))
unassoc :: k (op a (op b c)) (op (op a b) c)
\end{code}
\begin{code}
class Ctor k op => Annihilates k op zero | op zero -> k where
annihilates :: k (op zero a) zero
\end{code}
\begin{code}
class (Ctor k add, Ctor k multi) => Distributes k add multi | add multi -> k where
distribute :: k (multi (add a b) c) (add (multi a c) (multi b c))
undistribute :: k (add (multi a c) (multi b c)) (multi (add a b) c)
\end{code}
I collect these into groups of laws to make different algebraic structures.
\begin{code}
class (Assocative k dot, Absorbs k dot id) =>
Monoidial k dot id | dot id -> k where
\end{code}
\begin{code}
class (Monoidial k dot id, Commutative k dot) =>
CommutativeMonoidial k dot id | dot id -> k where
\end{code}
\begin{code}
class (CommutativeMonoidial k add zero,
CommutativeMonoidial k multi one,
Annihilates k multi zero,
Distributes k add multi) =>
Semiring k add zero multi one | add zero multi one -> k where
\end{code}
From which I regain {\tt Arrow} and {\tt ArrowChoice} functionality. Although, because of {\tt promote}, I already had this capability.
\begin{code}
first :: Semiring a add zero multi one => a b c -> a (multi b d) (multi c d)
first = promote
second :: Semiring a add zero multi one => a b c -> a (multi d b) (multi d c)
second = swap_promote
left :: Semiring a add zero multi one => a b c -> a (add b d) (add c d)
left = promote
right :: Semiring a add zero multi one => a b c -> a (add d b) (add d c)
right = swap_promote
\end{code}
Many of the Generic Arrow functions can be included through absorption ({\tt cancel}, {\tt uncancel}) and commutativity ({\tt swap}). I'm not interested in adding looping at this point.
This also makes clear the relationship between {\tt Arrow} and {\tt ArrowChoice} as has been noted else where. Basically the same thing with a different endofunctor or constructor ({\tt Arrow} uses product types, {\tt ArrowChoice} uses sum types) as the monoid operator of a type level commutative monoid.
Making instances is a little onerous because of the use of multiparameter classes and the functional dependencies I have chosen. When I begin actually using these classes, it could result in massive changes. I am open to any suggestions on better designs.
\newpage
The rest of the code is basically boilerplate. I used Djinn to write some of the functions (hopefully they work :)).
\section{Small Category Instances}
\subsection{Function Instances}
\subsubsection{Sum Commutative Monoid Instances}
%format Sum = "\bigplus "
%format Zero = "\MVZero "
\begin{code}
--Sugar
type Sum = Either
type Zero = Void
instance Ctor (->) Sum where
selfmap f g = either (Left . f) (Right . g)
instance Absorbs (->) Sum Zero where
absorb (Right x) = x
absorb _ = error "Absorbs,->,Sum,Zero Semiring.lhs absorb:impossible!"
unabsorb = Right
instance Assocative (->) Sum where
assoc = either (either Left (Right . Left)) (Right . Right)
unassoc = either (Left . Left) (either (Left . Right) Right)
instance Monoidial (->) Sum Zero where
instance Commutative (->) Sum where
commute = either Right Left
instance CommutativeMonoidial (->) Sum Zero where
\end{code}
\subsubsection{Product Commutative Monoid Instances}
%format Product = "\ast "
%format One = "\MVOne "
\begin{code}
type Product = (,)
type One = ()
instance Ctor (->) Product where
selfmap f g (x, y) = (f x, g y)
instance Absorbs (->) Product One where
absorb ((), x) = x
unabsorb x = ((), x)
instance Assocative (->) Product where
assoc ((x, y), z) = (x, (y, z))
unassoc (x, (y, z)) = ((x, y), z)
instance Monoidial (->) Product One where
instance Commutative (->) Product where
commute (x, y) = (y, x)
instance CommutativeMonoidial (->) Product One where
\end{code}
\subsubsection{Function Semiring Instance}
\begin{code}
instance Annihilates (->) Product Zero where
annihilates (_, _) = undefined
instance Distributes (->) Sum Product where
distribute (Left x, z) = Left (x, z)
distribute (Right y, z) = Right (y, z)
undistribute (Left (x, z)) = (Left x, z)
undistribute (Right (y, z)) = (Right y, z)
instance Semiring (->) Sum Zero Product One where
\end{code}
\subsection{Kleisli Instances}
The functional dependencies of the classes require alternate versions of the sum and product types used for \to instances.
%format KSum = "\bigplus "
%format KZero = "\MVZero "
\subsection{Sum Commutative Monoid Instances}
\begin{code}
data KSum a b = KLeft a | KRight b
newtype KZero = KZ Void
instance Monad m => Ctor (Kleisli m) KSum where
selfmap (Kleisli f) (Kleisli g) = Kleisli $
\e -> case e of
KLeft x -> KLeft `liftM` f x
KRight x -> KRight `liftM` g x
instance Monad m => Absorbs (Kleisli m) KSum KZero where
absorb = Kleisli $ \e -> case e of
KRight x -> return x
_ -> error "Absorbs,Kleisli,KSum,KZero Semiring.lhs absorb:impossible!"
unabsorb = Kleisli $ \x -> return $ KRight x
instance Monad m => Assocative (Kleisli m) KSum where
assoc = Kleisli $ \e -> case e of
KLeft x -> case x of
KLeft y -> return $ KLeft y
KRight y -> return $ KRight $ KLeft y
KRight x -> return $ KRight $ KRight x
unassoc = Kleisli $ \e -> case e of
KLeft x -> return $ KLeft $ KLeft x
KRight x -> case x of
KLeft y -> return $ KLeft $ KRight y
KRight y -> return $ KRight y
instance Monad m => Monoidial (Kleisli m) KSum KZero where
instance Monad m => Commutative (Kleisli m) KSum where
commute = Kleisli $ \e -> case e of
KLeft x -> return $ KRight x
KRight x -> return $ KLeft x
instance Monad m => CommutativeMonoidial (Kleisli m) KSum KZero where
\end{code}
%format KProduct = "\ast "
%format KOne = "\MVOne "
\subsubsection{Product Commutative Monoid Instances}
\begin{code}
data KProduct a b = KP a b
newtype KOne = KO ()
instance Monad m => Ctor (Kleisli m) KProduct where
selfmap (Kleisli f) (Kleisli g) = Kleisli $
\(KP x y) -> uncurry KP `liftM` mfuse (f x, g y)
instance Monad m => Absorbs (Kleisli m) KProduct KOne where
absorb = Kleisli $ \(KP (KO ()) x) -> return x
unabsorb = Kleisli $ \x -> return $ KP (KO ()) x
instance Monad m => Assocative (Kleisli m) KProduct where
assoc = Kleisli $ \(KP (KP x y) z) -> return $ KP x (KP y z)
unassoc = Kleisli $ \(KP x (KP y z)) -> return $ KP (KP x y) z
instance Monad m => Monoidial (Kleisli m) KProduct KOne where
instance Monad m => Commutative (Kleisli m) KProduct where
commute = Kleisli $ \(KP x y) -> return $ KP y x
instance Monad m => CommutativeMonoidial (Kleisli m) KProduct KOne where
\end{code}
\subsubsection{Function Semiring Instance}
\begin{code}
instance Monad m => Annihilates (Kleisli m) KProduct KZero where
annihilates = Kleisli $ \(KP _ _) -> return undefined
instance Monad m => Distributes (Kleisli m) KSum KProduct where
distribute = Kleisli $ \e -> case e of
KP (KLeft x) z -> return $ KLeft $ KP x z
KP (KRight y) z -> return $ KRight $ KP y z
undistribute = Kleisli $ \e -> case e of
KLeft (KP x z) -> return $ KP (KLeft x) z
KRight (KP x z) -> return $ KP (KRight x) z
instance Monad m => Semiring (Kleisli m) KSum KZero KProduct KOne where
\end{code}
\section{Groupoid Class}
\begin{code}
class (Category g) => Groupoid g where
inv :: g a b -> g b a
\end{code}
\section{Groupoid Instances}
\begin{code}
data Iso k a b = Iso {
embed :: k a b,
project :: k b a
}
instance (Category k) => Category (Iso k) where
id = Iso id id
(Iso f g) . (Iso h i) = Iso (f . h) (i . g)
instance Newtype (Iso k a b) (k a b, k b a) where
pack (f, g) = Iso f g
unpack (Iso f g) = (f, g)
instance (Category k) => Groupoid (Iso k) where
inv (Iso f g) = Iso g f
\end{code}
\subsection{Helper Code}
\begin{code}
type Biject = Iso (->)
type KBiject m = Iso (Kleisli m)
(<->) :: k a b -> k b a -> Iso k a b
(<->) = Iso
\end{code}
\subsection{Groupoid Semirings Instances}
\subsection{Groupoid with a Function as the base category}
\subsubsection{Sum Commutative Monoid Instances}
%format BSum = "\bigplus "
%format BZero = "\MVZero "
\begin{code}
data BSum a b = BLeft a | BRight b
newtype BZero = BZ Void
instance Ctor Biject BSum where
selfmap f g = fw <-> bk where
fw (BLeft x) = BLeft $ embed f x
fw (BRight x) = BRight $ embed g x
bk (BLeft x) = BLeft $ project f x
bk (BRight x) = BRight $ project g x
instance Absorbs Biject BSum BZero where
absorb = biject_sum_absorb
unabsorb = inv biject_sum_absorb
biject_sum_absorb :: Biject (BSum BZero a) a
biject_sum_absorb = fw <-> bk where
fw (BRight x) = x
fw _ = error "biject_sum_absorb fw: impossible"
bk = BRight
instance Assocative Biject BSum where
assoc = biject_sum_assoc
unassoc = inv biject_sum_assoc
biject_sum_assoc :: Biject (BSum (BSum a b) c) (BSum a (BSum b c))
biject_sum_assoc = fw <-> bk where
fw (BLeft (BLeft x)) = BLeft x
fw (BLeft (BRight x)) = BRight $ BLeft x
fw (BRight x) = BRight $ BRight x
bk (BLeft x) = BLeft (BLeft x)
bk (BRight (BLeft x)) = BLeft (BRight x)
bk (BRight (BRight x)) = BRight x
instance Monoidial Biject BSum BZero where
instance Commutative Biject BSum where
commute = fw <-> bk where
fw (BRight x) = BLeft x
fw (BLeft x) = BRight x
bk (BRight x) = BLeft x
bk (BLeft x) = BRight x
instance CommutativeMonoidial Biject BSum BZero where
\end{code}
\subsubsection{Product Commutative Monoid Instances}
%format BProduct = "\ast "
%format BOne = "\MVOne "
\begin{code}
data BProduct a b = BP a b
newtype BOne = BO ()
instance Ctor Biject BProduct where
selfmap (Iso f_fw f_bk ) (Iso g_fw g_bk) =
Iso (\(BP x y) -> BP (f_fw x) (g_fw y)) (\(BP x y) -> BP (f_bk x) (g_bk y))
instance Absorbs Biject BProduct BOne where
absorb = biject_product_absorb
unabsorb = inv biject_product_absorb
biject_product_absorb :: Biject (BProduct BOne a) a
biject_product_absorb = fw <-> bk where
fw (BP (BO ()) x) = x
bk x = BP (BO ()) x
instance Assocative Biject BProduct where
assoc = biject_product_assoc
unassoc = inv biject_product_assoc
biject_product_assoc :: Biject (BProduct (BProduct a b) c) (BProduct a (BProduct b c))
biject_product_assoc = fw <-> bk where
fw (BP (BP x y) z) = BP x (BP y z)
bk (BP x (BP y z)) = BP (BP x y) z
instance Monoidial Biject BProduct BOne where
instance Commutative Biject BProduct where
commute = (\(BP x y) -> BP y x) <-> (\(BP x y) -> BP y x)
instance CommutativeMonoidial Biject BProduct BOne where
\end{code}
\subsubsection{Semiring Instance}
\begin{code}
instance Annihilates Biject BProduct BZero where
annihilates = (\(BP _ _) -> undefined) <-> (`BP` undefined)
instance Distributes Biject BSum BProduct where
distribute = biject_distributes
undistribute = inv biject_distributes
biject_distributes :: Biject (BProduct (BSum a b) c) (BSum (BProduct a c) (BProduct b c))
biject_distributes = fw <-> bk where
fw (BP (BLeft x) z) = BLeft (BP x z)
fw (BP (BRight y) z) = BRight (BP y z)
bk (BLeft (BP x z)) = BP (BLeft x) z
bk (BRight (BP y z)) = BP (BRight y) z
instance Semiring Biject BSum BZero BProduct BOne where
\end{code}
\subsection{Groupoid with a Klesli arrow as the base category}
\subsubsection{Sum Commutative Monoid Instances}
%format KBSum = "\bigplus "
%format KBZero = "\MVZero "
\begin{code}
data KBSum a b = KBLeft a | KBRight b
newtype KBZero = KBZ Void
instance Monad m => Ctor (KBiject m) KBSum where
selfmap f g = fw <-> bk where
fw = Kleisli $ run_pair (embed f) (embed g)
bk = Kleisli $ run_pair (project f) (project g)
run_pair t _ (KBLeft x) = KBLeft `liftM` runKleisli t x
run_pair _ u (KBRight x) = KBRight `liftM` runKleisli u x
instance Monad m => Absorbs (KBiject m) KBSum KBZero where
absorb = kbiject_sum_absorb
unabsorb = inv kbiject_sum_absorb
kbiject_sum_absorb :: Monad m => (KBiject m) (KBSum KBZero a) a
kbiject_sum_absorb = fw <-> bk where
fw = Kleisli $ \e -> case e of
KBRight x -> return x
_ -> error "kbiject_sum_absorb fw: impossible"
bk = Kleisli $ \x -> return $ KBRight x
instance Monad m => Assocative (KBiject m) KBSum where
assoc = kbiject_sum_assoc
unassoc = inv kbiject_sum_assoc
kbiject_sum_assoc :: Monad m => (KBiject m) (KBSum (KBSum a b) c) (KBSum a (KBSum b c))
kbiject_sum_assoc = fw <-> bk where
fw = Kleisli $ \e -> case e of
KBLeft x -> case x of
KBLeft y -> return $ KBLeft y
KBRight y -> return $ KBRight $ KBLeft y
KBRight x -> return $ KBRight $ KBRight x
bk = Kleisli $ \e -> case e of
KBLeft x -> return $ KBLeft $ KBLeft x
KBRight x -> case x of
KBLeft y -> return $ KBLeft $ KBRight y
KBRight y -> return $ KBRight y
instance Monad m => Monoidial (KBiject m) KBSum KBZero where
instance Monad m => Commutative (KBiject m) KBSum where
commute = fw <-> fw where
fw = Kleisli $ \e -> case e of
KBLeft x -> return $ KBRight x
KBRight x -> return $ KBLeft x
instance (Monad m) => CommutativeMonoidial (KBiject m) KBSum KBZero where
\end{code}
\subsubsection{Product Commutative Monoid Instances}
%format KBProduct = "\ast "
%format KBOne = "\MVOne "
\begin{code}
data KBProduct a b = KBP a b
newtype KBOne = KBO ()
instance Monad m => Ctor (KBiject m) KBProduct where
selfmap f g = fw <-> bk where
fw = Kleisli $ run_pair (embed f) (embed g)
bk = Kleisli $ run_pair (project f) (project g)
run_pair t u (KBP x y) =
uncurry KBP `liftM` mfuse (runKleisli t x, runKleisli u y)
instance Monad m => Absorbs (KBiject m) KBProduct KBOne where
absorb = kbiject_product_absorb
unabsorb = inv kbiject_product_absorb
kbiject_product_absorb :: Monad m => (KBiject m) (KBProduct KBOne a) a
kbiject_product_absorb = fw <-> bk where
fw = Kleisli $ \(KBP (KBO ()) x) -> return x
bk = Kleisli $ \x -> return $ KBP (KBO ()) x
instance Monad m => Assocative (KBiject m) KBProduct where
assoc = kbiject_product_assoc
unassoc = inv kbiject_product_assoc
kbiject_product_assoc :: Monad m
=> (KBiject m) (KBProduct (KBProduct a b) c) (KBProduct a (KBProduct b c))
kbiject_product_assoc = fw <-> bk where
fw = Kleisli $ \(KBP (KBP f g) h) -> return $ KBP f (KBP g h)
bk = Kleisli $ \(KBP f (KBP g h)) -> return $ KBP (KBP f g) h
instance Monad m => Monoidial (KBiject m) KBProduct KBOne where
instance Monad m => Commutative (KBiject m) KBProduct where
commute = fw <-> fw where
fw = Kleisli $ \(KBP x y) -> return $ KBP y x
instance (Monad m) => CommutativeMonoidial (KBiject m) KBProduct KBOne where
\end{code}
\subsubsection{Semiring Instance}
\begin{code}
instance (Monad m) => Annihilates (KBiject m) KBProduct KBZero where
annihilates = fw <-> bk where
fw = Kleisli $ \(KBP _ _) -> return undefined
bk = Kleisli $ \x -> return $ KBP x undefined
instance (Monad m) => Distributes (KBiject m) KBSum KBProduct where
distribute = kbiject_distributes
undistribute = inv kbiject_distributes
kbiject_distributes :: Monad m
=> (KBiject m) (KBProduct (KBSum a b) c) (KBSum (KBProduct a c) (KBProduct b c))
kbiject_distributes = fw <-> bk where
fw = Kleisli $ \e -> case e of
KBP (KBLeft x) z -> return $ KBLeft (KBP x z)
KBP (KBRight y) z -> return $ KBRight (KBP y z)
bk = Kleisli $ \e -> case e of
KBLeft (KBP x z) -> return $ KBP (KBLeft x) z
KBRight (KBP y z) -> return $ KBP (KBRight y) z
instance Monad m => Semiring (KBiject m) KBSum KBZero KBProduct KBOne where
\end{code}
\end{document}