A plethora of new optics

todo: split the commit up a bit

Author: b-mehta

src/Control/Optics/Linear/Internal.hs

@@ -12,12 +12,16 @@ 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.Semigroup.Linear
 import Data.Profunctor.Linear
 import Data.Void
-import Prelude.Linear
+import Prelude.Linear hiding ((<$>))
+-- ^ XXX: not entirely sure why the hiding is necessary here...
 import qualified Prelude as P
 
+-- TODO: documentation in this module
+-- Put the functions in some sensible order: possibly split into separate
+-- Lens/Prism/Traversal/Iso modules
 newtype Optic_ arr a b s t = Optical (a `arr` b -> s `arr` t)
 
 type Optic c a b s t =
@@ -29,8 +33,12 @@ type Lens a b s t = Optic (Strong (,) ()) a b s t
 type Lens' a s = Lens a a s s
 type Prism a b s t = Optic (Strong Either Void) a b s t
 type Prism' a s = Prism a a s s
-type Traversal a b s t = Optic Wandering a b s t
-type Traversal' a s = Traversal a a s s
+type PTraversal a b s t = Optic PWandering a b s t
+type PTraversal' a s = PTraversal a a s s
+type DTraversal a b s t = Optic DWandering a b s t
+type DTraversal' a s = DTraversal a a s s
+-- XXX: these will unify into
+-- type Traversal (p :: Multiplicity) a b s t = Optic (Wandering p) a b s t
 
 swap :: SymmetricMonoidal m u => Iso (a `m` b) (c `m` d) (b `m` a) (d `m` c)
 swap = iso Bifunctor.swap Bifunctor.swap
@@ -41,6 +49,10 @@ 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)
 
+-- c is the complement (probably)
+lens :: (s ->. (c,a)) -> ((c,b) ->. t) -> Lens a b s t
+lens sca cbt = Optical $ \f -> dimap sca cbt (second f)
+
 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))
 
@@ -50,6 +62,37 @@ _1 = Optical first
 _2 :: Lens a b (c,a) (c,b)
 _2 = Optical second
 
+-- XXX: these will unify to
+-- > both :: forall (p :: Multiplicity). Traversal p a b (a,a) (b,b)
+both' :: PTraversal a b (a,a) (b,b)
+both' = _Pairing .> ptraversed
+
+both :: DTraversal a b (a,a) (b,b)
+both = _Pairing .> dtraversed
+
+-- XXX: these are a special case of Bitraversable, but just the simple case
+-- is included here for now
+_Pairing :: Iso (Pair a) (Pair b) (a,a) (b,b)
+_Pairing = iso Paired unpair
+
+newtype Pair a = Paired (a,a)
+unpair :: Pair a ->. (a,a)
+unpair (Paired x) = x
+
+instance P.Functor Pair where
+  fmap f (Paired (x,y)) = Paired (f x, f y)
+instance Functor Pair where
+  fmap f (Paired (x,y)) = Paired (f x, f y)
+instance Foldable Pair where
+  foldMap f (Paired (x,y)) = f x P.<> f y
+instance P.Traversable Pair where
+  traverse f (Paired (x,y)) = Paired P.<$> ((,) P.<$> f x P.<*> f y)
+instance Traversable Pair where
+  traverse f (Paired (x,y)) = Paired <$> ((,) <$> f x <*> f y)
+
+toListOf :: Optic_ (Kleisli (Const [a])) a b s t -> s -> [a]
+toListOf l = gets l (\a -> [a])
+
 _Left :: Prism a b (Either a c) (Either b c)
 _Left = Optical first
 
@@ -62,8 +105,11 @@ _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
+ptraversed :: P.Traversable t => PTraversal a b (t a) (t b)
+ptraversed = Optical pwander
+
+dtraversed :: Traversable t => DTraversal a b (t a) (t b)
+dtraversed = Optical dwander
 
 over :: Optic_ LinearArrow a b s t -> (a ->. b) -> s ->. t
 over (Optical l) f = getLA (l (LA f))
@@ -74,6 +120,18 @@ traverseOf (Optical l) f = runLKleisli (l (LKleisli f))
 get :: Optic_ (Kleisli (Const a)) a b s t -> s -> a
 get l = gets l P.id
 
