{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE Trustworthy #-}

-----------------------------------------------------------------------------
-- |
-- 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 Control.Category
import Data.Functor.Bind
import Data.Semigroup
import qualified Data.Type.Coercion as Co
import qualified Data.Type.Equality as Eq
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

-- | '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 :: forall j k i. (j -> k) -> (i -> j) -> i -> k
o = 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 :: forall j k i. (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 :: forall j k i. Kleisli m j k -> Kleisli m i j -> Kleisli m i k
`o` Kleisli i -> m j
f = forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli forall a b. (a -> b) -> a -> b
$ \i
a -> i -> m j
f i
a 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 :: forall j k i. Cokleisli w j k -> Cokleisli w i j -> Cokleisli w i k
`o` Cokleisli w i -> j
g = forall {k} (w :: k -> *) (a :: k) b. (w a -> b) -> Cokleisli w a b
Cokleisli forall a b. (a -> b) -> a -> b
$ w j -> k
f forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. 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 :: forall j k i. Op j k -> Op i j -> Op i k
`o` Op j -> i
g = forall a b. (b -> a) -> Op a b
Op (j -> i
g 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 { forall {k} {k} (k :: k -> k -> *) (a :: k) (b :: k).
WrappedCategory k a b -> k a b
unwrapCategory :: k a b }

instance Category k => Semigroupoid (WrappedCategory k) where
  WrapCategory k j k
f o :: forall (j :: k) (k :: k) (i :: k).
WrappedCategory k j k
-> WrappedCategory k i j -> WrappedCategory k i k
`o` WrapCategory k i j
g = forall {k} {k} (k :: k -> k -> *) (a :: k) (b :: k).
k a b -> WrappedCategory k a b
WrapCategory (k j k
f 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 :: forall (a :: k). WrappedCategory k a a
id = forall {k} {k} (k :: k -> k -> *) (a :: k) (b :: k).
k a b -> WrappedCategory k a b
WrapCategory forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
  WrapCategory k b c
f . :: forall (b :: k) (c :: k) (a :: k).
WrappedCategory k b c
-> WrappedCategory k a b -> WrappedCategory k a c
. WrapCategory k a b
g = forall {k} {k} (k :: k -> k -> *) (a :: k) (b :: k).
k a b -> WrappedCategory k a b
WrapCategory (k b c
f 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 { forall {k} {k} m (a :: k) (b :: k). Semi m a b -> m
getSemi :: m }

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

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

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

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

instance Semigroupoid Co.Coercion where
  o :: forall (j :: k) (k :: k) (i :: k).
Coercion j k -> Coercion i j -> Coercion i k
o = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall {k} (a :: k) (b :: k) (c :: k).
Coercion a b -> Coercion b c -> Coercion a c
Co.trans

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

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