summaryrefslogtreecommitdiff
path: root/src/Data/Profunctor/Arrow.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Data/Profunctor/Arrow.hs')
-rw-r--r--src/Data/Profunctor/Arrow.hs111
1 files changed, 68 insertions, 43 deletions
diff --git a/src/Data/Profunctor/Arrow.hs b/src/Data/Profunctor/Arrow.hs
index 0391252..f57cb9e 100644
--- a/src/Data/Profunctor/Arrow.hs
+++ b/src/Data/Profunctor/Arrow.hs
@@ -1,37 +1,42 @@
{-# LANGUAGE GADTs #-}
-{-# LANGUAGE Arrows #-}
-{-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE ExistentialQuantification #-}
-module Data.Profunctor.Arrow where
+module Data.Profunctor.Arrow (
+ arr
+ , ex1
+ , ex2
+ , inl
+ , inr
+ , braid
+ , ebraid
+ , loop
+ , left
+ , right
+ , first
+ , second
+ , returnA
+ , (***)
+ , (+++)
+ , (&&&)
+ , (|||)
+ , ($$$)
+ , adivide
+ , adivide'
+ , adivided
+ , aselect
+ , aselect'
+ , aselected
+) where
-import Control.Arrow (Arrow)
import Control.Category hiding ((.), id)
import Data.Profunctor
import Data.Profunctor.Extra
import Prelude
-import qualified Control.Arrow as A
import qualified Control.Category as C
-newtype PArrow p a b = PArrow { runPArrow :: forall x y. p (b , x) y -> p (a , x) y }
-
-instance Profunctor p => Profunctor (PArrow p) where
- dimap f g (PArrow pp) = PArrow $ \p -> dimap (lft f) id (pp (dimap (lft g) id p))
- where lft h (a, b) = (h a, b)
-
-instance Profunctor p => Category (PArrow p) where
- id = PArrow id
-
- PArrow pp . PArrow qq = PArrow $ \r -> qq (pp r)
-
-instance Profunctor p => Strong (PArrow p) where
- first' (PArrow pp) = PArrow $ lmap assocr . pp . lmap assocl
-
-toArrow :: Arrow a => PArrow a b c -> a b c
-toArrow (PArrow aa) = A.arr (\x -> (x,())) >>> aa (A.arr fst)
-
-fromArrow :: Arrow a => a b c -> PArrow a b c
-fromArrow x = PArrow (\z -> A.first x >>> z)
-
+-- | Lift a function into a profunctor arrow.
+--
+-- Usable w/ arrow syntax w/ the /Arrows/ & /RebindableSyntax/ extensions.
+--
-- @
-- (a '>>>' b) '>>>' c = a '>>>' (b '>>>' c)
-- 'arr' f '>>>' a = 'dimap' f id a
@@ -41,36 +46,43 @@ fromArrow x = PArrow (\z -> A.first x >>> z)
--
arr :: Category p => Profunctor p => (a -> b) -> p a b
arr f = rmap f C.id
-
-preturn :: Category p => Profunctor p => p a a
-preturn = arr id
+{-# INLINE arr #-}
ex1 :: Category p => Profunctor p => p (a , b) b
ex1 = arr snd
+{-# INLINE ex1 #-}
ex2 :: Category p => Profunctor p => p (a , b) a
ex2 = arr fst
+{-# INLINE ex2 #-}
inl :: Category p => Profunctor p => p a (a + b)
inl = arr Left
+{-# INLINE inl #-}
inr :: Category p => Profunctor p => p b (a + b)
inr = arr Right
+{-# INLINE inr #-}
braid :: Category p => Profunctor p => p (a , b) (b , a)
-braid = arr swp
+braid = arr swap
+{-# INLINE braid #-}
-braide :: Category p => Profunctor p => p (a + b) (b + a)
-braide = arr eswp
+ebraid :: Category p => Profunctor p => p (a + b) (b + a)
+ebraid = arr eswap
+{-# INLINE ebraid #-}
loop :: Costrong p => p (a, d) (b, d) -> p a b
loop = unfirst
+{-# INLINE loop #-}
left :: Choice p => p a b -> p (a + c) (b + c)
left = left'
+{-# INLINE left #-}
right :: Choice p => p a b -> p (c + a) (c + b)
right = right'
+{-# INLINE right #-}
-- @
-- first ('arr' f) = 'arr' (f '***' id)
@@ -79,53 +91,66 @@ right = right'
--
first :: Strong p => p a b -> p (a , c) (b , c)
first = first'
+{-# INLINE first #-}
second :: Strong p => p a b -> p (c , a) (c , b)
second = second'
+{-# INLINE second #-}
returnA :: Category p => Profunctor p => p a a
returnA = C.id
+{-# INLINE returnA #-}
infixr 3 ***
(***) :: Category p => Strong p => p a1 b1 -> p a2 b2 -> p (a1 , a2) (b1 , b2)
-x *** y = first x >>> arr swp >>> first y >>> arr swp
+x *** y = first x >>> arr swap >>> first y >>> arr swap
+{-# INLINE (***) #-}
infixr 2 +++
(+++) :: Category p => Choice p => p a1 b1 -> p a2 b2 -> p (a1 + a2) (b1 + b2)
-x +++ y = left x >>> arr eswp >>> left y >>> arr eswp
+x +++ y = left x >>> arr eswap >>> left y >>> arr eswap
+{-# INLINE (+++) #-}
infixr 3 &&&
(&&&) :: Category p => Strong p => p a b1 -> p a b2 -> p a (b1 , b2)
x &&& y = dimap fork id $ x *** y
+{-# INLINE (&&&) #-}
infixr 2 |||
(|||) :: Category p => Choice p => p a1 b -> p a2 b -> p (a1 + a2) b
-x ||| y = achoose id x y
+x ||| y = dimap id join $ x +++ y
+{-# INLINE (|||) #-}
infixr 0 $$$
($$$) :: Category p => Strong p => p a (b -> c) -> p a b -> p a c
($$$) f x = dimap fork apply (f *** x)
+{-# INLINE ($$$) #-}
-achoose :: Category p => Choice p => (a -> (a1 + a2)) -> p a1 b -> p a2 b -> p a b
-achoose f x y = dimap f join $ x +++ y
-
--- | Profunctor arrow equivalent of 'Data.Functor.Divisible.divide'.
---
adivide :: Category p => Strong p => (a -> (a1 , a2)) -> p a1 b -> p a2 b -> p a b
adivide f x y = dimap f fst $ x *** y
+{-# INLINE adivide #-}
-aselect :: Category p => Choice p => ((b1 + b2) -> b) -> p a b1 -> p a b2 -> p a b
-aselect f x y = dimap Left f $ x +++ y
+adivide' :: Category p => Strong p => p a b -> p a b -> p a b
+adivide' = adivide fork
+{-# INLINE adivide' #-}
--- | Profunctor arrow equivalent of 'Data.Functor.Divisible.divided'.
---
adivided :: Category p => Strong p => p a1 b -> p a2 b -> p (a1 , a2) b
adivided = adivide id
+{-# INLINE adivided #-}
+
+aselect :: Category p => Choice p => ((b1 + b2) -> b) -> p a b1 -> p a b2 -> p a b
+aselect f x y = dimap Left f $ x +++ y
+{-# INLINE aselect #-}
+
+aselect' :: Category p => Choice p => p a b -> p a b -> p a b
+aselect' = aselect join
+{-# INLINE aselect' #-}
aselected :: Category p => Choice p => p a b1 -> p a b2 -> p a (b1 + b2)
aselected = aselect id
+{-# INLINE aselected #-}