summaryrefslogtreecommitdiff
path: root/src/Data/Profunctor/Cayley.hs
blob: 24ddd1952df3f562f135c677ee145f668963ee0e (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE Trustworthy #-}
-----------------------------------------------------------------------------
-- |
-- Copyright   :  (C) 2014-2015 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
--
----------------------------------------------------------------------------

module Data.Profunctor.Cayley where

import Control.Applicative
import Control.Arrow
import Control.Category
import Control.Comonad
import Data.Profunctor
import Data.Profunctor.Monad
import Data.Profunctor.Traversing
import Data.Profunctor.Unsafe
import Prelude hiding ((.), id)

-- static arrows
newtype Cayley f p a b = Cayley { runCayley :: f (p a b) }

instance Functor f => ProfunctorFunctor (Cayley f) where
  promap f (Cayley p) = Cayley (fmap f p)

-- | Cayley transforms Monads in @Hask@ into monads on @Prof@
instance (Functor f, Monad f) => ProfunctorMonad (Cayley f) where
  proreturn = Cayley . return
  projoin (Cayley m) = Cayley $ m >>= runCayley

-- | Cayley transforms Comonads in @Hask@ into comonads on @Prof@
instance Comonad f => ProfunctorComonad (Cayley f) where
  proextract = extract . runCayley
  produplicate (Cayley w) = Cayley $ extend Cayley w

instance (Functor f, Profunctor p) => Profunctor (Cayley f p) where
  dimap f g = Cayley . fmap (dimap f g) . runCayley
  lmap f = Cayley . fmap (lmap f) . runCayley
  rmap g = Cayley . fmap (rmap g) . runCayley
  w #. Cayley fp = Cayley $ fmap (w #.) fp
  Cayley fp .# w = Cayley $ fmap (.# w) fp

instance (Functor f, Strong p) => Strong (Cayley f p) where
  first'  = Cayley . fmap first' . runCayley
  second' = Cayley . fmap second' . runCayley

instance (Functor f, Costrong p) => Costrong (Cayley f p) where
  unfirst (Cayley fp) = Cayley (fmap unfirst fp)
  unsecond (Cayley fp) = Cayley (fmap unsecond fp)

instance (Functor f, Choice p) => Choice (Cayley f p) where
  left'   = Cayley . fmap left' . runCayley
  right'  = Cayley . fmap right' . runCayley

instance (Functor f, Cochoice p) => Cochoice (Cayley f p) where
  unleft (Cayley fp) = Cayley (fmap unleft fp)
  {-# INLINE unleft #-}
  unright (Cayley fp) = Cayley (fmap unright fp)
  {-# INLINE unright #-}

instance (Functor f, Closed p) => Closed (Cayley f p) where
  closed = Cayley . fmap closed . runCayley

instance (Functor f, Traversing p) => Traversing (Cayley f p) where
  traverse' = Cayley . fmap traverse' . runCayley

instance (Functor f, Mapping p) => Mapping (Cayley f p) where
  map' = Cayley . fmap map' . runCayley

instance (Applicative f, Category p) => Category (Cayley f p) where
  id = Cayley $ pure id
  Cayley fpbc . Cayley fpab = Cayley $ liftA2 (.) fpbc fpab

instance (Applicative f, Arrow p) => Arrow (Cayley f p) where
  arr f = Cayley $ pure $ arr f
  first = Cayley . fmap first . runCayley
  second = Cayley . fmap second . runCayley
  Cayley ab *** Cayley cd = Cayley $ liftA2 (***) ab cd
  Cayley ab &&& Cayley ac = Cayley $ liftA2 (&&&) ab ac

instance (Applicative f, ArrowChoice p) => ArrowChoice (Cayley f p) where
  left  = Cayley . fmap left . runCayley
  right = Cayley . fmap right . runCayley
  Cayley ab +++ Cayley cd = Cayley $ liftA2 (+++) ab cd
  Cayley ac ||| Cayley bc = Cayley $ liftA2 (|||) ac bc

instance (Applicative f, ArrowLoop p) => ArrowLoop (Cayley f p) where
  loop = Cayley . fmap loop . runCayley

instance (Applicative f, ArrowZero p) => ArrowZero (Cayley f p) where
  zeroArrow = Cayley $ pure zeroArrow

instance (Applicative f, ArrowPlus p) => ArrowPlus (Cayley f p) where
  Cayley f <+> Cayley g = Cayley (liftA2 (<+>) f g)

mapCayley :: (forall a. f a -> g a) -> Cayley f p x y -> Cayley g p x y
mapCayley f (Cayley g) = Cayley (f g)

-- instance Adjunction f g => ProfunctorAdjunction (Cayley f) (Cayley g) where

{-
newtype Uncayley p a = Uncayley (p () a)

instance Profunctor p => Functor (Uncayley p) where
  fmap f (Uncayley p) = Uncayley (rmap f p)

smash :: Strong p => Cayley (Uncayley p) (->) a b -> p a b
smash (Cayley (Uncayley pab)) = dimap ((,)()) (uncurry id) (first' pab)

unsmash :: Closed p => p a b -> Cayley (Uncayley p) (->) a b
unsmash = Cayley . Uncayley . curry' . lmap snd

type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)

-- pastro and street's strong tambara module
class (Strong p, Closed p) => Stronger p

-- only a true iso for Stronger p and q, no?
_Smash :: (Strong p, Closed q) => Iso
  (Cayley (Uncayley p) (->) a b)
  (Cayley (Uncayley q) (->) c d)
  (p a b)
  (q c d)
_Smash = dimap hither (fmap yon) where
  hither (Cayley (Uncayley pab)) = dimap ((,)()) (uncurry id) (first' pab)
  yon = Cayley . Uncayley . curry' . lmap snd

fsmash :: (forall x y. p x y -> q x y) -> Cayley (Uncayley p) (->) a b -> Cayley (Uncayley q) (->) a b
fsmash f (Cayley (Uncayley puab)) = Cayley (Uncayley (f puab))

-- | proposition 4.3 from pastro and street is that fsmash and funsmash form an equivalence of categories
funsmash :: (Closed p, Strong q) => (forall x y. Cayley (Uncayley p) (->) x y -> Cayley (Uncayley q) (->) x y) -> p a b -> q a b
funsmash k = smash . k . unsmash
-}