Permalink
Browse files

repo initialized

  • Loading branch information...
0 parents commit ed7d78cb3953d95bb8a53955c0af58bf74f078af Edward Kmett committed Jun 28, 2011
Showing with 398 additions and 0 deletions.
  1. +140 −0 Data/Lens/Common.hs
  2. +90 −0 Data/Lens/Lazy.hs
  3. +90 −0 Data/Lens/Strict.hs
  4. +30 −0 LICENSE
  5. +48 −0 lens.cabal
@@ -0,0 +1,140 @@
+module Data.Lens.Common
+ ( Lens(..)
+ -- * Lens construction
+ , lens -- build a lens from a getter and setter
+ , iso -- build a lens from an isomorphism
+ -- * Functional API
+ , (^$), (^$!) -- getter -- :: Lens a b -> a -> b
+ , (^.), (^!) -- getter -- :: a -> Lens a b -> b
+ , (^=), (^!=) -- 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
+ -- * Pseudo-imperatives
+ , (^+=), (^!+=) -- addition
+ , (^-=), (^!-=) -- subtraction
+ , (^*=), (^!*=) -- multiplication
+ , (^/=), (^!/=) -- division
+ -- * Stock lenses
+ , fstLens
+ , sndLens
+ , mapLens
+ , intMapLens
+ , setLens
+ , intSetLens
+ ) where
+
+import Control.Applicative
+import Control.Comonad.Trans.Store
+import Control.Category
+import Data.Functor.Identity
+import Data.Functor.Apply
+import Data.Semigroupoid
+import Prelude hiding ((.), id)
+import Data.IntMap (IntMap)
+import qualified Data.Map as Map
+import Data.Set (Set)
+import qualified Data.IntMap as IntMap
+import Data.Map (Map)
+import qualified Data.Set as Set
+import Data.IntSet (IntSet)
+import qualified Data.IntSet as IntSet
+
+newtype Lens a b = Lens { runLens :: a -> Store b a }
+
+instance Semigroupoid Lens where
+ Lens f `o` Lens g = Lens $ \a -> case g a of
+ StoreT wba b -> case f b of
+ StoreT wcb c -> StoreT ((.) <$> wba <.> wcb) c
+
+instance Category Lens where
+ id = Lens $ StoreT (pure id)
+ Lens f . Lens g = Lens $ \a -> case g a of
+ StoreT wba b -> case f b of
+ StoreT wcb c -> StoreT ((.) <$> wba <*> wcb) c
+
+-- * Lens construction
+
+-- | build a lens out of a getter and setter
+lens :: (a -> b) -> (b -> a -> a) -> Lens a b
+lens get set = Lens $ \a -> store (\b -> set b a) (get a)
+
+-- | build a lens out of an isomorphism
+iso :: (a -> b) -> (b -> a) -> Lens a b
+iso f g = Lens (store g . f)
+
+infixr 0 ^$, ^$!
+
+-- | functional getter
+(^$), (^$!) :: Lens a b -> a -> b
+Lens f ^$ a = pos (f a)
+Lens f ^$! a = pos (f $! a)
+
+infixr 9 ^., ^!
+-- | functional getter, which acts like a field accessor
+(^.), (^!) :: a -> Lens a b -> b
+a ^. Lens f = pos (f a)
+a ^! Lens f = pos (f $! a)
+
+infixr 4 ^=, ^!=
+-- | functional setter
+(^=), (^!=) :: Lens a b -> b -> a -> a
+Lens f ^= b = peek b . f
+Lens f ^!= b = \a -> case f a of
+ StoreT (Identity g) _ -> g $! b
+
+infixr 4 ^%=, ^!%=
+-- | functional modify
+(^%=), (^!%=) :: Lens a b -> (b -> b) -> a -> a
+Lens f ^%= g = peeks g . f
+Lens f ^!%= g = \a -> case f a of
+ StoreT (Identity h) b -> h $! g b
+
+infixr 4 ^%%=
+-- | functorial modify
+(^%%=) :: Functor f => Lens a b -> (b -> f b) -> a -> f a
+Lens f ^%%= g = \a -> case f a of
+ StoreT (Identity h) b -> h <$> g b
+
+infixr 4 ^+=, ^!+=, ^-=, ^!-=, ^*=, ^!*=
+(^+=), (^!+=), (^-=), (^!-=), (^*=), (^!*=) :: Num b => Lens a b -> b -> a -> a
+l ^+= n = l ^%= (+ n)
+l ^-= n = l ^%= subtract n
+l ^*= n = l ^%= (* n)
+l ^!+= n = l ^!%= (+ n)
+l ^!-= n = l ^!%= subtract n
+l ^!*= n = l ^!%= (* n)
+
+infixr 4 ^/=, ^!/=
+(^/=), (^!/=) :: Fractional b => Lens a b -> b -> a -> a
+l ^/= r = l ^%= (/ r)
+l ^!/= r = l ^!%= (/ r)
+
+-- * Stock lenses
+
+fstLens :: Lens (a,b) a
+fstLens = Lens $ \(a,b) -> store (\ a' -> (a', b)) a
+
+sndLens :: Lens (a,b) b
+sndLens = Lens $ \(a,b) -> store (\ b' -> (a, b')) b
+
+mapLens :: Ord k => k -> Lens (Map k v) (Maybe v)
+mapLens k = Lens $ \m -> store (\mv -> case mv of
+ Nothing -> Map.delete k m
+ Just v' -> Map.insert k v' m
+ ) (Map.lookup k m)
+
+intMapLens :: Int -> Lens (IntMap v) (Maybe v)
+intMapLens k = Lens $ \m -> store (\mv -> case mv of
+ Nothing -> IntMap.delete k m
+ Just v' -> IntMap.insert k v' m
+ ) (IntMap.lookup k m)
+
+setLens :: Ord k => k -> Lens (Set k) Bool
+setLens k = Lens $ \m -> store (\mv ->
+ if mv then Set.delete k m else Set.insert k m
+ ) (Set.member k m)
+
+intSetLens :: Int -> Lens IntSet Bool
+intSetLens k = Lens $ \m -> store (\mv ->
+ if mv then IntSet.delete k m else IntSet.insert k m
+ ) (IntSet.member k m)
@@ -0,0 +1,90 @@
+module Data.Lens.Lazy
+ ( module Data.Lens.Common
+ -- * State API
+ , access -- getter -- :: Monad m => Lens a b -> StateT a m b
+ , (~=), (!=) -- setter -- :: Monad m => Lens a b -> b -> StateT a m b
+ , (%=), (!%=) -- modify -- :: Monad m => Lens a b -> (b -> b) -> StateT a m b
+ , (%%=), (!%%=) -- modify -- :: Monad m => Lens a b -> (b -> (c, b)) -> StateT a m c
+ , (+=), (!+=) -- modify -- :: (Monad m, Num b) => Lens a b -> b -> StateT a m b
+ , (-=), (!-=) -- modify -- :: (Monad m, Num b) => Lens a b -> b -> StateT a m b
+ , (*=), (!*=) -- modify -- :: (Monad m, Num b) => Lens a b -> b -> StateT a m b
+ , (//=), (!/=) -- modify -- :: (Monad m, Fractional b) => Lens a b -> b -> StateT a m b
+ , (&&=), (!&&=) -- modify -- :: Monad m => Lens a Bool -> Bool -> StateT a m Bool
+ , (||=), (!||=) -- modify -- :: Monad m => Lens a Bool -> Bool -> StateT a m Bool
+ , focus -- modify -- :: Monad m => Lens a b -> StateT m b c -> StateT m a c
+ ) where
+
+import Control.Comonad.Trans.Store
+import Control.Monad.Trans.State
+import Control.Monad (liftM)
+import Data.Functor.Identity
+import Data.Lens.Common
+
+-- * State actions
+
+-- | get the value of a lens into state
+access :: Monad m => Lens a b -> StateT a m b
+access (Lens f) = gets (pos . f)
+{-# INLINE access #-}
+
+focus :: Monad m => Lens a b -> StateT b m c -> StateT a m c
+focus (Lens f) (StateT g) = StateT $ \a -> case f a of
+ StoreT (Identity h) b -> liftM (\(c, b') -> (c, h b')) (g b)
+
+infixr 4 ~=, !=
+
+-- | set a value using a lens into state
+(~=), (!=) :: Monad m => Lens a b -> b -> StateT a m b
+Lens f ~= b = StateT $ \a -> let c = peek b (f a) in
+ return (b, c)
+Lens f != b = StateT $ \a -> case f a of
+ StoreT (Identity h) _ -> let c = h $! b in
+ return (b, c)
+
+infixr 4 %=, !%=
+
+-- | infix modification a value through a lens into state
+(%=), (!%=) :: Monad m => Lens a b -> (b -> b) -> StateT a m b
+Lens f %= g = StateT $ \a -> case f a of
+ StoreT (Identity h) b -> let b' = g b in
+ return (b', h b')
+Lens f !%= g = StateT $ \a -> case f a of
+ StoreT (Identity h) b -> let b' = g b in
+ b' `seq` return (b', h b')
+
+infixr 4 %%=, !%%=
+
+-- | infix modification of a value through a lens into state
+-- with a supplemental response
+(%%=), (!%%=) :: Monad m => Lens a b -> (b -> (c, b)) -> StateT a m c
+Lens f %%= g = StateT $ \a -> case f a of
+ StoreT (Identity h) b -> case g b of
+ (c, b') -> return (c, h b')
+Lens f !%%= g = StateT $ \a -> case f a of
+ StoreT (Identity h) b -> case g b of
+ (c, b') -> return (c, h $! b')
+
+infixr 4 +=, !+=, -=, !-=, *=, !*=
+
+(+=), (!+=), (-=), (!-=), (*=), (!*=) :: (Monad m, Num b) => Lens a b -> b -> StateT a m b
+f += b = f %= (+ b)
+f -= b = f %= subtract b
+f *= b = f %= (* b)
+f !+= b = f !%= (+ b)
+f !-= b = f !%= subtract b
+f !*= b = f !%= (* b)
+
+infixr 4 //=, !/=
+
+(//=), (!/=) :: (Monad m, Fractional b) => Lens a b -> b -> StateT a m b
+f //= b = f %= (/ b)
+f !/= b = f !%= (/ b)
+
+infixr 4 &&=, !&&=, ||=, !||=
+
+(&&=), (||=), (!&&=), (!||=) :: Monad m => Lens a Bool -> Bool -> StateT a m Bool
+f &&= b = f %= (&& b)
+f ||= b = f %= (|| b)
+f !&&= b = f !%= (&& b)
+f !||= b = f !%= (|| b)
+
@@ -0,0 +1,90 @@
+module Data.Lens.Strict
+ ( module Data.Lens.Common
+ -- * State API
+ , access -- getter -- :: Monad m => Lens a b -> StateT a m b
+ , (~=), (!=) -- setter -- :: Monad m => Lens a b -> b -> StateT a m b
+ , (%=), (!%=) -- modify -- :: Monad m => Lens a b -> (b -> b) -> StateT a m b
+ , (%%=), (!%%=) -- modify -- :: Monad m => Lens a b -> (b -> (c, b)) -> StateT a m c
+ , (+=), (!+=) -- modify -- :: (Monad m, Num b) => Lens a b -> b -> StateT a m b
+ , (-=), (!-=) -- modify -- :: (Monad m, Num b) => Lens a b -> b -> StateT a m b
+ , (*=), (!*=) -- modify -- :: (Monad m, Num b) => Lens a b -> b -> StateT a m b
+ , (//=), (!/=) -- modify -- :: (Monad m, Fractional b) => Lens a b -> b -> StateT a m b
+ , (&&=), (!&&=) -- modify -- :: Monad m => Lens a Bool -> Bool -> StateT a m Bool
+ , (||=), (!||=) -- modify -- :: Monad m => Lens a Bool -> Bool -> StateT a m Bool
+ , focus -- modify -- :: Monad m => Lens a b -> StateT m b c -> StateT m a c
+ ) where
+
+import Control.Comonad.Trans.Store
+import Control.Monad.Trans.State.Strict
+import Control.Monad (liftM)
+import Data.Functor.Identity
+import Data.Lens.Common
+
+-- * State actions
+
+-- | get the value of a lens into state
+access :: Monad m => Lens a b -> StateT a m b
+access (Lens f) = gets (pos . f)
+{-# INLINE access #-}
+
+focus :: Monad m => Lens a b -> StateT b m c -> StateT a m c
+focus (Lens f) (StateT g) = StateT $ \a -> case f a of
+ StoreT (Identity h) b -> liftM (\(c, b') -> (c, h b')) (g b)
+
+infixr 4 ~=, !=
+
+-- | set a value using a lens into state
+(~=), (!=) :: Monad m => Lens a b -> b -> StateT a m b
+Lens f ~= b = StateT $ \a -> let c = peek b (f a) in
+ return (b, c)
+Lens f != b = StateT $ \a -> case f a of
+ StoreT (Identity h) _ -> let c = h $! b in
+ return (b, c)
+
+infixr 4 %=, !%=
+
+-- | infix modification a value through a lens into state
+(%=), (!%=) :: Monad m => Lens a b -> (b -> b) -> StateT a m b
+Lens f %= g = StateT $ \a -> case f a of
+ StoreT (Identity h) b -> let b' = g b in
+ return (b', h b')
+Lens f !%= g = StateT $ \a -> case f a of
+ StoreT (Identity h) b -> let b' = g b in
+ b' `seq` return (b', h b')
+
+infixr 4 %%=, !%%=
+
+-- | infix modification of a value through a lens into state
+-- with a supplemental response
+(%%=), (!%%=) :: Monad m => Lens a b -> (b -> (c, b)) -> StateT a m c
+Lens f %%= g = StateT $ \a -> case f a of
+ StoreT (Identity h) b -> case g b of
+ (c, b') -> return (c, h b')
+Lens f !%%= g = StateT $ \a -> case f a of
+ StoreT (Identity h) b -> case g b of
+ (c, b') -> return (c, h $! b')
+
+infixr 4 +=, !+=, -=, !-=, *=, !*=
+
+(+=), (!+=), (-=), (!-=), (*=), (!*=) :: (Monad m, Num b) => Lens a b -> b -> StateT a m b
+f += b = f %= (+ b)
+f -= b = f %= subtract b
+f *= b = f %= (* b)
+f !+= b = f !%= (+ b)
+f !-= b = f !%= subtract b
+f !*= b = f !%= (* b)
+
+infixr 4 //=, !/=
+
+(//=), (!/=) :: (Monad m, Fractional b) => Lens a b -> b -> StateT a m b
+f //= b = f %= (/ b)
+f !/= b = f !%= (/ b)
+
+infixr 4 &&=, !&&=, ||=, !||=
+
+(&&=), (||=), (!&&=), (!||=) :: Monad m => Lens a Bool -> Bool -> StateT a m Bool
+f &&= b = f %= (&& b)
+f ||= b = f %= (|| b)
+f !&&= b = f !%= (&& b)
+f !||= b = f !%= (|| b)
+
30 LICENSE
@@ -0,0 +1,30 @@
+Copyright 2008-2011 Edward Kmett
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+
+1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+
+3. Neither the name of the author nor the names of his contributors
+ may be used to endorse or promote products derived from this software
+ without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGE.
Oops, something went wrong.

0 comments on commit ed7d78c

Please sign in to comment.