profunctor-arrows 0.0.0.1 → 0.0.0.2

raw patch · 5 files changed

+267/−113 lines, 5 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−0
• profunctor-arrows.cabal +2/−1
• src/Data/Profunctor/Arrow.hs +68/−43
• src/Data/Profunctor/Arrow/Free.hs +29/−2
• src/Data/Profunctor/Extra.hs +163/−67

@@ -0,0 +1,5 @@+# Revision history for dioids++## 0.0.1  -- YYYY-mm-dd++* First version. Released on an unsuspecting world.

@@ -1,7 +1,7 @@ cabal-version: >= 1.10  name:           profunctor-arrows-version:        0.0.0.1+version:        0.0.0.2 synopsis:       Profunctor arrows description:    Free prearrows and arrows for profunctors. category:       Data, Profunctors@@ -13,6 +13,7 @@ license:        BSD3 license-file:   LICENSE build-type:     Simple+extra-source-files:  ChangeLog.md  source-repository head   type: git

@@ -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 @@ -- 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 @@ -- 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)--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+{-# INLINE ($$$) #-} --- | 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 #-}

@@ -1,17 +1,42 @@ {-# LANGUAGE GADTs #-}-{-# LANGUAGE Arrows #-}-{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE ExistentialQuantification #-} module Data.Profunctor.Arrow.Free where +import Control.Arrow (Arrow) import Control.Category hiding ((.), id) import Data.Profunctor import Data.Profunctor.Arrow+import Data.Profunctor.Extra import Data.Profunctor.Traversing+import qualified Control.Arrow as A import qualified Control.Category as C  import Prelude +-- | Lift a profunctor into an 'Arrow' cofreely.+--+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)+{-# INLINE toArrow #-}++fromArrow :: Arrow a => a b c -> PArrow a b c+fromArrow x = PArrow (\z -> A.first x >>> z)+{-# INLINE fromArrow #-}+ -- | Free monoid in the category of profunctors. -- -- See <https://arxiv.org/abs/1406.4823> section 6.2.@@ -55,11 +80,13 @@ foldFree :: Category q => Profunctor q => p :-> q -> Free p a b -> q a b foldFree _ (Parr ab) = arr ab foldFree pq (Free p f) = pq p <<< foldFree pq f+{-# INLINE foldFree  #-}  -- | Lift a natural transformation from @f@ to @g@ into a natural transformation from @'Free' f@ to @'Free' g@. hoistFree :: p :-> q -> Free p a b -> Free q a b hoistFree _ (Parr ab)  = Parr ab hoistFree pq (Free p f) = Free (pq p) (hoistFree pq f)+{-# INLINE hoistFree #-}  -- Analog of 'Const' for pliftows newtype Append r a b = Append { getAppend :: r }

@@ -1,5 +1,64 @@-module Data.Profunctor.Extra where+module Data.Profunctor.Extra (+    type (+)+  , rgt+  , rgt'+  , lft+  , lft'+  , swap+  , eswap+  , fork+  , join+  , eval+  , apply+  , coeval +  , branch+  , branch'+  , assocl+  , assocr+  , assocl' +  , assocr'+  , eassocl+  , eassocr+  , eassocr'+  , forget1+  , forget2+  , forgetl+  , forgetr+  , unarr+  , peval +  , constl+  , constr+  , shiftl+  , shiftr+  , coercel +  , coercer+  , coercel'+  , coercer'+  , strong +  , costrong+  , choice+  , cochoice+  , pull+  , repn+  , corepn+  , star+  , toStar+  , fromStar +  , costar+  , uncostar+  , toCostar+  , fromCostar+  , pushr+  , pushl +  , pliftA+  , pdivide+  , pappend+  , (<<*>>)+  , (****)+  , (&&&&)+) where +import Control.Applicative (liftA2) import Control.Arrow ((|||),(&&&)) import Control.Category (Category) import Control.Comonad (Comonad(..))@@ -8,6 +67,7 @@ import Data.Profunctor import Data.Profunctor.Rep import Data.Profunctor.Sieve+import Data.Tuple (swap) import Data.Void import Prelude import qualified Control.Category as C (id)@@ -19,194 +79,230 @@  rgt :: (a -> b) -> a + b -> b rgt f = either f id- +{-# INLINE rgt #-}+ rgt' :: Void + b -> b rgt' = rgt absurd +{-# INLINE rgt' #-}  lft :: (b -> a) -> a + b -> a lft f = either id f+{-# INLINE lft #-}  lft' :: a + Void -> a lft' = lft absurd--swp :: (a1 , a2) -> (a2 , a1)-swp = snd &&& fst+{-# INLINE lft' #-} -eswp :: (a1 + a2) -> (a2 + a1)-eswp = Right ||| Left+eswap :: (a1 + a2) -> (a2 + a1)+eswap = Right ||| Left+{-# INLINE eswap #-}  fork :: a -> (a , a) fork = M.join (,)+{-# INLINE fork #-}  join :: (a + a) -> a join = M.join either id+{-# INLINE join #-}  eval :: (a , a -> b) -> b eval = uncurry $ flip id+{-# INLINE eval #-}  apply :: (b -> a , b) -> a apply = uncurry id+{-# INLINE apply #-}  coeval :: b -> (b -> a) + a -> a coeval b = either ($ b) id+{-# INLINE coeval #-}  branch :: (a -> Bool) -> b -> c -> a -> b + c branch f y z x = if f x then Right z else Left y+{-# INLINE branch #-}  branch' :: (a -> Bool) -> a -> a + a branch' f x = branch f x x x+{-# INLINE branch' #-}  assocl :: (a , (b , c)) -> ((a , b) , c) assocl (a, (b, c)) = ((a, b), c)+{-# INLINE assocl #-}  assocr :: ((a , b) , c) -> (a , (b , c)) assocr ((a, b), c) = (a, (b, c))+{-# INLINE assocr #-} -eassocl :: (a + (b + c)) -> ((a + b) + c)+assocl' :: (a , b + c) -> (a , b) + c+assocl' = eswap . traverse eswap+{-# INLINE assocl' #-}++assocr' :: (a + b , c) -> a + (b , c)+assocr' (f, b) = fmap (,b) f+{-# INLINE assocr' #-}++eassocl :: a + (b + c) -> (a + b) + c eassocl (Left a)          = Left (Left a) eassocl (Right (Left b))  = Left (Right b) eassocl (Right (Right c)) = Right c+{-# INLINE eassocl #-} -eassocr :: ((a + b) + c) -> (a + (b + c))+eassocr :: (a + b) + c -> a + (b + c) eassocr (Left (Left a))  = Left a eassocr (Left (Right b)) = Right (Left b) eassocr (Right c)        = Right (Right c)--fstrong :: Functor f => f a -> b -> f (a , b)-fstrong f b = fmap (,b) f+{-# INLINE eassocr #-} -fchoice :: Traversable f => f (a + b) -> (f a) + b-fchoice = eswp . traverse eswp+eassocr' :: (a -> b) + c -> a -> b + c+eassocr' abc a = either (\ab -> Left $ ab a) Right abc+{-# INLINE eassocr' #-} -forget1 :: ((c , a) -> (c , b)) -> a -> b+forget1 :: ((c, a) -> (c, b)) -> a -> b forget1 f a = b where (c, b) = f (c, a)+{-# INLINE forget1 #-} -forget2 :: ((a , c) -> (b , c)) -> a -> b+forget2 :: ((a, c) -> (b, c)) -> a -> b forget2 f a = b where (b, c) = f (a, c)+{-# INLINE forget2 #-} -forgetl :: ((c + a) -> (c + b)) -> a -> b+forgetl :: (c + a -> c + b) -> a -> b forgetl f = go . Right where go = either (go . Left) id . f+{-# INLINE forgetl #-} -forgetr :: ((a + c) -> (b + c)) -> a -> b+forgetr :: (a + c -> b + c) -> a -> b forgetr f = go . Left where go = either id (go . Right) . f+{-# INLINE forgetr #-}  unarr :: Comonad w => Sieve p w => p a b -> a -> b  unarr = (extract .) . sieve+{-# INLINE unarr #-}  peval :: Strong p => p a (a -> b) -> p a b peval = rmap eval . pull+{-# INLINE peval #-}  constl :: Profunctor p => b -> p b c -> p a c constl = lmap . const+{-# INLINE constl #-}  constr :: Profunctor p => c -> p a b -> p a c constr = rmap . const+{-# INLINE constr #-}  shiftl :: Profunctor p => p (a + b) c -> p b (c + d) shiftl = dimap Right Left+{-# INLINE shiftl #-}  shiftr :: Profunctor p => p b (c , d) -> p (a , b) c shiftr = dimap snd fst--coercer :: Profunctor p => Contravariant (p a) => p a b -> p a c-coercer = rmap absurd . contramap absurd--coercer' :: Representable p => Contravariant (Rep p) => p a b -> p a c-coercer' = lift (phantom .)+{-# INLINE shiftr #-}  coercel :: Profunctor p => Bifunctor p => p a b -> p c b coercel = first absurd . lmap absurd+{-# INLINE coercel #-} +coercer :: Profunctor p => Contravariant (p a) => p a b -> p a c+coercer = rmap absurd . contramap absurd+{-# INLINE coercer #-}+ coercel' :: Corepresentable p => Contravariant (Corep p) => p a b -> p c b-coercel' = lower (. phantom)+coercel' = corepn (. phantom)+{-# INLINE coercel' #-} +coercer' :: Representable p => Contravariant (Rep p) => p a b -> p a c+coercer' = repn (phantom .)+{-# INLINE coercer' #-}+ strong :: Strong p => ((a , b) -> c) -> p a b -> p a c strong f = dimap fork f . second'+{-# INLINE strong #-}  costrong :: Costrong p => ((a , b) -> c) -> p c a -> p b a costrong f = unsecond . dimap f fork+{-# INLINE costrong #-}  choice :: Choice p => (c -> (a + b)) -> p b a -> p c a choice f = dimap f join . right'+{-# INLINE choice #-}  cochoice :: Cochoice p => (c -> (a + b)) -> p a c -> p a b cochoice f = unright . dimap join f+{-# INLINE cochoice #-}  pull :: Strong p => p a b -> p a (a , b) pull = lmap fork . second'--pull' :: Strong p => p b c -> p (a , b) b-pull' = shiftr . pull+{-# INLINE pull #-} -lift :: Representable p => ((a -> Rep p b) -> s -> Rep p t) -> p a b -> p s t-lift f = tabulate . f . sieve+repn :: Representable p => ((a -> Rep p b) -> s -> Rep p t) -> p a b -> p s t+repn f = tabulate . f . sieve+{-# INLINE repn #-} -lower :: Corepresentable p => ((Corep p a -> b) -> Corep p s -> t) -> p a b -> p s t-lower f = cotabulate . f . cosieve+corepn :: Corepresentable p => ((Corep p a -> b) -> Corep p s -> t) -> p a b -> p s t+corepn f = cotabulate . f . cosieve+{-# INLINE corepn #-}  star :: Applicative f => Star f a a star = Star pure+{-# INLINE star #-}  toStar :: Sieve p f => p d c -> Star f d c toStar = Star . sieve+{-# INLINE toStar #-}  fromStar :: Representable p => Star (Rep p) a b -> p a b fromStar = tabulate . runStar+{-# INLINE fromStar #-}  costar :: Foldable f => Monoid b => (a -> b) -> Costar f a b costar f = Costar (foldMap f)+{-# INLINE costar #-}  uncostar :: Applicative f => Costar f a b -> a -> b uncostar f = runCostar f . pure+{-# INLINE uncostar #-}  toCostar :: Cosieve p f => p a b -> Costar f a b toCostar = Costar . cosieve+{-# INLINE toCostar #-}  fromCostar :: Corepresentable p => Costar (Corep p) a b -> p a b fromCostar = cotabulate . runCostar+{-# INLINE fromCostar #-} -pushr :: Closed p => (forall x. Applicative (p x)) => p (a , b) c -> p a b -> p a c-pushr = papply . curry' +pushr :: Closed p => Representable p => Applicative (Rep p) => p (a , b) c -> p a b -> p a c+pushr = (<<*>>) . curry' +{-# INLINE pushr #-} -pushl :: Closed p => (forall x. Applicative (p x)) => p a c -> p b c -> p a (b -> c)-pushl f g = curry' $ pdivided f g+pushl :: Closed p => Representable p => Applicative (Rep p) => p a c -> p b c -> p a (b -> c)+pushl p q = curry' $ pdivide id p q+{-# INLINE pushl #-} -ppure :: Profunctor p => (forall x. Applicative (p x)) => b -> p a b-ppure b = dimap (const ()) (const b) $ pure ()+pliftA :: Representable p => Applicative (Rep p) => (b -> c -> d) -> p a b -> p a c -> p a d+pliftA f x y = tabulate $ \s -> liftA2 f (sieve x s) (sieve y s)+{-# INLINE pliftA #-} ---pabsurd :: Profunctor p => (forall x. Divisible (p x)) => p Void a---pabsurd = rmap absurd $ conquer+infixl 4 <<*>> -infixr 3 @@@+(<<*>>) :: Representable p => Applicative (Rep p) => p a (b -> c) -> p a b -> p a c+(<<*>>) = pliftA ($)+{-# INLINE (<<*>>) #-} --- | Profunctor version of '***' from 'Control.Arrow'.------ @--- p <*> x ≡ dimap fork eval (p @@@ x)--- @----(@@@) :: Profunctor p => (forall x. Applicative (p x)) => p a1 b1 -> p a2 b2 -> p (a1 , a2) (b1 , b2)-f @@@ g = pappend f g+infixr 3 **** -pappend :: Profunctor p => (forall x. Applicative (p x)) => p a1 b1 -> p a2 b2 -> p (a1 , a2) (b1 , b2)-pappend f g = dimap fst (,) f <*> lmap snd g+(****) :: Representable p => Applicative (Rep p) => p a1 b1 -> p a2 b2 -> p (a1 , a2) (b1 , b2)+p **** q = dimap fst (,) p <<*>> lmap snd q+{-# INLINE (****) #-} --- | Profunctor equivalent of 'Data.Functor.Divisible.divide'.----pdivide :: Profunctor p => (forall x. Applicative (p x)) => (a -> (a1 , a2)) -> p a1 b -> p a2 b -> p a b-pdivide f x y = dimap f fst $ x @@@ y+infixr 3 &&&& --- | Profunctor equivalent of 'Data.Functor.Divisible.divided'.----pdivided :: Profunctor p => (forall x. Applicative (p x)) => p a1 b -> p a2 b -> p (a1 , a2) b-pdivided = pdivide id+(&&&&) ::  Representable p => Applicative (Rep p) => p a b1 -> p a b2 -> p a (b1 , b2)+p &&&& q = pliftA (,) p q+{-# INLINE (&&&&) #-} --- | Profunctor equivalent of '<*>'.----papply :: Profunctor p => (forall x. Applicative (p x)) => p a (b -> c) -> p a b -> p a c-papply f x = dimap fork apply (f @@@ x)+pdivide :: Representable p => Applicative (Rep p) => (a -> (a1 , a2)) -> p a1 b -> p a2 b -> p a b+pdivide f p q = dimap f fst $ dimap fst (,) p <<*>> lmap snd q+{-# INLINE pdivide #-} --- | Profunctor equivalent of 'liftA2'.----pliftA2 :: Profunctor p => (forall x. Applicative (p x)) => ((b1 , b2) -> b) -> p a b1 -> p a b2 -> p a b-pliftA2 f x y = dimap fork f $ pappend x y+pappend :: Representable p => Applicative (Rep p) => p a b -> p a b -> p a b+pappend = pdivide fork+{-# INLINE pappend #-}