+preview :: Optic_ (Kleisli (Const (Maybe (First a)))) a b s t -> s -> Maybe a
+preview (Optical l) s = getFirst P.<$> (getConst (runKleisli (l (Kleisli (\a -> Const (Just (First a))))) s))
+
+get' :: Optic_ (LKleisli (Const (Top, a))) a b s t -> s ->. (Top, a)
+get' l = gets' l id
+
+gets' :: Optic_ (LKleisli (Const (Top, r))) a b s t -> (a ->. r) -> s ->. (Top, r)
+gets' (Optical l) f s = getConst' (runLKleisli (l (LKleisli (\a -> Const (Top (), f a)))) s)
+
+set' :: Optic_ (LKleisli (MyFunctor a b)) a b s t -> s ->. b ->. (a, t)
+set' (Optical l) = runMyFunctor . runLKleisli (l (LKleisli (\a -> MyFunctor (\b -> (a,b)))))
+
 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)
 
@@ -115,4 +173,3 @@ 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,7 +15,9 @@
 module Data.Functor.Linear where
 
 import Prelude.Linear.Internal.Simple
+import Prelude (Maybe(..))
 import Data.Functor.Const
+import Data.Semigroup.Linear
 
 class Functor f where
   fmap :: (a ->. b) -> f a ->. f b
@@ -74,3 +76,11 @@ instance Traversable [] where
 
 instance Functor (Const x) where
   fmap _ (Const x) = Const x
+
+instance Monoid x => Applicative (Const x) where
+  pure _ = Const mempty
+  Const x <*> Const y = Const (x <> y)
+
+instance Functor Maybe where
+  fmap _ Nothing = Nothing
+  fmap f (Just x) = Just (f x)

src/Data/Profunctor/Linear.hs

@@ -1,23 +1,28 @@
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE LinearTypes #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeOperators #-}
 
 module Data.Profunctor.Linear
   ( Profunctor(..)
   , Monoidal(..)
   , Strong(..)
-  , Wandering(..)
+  , PWandering(..)
+  , DWandering(..)
   , LinearArrow(..), getLA
   , Kleisli(..)
   , LKleisli(..)
   , CoLKleisli(..)
   , Exchange(..)
+  , Top(..)
+  , MyFunctor(..), runMyFunctor
   ) where
 
 import qualified Control.Monad.Linear as Control
@@ -60,16 +65,24 @@ class (SymmetricMonoidal m u, Profunctor arr) => Strong m u arr where
   second arr = dimap swap swap (first arr)
   {-# INLINE second #-}
 
-class (Strong (,) () arr, Strong Either Void arr) => Wandering arr where
-  wander :: Data.Traversable f => a `arr` b -> f a `arr` f b
+-- XXX: Just as Prelude.Functor/Data.Functor will combine into
+-- > `class Functor (p :: Multiplicity) f`
+-- so will Traversable, and then we would instead write
+-- > class (...) => Wandering (p :: Multiplicity) arr where
+-- >   wander :: Traversable p f => a `arr` b -> f a `arr` f b
+-- For now, however, we cannot do this, so we use two classes instead:
+-- PreludeWandering and DataWandering
+class (Strong (,) () arr, Strong Either Void arr) => PWandering arr where
+  pwander :: Prelude.Traversable f => a `arr` b -> f a `arr` f b
+class (Strong (,) () arr, Strong Either Void arr) => DWandering arr where
+  dwander :: Data.Traversable f => a `arr` b -> f a `arr` f b
 
 ---------------
 -- Instances --
 ---------------
 
 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,10 +97,13 @@ instance Strong Either Void LinearArrow where
   first  (LA f) = LA $ either (Left . f) Right
   second (LA g) = LA $ either Left (Right . g)
 
+instance DWandering LinearArrow where
+  dwander (LA f) = LA (Data.fmap f)
+
 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))
+  dimap f g (Kleisli h) = Kleisli (\x -> eta g Prelude.<$> h (f x))
 
 instance Prelude.Functor f => Strong (,) () (Kleisli f) where
   first  (Kleisli f) = Kleisli (\(a,b) -> (,b) Prelude.<$> f a)
