Add more basic prisms and isos and match/build

Author: b-mehta

src/Control/Optics/Linear/Internal.hs

@@ -33,14 +33,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,6 +56,12 @@ _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
 
@@ -66,11 +75,29 @@ get :: Optic_ (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 (Optical l) f s = getConst' (runKleisli (l (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))
+
+-- 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))
+
+build :: Optic_ (CoLKleisli (Const b)) a b s t -> b ->. t
+build (Optical l) x = runCoLKleisli (l (CoLKleisli 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 l s = getSum (gets l (const (Sum 1)) s)
 
@@ -81,3 +108,11 @@ 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))
+
+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/Linear.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE LinearTypes #-}
@@ -12,14 +13,17 @@ module Data.Profunctor.Linear
   , Monoidal(..)
   , Strong(..)
   , Wandering(..)
-  , LinearArrow(..)
+  , 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
@@ -63,7 +67,11 @@ 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
+-- TODO: maybe use TH to automatically write things like this?
+getLA :: LinearArrow a b ->. a ->. b
+getLA (LA f) = f
 
 instance Profunctor LinearArrow where
   dimap f g (LA h) = LA $ g . h . f
@@ -90,8 +98,6 @@ instance Prelude.Applicative f => Strong Either Void (Kleisli f) where
                                    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 }
 
@@ -116,3 +122,20 @@ instance Strong (,) () (->) where
 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

@@ -18,6 +18,7 @@ module Prelude.Linear
   , (.)
   , either
   , maybe
+  , forget
     -- * Unrestricted
     -- $ unrestricted
   , Unrestricted(..)
@@ -71,6 +72,12 @@ maybe :: b -> (a ->. b) -> Maybe a ->. b
 maybe x _ Nothing = x
 maybe _ f (Just y) = f y
 
+-- XXX: temporary
+-- | 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,