Merge pull request #19 from zrho/master

Some rudimentary interaction with state monads.

Author: paf31

bower.json

@@ -22,6 +22,7 @@
     "purescript-maps": "~0.5.2",
     "purescript-profunctor": "~0.3.0",
     "purescript-sets": "~0.5.1",
-    "purescript-unsafe-coerce": "~0.1.0"
+    "purescript-unsafe-coerce": "~0.1.0",
+    "purescript-transformers": "~0.8.1"
   }
 }

src/Data/Lens/Fold.purs

@@ -12,7 +12,6 @@ import Prelude
 
 import Control.Apply ((*>))
 
-import Data.Const (Const(..), getConst)
 import Data.Either (Either(..), either)
 import Data.Foldable (Foldable, foldr)
 import Data.Functor.Contravariant (Contravariant)
@@ -32,6 +31,7 @@ import Data.Profunctor.Star (Star(..), runStar)
 import Data.Tuple (Tuple(..))
 
 import Data.Lens.Internal.Void (coerce)
+import Data.Lens.Internal.Forget (Forget (..), runForget)
 import Data.Lens.Types (Fold(), FoldP()) as ExportTypes
 import Data.Lens.Types (Optic(), OpticP(), Fold())
 
@@ -48,11 +48,11 @@ preview p = runFirst <<< foldMapOf p (First <<< Just)
 
 -- | Folds all foci of a `Fold` to one. Note that this is the same as `view`.
 foldOf :: forall s t a b. Fold a s t a b -> s -> a
-foldOf p = getConst <<< runStar (p (Star Const))
+foldOf p = runForget (p (Forget id))
 
 -- | Maps and then folds all foci of a `Fold`.
 foldMapOf :: forall s t a b r. Fold r s t a b -> (a -> r) -> s -> r
-foldMapOf p f = getConst <<< runStar (p (Star (Const <<< f)))
+foldMapOf p f = runForget (p (Forget f))
 
 -- | Right fold over a `Fold`.
 foldrOf :: forall s t a b r. Fold (Endo r) s t a b -> (a -> r -> r) -> r -> s -> r

src/Data/Lens/Getter.purs

@@ -2,23 +2,25 @@
 
 module Data.Lens.Getter
   ( (^.)
-  , view, to
+  , view, to, use
   , module Data.Lens.Types
   ) where
 
-import Prelude ((<<<))
+import Prelude (id, (<<<))
 
 import Data.Const (Const(..), getConst)
 import Data.Functor.Contravariant (Contravariant, cmap)
 import Data.Profunctor.Star (Star(..), runStar)
+import Control.Monad.State.Class (MonadState, gets)
 
+import Data.Lens.Internal.Forget (Forget (..), runForget)
 import Data.Lens.Types (Getter(), Optic())
 
 infixl 8 ^.
 
 -- | View the focus of a `Getter`.
 view :: forall s t a b. Getter s t a b -> s -> a
-view l s = getConst (runStar (l (Star Const)) s)
+view l = runForget (l (Forget id))
 
 -- | Synonym for `view`, flipped.
 (^.) :: forall s t a b. s -> Getter s t a b -> a
@@ -27,3 +29,6 @@ view l s = getConst (runStar (l (Star Const)) s)
 -- | Convert a function into a getter.
 to :: forall s a f. (Contravariant f) => (s -> a) -> Optic (Star f) s s a a
 to f p = Star (cmap f <<< runStar p <<< f)
+
+use :: forall s t a b m. (MonadState s m) => Getter s t a b -> m a
+use p = gets (^. p)

src/Data/Lens/Internal/Focusing.purs

