Move Kleisli arrows to their own modules

Author: b-mehta

linear-base.cabal

@@ -25,6 +25,8 @@ library
     Data.Functor.Linear
     Data.Vector.Linear
     Data.Profunctor.Linear
+    Data.Profunctor.Kleisli.Linear
+    Data.Profunctor.Kleisli.NonLinear
     Foreign.Marshal.Pure
     Prelude.Linear
     Prelude.Linear.Internal.Simple

src/Control/Optics/Linear/Internal.hs

@@ -14,6 +14,8 @@ import Data.Functor.Const
 import Data.Functor.Linear
 import Data.Monoid
 import Data.Profunctor.Linear
+import qualified Data.Profunctor.Kleisli.Linear as Linear
+import qualified Data.Profunctor.Kleisli.NonLinear as NonLinear
 import Data.Void
 import Prelude.Linear
 import qualified Prelude as P
@@ -68,51 +70,48 @@ traversed = Optical wander
 over :: Optic_ LinearArrow a b s t -> (a ->. b) -> s ->. t
 over (Optical l) f = getLA (l (LA f))
 
-traverseOf :: Optic_ (LKleisli f) a b s t -> (a ->. f b) -> s ->. f t
-traverseOf (Optical l) f = runLKleisli (l (LKleisli f))
+traverseOf :: Optic_ (Linear.Kleisli f) a b s t -> (a ->. f b) -> s ->. f t
+traverseOf (Optical l) f = Linear.runKleisli (l (Linear.Kleisli f))
 
-get :: Optic_ (Kleisli (Const a)) a b s t -> s -> a
+get :: Optic_ (NonLinear.Kleisli (Const a)) a b s t -> s -> a
 get l = gets l P.id
 
-gets :: Optic_ (Kleisli (Const r)) a b s t -> (a -> r) -> s -> r
-gets (Optical l) f s = getConst' (runKleisli (l (Kleisli (Const P.. f))) s)
+gets :: Optic_ (NonLinear.Kleisli (Const r)) a b s t -> (a -> r) -> s -> r
+gets (Optical l) f s = getConst' (NonLinear.runKleisli (l (NonLinear.Kleisli (Const P.. f))) s)
 
 set :: Optic_ (->) a b s t -> b -> s -> t
 set (Optical l) x = l (const x)
 
--- get can't return a linear arrow, so `withIso swap const` needs to be used
--- instead of `get swap`
-match :: Optic_ (LKleisli (Either a)) a b s t -> s ->. Either t a
-match (Optical l) = withIso swap (\x _ -> x) . runLKleisli (l (LKleisli Left))
+match :: Optic_ (Linear.Kleisli (Either a)) a b s t -> s ->. Either t a
+match (Optical l) = withIso swap (\x _ -> x) . Linear.runKleisli (l (Linear.Kleisli Left))
 
 -- will be redundant with multiplicity polymorphism
-match' :: Optic_ (Kleisli (Either a)) a b s t -> s -> Either t a
-match' (Optical l) = get swap P.. runKleisli (l (Kleisli Left))
+match' :: Optic_ (NonLinear.Kleisli (Either a)) a b s t -> s -> Either t a
+match' (Optical l) = withIso swap (\x _ -> forget x) P.. NonLinear.runKleisli (l (NonLinear.Kleisli Left))
 
