module Control.Categorical.Functor
( Functor(fmap)
, EndoFunctor
, LiftedFunctor(..)
, LoweredFunctor(..)
) where
import Control.Category
import Prelude hiding (id, (.), Functor(..))
import qualified Prelude
#ifdef GLASGOW_HASKELL
import Data.Data (Data(..), mkDataType, DataType, mkConstr, Constr, constrIndex, Fixity(..))
import Data.Typeable (Typeable1(..), TyCon, mkTyCon, mkTyConApp, gcast1)
#endif
newtype LiftedFunctor f a = LiftedFunctor (f a)
deriving (Show, Read)
#ifdef GLASGOW_HASKELL
liftedTyCon :: TyCon
liftedTyCon = mkTyCon "Control.Categorical.Functor.LiftedFunctor"
liftedConstr :: Constr
liftedConstr = mkConstr liftedDataType "LiftedFunctor" [] Prefix
liftedDataType :: DataType
liftedDataType = mkDataType "Control.Categorical.Fucntor.LiftedFunctor" [liftedConstr]
instance Typeable1 f => Typeable1 (LiftedFunctor f) where
typeOf1 tfa = mkTyConApp liftedTyCon [typeOf1 (undefined `asArgsType` tfa)]
where asArgsType :: f a -> t f a -> f a
asArgsType = const
instance (Typeable1 f, Data (f a), Data a) => Data (LiftedFunctor f a) where
gfoldl f z (LiftedFunctor a) = z LiftedFunctor `f` a
toConstr _ = liftedConstr
gunfold k z c = case constrIndex c of
1 -> k (z LiftedFunctor)
_ -> error "gunfold"
dataTypeOf _ = liftedDataType
dataCast1 f = gcast1 f
#endif
newtype LoweredFunctor f a = LoweredFunctor (f a)
deriving (Show, Read)
#ifdef GLASGOW_HASKELL
loweredTyCon :: TyCon
loweredTyCon = mkTyCon "Control.Categorical.Functor.LoweredFunctor"
loweredConstr :: Constr
loweredConstr = mkConstr loweredDataType "LoweredFunctor" [] Prefix
loweredDataType :: DataType
loweredDataType = mkDataType "Control.Categorical.Fucntor.LoweredFunctor" [loweredConstr]
instance Typeable1 f => Typeable1 (LoweredFunctor f) where
typeOf1 tfa = mkTyConApp loweredTyCon [typeOf1 (undefined `asArgsType` tfa)]
where asArgsType :: f a -> t f a -> f a
asArgsType = const
instance (Typeable1 f, Data (f a), Data a) => Data (LoweredFunctor f a) where
gfoldl f z (LoweredFunctor a) = z LoweredFunctor `f` a
toConstr _ = loweredConstr
gunfold k z c = case constrIndex c of
1 -> k (z LoweredFunctor)
_ -> error "gunfold"
dataTypeOf _ = loweredDataType
dataCast1 f = gcast1 f
#endif
class (Category r, Category t) => Functor f r t | f r -> t, f t -> r where
fmap :: r a b -> t (f a) (f b)
instance Functor f (->) (->) => Prelude.Functor (LoweredFunctor f) where
fmap f (LoweredFunctor a) = LoweredFunctor (Control.Categorical.Functor.fmap f a)
instance Prelude.Functor f => Functor (LiftedFunctor f) (->) (->) where
fmap f (LiftedFunctor a) = LiftedFunctor (Prelude.fmap f a)
instance Functor ((,) a) (->) (->) where
fmap f ~(a, b) = (a, f b)
instance Functor (Either a) (->) (->) where
fmap _ (Left a) = Left a
fmap f (Right a) = Right (f a)
instance Functor Maybe (->) (->) where
fmap = Prelude.fmap
instance Functor [] (->) (->) where
fmap = Prelude.fmap
instance Functor IO (->) (->) where
fmap = Prelude.fmap
class (Functor f (~>) (~>)) => EndoFunctor f (~>)
instance (Functor f (~>) (~>)) => EndoFunctor f (~>)