Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP

Loading…

module Data.Lens.Maybe, (***), (|||), codiagonal #3

Closed
wants to merge 8 commits into from

2 participants

Commits on Jan 13, 2012
  1. @tonymorris
  2. @tonymorris

    lens product

    tonymorris authored
  3. @tonymorris

    lens product

    tonymorris authored
  4. @tonymorris

    codiagonal

    tonymorris authored
Commits on Jan 14, 2012
  1. @tonymorris

    setJust

    tonymorris authored
Commits on Jan 19, 2012
  1. @tonymorris

    export it

    tonymorris authored
  2. @tonymorris

    kleisli get

    tonymorris authored
  3. @tonymorris

    newtype

    tonymorris authored
This page is out of date. Refresh to see the latest.
Showing with 139 additions and 1 deletion.
  1. +40 −0 Data/Lens/Common.hs
  2. +96 −0 Data/Lens/Maybe.hs
  3. +3 −1 data-lens.cabal
View
40 Data/Lens/Common.hs
@@ -13,12 +13,19 @@ module Data.Lens.Common
, (^=), (^!=) -- setter -- :: Lens a b -> b -> (a -> a)
, (^%=), (^!%=) -- modify -- :: Lens a b -> (b -> b) -> (a -> a)
, (^%%=) -- modify -- :: Functor f => Lens a b -> (b -> f b) -> a -> f a
+ , (***) -- product
+ , (|||) -- choice
+ , (>->) -- Kleisli composition (get)
+ , (<-<) -- Kleisli composition (get)
+ -- * Morphisms
+ , codiagonal
-- * Pseudo-imperatives
, (^+=), (^!+=) -- addition
, (^-=), (^!-=) -- subtraction
, (^*=), (^!*=) -- multiplication
, (^/=), (^!/=) -- division
-- * Stock lenses
+ , newtypeLens
, fstLens
, sndLens
, mapLens
@@ -30,6 +37,7 @@ module Data.Lens.Common
import Control.Applicative
import Control.Comonad.Trans.Store
import Control.Category
+import Control.Newtype
import Data.Functor.Identity
import Data.Functor.Apply
import Data.Semigroupoid
@@ -108,6 +116,35 @@ infixr 4 ^%%=
Lens f ^%%= g = \a -> case f a of
StoreT (Identity h) b -> h <$> g b
+infixr 3 ***
+-- | lens product
+(***) :: Lens a b -> Lens c d -> Lens (a, c) (b, d)
+Lens f *** Lens g = Lens $ \(a, c) ->
+ let x = f a
+ y = g c
+ in store (\(b, d) -> (peek b x, peek d y)) (pos x, pos y)
+
+infixr 2 |||
+-- lens choice
+(|||) :: Lens a c -> Lens b c -> Lens (Either a b) c
+Lens f ||| Lens g = Lens $
+ either (\a ->
+ let x = f a
+ in store (Left . flip peek x) (pos x))
+ (\b ->
+ let y = g b
+ in store (Right . flip peek y) (pos y))
+
+(>->) :: Monad m => Lens a (m b) -> Lens b (m c) -> a -> (m c)
+f >-> g = \a -> getL f a >>= getL g
+
+(<-<) :: Monad m => Lens b (m c) -> Lens a (m b) -> a -> (m c)
+(<-<) = flip (>->)
+
+-- codiagonal lens
+codiagonal :: Lens (Either a a) a
+codiagonal = id ||| id
+
infixr 4 ^+=, ^!+=, ^-=, ^!-=, ^*=, ^!*=
(^+=), (^!+=), (^-=), (^!-=), (^*=), (^!*=) :: Num b => Lens a b -> b -> a -> a
l ^+= n = l ^%= (+ n)
@@ -124,6 +161,9 @@ l ^!/= r = l ^!%= (/ r)
-- * Stock lenses
+newtypeLens :: Newtype a b => Lens a b
+newtypeLens = Lens (store pack . unpack)
+
fstLens :: Lens (a,b) a
fstLens = Lens $ \(a,b) -> store (\ a' -> (a', b)) a
View
96 Data/Lens/Maybe.hs
@@ -0,0 +1,96 @@
+-- | Lenses that project on to a @Maybe@ value.
+module Data.Lens.Maybe
+ ( MLens
+ -- * Functional API
+ , mgetL
+ , mset
+ , unset
+ , setJust
+ -- * Operator API
+ , (^|), (^|!) -- getter
+ , (^|=), (^|!=) -- setter
+ ) where
+
+import Data.Lens.Common
+import Control.Comonad.Trans.Store
+import Data.Maybe
+
+-- |
+type MLens a b =
+ Lens a (Maybe b)
+
+-- | Gets the @Just@ value from a lens or a default if @Nothing@.
+mgetL ::
+ MLens a b
+ -> a
+ -> b -- ^ The default if @Nothing@.
+ -> b
+mgetL =
+ (^|)
+
+-- | Gets the @Just@ value from a lens or a default if @Nothing@.
+(^|) ::
+ MLens a b
+ -> a
+ -> b -- ^ The default if @Nothing@.
+ -> b
+l ^| a =
+ flip fromMaybe (l ^$ a)
+
+-- | Gets the @Just@ value from a lens or a default if @Nothing@.
+(^|!) ::
+ MLens a b
+ -> a
+ -> b -- ^ The default if @Nothing@.
+ -> b
+l ^|! a =
+ flip fromMaybe (l ^$! a)
+
+-- | Sets a @Just@ value on a lens.
+mset ::
+ MLens a b
+ -> b -- ^ The value to set.
+ -> a
+ -> a
+mset =
+ (^|=)
+
+-- | Sets a @Just@ value on a lens.
+(^|=) ::
+ MLens a b
+ -> b -- ^ The value to set.
+ -> a
+ -> a
+l ^|= b =
+ l ^= Just b
+
+-- | Sets a @Just@ value on a lens.
+(^|!=) ::
+ MLens a b
+ -> b -- ^ The value to set.
+ -> a
+ -> a
+l ^|!= b =
+ l ^!= Just b
+
+-- | Sets a @Nothing@ value on a lens.
+unset ::
+ MLens a b
+ -> a
+ -> a
+unset l =
+ l ^= Nothing
+
+-- | Sets the given c value on the lens if the given @Maybe@ lens gives a @Just@ value.
+setJust ::
+ MLens a b
+ -> Lens b c
+ -> a
+ -> c
+ -> a
+setJust (Lens f) g a c =
+ let a' = f a
+ in case pos a' of
+ Nothing -> a
+ Just b -> peek (Just (setL g c b)) a'
+
View
4 data-lens.cabal
@@ -30,7 +30,8 @@ library
contravariant >= 0.1.2 && < 0.2,
distributive >= 0.2 && < 0.3,
semigroupoids >= 1.2.4 && < 1.3,
- transformers >= 0.2.0 && <= 0.3
+ transformers >= 0.2.0 && <= 0.3,
+ newtype >= 0.1 && <= 0.2
if flag(DeriveDataTypeable)
extensions: DeriveDataTypeable
@@ -42,5 +43,6 @@ library
Data.Lens.Common
Data.Lens.Lazy
Data.Lens.Strict
+ Data.Lens.Maybe
ghc-options: -Wall
Something went wrong with that request. Please try again.