@@ -98,6 +114,8 @@ instance Prelude.Applicative f => Strong Either Void (Kleisli f) where
                                    Left  x -> Prelude.fmap Left (f x)
                                    Right y -> Prelude.pure (Right y)
 
+instance Prelude.Applicative f => PWandering (Kleisli f) where
+  pwander (Kleisli f) = Kleisli (Prelude.traverse f)
 
 newtype LKleisli m a b = LKleisli { runLKleisli :: a ->. m b }
 
@@ -112,8 +130,8 @@ 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 Control.Applicative f => DWandering (LKleisli f) where
+  dwander (LKleisli f) = LKleisli (Data.traverse f)
 
 instance Profunctor (->) where
   dimap f g h x = g (h (f x))
@@ -122,6 +140,8 @@ instance Strong (,) () (->) where
 instance Strong Either Void (->) where
   first f (Left x) = Left (f x)
   first _ (Right y) = Right y
+instance PWandering (->) where
+  pwander = Prelude.fmap
 
 -- XXX: Since CoLKleisli has uses, it might be better to replace all this
 -- with a Bif-like structure...

src/Data/Semigroup/Linear.hs

@@ -0,0 +1,70 @@
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LinearTypes #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
+-- | = The linear semigroup hierarchy
+--
+-- TODO: documentation
+
+module Data.Semigroup.Linear
+  ( Semigroup(..)
+  , Monoid(..)
+  , LEndo(..), appLEndo
+  , module Data.Semigroup
+  )
+  where
+
+import Prelude.Linear.Internal.Simple
+import Data.Semigroup hiding (Semigroup(..))
+import qualified Data.Semigroup as Prelude
+import qualified Prelude
+import qualified Unsafe.Linear as Unsafe
+
+class Prelude.Semigroup a => Semigroup a where
+  (<>) :: a ->. a ->. a
+
+class (Semigroup a, Prelude.Monoid a) => Monoid a where
+  {-# MINIMAL #-}
+  mempty :: a
+  mempty = mempty
+  -- convenience redefine
+
+---------------
+-- Instances --
+---------------
+
+instance Semigroup () where
+  () <> () = ()
+
+data LEndo a = LEndo (a ->. a)
+
+appLEndo :: LEndo a ->. a ->. a
+appLEndo (LEndo f) = f
+
+instance Prelude.Semigroup (LEndo a) where
+  LEndo f <> LEndo g = LEndo (f . g)
+instance Prelude.Monoid (LEndo a) where
+  mempty = LEndo id
+instance Semigroup (LEndo a) where
+  LEndo f <> LEndo g = LEndo (f . g)
+instance Monoid (LEndo a) where
+
+instance (Semigroup a, Semigroup b) => Semigroup (a,b) where
+  (a,x) <> (b,y) = (a <> b, x <> y)
+instance (Monoid a, Monoid b) => Monoid (a,b)
+
+newtype LWrap a = LWrap a
+  deriving (Prelude.Semigroup, Prelude.Monoid)
+
+-- This instance is unsafe: do not export LWrap so it cannot be used.
+instance Prelude.Semigroup a => Semigroup (LWrap a) where
+  LWrap a <> LWrap b = LWrap (Unsafe.toLinear2 (Prelude.<>) a b)
+instance Prelude.Monoid a => Monoid (LWrap a)
+
+-- XXX: I think these are safe but I'm not fully confident
+deriving via (LWrap (Sum a)) instance Prelude.Num a => Semigroup (Sum a)
+deriving via (LWrap (Sum a)) instance Prelude.Num a => Monoid (Sum a)
+deriving via (LWrap (Product a)) instance Prelude.Num a => Semigroup (Product a)
+deriving via (LWrap (Product a)) instance Prelude.Num a => Monoid (Product a)

src/Prelude/Linear.hs

@@ -223,3 +223,7 @@ instance Data.Functor Unrestricted where
 instance Data.Applicative Unrestricted where
   pure = Unrestricted
   Unrestricted f <*> Unrestricted x = Unrestricted (f x)
+
+-- TODO: move this somewhere more sensible to avoid orphan instance
+instance Data.Functor (Either e) where
+  fmap f = either Left (Right . f)