-build :: Optic_ (CoLKleisli (Const b)) a b s t -> b ->. t
-build (Optical l) x = runCoLKleisli (l (CoLKleisli getConst')) (Const x)
+build :: Optic_ (Linear.CoKleisli (Const b)) a b s t -> b ->. t
+build (Optical l) x = Linear.runCoKleisli (l (Linear.CoKleisli getConst')) (Const x)
 
 -- XXX: move this to Prelude
 -- | Linearly typed patch for the newtype deconstructor. (Temporary until
 -- inference will get this from the newtype declaration.)
 getConst' :: Const a b ->. a
 getConst' (Const x) = x
 
-lengthOf :: Num r => Optic_ (Kleisli (Const (Sum r))) a b s t -> s -> r
+lengthOf :: Num r => Optic_ (NonLinear.Kleisli (Const (Sum r))) a b s t -> s -> r
 lengthOf l s = getSum (gets l (const (Sum 1)) s)
 
 -- XXX: the below two functions will be made redundant with multiplicity
 -- polymorphism on over and traverseOf'
 over' :: Optic_ (->) a b s t -> (a -> b) -> s -> t
 over' (Optical l) f = l f
 
-traverseOf' :: Optic_ (Kleisli f) a b s t -> (a -> f b) -> s -> f t
-traverseOf' (Optical l) f = runKleisli (l (Kleisli f))
+traverseOf' :: Optic_ (NonLinear.Kleisli f) a b s t -> (a -> f b) -> s -> f t
+traverseOf' (Optical l) f = NonLinear.runKleisli (l (NonLinear.Kleisli f))
 
 iso :: (s ->. a) -> (b ->. t) -> Iso a b s t
 iso f g = Optical (dimap f g)
 
 withIso :: Optic_ (Exchange a b) a b s t -> ((s ->. a) -> (b ->. t) -> r) -> r
 withIso (Optical l) f = f fro to
   where Exchange fro to = l (Exchange id id)
-

src/Data/Profunctor/Kleisli/Linear.hs

@@ -0,0 +1,68 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LinearTypes #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE TupleSections #-}
+module Data.Profunctor.Kleisli.Linear
+  ( Kleisli(..)
+  , CoKleisli(..)
+  )
+  where
+
+-- | This module is intended to be imported qualified
+
+import Data.Functor.Const
+import Data.Profunctor.Linear
+import Data.Void
+import Prelude.Linear (Either(..), either)
+import Prelude.Linear.Internal.Simple
+import qualified Control.Monad.Linear as Control
+import qualified Data.Functor.Linear as Data
+
+-- Ideally, there would only be one Kleisli arrow, parametrised by
+-- a multiplicity parameter:
+-- newtype Kleisli p m a b = Kleisli { runKleisli :: a # p -> m b }
+--
+-- Some instances would also still work, eg
+-- instance Functor p f => Profunctor (Kleisli p f)
+
+-- | Linear Kleisli arrows for the monad `m`. These arrows are still useful
+-- in the case where `m` is not a monad however, and some profunctorial
+-- properties still hold in this weaker setting.
+newtype Kleisli m a b = Kleisli { runKleisli :: a ->. m b }
+
+instance Data.Functor f => Profunctor (Kleisli f) where
+  dimap f g (Kleisli h) = Kleisli (Data.fmap g . h . f)
+
+instance Control.Functor f => Strong (,) () (Kleisli f) where
+  first  (Kleisli f) = Kleisli (\(a,b) -> (,b) Control.<$> f a)
+  second (Kleisli g) = Kleisli (\(a,b) -> (a,) Control.<$> g b)
+
+instance Control.Applicative f => Strong Either Void (Kleisli f) where
+  first  (Kleisli f) = Kleisli (either (Data.fmap Left . f) (Control.pure . Right))
+  second (Kleisli g) = Kleisli (either (Control.pure . Left) (Data.fmap Right . g))
+
+instance Control.Applicative f => Wandering (Kleisli f) where
+  wander (Kleisli f) = Kleisli (Data.traverse f)
+
+-- | Linear co-Kleisli arrows for the comonad `w`. These arrows are still
+-- useful in the case where `w` is not a comonad however, and some
+-- profunctorial properties still hold in this weaker setting.
+-- However stronger requirements on `f` are needed for profunctorial
+-- strength, so we have fewer instances.
+--
+-- Category theoretic remark: duality doesn't work in the obvious way, since
+-- (,) isn't the categorical product. Instead, we have a product (&), called
+-- "With", defined by
+-- > type With a b = forall r. Either (a ->. r) (b ->. r) ->. r
+-- which satisfies the universal property of the product of `a` and `b`.
+-- CoKleisli arrows are strong with respect to this monoidal structure,
+-- although this might not be useful...
+newtype CoKleisli w a b = CoKleisli { runCoKleisli :: w a ->. b }
+
+instance Data.Functor f => Profunctor (CoKleisli f) where
+  dimap f g (CoKleisli h) = CoKleisli (g . h . Data.fmap f)
+
+-- instance of a more general idea, but this will do for now
+instance Strong Either Void (CoKleisli (Const x)) where
+  first (CoKleisli f) = CoKleisli (\(Const x) -> Left (f (Const x)))

src/Data/Profunctor/Kleisli/NonLinear.hs

@@ -0,0 +1,34 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE LinearTypes #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE TupleSections #-}
+
+module Data.Profunctor.Kleisli.NonLinear
+  ( Kleisli(..)
+  )
+  where
+
+import Data.Profunctor.Linear
+import Data.Void
+import qualified Prelude
+import Prelude.Linear (Either(..), forget)
+import Prelude.Linear.Internal.Simple (($))
+
+-- Non-linear Kleisli arrows for the monad `m`. As in the linear case,
+-- these arrows are still useful if `m` is only a `Functor` or an
+-- `Applicative`.
+newtype Kleisli m a b = Kleisli { runKleisli :: a -> m b }
+
+instance Prelude.Functor f => Profunctor (Kleisli f) where
+  dimap f g (Kleisli h) = Kleisli (\x -> forget g Prelude.<$> h (f x))
+
+instance Prelude.Functor f => Strong (,) () (Kleisli f) where
+  first  (Kleisli f) = Kleisli (\(a,b) -> (,b) Prelude.<$> f a)
+  second (Kleisli g) = Kleisli (\(a,b) -> (a,) Prelude.<$> g b)
+
+instance Prelude.Applicative f => Strong Either Void (Kleisli f) where
+  first  (Kleisli f) = Kleisli $ \case
+                                   Left  x -> Prelude.fmap Left (f x)
+                                   Right y -> Prelude.pure (Right y)

src/Data/Profunctor/Linear.hs

@@ -1,7 +1,5 @@
 {-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE LinearTypes #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NoImplicitPrelude #-}
@@ -14,19 +12,13 @@ module Data.Profunctor.Linear
   , Strong(..)
   , Wandering(..)
   , LinearArrow(..), getLA
-  , Kleisli(..)
-  , LKleisli(..)
-  , CoLKleisli(..)
   , Exchange(..)
   ) where
 
-import qualified Control.Monad.Linear as Control
 import qualified Data.Functor.Linear as Data
 import Data.Bifunctor.Linear hiding (first, second)
-import Data.Functor.Const
 import Prelude.Linear
 import Data.Void
-import qualified Prelude
 
 -- TODO: write laws
 
@@ -69,7 +61,6 @@ class (Strong (,) () arr, Strong Either Void arr) => Wandering arr where
 
 newtype LinearArrow a b = LA (a ->. b)
 -- | Temporary deconstructor since inference doesn't get it right
--- TODO: maybe use TH to automatically write things like this?
 getLA :: LinearArrow a b ->. a ->. b
 getLA (LA f) = f
 
@@ -84,37 +75,6 @@ instance Strong Either Void LinearArrow where
   first  (LA f) = LA $ either (Left . f) Right
   second (LA g) = LA $ either Left (Right . g)
 
-newtype Kleisli m a b = Kleisli { runKleisli :: a -> m b }
-
-instance Prelude.Functor f => Profunctor (Kleisli f) where
-  dimap f g (Kleisli h) = Kleisli (\x -> forget g Prelude.<$> h (f x))
-
-instance Prelude.Functor f => Strong (,) () (Kleisli f) where
-  first  (Kleisli f) = Kleisli (\(a,b) -> (,b) Prelude.<$> f a)
-  second (Kleisli g) = Kleisli (\(a,b) -> (a,) Prelude.<$> g b)
-
-instance Prelude.Applicative f => Strong Either Void (Kleisli f) where
-  first  (Kleisli f) = Kleisli $ \case
-                                   Left  x -> Prelude.fmap Left (f x)
-                                   Right y -> Prelude.pure (Right y)
-
-
-newtype LKleisli m a b = LKleisli { runLKleisli :: a ->. m b }
-
-instance Data.Functor f => Profunctor (LKleisli f) where
-  dimap f g (LKleisli h) = LKleisli (Data.fmap g . h . f)
-
-instance Control.Functor f => Strong (,) () (LKleisli f) where
-  first  (LKleisli f) = LKleisli (\(a,b) -> (,b) Control.<$> f a)
-  second (LKleisli g) = LKleisli (\(a,b) -> (a,) Control.<$> g b)
-
-instance Control.Applicative f => Strong Either Void (LKleisli f) where
-  first  (LKleisli f) = LKleisli (either (Data.fmap Left . f) (Control.pure . Right))
-  second (LKleisli g) = LKleisli (either (Control.pure . Left) (Data.fmap Right . g))
-
-instance Control.Applicative f => Wandering (LKleisli f) where
-  wander (LKleisli f) = LKleisli (Data.traverse f)
-
 instance Profunctor (->) where
   dimap f g h x = g (h (f x))
 instance Strong (,) () (->) where
@@ -123,19 +83,6 @@ instance Strong Either Void (->) where
   first f (Left x) = Left (f x)
   first _ (Right y) = Right y
 
--- XXX: Since CoLKleisli has uses, it might be better to replace all this
--- with a Bif-like structure...
---
-newtype CoLKleisli w a b = CoLKleisli { runCoLKleisli :: w a ->. b }
-
-instance Data.Functor f => Profunctor (CoLKleisli f) where
-  dimap f g (CoLKleisli h) = CoLKleisli (g . h . Data.fmap f)
-
--- instance of a more general idea, but this will do for now
-instance Strong Either Void (CoLKleisli (Const x)) where
-  first (CoLKleisli f) = CoLKleisli (\(Const x) -> Left (f (Const x)))
-
 data Exchange a b s t = Exchange (s ->. a) (b ->. t)
 instance Profunctor (Exchange a b) where
   dimap f g (Exchange p q) = Exchange (p . f) (g . q)
-

src/Prelude/Linear.hs

@@ -72,7 +72,9 @@ maybe :: b -> (a ->. b) -> Maybe a ->. b
 maybe x _ Nothing = x
 maybe _ f (Just y) = f y
 
--- XXX: temporary
+-- XXX: temporary: with multiplicity polymorphism functions expecting a
+-- non-linear arrow would allow a linear arrow passed, so this would be
+-- redundant
 -- | Convenience operator when a higher-order function expects a non-linear
 -- arrow but we have a linear arrow
 forget :: (a ->. b) ->. a -> b