module Control.Arrow
    ( module Control.Category
    , CategoryApply (..)
    , CategoryFix (..)
    , LFunctor (..)
    , RFunctor (..)
    , Bifunctor (..)
    , Bipointed (..)
    , LCopointed (..)
    , RCopointed (..)
    , Bicopointed (..)
    , (***)
    , (+++)
    , (&&&)
    , (|||)
    , either
    ) where

import Control.Category
import Data.Either

infixr 3 ***
infixr 3 &&&
infixr 2 +++
infixr 2 |||

class Category (~>) => LFunctor (~>) f where
    first :: a ~> b  ->  f a c ~> f b c

instance LFunctor Hask (,) where
    first f ~(x, y) = (f x, y)

instance LFunctor Hask Either where
    first f (Left x) = Left (f x)
    first _ (Right y) = Right y

class Category (~>) => RFunctor (~>) f where
    second :: a ~> b  ->  f c a ~> f c b

instance RFunctor Hask (,) where
    second f ~(x, y) = (x, f y)

instance RFunctor Hask Either where
    second _ (Left x) = Left x
    second f (Right y) = Right (f y)

class (LFunctor (~>) f , RFunctor (~>) f ) => Bifunctor (~>) f where
    bimap :: a ~> c  ->  b ~> d  ->  f a b ~> f c d

{-# RULES
"compose/first"  forall f g .
                   first f . first g = first (f . g)
"compose/second" forall f g .
                   second f . second g = second (f . g)
"compose/bimap" forall f f' g g' .
                   bimap f g . bimap f' g' = bimap (f . g) (f' . g')
 #-}

instance Bifunctor Hask (,) where
    bimap f g ~(x, y) = (f x, g y)

instance Bifunctor Hask Either where
    bimap f _ (Left x) = Left (f x)
    bimap _ g (Right y) = Right (g y)

(***) :: Bifunctor (~>) (,) => a ~> c  ->  b ~> d  ->  (a, b) ~> (c, d)
(***) = bimap

(+++) :: Bifunctor (~>) Either => a ~> c  ->  b ~> d  ->  Either a b ~> Either c d
(+++) = bimap

class Bifunctor (~>) f => Bipointed (~>) f where
    bipoint :: a ~> f a a

instance Bipointed Hask (,) where
    bipoint x = (x, x)

(&&&) :: Bipointed (~>) (,) => a ~> b  ->  a ~> c  ->  a ~> (b, c)
f &&& g = f *** g <<< bipoint

class LFunctor (~>) f => LCopointed (~>) f where
    fst :: f a b ~> a

instance LCopointed Hask (,) where
    fst (x, _) = x

class RFunctor (~>) f => RCopointed (~>) f where
    snd :: f a b ~> b

instance RCopointed Hask (,) where
    snd (_, y) = y

class Bifunctor (~>) f => Bicopointed (~>) f where
    biextract :: f a a ~> a

instance Bicopointed Hask Either where
    biextract (Left x) = x
    biextract (Right y) = y

(|||) :: Bicopointed (~>) Either => a ~> c  ->  b ~> c  ->  Either a b ~> c
f ||| g = biextract <<< f +++ g

either :: Bicopointed (~>) Either => a ~> c  ->  b ~> c  ->  Either a b ~> c
either = (|||)

class Category (~>) => CategoryApply (~>) where
    app :: (a ~> b, a) ~> b


instance CategoryApply Hask where
    app (f, x) = f x


class Category (~>) => CategoryFix (~>) where
    cfix :: (a, c) ~> (b, c)  ->  a ~> b


instance CategoryFix (->) where
    cfix f x = let (a, b) = f (x, b) in a