{-# LANGUAGE FlexibleInstances #-}
-- |A module for functors
module Clean.Functor(
  Functor(..),Cofunctor(..),
  
  Id(..),Const(..),Flip(..),Compose(..),

  (<$>),(<$),(<&>),void,
  promap
  ) where

import qualified Prelude as P

import Clean.Classes
import Clean.Core
import Data.Tree

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

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 instance Semigroup a => Semigroup (Id a)
deriving instance Monoid w => Monoid (Id w)
deriving instance Ring w => Ring (Id w)
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 }
deriving instance Semigroup w => Semigroup (Const w a)
deriving instance Monoid a => Monoid (Const a b)
instance Unit (Const a) where pure _ = Const undefined
instance Functor (Const a)
instance Applicative (Const a)
instance Monad (Const a) where Const a >>= _ = Const a

-- |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 Product f g a = Product { getProduct :: f a:*:g a }
instance (Functor f,Functor g) => Functor (Product f g) where
  map f = Product . (map f <#> map f) . getProduct
newtype Sum f g a = Sum { getSum :: f a:+:g a }
instance (Functor f,Functor g) => Functor (Sum f g) where
  map f = Sum . (Left<$>map f <|> Right<$>map f) . getSum

instance Functor (Either b) where map f = Left <|> Right . f
instance Functor ((,) b) where map f (b,a) = (b,f a)
instance Functor ((->) a) where map = (.)
deriving instance Functor Interleave

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

(<$>) = map
x<&>f = map f x
a <$ x = const a <$> x

void :: Functor f => f a -> f ()
void = map (const ())