{-# LANGUAGE DefaultSignatures, TupleSections #-}
module SimpleH.Arrow (
  module SimpleH.Monad,
  
  Arrow(..),
  (>>^),(^>>),

  Apply(..),comapA,app,dup,

  Kleisli(..),

  ListA(..)
  ) where

import SimpleH.Core hiding (flip)
import SimpleH.Classes
import SimpleH.Monad
import SimpleH.Foldable

(^>>) = promap
(>>^) = (<&>)
infixr 4 ^>>,>>^
dup = arr (\a -> (a,a))

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

comapA f (Flip g) = Flip (arr f >>> g)
app f = arr (f,) >>> apply

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)

newtype ListA k a b = ListA { runListA :: k [a] [b] }
instance Category k => Category (ListA k) where
  id = ListA id
  ListA a . ListA b = ListA (a . b)
instance Arrow k => Choice (ListA k) where
  ListA f <|> ListA g = ListA (arr partitionEithers >>> (f<#>g) >>> arr (uncurry (+)))
instance Arrow k => Split (ListA k) where
  ListA f <#> ListA g = ListA (arr (\l -> (fst<$>l,snd<$>l)) >>> (f<#>g)
                               >>> arr (\(c,d) -> (,)<$>c<*>d))
instance Arrow k => Arrow (ListA k) where
  arr f = ListA (arr (map f))