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)
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
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)
newtype Flip f a b = Flip { unFlip :: f b a }
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))