{-# LANGUAGE DefaultSignatures, TupleSections #-}
module Clean.Arrow (
  Arrow(..),
  (>>>),(<<<),(>>^),(^>>),(|||),

  Apply(..),app,

  Kleisli(..)
  ) where

import Clean.Core hiding (flip)
import Clean.Classes
import Clean.Monad
import Clean.Traversable
import Clean.Lens

(>>>) = flip (.)
(<<<) = (.)
(^>>) = promap
(>>^) = (<&>)
infixr 4 >>>,<<<,^>>,>>^

class (Split k,Choice k) => Arrow k where
  arr :: (a -> b) -> k a b
instance Arrow (->) where arr = id
class Arrow k => Apply k where
  apply :: k (k a b,a) b
instance Apply (->) where apply (f,x) = f x
instance Arrow k => Cofunctor (Flip k a) where
  comap f (Flip g) = Flip (arr f >>> g)
app f = arr (f,) >>> apply

a ||| b = (Left<$>a) <|> (Right<$>b)

instance (Monad f,Contravariant f,Monad g) => Monad (Compose f g) where
  join = map getCompose >>> getCompose >>> map collect
         >>> join >>> map join >>> Compose

kc = iso (Compose . runKleisli) (Kleisli . getCompose)
kc' = iso (Kleisli . getCompose) (Compose . runKleisli)
newtype Kleisli m a b = Kleisli { runKleisli :: a -> m b }
instance Unit m => Unit (Kleisli m a) where pure = Kleisli . const . pure 
instance Functor f => Functor (Kleisli f a) where map f m = m ^. kc.lam (map f).kc'
instance Monad m => Applicative (Kleisli m a)
instance Monad m => Monad (Kleisli m a) where join m = m ^. kc.lam (join . map (^.kc)).kc'

instance Monad m => Category (Kleisli m) where
  id = Kleisli pure
  Kleisli f . Kleisli g = Kleisli (\a -> g a >>= f)
instance Monad m => Choice (Kleisli m) where
  Kleisli f <|> Kleisli g = Kleisli (f <|> g)
instance Monad m => Split (Kleisli m) where
  Kleisli f <#> Kleisli g = Kleisli (\(a,c) -> (,)<$>f a<*>g c)
instance Monad m => Apply (Kleisli m) where
  apply = Kleisli (\(Kleisli f,a) -> f a)
instance Monad m => Arrow (Kleisli m) where
  arr a = Kleisli (pure . a)