Permalink
Browse files

Added the 'au' combinator in the spirit of 'ala' from Control.Newtype…

…, and isomorphisms for Data.Monoid to use it with
  • Loading branch information...
1 parent 3db0687 commit bc419056ab01e19eb9236931057d3ef3fb8eef7d @ekmett committed Aug 13, 2012
Showing with 95 additions and 0 deletions.
  1. +1 −0 lens.cabal
  2. +22 −0 src/Control/Lens/Iso.hs
  3. +72 −0 src/Data/Monoid/Lens.hs
View
@@ -125,6 +125,7 @@ library
Data.IntMap.Lens
Data.IntSet.Lens
Data.Map.Lens
+ Data.Monoid.Lens
Data.Sequence.Lens
Data.Set.Lens
Data.Tree.Lens
@@ -16,6 +16,7 @@ module Control.Lens.Iso
Iso
, iso
, isos
+ , au
-- ** Combinators
, via
, from
@@ -31,6 +32,8 @@ module Control.Lens.Iso
import Control.Applicative
import Control.Category
+import Control.Lens.Type
+import Control.Lens.Getter
import Data.Functor.Identity
import Data.Typeable
import Prelude hiding ((.),id)
@@ -159,6 +162,25 @@ iso ab ba = isos ab ba ab ba
{-# SPECIALIZE iso :: Functor f => (a -> b) -> (b -> a) -> (b -> f b) -> a -> f a #-}
{-# SPECIALIZE iso :: Functor f => (a -> b) -> (b -> a) -> Isomorphism (b -> f b) (a -> f a) #-}
+-- | Based on @ala@ from Conor McBride's work on Epigram and @Control.Newtype@ from the
+-- 'newtype package.
+--
+-- Mnemonically, /au/ is a French contraction of /à le/.
+--
+-- >>> :m + Control.Lens Data.Monoid.Lens
+-- >>> au _sum foldMap [1,2,3,4]
+-- 10
+au :: Simple Iso a b -> ((a -> b) -> e -> b) -> e -> a
+au l f e = f (view l) e ^. from l
+
+{-
+under :: Setter a b c d -> (c -> d) -> a -> b
+under = adjust
+
+over :: Isomorphism (c -> Identity d) (a -> Identity b) -> (a -> b) -> c -> d
+over = under . from
+-}
+
-----------------------------------------------------------------------------
-- Isomorphisms
-----------------------------------------------------------------------------
@@ -0,0 +1,72 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Data.Monoid.Lens
+-- Copyright : (C) 2012 Edward Kmett
+-- License : BSD-style (see the file LICENSE)
+-- Maintainer : Edward Kmett <ekmett@gmail.com>
+-- Stability : experimental
+-- Portability : Rank2Types
+--
+----------------------------------------------------------------------------
+module Data.Monoid.Lens
+ ( _dual, _endo, _all, _any, _sum, _product, _first, _last
+ ) where
+
+import Data.Monoid
+import Control.Lens
+
+-- | Isomorphism for 'Dual'
+_dual :: Iso a b (Dual a) (Dual b)
+_dual = isos Dual getDual Dual getDual
+{-# INLINE _dual #-}
+{-# SPECIALIZE _dual :: Functor f => Isomorphism (Dual a -> f (Dual b)) (a -> f b) #-}
+{-# SPECIALIZE _dual :: Functor f => (Dual a -> f (Dual b)) -> a -> f b #-}
+
+-- | Isomorphism for 'Endo'
+_endo :: Iso (a -> a) (b -> b) (Endo a) (Endo b)
+_endo = isos Endo appEndo Endo appEndo
+{-# INLINE _endo #-}
+{-# SPECIALIZE _endo :: Functor f => Isomorphism (Endo a -> f (Endo b)) ((a -> a) -> f (b -> b)) #-}
+{-# SPECIALIZE _endo :: Functor f => (Endo a -> f (Endo b)) -> (a -> a) -> f (b -> b) #-}
+
+-- | Isomorphism for 'All'
+_all :: Simple Iso Bool All
+_all = iso All getAll
+{-# INLINE _all #-}
+{-# SPECIALIZE _all :: Functor f => Isomorphism (All -> f All) (Bool -> f Bool) #-}
+{-# SPECIALIZE _all :: Functor f => (All -> f All) -> Bool -> f Bool #-}
+
+-- | Isomorphism for 'Any'
+_any :: Simple Iso Bool Any
+_any = iso Any getAny
+{-# INLINE _any #-}
+{-# SPECIALIZE _any :: Functor f => Isomorphism (Any -> f Any) (Bool -> f Bool) #-}
+{-# SPECIALIZE _any :: Functor f => (Any -> f Any) -> Bool -> f Bool #-}
+
+-- | Isomorphism for 'Sum'
+_sum :: Iso a b (Sum a) (Sum b)
+_sum = isos Sum getSum Sum getSum
+{-# INLINE _sum #-}
+{-# SPECIALIZE _sum :: Functor f => Isomorphism (Sum a -> f (Sum b)) (a -> f b) #-}
+{-# SPECIALIZE _sum :: Functor f => (Sum a -> f (Sum b)) -> a -> f b #-}
+
+-- | Isomorphism for 'Product'
+_product :: Iso a b (Product a) (Product b)
+_product = isos Product getProduct Product getProduct
+{-# INLINE _product #-}
+{-# SPECIALIZE _product :: Functor f => Isomorphism (Product a -> f (Product b)) (a -> f b) #-}
+{-# SPECIALIZE _product :: Functor f => (Product a -> f (Product b)) -> a -> f b #-}
+
+-- | Isomorphism for 'First'
+_first :: Iso (Maybe a) (Maybe b) (First a) (First b)
+_first = isos First getFirst First getFirst
+{-# INLINE _first #-}
+{-# SPECIALIZE _first :: Functor f => Isomorphism (First a -> f (First b)) (Maybe a -> f (Maybe b)) #-}
+{-# SPECIALIZE _first :: Functor f => (First a -> f (First b)) -> Maybe a -> f (Maybe b) #-}
+
+-- | Isomorphism for 'Last'
+_last :: Iso (Maybe a) (Maybe b) (Last a) (Last b)
+_last = isos Last getLast Last getLast
+{-# INLINE _last #-}
+{-# SPECIALIZE _last :: Functor f => Isomorphism (Last a -> f (Last b)) (Maybe a -> f (Maybe b)) #-}
+{-# SPECIALIZE _last :: Functor f => (Last a -> f (Last b)) -> Maybe a -> f (Maybe b) #-}

0 comments on commit bc41905

Please sign in to comment.