@@ -0,0 +1,25 @@
+-- | This module defines the `Focusing` functor
+
+module Data.Lens.Internal.Focusing
+  ( Focusing (..)
+  , runFocusing
+  ) where
+
+import Prelude
+import Data.Monoid (Monoid)
+import Data.Tuple (Tuple ())
+
+-- | The functor used to zoom into `StateT`.
+newtype Focusing m s a = Focusing (m (Tuple s a))
+
+runFocusing :: forall m s a. Focusing m s a -> m (Tuple s a)
+runFocusing (Focusing r) = r
+
+instance focusingFunctor :: (Functor m) => Functor (Focusing m s) where
+  map f (Focusing r) = Focusing (map (map f) r)
+
+instance focusingApply :: (Apply m, Semigroup s) => Apply (Focusing m s) where
+  apply (Focusing rf) (Focusing rx) = Focusing (map (<*>) rf <*> rx)
+
+instance focusingApplicative :: (Applicative m, Monoid s) => Applicative (Focusing m s) where
+  pure = Focusing <<< pure <<< pure

src/Data/Lens/Internal/Forget.purs

@@ -0,0 +1,46 @@
+module Data.Lens.Internal.Forget where
+
+import Prelude
+
+import Data.Tuple (Tuple (..), fst, snd)
+import Data.Either (Either (..), either)
+import Data.Monoid (Monoid, mempty)
+import Data.Const (Const (..), getConst)
+import Data.Profunctor (Profunctor)
+import Data.Profunctor.Strong (Strong)
+import Data.Profunctor.Choice (Choice)
+import Data.Profunctor.Cochoice (Cochoice)
+
+import Data.Lens.Internal.Wander (Wander)
+
+-- | Profunctor that forgets the `b` value and returns (and accumulates) a
+-- | value of type `r`.
+-- |
+-- | `Forget r` is isomorphic to `Star (Const r)`, but can be given a `Cochoice`
+-- | instance.
+newtype Forget r a b = Forget (a -> r)
+
+-- | Unwrap a value of type `Forget`.
+runForget :: forall r a b. Forget r a b -> a -> r
+runForget (Forget z) = z
+
+instance profunctorForget :: Profunctor (Forget r) where
+  dimap f _ (Forget z) = Forget (z <<< f)
+
+instance choiceForget :: (Monoid r) => Choice (Forget r) where
+  left  (Forget z) = Forget (either z mempty)
+  right (Forget z) = Forget (either mempty z)
+
+instance strongForget :: Strong (Forget r) where
+  first  (Forget z) = Forget (z <<< fst)
+  second (Forget z) = Forget (z <<< snd)
+
+instance cochoiceForget :: Cochoice (Forget r) where
+  unleft  (Forget z) = Forget (z <<< Left)
+  unright (Forget z) = Forget (z <<< Right)
+
+instance wanderForget :: (Monoid r) => Wander (Forget r) where
+  wander f (Forget r) = Forget \s -> getConst (f (Const <<< r) s)
+
+-- forall s t a b. (forall f. (Applicative f) => (a -> f b) -> s -> f t)
+-- -> p a b -> p s t

src/Data/Lens/Internal/Re.purs

@@ -0,0 +1,36 @@
+-- | This module defines the `Re` profunctor
+
+module Data.Lens.Internal.Re where
+
+import Prelude
+
+import Data.Profunctor
+import Data.Profunctor.Strong
+import Data.Profunctor.Choice
+import Data.Profunctor.Cochoice
+import Data.Profunctor.Costrong
+
+--
+newtype Re p s t a b = Re (p b a -> p t s)
+
+runRe :: forall p s t a b. Re p s t a b -> p b a -> p t s
+runRe (Re r) = r
+
+instance profunctorRe :: (Profunctor p) => Profunctor (Re p s t) where
+  dimap f g (Re r) = Re (r <<< dimap g f)
+
+instance choiceRe :: (Choice p) => Cochoice (Re p s t) where
+  unleft (Re r) = Re (r <<< left)
+  unright (Re r) = Re (r <<< right)
+
+instance cochoiceRe :: (Cochoice p) => Choice (Re p s t) where
+  left (Re r) = Re (r <<< unleft)
+  right (Re r) = Re (r <<< unright)
+
+instance strongRe :: (Strong p) => Costrong (Re p s t) where
+  unfirst (Re r) = Re (r <<< first)
+  unsecond (Re r) = Re (r <<< second)
+
+instance costrongRe :: (Costrong p) => Strong (Re p s t) where
+  first (Re r) = Re (r <<< unfirst)
+  second (Re r) = Re (r <<< unsecond)

