{-# LANGUAGE MultiParamTypeClasses, RankNTypes, DefaultSignatures #-}
-- |A module for functors
module SimpleH.Functor(
  Functor(..),Cofunctor(..),Bifunctor(..),
  
  Id(..),Const(..),Flip(..),Compose(..),FProd(..),Sum(..),

  (<$>),(|||),(<$),(<&>),void,left,right,
  promap,map2,map3
  ) where

import qualified Prelude as P

import SimpleH.Classes
import SimpleH.Core
import Data.Tree

class Cofunctor f where
  comap :: (a -> b) -> f b -> f a
instance (Functor f,Cofunctor g) => Cofunctor (Compose f g) where
  comap f (Compose c) = Compose (map (comap f) c)
instance Cofunctor (Flip (->) a) where
  comap f (Flip g) = Flip (g . f)
instance Bifunctor (->)

class Bifunctor p where
  dimap :: (c -> a) -> (b -> d) -> p a b -> p c d
  default dimap :: (Functor (p a),Cofunctor (Flip p d)) => (c -> a) -> (b -> d) -> p a b -> p c d
  dimap f g = promap f . map g

instance Functor [] where map f = f' where f' [] = [] ; f' (x:t) = f x:f' t
instance Functor Tree where
  map f (Node a subs) = Node (f a) (map (map f) subs)

-- |The Identity Functor
newtype Id a = Id { getId :: a }
             deriving Show
instance Unit Id where pure = Id
instance Functor Id
instance Applicative Id
instance Monad Id where Id a >>= k = k a

-- |The Constant Functor
newtype Const a b = Const { getConst :: a }
instance Semigroup (Const a b) where a+_ = a
instance Functor (Const a) where map _ (Const a) = Const a
instance Monoid a => Unit (Const a) where pure _ = Const zero
instance Monoid a => Applicative (Const a) where
  Const a <*> Const b = Const (a+b)

-- |A motherflippin' functor
newtype Flip f a b = Flip { unFlip :: f b a }

-- |The Composition functor
newtype Compose f g a = Compose { getCompose :: f (g a) }
instance (Unit f,Unit g) => Unit (Compose f g) where pure = Compose . pure . pure
instance (Functor f,Functor g) => Functor (Compose f g) where
  map f (Compose c) = Compose (map (map f) c)

newtype FProd f g a = FProd { getFProd :: f a:*:g a }
instance (Functor f,Functor g) => Functor (FProd f g) where
  map f = FProd . (map f <#> map f) . getFProd
newtype Sum f g a = Sum { getSum :: f a:+:g a }
instance (Functor f,Functor g) => Functor (Sum f g) where
  map f = Sum . (map f ||| map f) . getSum

instance Functor (Either b) where map f = Left <|> Right . f
instance Functor Maybe where map _ Nothing = Nothing; map f (Just a) = Just (f a)
instance Functor ((,) b) where map f ~(b,a) = (b,f a)
instance Functor ((->) a) where map = (.)
deriving instance Functor Interleave
deriving instance Functor OrdList

instance Functor IO where map = P.fmap
instance Applicative IO
instance Monad IO where (>>=) = (P.>>=)

(<$>) = map
(|||) :: (Choice k, Functor (k a), Functor (k b)) => k a c -> k b d -> k (a:+:b) (c:+:d)
f ||| g = Left<$>f <|> Right<$>g
x<&>f = map f x
(<$) :: Functor f => b -> f a -> f b
a <$ x = const a <$> x
infixr 3 <$>,<$
infixl 1 <&>
infixr 1 |||

left a = a ||| id
right a = id ||| a

void :: Functor f => f a -> f ()
void = (()<$)

map2 :: (Functor f, Functor f') => (a -> b) -> f (f' a) -> f (f' b)
map2 = map map map
map3 :: (Functor f, Functor f', Functor f'') => (a -> b) -> f (f' (f'' a)) -> f (f' (f'' b))
map3 = map.map2

promap :: Cofunctor (Flip f c) => (a -> b) -> f b c -> f a c
promap f c = unFlip (comap f (Flip c))