diff --git a/src/Control/Optics/Linear/Internal.hs b/src/Control/Optics/Linear/Internal.hs index d0a532d2..bb159a71 100644 --- a/src/Control/Optics/Linear/Internal.hs +++ b/src/Control/Optics/Linear/Internal.hs @@ -13,7 +13,8 @@ module Control.Optics.Linear.Internal , Iso, Iso' , Lens, Lens' , Prism, Prism' - , Traversal, Traversal' + , PTraversal, PTraversal' + , DTraversal, DTraversal' -- * Composing optics , (.>) -- * Common optics @@ -21,30 +22,38 @@ module Control.Optics.Linear.Internal , _1, _2 , _Left, _Right , _Just, _Nothing - , traversed + , ptraversed, dtraversed + , both, both' -- * Using optics , get, set, gets + , get', gets', set', set'' , match, match', build + , preview , over, over' , traverseOf, traverseOf' , lengthOf - , withIso + , withIso, withLens + , toListOf -- * Constructing optics - , iso, prism + , iso, prism, lens ) where import qualified Control.Arrow as NonLinear import qualified Data.Bifunctor.Linear as Bifunctor import Data.Bifunctor.Linear (SymmetricMonoidal) -import Data.Monoid -import Data.Profunctor.Linear +import Data.Monoid (First(..), Sum(..)) +import Data.Functor.Const import Data.Functor.Linear +import Data.Profunctor.Linear import qualified Data.Profunctor.Kleisli.Linear as Linear import Data.Void import Prelude.Linear 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 = @@ -56,8 +65,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 @@ -68,6 +81,12 @@ 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) +lens :: (s ->. (a, b ->. t)) -> Lens a b s t +lens k = Optical $ \f -> dimap k (\(x,g) -> g $ x) (first f) + +withLens :: Optic_ (Linear.Kleisli (OtherFunctor a b)) a b s t -> s ->. (a, b ->. t) +withLens (Optical l) s = runOtherFunctor (Linear.runKleisli (l (Linear.Kleisli (\a -> OtherFunctor (a, id)))) s) + 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)) @@ -77,6 +96,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_ (NonLinear.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 @@ -89,8 +139,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)) @@ -104,6 +157,21 @@ get l = gets l P.id 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) +preview :: Optic_ (NonLinear.Kleisli (Const (First a))) a b s t -> s -> Maybe a +preview (Optical l) s = getFirst (getConst (NonLinear.runKleisli (l (NonLinear.Kleisli (\a -> Const (First (Just a))))) s)) + +get' :: Optic_ (Linear.Kleisli (Const (Top, a))) a b s t -> s ->. (Top, a) +get' l = gets' l id + +gets' :: Optic_ (Linear.Kleisli (Const (Top, r))) a b s t -> (a ->. r) -> s ->. (Top, r) +gets' (Optical l) f s = getConst' (Linear.runKleisli (l (Linear.Kleisli (\a -> Const (mempty, f a)))) s) + +set' :: Optic_ (Linear.Kleisli (MyFunctor a b)) a b s t -> s ->. b ->. (a, t) +set' (Optical l) s = runMyFunctor (Linear.runKleisli (l (Linear.Kleisli (\a -> MyFunctor (\b -> (a,b))))) s) + +set'' :: Optic_ (NonLinear.Kleisli (Reader b)) a b s t -> b ->. s -> t +set'' (Optical l) b s = runReader (NonLinear.runKleisli (l (NonLinear.Kleisli (const (Reader id)))) s) b + set :: Optic_ (->) a b s t -> b -> s -> t set (Optical l) x = l (const x) diff --git a/src/Data/Monoid/Linear.hs b/src/Data/Monoid/Linear.hs index 1cadea9a..9fcdecda 100644 --- a/src/Data/Monoid/Linear.hs +++ b/src/Data/Monoid/Linear.hs @@ -3,6 +3,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LinearTypes #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE StandaloneDeriving #-} -- | = The linear monoid hierarchy @@ -14,6 +15,7 @@ module Data.Monoid.Linear , Monoid(..) , Endo(..), appEndo , NonLinear(..) + , Top, throw , module Data.Semigroup ) where @@ -80,3 +82,15 @@ newtype NonLinear a = NonLinear a instance Semigroup a => Prelude.Semigroup (NonLinear a) where NonLinear a <> NonLinear b = NonLinear (a <> b) + +data Top = forall x. Top x +throw :: x ->. Top +throw = Top + +instance Prelude.Semigroup Top where + Top x <> Top y = Top (x,y) +instance Semigroup Top where + Top x <> Top y = Top (x,y) +instance Prelude.Monoid Top where + mempty = Top () +instance Monoid Top where diff --git a/src/Data/Profunctor/Kleisli/Linear.hs b/src/Data/Profunctor/Kleisli/Linear.hs index 61951ef5..6394c788 100644 --- a/src/Data/Profunctor/Kleisli/Linear.hs +++ b/src/Data/Profunctor/Kleisli/Linear.hs @@ -41,22 +41,14 @@ 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) +instance Control.Applicative f => DWandering (Kleisli f) where + dwander (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 diff --git a/src/Data/Profunctor/Linear.hs b/src/Data/Profunctor/Linear.hs index e71493d0..82582196 100644 --- a/src/Data/Profunctor/Linear.hs +++ b/src/Data/Profunctor/Linear.hs @@ -1,27 +1,39 @@ +{-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE LinearTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + module Data.Profunctor.Linear ( Profunctor(..) , Monoidal(..) , Strong(..) - , Wandering(..) + , PWandering(..) + , DWandering(..) , LinearArrow(..), getLA , Exchange(..) + , Top + , MyFunctor(..), runMyFunctor + , OtherFunctor(..), runOtherFunctor ) where import qualified Data.Functor.Linear as Data +import qualified Control.Monad.Linear as Control import Data.Bifunctor.Linear hiding (first, second) import Prelude.Linear import Data.Void import qualified Prelude import Control.Arrow (Kleisli(..)) +import Data.Monoid.Linear +import Data.Functor.Const -- TODO: write laws @@ -55,8 +67,17 @@ 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 -- @@ -78,6 +99,9 @@ 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) + instance Profunctor (->) where dimap f g h x = g (h (f x)) instance Strong (,) () (->) where @@ -85,6 +109,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 data Exchange a b s t = Exchange (s ->. a) (b ->. t) instance Profunctor (Exchange a b) where @@ -101,3 +127,29 @@ 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) + +instance Control.Functor (Const (Top, a)) where + fmap f (Const (t, x)) = Const (throw f <> t, x) +instance Monoid a => Control.Applicative (Const (Top, a)) where + pure x = Const (throw x, mempty) + Const x <*> Const y = Const (x <> y) + +-- TODO: pick a more sensible name for this +newtype MyFunctor a b t = MyFunctor (b ->. (a, t)) +runMyFunctor :: MyFunctor a b t ->. b ->. (a, t) +runMyFunctor (MyFunctor f) = f + +instance Data.Functor (MyFunctor a b) where + fmap f (MyFunctor g) = MyFunctor (getLA (second (LA f)) . g) +instance Control.Functor (MyFunctor a b) where + fmap f (MyFunctor g) = MyFunctor (thing f . g) + where thing :: (c ->. d) ->. (e, c) ->. (e, d) + thing k (x,y) = (x, k y) + +newtype OtherFunctor a b t = OtherFunctor (a, b ->. t) +runOtherFunctor :: OtherFunctor a b t ->. (a, b ->. t) +runOtherFunctor (OtherFunctor f) = f +instance Data.Functor (OtherFunctor a b) where + fmap f (OtherFunctor (a,g)) = OtherFunctor (a,f . g) +instance Control.Functor (OtherFunctor a b) where + fmap f (OtherFunctor (a,g)) = OtherFunctor (a,f . g) diff --git a/src/Foreign/Marshal/Pure.hs b/src/Foreign/Marshal/Pure.hs index 648085c0..0dbd6416 100644 --- a/src/Foreign/Marshal/Pure.hs +++ b/src/Foreign/Marshal/Pure.hs @@ -60,7 +60,7 @@ import Foreign.Marshal.Utils import Foreign.Ptr import Foreign.Storable import Foreign.Storable.Tuple () -import Prelude (($), return, (<*>)) +import Prelude (($), return, (<*>), (<$>)) import Prelude.Linear hiding (($)) import System.IO.Unsafe import qualified Unsafe.Linear as Unsafe diff --git a/src/Prelude/Linear.hs b/src/Prelude/Linear.hs index 8b18498e..abcf95ec 100644 --- a/src/Prelude/Linear.hs +++ b/src/Prelude/Linear.hs @@ -53,7 +53,7 @@ import Prelude hiding , foldr , maybe , (.) - , Functor(..) + , Functor(..), (<$>) , Applicative(..) , Monad(..) , Traversable(..) diff --git a/src/System/IO/Linear.hs b/src/System/IO/Linear.hs index bf6ee2fc..453b6540 100644 --- a/src/System/IO/Linear.hs +++ b/src/System/IO/Linear.hs @@ -41,6 +41,7 @@ import qualified Control.Monad.Linear as Control import qualified Data.Functor.Linear as Data import GHC.Exts (State#, RealWorld) import Prelude.Linear hiding (IO) +import Prelude ((<$>)) import qualified Unsafe.Linear as Unsafe import qualified System.IO as System