src/Data/Lens/Internal/Tagged.purs

@@ -4,7 +4,9 @@ module Data.Lens.Internal.Tagged where
 
 import Data.Profunctor (Profunctor)
 import Data.Profunctor.Choice (Choice)
+import Data.Profunctor.Costrong (Costrong)
 import Data.Either (Either(..))
+import Data.Tuple (Tuple(..))
 
 newtype Tagged a b = Tagged b
 
@@ -15,5 +17,9 @@ instance taggedChoice :: Choice Tagged where
   left  (Tagged x) = Tagged (Left x)
   right (Tagged x) = Tagged (Right x)
 
+instance taggedCostrong :: Costrong Tagged where
+  unfirst (Tagged (Tuple b _)) = Tagged b
+  unsecond (Tagged (Tuple _ c)) = Tagged c
+
 unTagged :: forall a b. Tagged a b -> b
 unTagged (Tagged x) = x

src/Data/Lens/Iso.purs

@@ -1,7 +1,7 @@
 -- | This module defines functions for working with isomorphisms.
 
 module Data.Lens.Iso
-  ( iso, withIso, cloneIso, au, auf, under, curried, uncurried, flipped
+  ( iso, withIso, cloneIso, re, au, auf, under, curried, uncurried, flipped
   , module Data.Lens.Types
   ) where
 
@@ -10,7 +10,7 @@ import Prelude ((<<<), flip, id)
 import Data.Profunctor (Profunctor, dimap, rmap)
 import Data.Tuple (Tuple(), curry, uncurry)
 
-import Data.Lens.Types (Iso(), IsoP(), AnIso(), AnIsoP(), Exchange(..))
+import Data.Lens.Types (Iso(), IsoP(), AnIso(), AnIsoP(), Optic(), Exchange(..), Re(..), runRe)
 
 -- | Create an `Iso` from a pair of morphisms.
 iso :: forall s t a b. (s -> a) -> (b -> t) -> Iso s t a b
@@ -25,6 +25,10 @@ withIso l f = case l (Exchange id id) of
 cloneIso :: forall s t a b. AnIso s t a b -> Iso s t a b
 cloneIso l = withIso l \x y p -> iso x y p
 
+-- | Reverses an optic.
+re :: forall p s t a b. Optic (Re p a b) s t a b -> Optic p b a t s
+re t = runRe (t (Re id))
+
 au :: forall s t a b e. AnIso s t a b -> ((b -> t) -> e -> s) -> e -> a
 au l = withIso l \sa bt f e -> sa (f bt e)
 

src/Data/Lens/Setter.purs

@@ -2,12 +2,14 @@
 
 module Data.Lens.Setter
   ( (%~), (.~), (+~), (-~), (*~), (//~), (||~), (&&~), (<>~), (++~), (?~)
+  , (.=), (%=), (+=), (*=), (-=), (//=), (||=), (&&=), (<>=), (++=), (?=)
   , over, set
   , module Data.Lens.Types
   ) where
 
 import Prelude
 
+import Control.Monad.State.Class (MonadState, modify)
 import Data.Maybe (Maybe(..))
 
 import Data.Lens.Types (Setter(), SetterP())
@@ -24,6 +26,18 @@ infixr 4 <>~
 infixr 4 ++~
 infixr 4 ?~
 
+infix 4 .=
+infix 4 %=
+infix 4 +=
+infix 4 *=
+infix 4 -=
+infix 4 //=
+infix 4 ||=
+infix 4 &&=
+infix 4 <>=
+infix 4 ++=
+infix 4 ?=
+
 -- | Apply a function to the foci of a `Setter`.
 over :: forall s t a b. Setter s t a b -> (a -> b) -> s -> t
 over l = l
@@ -66,3 +80,48 @@ set l b = over l (const b)
 
 (?~) :: forall s t a b. Setter s t a (Maybe b) -> b -> s -> t
 (?~) p = set p <<< Just
+
+-- Stateful
+
+-- | Set the foci of a `Setter` in a monadic state to a constant value.
+assign :: forall s a b m. (MonadState s m) => Setter s s a b -> b -> m Unit
+assign p b = modify (set p b)
+
+-- | Modify the foci of a `Setter` in a monadic state.
+modifying :: forall s a b m. (MonadState s m) => Setter s s a b -> (a -> b) -> m Unit
+modifying p f = modify (over p f)
+
+-- | Synonym for `assign`
+(.=) :: forall s a b m. (MonadState s m) => Setter s s a b -> b -> m Unit
+(.=) = assign
+
+-- | Synonym for `modifying`
+(%=) :: forall s a b m. (MonadState s m) => Setter s s a b -> (a -> b) -> m Unit
+(%=) = modifying
+
+(+=) :: forall s a m. (MonadState s m, Semiring a) => SetterP s a -> a -> m Unit
+(+=) p = modifying p <<< add
+
+(*=) :: forall s a m. (MonadState s m, Semiring a) => SetterP s a -> a -> m Unit
+(*=) p = modifying p <<< flip mul
+
+(-=) :: forall s a m. (MonadState s m, Ring a) => SetterP s a -> a -> m Unit
+(-=) p = modifying p <<< flip sub
+
+(//=) :: forall s a m. (MonadState s m, DivisionRing a) => SetterP s a -> a -> m Unit
+(//=) p = modifying p <<< flip div
+
+(||=) :: forall s a m. (MonadState s m, BooleanAlgebra a) => SetterP s a -> a -> m Unit
+(||=) p = modifying p <<< flip disj
+
+(&&=) :: forall s a m. (MonadState s m, BooleanAlgebra a) => SetterP s a -> a -> m Unit
+(&&=) p = modifying p <<< flip conj
+
+(<>=) :: forall s a m. (MonadState s m, Semigroup a) => SetterP s a -> a -> m Unit
+(<>=) p = modifying p <<< flip append
+
+(++=) :: forall s a m. (MonadState s m, Semigroup a) => SetterP s a -> a -> m Unit
+(++=) p = modifying p <<< flip append
+
+(?=) :: forall s a b m. (MonadState s m) => Setter s s a (Maybe b) -> b -> m Unit
+(?=) p = assign p <<< Just

src/Data/Lens/Types.purs

@@ -6,20 +6,25 @@ module Data.Lens.Types
   , module Data.Lens.Internal.Market
   , module Data.Lens.Internal.Shop
   , module Data.Lens.Internal.Tagged
+  , module Data.Lens.Internal.Forget
   , module Data.Lens.Internal.Wander
+  , module Data.Lens.Internal.Re
   ) where
 
 import Data.Const (Const())
 import Data.Profunctor (Profunctor)
 import Data.Profunctor.Choice (Choice)
 import Data.Profunctor.Star (Star())
 import Data.Profunctor.Strong (Strong)
+import Data.Profunctor.Closed (Closed)
 
 import Data.Lens.Internal.Exchange (Exchange(..))
 import Data.Lens.Internal.Market (Market(..))
 import Data.Lens.Internal.Shop (Shop(..))
 import Data.Lens.Internal.Tagged (Tagged(..), unTagged)
+import Data.Lens.Internal.Forget (Forget(..), runForget)
 import Data.Lens.Internal.Wander (Wander, wander)
+import Data.Lens.Internal.Re (Re(..), runRe)
 
 -- | A general-purpose Data.Lens.
 type Optic p s t a b = p a b -> p s t
@@ -63,5 +68,5 @@ type Review s t a b = Optic Tagged s t a b
 type ReviewP s a = Review s s a a
 
 -- | A fold.
-type Fold r s t a b = Optic (Star (Const r)) s t a b
+type Fold r s t a b = Optic (Forget r) s t a b
 type FoldP r s a = Fold r s s a a