#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702
#endif
module Data.Profunctor
(
Profunctor(dimap,lmap,rmap)
, Lenticular(..)
, Prismatic(..)
, UpStar(..)
, DownStar(..)
, WrappedArrow(..)
) where
import Control.Applicative hiding (WrappedArrow(..))
import Control.Arrow
import Control.Category
import Control.Comonad (Cokleisli(..))
import Data.Tagged
import Data.Traversable
import Data.Profunctor.Unsafe
import Prelude hiding (id,(.),sequence)
import Unsafe.Coerce
newtype UpStar f d c = UpStar { runUpStar :: d -> f c }
instance Functor f => Profunctor (UpStar f) where
dimap ab cd (UpStar bfc) = UpStar (fmap cd . bfc . ab)
lmap k (UpStar f) = UpStar (f . k)
rmap k (UpStar f) = UpStar (fmap k . f)
p .# _ = unsafeCoerce p
instance Functor f => Functor (UpStar f a) where
fmap = rmap
newtype DownStar f d c = DownStar { runDownStar :: f d -> c }
instance Functor f => Profunctor (DownStar f) where
dimap ab cd (DownStar fbc) = DownStar (cd . fbc . fmap ab)
lmap k (DownStar f) = DownStar (f . fmap k)
rmap k (DownStar f) = DownStar (k . f)
( #. ) _ = unsafeCoerce
instance Functor (DownStar f a) where
fmap k (DownStar f) = DownStar (k . f)
newtype WrappedArrow p a b = WrapArrow { unwrapArrow :: p a b }
instance Category p => Category (WrappedArrow p) where
WrapArrow f . WrapArrow g = WrapArrow (f . g)
id = WrapArrow id
instance Arrow p => Arrow (WrappedArrow p) where
arr = WrapArrow . arr
first = WrapArrow . first . unwrapArrow
second = WrapArrow . second . unwrapArrow
WrapArrow a *** WrapArrow b = WrapArrow (a *** b)
WrapArrow a &&& WrapArrow b = WrapArrow (a &&& b)
instance ArrowZero p => ArrowZero (WrappedArrow p) where
zeroArrow = WrapArrow zeroArrow
instance ArrowChoice p => ArrowChoice (WrappedArrow p) where
left = WrapArrow . left . unwrapArrow
right = WrapArrow . right . unwrapArrow
WrapArrow a +++ WrapArrow b = WrapArrow (a +++ b)
WrapArrow a ||| WrapArrow b = WrapArrow (a ||| b)
instance ArrowApply p => ArrowApply (WrappedArrow p) where
app = WrapArrow $ app . arr (first unwrapArrow)
instance ArrowLoop p => ArrowLoop (WrappedArrow p) where
loop = WrapArrow . loop . unwrapArrow
instance Arrow p => Profunctor (WrappedArrow p) where
lmap = (^>>)
rmap = (^<<)
class Profunctor p => Lenticular p where
lenticular :: p a b -> p a (a, b)
instance Lenticular (->) where
lenticular f a = (a, f a)
instance Monad m => Lenticular (Kleisli m) where
lenticular (Kleisli f) = Kleisli $ \ a -> do
b <- f a
return (a, b)
instance Functor m => Lenticular (UpStar m) where
lenticular (UpStar f) = UpStar $ \ a -> (,) a <$> f a
instance Arrow p => Lenticular (WrappedArrow p) where
lenticular (WrapArrow k) = WrapArrow (id &&& k)
class Profunctor p => Prismatic p where
prismatic :: p a b -> p (Either b a) b
instance Prismatic (->) where
prismatic = either id
instance Monad m => Prismatic (Kleisli m) where
prismatic (Kleisli pab) = Kleisli (either return pab)
instance Traversable w => Prismatic (Cokleisli w) where
prismatic (Cokleisli wab) = Cokleisli (either id wab . sequence)
instance Traversable w => Prismatic (DownStar w) where
prismatic (DownStar wab) = DownStar (either id wab . sequence)
instance Prismatic Tagged where
prismatic = retag
instance ArrowChoice p => Prismatic (WrappedArrow p) where
prismatic (WrapArrow k) = WrapArrow (id ||| k)