{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}

#if __GLASGOW_HASKELL__ >= 706
{-# LANGUAGE PolyKinds #-}
#endif

#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-}
#endif

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Semigroupoid
-- Copyright   :  (C) 2007-2015 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  portable
--
-- A semigroupoid satisfies all of the requirements to be a Category except
-- for the existence of identity arrows.
----------------------------------------------------------------------------
module Data.Semigroupoid
  ( Semigroupoid(..)
  , WrappedCategory(..)
  , Semi(..)
  ) where

import Control.Applicative
import Control.Arrow
import Data.Functor.Bind
import Data.Semigroup
import Control.Category
import Prelude hiding (id, (.))

#ifdef MIN_VERSION_contravariant
import Data.Functor.Contravariant
#endif

#ifdef MIN_VERSION_comonad
import Data.Functor.Extend
import Control.Comonad
#endif

#ifdef MIN_VERSION_tagged
import Data.Tagged (Tagged (..))
#endif

#if MIN_VERSION_base(4,7,0)
import qualified Data.Type.Coercion as Co
import qualified Data.Type.Equality as Eq
#endif

-- | 'Control.Category.Category' sans 'Control.Category.id'
class Semigroupoid c where
  o :: c j k -> c i j -> c i k

instance Semigroupoid (->) where
  o :: (j -> k) -> (i -> j) -> i -> k
o = (j -> k) -> (i -> j) -> i -> k
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
(.)

-- | <http://en.wikipedia.org/wiki/Band_(mathematics)#Rectangular_bands>
instance Semigroupoid (,) where
  o :: (j, k) -> (i, j) -> (i, k)
o (j
_,k
k) (i
i,j
_) = (i
i,k
k)

instance Bind m => Semigroupoid (Kleisli m) where
  Kleisli j -> m k
g o :: Kleisli m j k -> Kleisli m i j -> Kleisli m i k
`o` Kleisli i -> m j
f = (i -> m k) -> Kleisli m i k
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli ((i -> m k) -> Kleisli m i k) -> (i -> m k) -> Kleisli m i k
forall a b. (a -> b) -> a -> b
$ \i
a -> i -> m j
f i
a m j -> (j -> m k) -> m k
forall (m :: * -> *) a b. Bind m => m a -> (a -> m b) -> m b
>>- j -> m k
g

#ifdef MIN_VERSION_comonad
instance Extend w => Semigroupoid (Cokleisli w) where
  Cokleisli w j -> k
f o :: Cokleisli w j k -> Cokleisli w i j -> Cokleisli w i k
`o` Cokleisli w i -> j
g = (w i -> k) -> Cokleisli w i k
forall k (w :: k -> *) (a :: k) b. (w a -> b) -> Cokleisli w a b
Cokleisli ((w i -> k) -> Cokleisli w i k) -> (w i -> k) -> Cokleisli w i k
forall a b. (a -> b) -> a -> b
$ w j -> k
f (w j -> k) -> (w i -> w j) -> w i -> k
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (w i -> j) -> w i -> w j
forall (w :: * -> *) a b. Extend w => (w a -> b) -> w a -> w b
extended w i -> j
g
#endif

#ifdef MIN_VERSION_contravariant
instance Semigroupoid Op where
  Op k -> j
f o :: Op j k -> Op i j -> Op i k
`o` Op j -> i
g = (k -> i) -> Op i k
forall a b. (b -> a) -> Op a b
Op (j -> i
g (j -> i) -> (k -> j) -> k -> i
forall k (c :: k -> k -> *) (j :: k) (k :: k) (i :: k).
Semigroupoid c =>
c j k -> c i j -> c i k
`o` k -> j
f)
#endif

newtype WrappedCategory k a b = WrapCategory { WrappedCategory k a b -> k a b
unwrapCategory :: k a b }

instance Category k => Semigroupoid (WrappedCategory k) where
  WrapCategory k j k
f o :: WrappedCategory k j k
-> WrappedCategory k i j -> WrappedCategory k i k
`o` WrapCategory k i j
g = k i k -> WrappedCategory k i k
forall k k (k :: k -> k -> *) (a :: k) (b :: k).
k a b -> WrappedCategory k a b
WrapCategory (k j k
f k j k -> k i j -> k i k
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. k i j
g)

instance Category k => Category (WrappedCategory k) where
  id :: WrappedCategory k a a
id = k a a -> WrappedCategory k a a
forall k k (k :: k -> k -> *) (a :: k) (b :: k).
k a b -> WrappedCategory k a b
WrapCategory k a a
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
  WrapCategory k b c
f . :: WrappedCategory k b c
-> WrappedCategory k a b -> WrappedCategory k a c
. WrapCategory k a b
g = k a c -> WrappedCategory k a c
forall k k (k :: k -> k -> *) (a :: k) (b :: k).
k a b -> WrappedCategory k a b
WrapCategory (k b c
f k b c -> k a b -> k a c
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. k a b
g)

newtype Semi m a b = Semi { Semi m a b -> m
getSemi :: m }

instance Semigroup m => Semigroupoid (Semi m) where
  Semi m
m o :: Semi m j k -> Semi m i j -> Semi m i k
`o` Semi m
n = m -> Semi m i k
forall k k m (a :: k) (b :: k). m -> Semi m a b
Semi (m
m m -> m -> m
forall a. Semigroup a => a -> a -> a
<> m
n)

instance Monoid m => Category (Semi m) where
  id :: Semi m a a
id = m -> Semi m a a
forall k k m (a :: k) (b :: k). m -> Semi m a b
Semi m
forall a. Monoid a => a
mempty
  Semi m
m . :: Semi m b c -> Semi m a b -> Semi m a c
. Semi m
n = m -> Semi m a c
forall k k m (a :: k) (b :: k). m -> Semi m a b
Semi (m
m m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` m
n)

instance Semigroupoid Const where
  Const j k
_ o :: Const j k -> Const i j -> Const i k
`o` Const i
a = i -> Const i k
forall k a (b :: k). a -> Const a b
Const i
a

#ifdef MIN_VERSION_tagged
instance Semigroupoid Tagged where
  Tagged k
b o :: Tagged j k -> Tagged i j -> Tagged i k
`o` Tagged i j
_ = k -> Tagged i k
forall k (s :: k) b. b -> Tagged s b
Tagged k
b
#endif

#if MIN_VERSION_base(4,7,0)
instance Semigroupoid Co.Coercion where
  o :: Coercion j k -> Coercion i j -> Coercion i k
o = (Coercion i j -> Coercion j k -> Coercion i k)
-> Coercion j k -> Coercion i j -> Coercion i k
forall a b c. (a -> b -> c) -> b -> a -> c
flip Coercion i j -> Coercion j k -> Coercion i k
forall k (a :: k) (b :: k) (c :: k).
Coercion a b -> Coercion b c -> Coercion a c
Co.trans

instance Semigroupoid (Eq.:~:) where
  o :: (j :~: k) -> (i :~: j) -> i :~: k
o = ((i :~: j) -> (j :~: k) -> i :~: k)
-> (j :~: k) -> (i :~: j) -> i :~: k
forall a b c. (a -> b -> c) -> b -> a -> c
flip (i :~: j) -> (j :~: k) -> i :~: k
forall k (a :: k) (b :: k) (c :: k).
(a :~: b) -> (b :~: c) -> a :~: c
Eq.trans
#endif

#if MIN_VERSION_base(4,10,0)
instance Semigroupoid (Eq.:~~:) where
  o :: (j :~~: k) -> (i :~~: j) -> i :~~: k
o j :~~: k
Eq.HRefl i :~~: j
Eq.HRefl = i :~~: k
forall k1 (a :: k1). a :~~: a
Eq.HRefl
#endif