Permalink
Browse files

Incorporating the rest of tmorris' pull request: #6

  • Loading branch information...
1 parent fa98bad commit d91d5dce9142b728f725cfefa70da10ea7a76778 @roconnor committed Jun 9, 2012
Showing with 56 additions and 37 deletions.
  1. +1 −1 data-lens.cabal
  2. +3 −0 src/Control/Comonad/StaredStore.hs
  3. +4 −0 src/Data/Lens/Common.hs
  4. +21 −15 src/Data/Lens/Multi/Common.hs
  5. +27 −21 src/Data/Lens/Partial/Common.hs
View
@@ -5,7 +5,7 @@ license: BSD3
cabal-version: >= 1.6
license-file: LICENSE
author: Russell O'Connor, Edward A. Kmett & Tony Morris
-maintainer: Russell O'Connor <roconnor@theorem.ca>
+maintainer: Russell O'Connor <roconnor@theorem.ca>, Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ>
stability: provisional
homepage: http://github.com/roconnor/data-lens/
copyright: Copyright (C) 2008-2012 Edward A. Kmett, Russell O'Connor & Tony Morris
@@ -53,3 +53,6 @@ eekss f (StaredStore s) = coproduct (pure . runIdentity) h s
h st = f v <**> eekss f g
where
(g, v) = runStoreT st
+
+isEmptyss :: StaredStore b a -> Bool
+isEmptyss (StaredStore s) = coproduct (const True) (const False) s
View
@@ -8,6 +8,7 @@ module Data.Lens.Common
, setL
, modL
, mergeL
+ , unzipL
-- * Operator API
, (^$), (^$!) -- getter -- :: Lens a b -> a -> b
, (^.), (^!) -- getter -- :: a -> Lens a b -> b
@@ -101,6 +102,9 @@ mergeL :: Lens a c -> Lens b c -> Lens (Either a b) c
Lens f `mergeL` Lens g =
Lens $ either (\a -> Left <$> f a) (\b -> Right <$> g b)
+unzipL :: Lens a (b, c) -> (Lens a b, Lens a c)
+unzipL f = (fstLens . f, sndLens . f)
+
infixr 4 ^%=, ^!%=
-- | functional modify
(^%=), (^!%=) :: Lens a b -> (b -> b) -> a -> a
@@ -1,10 +1,10 @@
module Data.Lens.Multi.Common where
-import Prelude hiding ((.), id, null)
+import Prelude hiding ((.), id)
import Control.Applicative
import Control.Applicative.Backwards
import Control.Category
-import Data.Lens.Common (Lens(..), sndLens)
+import Data.Lens.Common (Lens(..), fstLens, sndLens)
import Data.Lens.Partial.Common (PartialLens, pLens, runPLens)
import Control.Comonad
import Control.Comonad.Trans.Store
@@ -17,16 +17,16 @@ import Control.Arrow ((***))
newtype MultiLens a b = MLens {runMLens :: a -> StaredStore b a}
instance Category MultiLens where
- id = totalLens id
+ id = totalML id
MLens f . g = MLens $ g ^%%= f
-- totalLens is a homomorphism of categories; ie a functor.
-totalLens :: Lens a b -> MultiLens a b
-totalLens (Lens f) = MLens $ fromStore . f
+totalML :: Lens a b -> MultiLens a b
+totalML (Lens f) = MLens $ fromStore . f
-- totalLens is a homomorphism of categories; ie a functor.
-partialLens :: PartialLens a b -> MultiLens a b
-partialLens l = MLens $ coproduct (pure . runIdentity) fromStore . runPLens l
+partialML :: PartialLens a b -> MultiLens a b
+partialML l = MLens $ coproduct (pure . runIdentity) fromStore . runPLens l
getML :: MultiLens a b -> a -> [b]
getML (MLens f) = poss . f
@@ -51,20 +51,26 @@ reverseML l = MLens (forwards . (l ^%%= (Backwards . runMLens id)))
backPL :: MultiLens a b -> PartialLens a b
backPL = frontPL . reverseML
+unzipML :: MultiLens a (b, c) -> (MultiLens a b, MultiLens a c)
+unzipML l = (totalML fstLens . l, totalML sndLens . l)
+
+isNullML :: MultiLens a b -> a -> Bool
+isNullML l = null . getML l
+
-- Stock Multilenses
-traversableLens :: (Traversable f) => MultiLens (f a) a
-traversableLens = MLens $ traverse (runMLens id)
+traversableML :: (Traversable f) => MultiLens (f a) a
+traversableML = MLens $ traverse (runMLens id)
-listLens :: MultiLens [a] a
-listLens = traversableLens
+listML :: MultiLens [a] a
+listML = traversableML
-lookupByL :: (k -> Bool) -> MultiLens [(k,v)] v
-lookupByL p = partialLens keyPL . listLens
+lookupByML :: (k -> Bool) -> MultiLens [(k,v)] v
+lookupByML p = partialML keyPL . listML
where
keyPL = pLens f
f (k,v) | p k = right (runLens sndLens (k,v))
| otherwise = left (Identity (k,v))
-lookupL :: (Eq k) => k -> MultiLens [(k,v)] v
-lookupL k = lookupByL (k==)
+lookupML :: (Eq k) => k -> MultiLens [(k,v)] v
+lookupML k = lookupByML (k==)
@@ -4,7 +4,7 @@ import Prelude hiding ((.), id, null, any, all)
import Control.Applicative
import Control.Category
import Control.Category.Product
-import Data.Lens.Common (Lens(..))
+import Data.Lens.Common (Lens(..), fstLens, sndLens)
import Control.Comonad.Trans.Store
import Data.Foldable (any, all)
import Data.Functor.Identity
@@ -22,18 +22,18 @@ runPLens :: PartialLens a b -> a -> (Coproduct Identity (Store b)) a
runPLens (PLens f) a = maybe (left (Identity a)) right (f a)
instance Category PartialLens where
- id = totalLens id
+ id = totalPL id
PLens f . PLens g = PLens $ \a -> do
(StoreT wba b) <- g a
(StoreT wcb c) <- f b
return (StoreT ((.) <$> wba <*> wcb) c)
-null :: PartialLens a b
-null = PLens (const Nothing)
+nullPL :: PartialLens a b
+nullPL = PLens (const Nothing)
--- totalLens is a homomorphism of categories; ie a functor.
-totalLens :: Lens a b -> PartialLens a b
-totalLens (Lens f) = PLens (Just . f)
+-- totalPL is a homomorphism of categories; ie a functor.
+totalPL :: Lens a b -> PartialLens a b
+totalPL (Lens f) = PLens (Just . f)
-- * Functional API
@@ -52,13 +52,19 @@ mergePL :: PartialLens a c -> PartialLens b c -> PartialLens (Either a b) c
(PLens f) `mergePL` (PLens g) =
PLens $ either (\a -> (fmap Left) <$> f a) (\b -> (fmap Right) <$> g b)
+unzipPL :: PartialLens a (b, c) -> (PartialLens a b, PartialLens a c)
+unzipPL f = (totalPL fstLens . f, totalPL sndLens . f)
+
-- If the Partial is null.
-nullPL :: PartialLens a b -> a -> Bool
-nullPL l = isNothing . getPL l
+isNullPL :: PartialLens a b -> a -> Bool
+isNullPL l = isNothing . getPL l
getorEmptyPL :: (Monoid o) => PartialLens a b -> (b -> o) -> a -> o
getorEmptyPL l p = maybe mempty p . getPL l
+emptyPL :: Monoid b => PartialLens a b -> a -> b
+emptyPL = flip getorEmptyPL id
+
-- returns 0 in case of null
sumPL :: (Num c) => PartialLens a b -> (b -> c) -> a -> c
sumPL l p = getSum . getorEmptyPL l (Sum . p)
@@ -125,25 +131,25 @@ l ^/= r = l ^%= (/ r)
-- * Stock partial lenses
-justLens :: PartialLens (Maybe a) a
-justLens = PLens $ \ma -> do
+justPL :: PartialLens (Maybe a) a
+justPL = PLens $ \ma -> do
a <- ma
return (store Just a)
-leftLens :: PartialLens (Either a b) a
-leftLens = PLens $ either (Just . store Left) (const Nothing)
+leftPL :: PartialLens (Either a b) a
+leftPL = PLens $ either (Just . store Left) (const Nothing)
-rightLens :: PartialLens (Either a b) b
-rightLens = PLens $ either (const Nothing) (Just . store Right)
+rightPL :: PartialLens (Either a b) b
+rightPL = PLens $ either (const Nothing) (Just . store Right)
-headLens :: PartialLens [a] a
-headLens = PLens f
+headPL :: PartialLens [a] a
+headPL = PLens f
where
f [] = Nothing
f (h:t) = Just (store (:t) h)
-tailLens :: PartialLens [a] [a]
-tailLens = PLens f
+tailPL :: PartialLens [a] [a]
+tailPL = PLens f
where
f [] = Nothing
f (h:t) = Just (store (h:) t)
@@ -157,11 +163,11 @@ nthLens n | n < 0 = null
-- setPL does not insert into a Map! it only modifies a value if the key already exists in the map
mapPLens :: Ord k => k -> PartialLens (Map.Map k v) v
-mapPLens k = justLens . totalLens (mapLens k)
+mapPLens k = justLens . totalPL (mapLens k)
-- setPL does not insert into a IntMap! it only modifies a value if the key already exists in the map
intMapPLens :: Int -> PartialLens (IntMap v) v
-intMapPLens k = justLens . totalLens (intMapLens k)
+intMapPLens k = justLens . totalPL (intMapLens k)
-}
instance Tensor PartialLens where

0 comments on commit d91d5dc

Please sign in to comment.