Merge branch 'prisms'

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

@@ -6,14 +6,42 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TypeOperators #-}
 
-module Control.Optics.Linear.Internal where
+module Control.Optics.Linear.Internal
+  ( -- * Types
+    Optic_(..)
+  , Optic
+  , Iso, Iso'
+  , Lens, Lens'
+  , Prism, Prism'
+  , Traversal, Traversal'
+    -- * Composing optics
+  , (.>)
+    -- * Common optics
+  , swap, assoc
+  , _1, _2
+  , _Left, _Right
+  , _Just, _Nothing
+  , traversed
+    -- * Using optics
+  , get, set, gets
+  , match, match', build
+  , over, over'
+  , traverseOf, traverseOf'
+  , lengthOf
+  , withIso
+    -- * Constructing optics
+  , iso, prism
+  )
+  where
 
 import qualified Data.Bifunctor.Linear as Bifunctor
 import Data.Bifunctor.Linear (SymmetricMonoidal)
 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
@@ -33,14 +61,17 @@ type Traversal a b s t = Optic Wandering a b s t
 type Traversal' a s = Traversal a a s s
 
 swap :: SymmetricMonoidal m u => Iso (a `m` b) (c `m` d) (b `m` a) (d `m` c)
-swap = Optical (dimap Bifunctor.swap Bifunctor.swap)
+swap = iso Bifunctor.swap Bifunctor.swap
 
 assoc :: SymmetricMonoidal m u => Iso ((a `m` b) `m` c) ((d `m` e) `m` f) (a `m` (b `m` c)) (d `m` (e `m` f))
-assoc = Optical (dimap Bifunctor.lassoc Bifunctor.rassoc)
+assoc = iso Bifunctor.lassoc Bifunctor.rassoc
 
 (.>) :: Optic_ arr a b s t -> Optic_ arr x y a b -> Optic_ arr x y s t
 Optical f .> Optical g = Optical (f P.. g)
 
+prism :: (b ->. t) -> (s ->. Either t a) -> Prism a b s t
+prism b s = Optical $ \f -> dimap s (either id id) (second (rmap b f))
+
 _1 :: Lens a b (a,c) (b,c)
 _1 = Optical first
 
@@ -53,31 +84,60 @@ _Left = Optical first
 _Right :: Prism a b (Either c a) (Either c b)
 _Right = Optical second
 
+_Just :: Prism a b (Maybe a) (Maybe b)
+_Just = prism Just (maybe (Left Nothing) Right)
+
+_Nothing :: Prism' () (Maybe a)
+_Nothing = prism (\() -> Nothing) Left
+
 traversed :: Traversable t => Traversal a b (t a) (t b)
 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)
 
-lengthOf :: Num r => Optic_ (Kleisli (Const (Sum r))) a b s t -> s -> r
+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_ (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_ (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_ (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/Functor/Linear.hs

@@ -15,6 +15,7 @@
 module Data.Functor.Linear where
 
 import Prelude.Linear.Internal.Simple
+import Data.Functor.Const
 
 class Functor f where
   fmap :: (a ->. b) -> f a ->. f b
@@ -70,3 +71,6 @@ instance Functor [] where
 instance Traversable [] where
   traverse _f [] = pure []
   traverse f (a : as) = (:) <$> f a <*> traverse f as
+
+instance Functor (Const x) where
+  fmap _ (Const x) = Const x

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,6 +1,5 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE LinearTypes #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NoImplicitPrelude #-}
@@ -12,17 +11,14 @@ module Data.Profunctor.Linear
   , Monoidal(..)
   , Strong(..)
   , Wandering(..)
-  , LinearArrow(..)
-  , Kleisli(..)
-  , LKleisli(..)
+  , LinearArrow(..), getLA
+  , Exchange(..)
   ) where
 
-import qualified Control.Monad.Linear as Control
 import qualified Data.Functor.Linear as Data
 import Data.Bifunctor.Linear hiding (first, second)
 import Prelude.Linear
 import Data.Void
-import qualified Prelude
 
 -- TODO: write laws
 
@@ -63,7 +59,10 @@ class (Strong (,) () arr, Strong Either Void arr) => Wandering arr where
 -- Instances --
 ---------------
 
-newtype LinearArrow a b = LA { getLA :: a ->. b }
+newtype LinearArrow a b = LA (a ->. b)
+-- | Temporary deconstructor since inference doesn't get it right
+getLA :: LinearArrow a b ->. a ->. b
+getLA (LA f) = f
 
 instance Profunctor LinearArrow where
   dimap f g (LA h) = LA $ g . h . f
@@ -76,43 +75,14 @@ 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)
-
-forget :: (a ->. b) -> a -> b
-forget f x = f x
-
-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
   first f (x, y) = (f x, y)
 instance Strong Either Void (->) where
   first f (Left x) = Left (f x)
   first _ (Right y) = Right y
+
+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

@@ -18,6 +18,7 @@ module Prelude.Linear
   , (.)
   , either
   , maybe
+  , forget
     -- * Unrestricted
     -- $ unrestricted
   , Unrestricted(..)
@@ -71,6 +72,14 @@ maybe :: b -> (a ->. b) -> Maybe a ->. b
 maybe x _ Nothing = x
 maybe _ f (Just y) = f y
 
+-- 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
+forget f x = f x
+
 -- $ unrestricted
 
 -- | @Unrestricted a@ represents unrestricted values of type @a@ in a linear context,