lens 1.3.1 → 1.4
raw patch · 13 files changed
+956/−148 lines, 13 filesdep ~arraydep ~basedep ~bytestring
Dependency ranges changed: array, base, bytestring, containers, mtl, parallel, text, transformers
Files
- examples/Pong.hs +184/−0
- examples/Pong2.hs +200/−0
- examples/Test.hs +31/−0
- lens.cabal +17/−12
- src/Control/Indexed.hs +70/−0
- src/Control/Lens.hs +110/−52
- src/Control/Lens/TH.hs +253/−80
- src/Control/Seq/Lens.hs +2/−2
- src/Data/Complex/Lens.hs +13/−0
- src/Data/Either/Lens.hs +40/−0
- src/Data/Pair/Lens.hs +34/−0
- src/Data/Sequence/Lens.hs +1/−1
- src/Language/Haskell/TH/Lens.hs +1/−1
+ examples/Pong.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE NoMonomorphismRestriction #-}++import Control.Applicative ((<$>), (<*>))+import Control.Lens+import Control.Lens.TH+import Control.Monad.State++import Data.Set (Set, member, empty, insert, delete)++import Graphics.Gloss+import Graphics.Gloss.Interface.Pure.Game++-- Some global constants++gameSize = 300+windowSize = 480+ballRadius = 0.02+initialSpeed = (0.8, 0.3)+speedIncrease = 1.1+paddleWidth = 0.02+paddleHeight = 0.3+paddleSpeed = 1+textSize = 0.3 / gameSize++-- Pure data type for representing the game state++data Pong = Pong+ { _ballPos :: Point+ , _ballSpeed :: Vector+ , _paddle1 :: Float+ , _paddle2 :: Float+ , _score :: (Int, Int)++ -- Since gloss doesn't cover this, we store the set of pressed keys+ , _keys :: Set Key+ }++initial :: Pong+initial = Pong (0, 0) initialSpeed 0 0 (0, 0) empty++-- Some nice lenses to go with it+makeLenses ''Pong++-- I'm just renaming the tuple lenses for enhanced clarity with points/vectors+_x = _1+_y = _2++-- This will be in Data.Pair.Lens soon+both :: Traversal (a,a) (b,b) a b+both f (x,y) = (,) <$> f x <*> f y++-- Game update logic++update :: Float -> Pong -> Pong+update time = execState $ do+ updatePaddles time+ updateBall time+ checkBounds++-- Move the ball by adding its current speed+updateBall :: Float -> State Pong ()+updateBall time = do+ speed <- use ballSpeed+ ballPos += speed `mul` time++ -- Make sure it doesn't leave the playing area+ ballPos.both %= clampPad ballRadius++ where+ (a,b) `mul` c = (c*a, c*b)+ infixl 7 `mul`++-- Update the paddles+updatePaddles :: Float -> State Pong ()+updatePaddles time = do+ p <- get++ -- Update the player's paddle based on keys+ when (SpecialKey KeyUp `isIn` p^.keys) $+ paddle1 += paddleSpeed * time++ when (SpecialKey KeyDown `isIn` p^.keys) $+ paddle1 -= paddleSpeed * time++ -- Update the CPU's paddle based on the ball's relative position+ case compare (p^.ballPos._y) (p^.paddle2) of+ GT -> paddle2 += paddleSpeed * time+ LT -> paddle2 -= paddleSpeed * time+ _ -> return ()++ -- Make sure both paddles don't leave the playing area+ paddle1 %= clamp+ paddle2 %= clamp++ where+ clamp = clampPad (paddleHeight/2)+ isIn = member+ infixl 7 `isIn`++-- Clamp to the region (-1, 1) but with padding+clampPad :: Float -> Float -> Float+clampPad pad = max (pad - 1) . min (1 - pad)++-- Check for collisions and/or scores+checkBounds :: State Pong ()+checkBounds = do+ p <- get+ let (x,y) = p^.ballPos++ -- Check for collisions with the top or bottom+ when (abs y >= top) $+ ballSpeed._y %= negate++ -- Check for collisions with paddles+ let check l = y >= p^.l - paddleHeight/2 && y <= p^.l + paddleHeight/2+ collide = do+ ballSpeed._x %= negate+ ballSpeed.both *= speedIncrease++ when (x <= left) $+ if check paddle1+ then collide+ else do+ score._2 += 1+ reset++ when (x >= right) $+ if check paddle2+ then collide+ else do+ score._1 += 1+ reset++ where+ top = 1 - ballRadius+ left = ballRadius + paddleWidth/2 - 1+ right = -left++-- Reset the game+reset :: State Pong ()+reset = do+ ballPos ^= initial^.ballPos+ ballSpeed ^= initial^.ballSpeed++-- Drawing a pong state to the screen++draw :: Pong -> Picture+draw p = scale gameSize gameSize $ Pictures+ [ drawBall `at` p^.ballPos+ , drawPaddle `at` (-1, p^.paddle1)+ , drawPaddle `at` ( 1, p^.paddle2)++ -- Score and playing field+ , scale textSize textSize (p^.score.pretty.to text) `at` (-0.1, 0.85)+ , rectangleWire 2 2+ ]+ where+ -- Pretty printing lens+ pretty = to (\(x,y) -> show x ++ " " ++ show y)+ p `at` (x,y) = translate x y p+ infixr 1 `at`++drawPaddle :: Picture+drawPaddle = rectangleSolid paddleWidth paddleHeight++drawBall :: Picture+drawBall = circleSolid ballRadius++-- Handle input by simply updating the keys set++handle :: Event -> Pong -> Pong+handle (EventKey k Down _ _) = keys %~ insert k+handle (EventKey k Up _ _) = keys %~ delete k+handle _ = id++-- The main program action++main = play display backColor fps initial draw handle update+ where+ -- display = InWindow "Pong!" (windowSize, windowSize) (800, 600)+ display = FullScreen (800,600)+ backColor = white+ fps = 120
+ examples/Pong2.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE TemplateHaskell, NoMonomorphismRestriction #-}++import Control.Applicative ((<$>), (<*>))+import Control.Lens+import Control.Lens.TH+import Control.Monad.State++import Data.Set (Set, member, empty, insert, delete)++import Graphics.Gloss+import Graphics.Gloss.Interface.Pure.Game++-- Some global constants++gameSize = 300+windowSize = 480+ballRadius = 0.02+initialSpeed = (0.5, 0.3)+speedIncrease = 1.1+paddleWidth = 0.02+paddleHeight = 0.3+paddleSpeed = 1+textSize = 0.3 / gameSize++-- Pure data type for representing the game state++data Pong = Pong+ { _ballPos :: Point+ , _ballSpeed :: Vector+ , _paddle1 :: Float+ , _paddle2 :: Float+ , _score :: (Int, Int)++ -- Since gloss doesn't cover this, we store the set of pressed keys+ , _keys :: Set Key+ }++initial :: Pong+initial = Pong (0, 0) initialSpeed 0 0 (0, 0) empty++-- Some nice lenses to go with it+makeLenses ''Pong++-- I'm just renaming the tuple lenses for enhanced clarity with points/vectors+_x = _1+_y = _2++-- This will be in Data.Pair.Lens soon+both :: Traversal (a,a) (b,b) a b+both f (x,y) = (,) <$> f x <*> f y++-- Calculate the y position at which the ball will next hit (on player2's side)+hitPos :: Point -> Vector -> Float+hitPos (x,y) (u,v) = ypos+ where+ xdist = if u >= 0 then 1 - x else 3 + x+ time = xdist / abs u+ ydist = v * time+ ypos = bounce (y + ydist)+ o = 1 - ballRadius++ -- Calculate bounces iteratively+ bounce n+ | n > o = bounce ( 2 *o - n)+ | n < -o = bounce ((-2)*o - n)+ | otherwise = n++-- Game update logic++update :: Float -> Pong -> Pong+update time = execState $ do+ updatePaddles time+ updateBall time+ checkBounds++-- Move the ball by adding its current speed+updateBall :: Float -> State Pong ()+updateBall time = do+ speed <- use ballSpeed+ ballPos += speed `mul` time++ -- Make sure it doesn't leave the playing area+ ballPos.both %= clampPad ballRadius++ where+ (a,b) `mul` c = (c*a, c*b)+ infixl 7 `mul`++-- Update the paddles+updatePaddles :: Float -> State Pong ()+updatePaddles time = do+ p <- get++ -- Update the player's paddle based on keys+ when (SpecialKey KeyUp `isIn` p^.keys) $+ paddle1 += paddleSpeed * time++ when (SpecialKey KeyDown `isIn` p^.keys) $+ paddle1 -= paddleSpeed * time++ -- Calculate the optimal position+ let optimal = hitPos (p^.ballPos) (p^.ballSpeed)++ -- Move the CPU's paddle towards this optimal position+ case compare optimal (p^.paddle2) of+ GT -> paddle2 += paddleSpeed * time+ LT -> paddle2 -= paddleSpeed * time+ _ -> return ()++ -- Make sure both paddles don't leave the playing area+ paddle1 %= clamp+ paddle2 %= clamp++ where+ clamp = clampPad (paddleHeight/2)+ isIn = member+ infixl 7 `isIn`++-- Clamp to the region (-1, 1) but with padding+clampPad :: Float -> Float -> Float+clampPad pad = max (pad - 1) . min (1 - pad)++-- Check for collisions and/or scores+checkBounds :: State Pong ()+checkBounds = do+ p <- get+ let (x,y) = p^.ballPos++ -- Check for collisions with the top or bottom+ when (abs y >= top) $+ ballSpeed._y %= negate++ -- Check for collisions with paddles+ let check l = y >= p^.l - paddleHeight/2 && y <= p^.l + paddleHeight/2++ let { collide = do+ ballSpeed._x %= negate+ ballSpeed.both *= speedIncrease+ }++ when (x <= left) $+ if check paddle1+ then collide+ else score._2 += 1 >> reset++ when (x >= right) $+ if check paddle2+ then collide+ else score._1 += 1 >> reset++ where+ top = 1 - ballRadius+ left = ballRadius + paddleWidth/2 - 1+ right = -left++-- Reset the game+reset :: State Pong ()+reset = do+ ballPos ^= initial^.ballPos+ ballSpeed ^= initial^.ballSpeed++-- Drawing a pong state to the screen++draw :: Pong -> Picture+draw p = scale gameSize gameSize $ Pictures+ [ drawBall `at` p^.ballPos+ , drawPaddle `at` (-1, p^.paddle1)+ , drawPaddle `at` ( 1, p^.paddle2)++ -- Score and playing field+ , scale textSize textSize (p^.score.pretty.to text) `at` (-0.1, 0.85)+ , rectangleWire 2 2+ ]+ where+ -- Pretty printing lens+ pretty = to (\(x,y) -> show x ++ " " ++ show y)+ p `at` (x,y) = translate x y p+ infixr 1 `at`++drawPaddle :: Picture+drawPaddle = rectangleSolid paddleWidth paddleHeight++drawBall :: Picture+drawBall = circleSolid ballRadius++-- Handle input by simply updating the keys set++handle :: Event -> Pong -> Pong+handle (EventKey k Down _ _) = keys %~ insert k+handle (EventKey k Up _ _) = keys %~ delete k+handle _ = id++-- The main program action++main = play display backColor fps initial draw handle update+ where+ -- display = InWindow "Pong!" (windowSize, windowSize) (200, 200)+ display = FullScreen (800,600)+ backColor = white+ fps = 120
+ examples/Test.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE TemplateHaskell #-}+module Test where++import Control.Lens+import Control.Lens.TH++data Foo a = Foo a+makeLenses ''Foo++data Bar a b c = Bar { _baz :: (a, b) }+makeLenses ''Bar++data Quux a b = Quux { _quaffle :: Int, _quartz :: Double }+makeLenses ''Quux++data Quark a = Qualified { _gaffer :: a }+ | Unqualified { _gaffer :: a, blockingGaffer :: a }+makeLenses ''Quark++data LensCrafted a = Still { _still :: a }+ | Works { _still :: a }+makeLenses ''LensCrafted++data Mono = Mono { _monoFoo :: Int, _monoBar :: Int }+makeClassy ''Mono++data Nucleosis = Nucleosis { _nuclear :: Mono }+makeClassy ''Nucleosis++instance HasMono Nucleosis where+ mono = nuclear
lens.cabal view
@@ -1,6 +1,6 @@ name: lens category: Data, Lenses-version: 1.3.1+version: 1.4 license: BSD3 cabal-version: >= 1.6 license-file: LICENSE@@ -148,7 +148,7 @@ build-type: Simple tested-with: GHC == 7.4.1-extra-source-files: .travis.yml+extra-source-files: .travis.yml examples/Pong.hs examples/Test.hs examples/Pong2.hs source-repository head type: git@@ -156,22 +156,24 @@ library build-depends:- base == 4.*,- containers >= 0.3 && < 0.6,- mtl >= 2.1.1 && < 2.2,- transformers >= 0.2 && < 0.4+ base >= 4.3 && < 5,+ containers >= 0.4.2 && < 0.6,+ mtl >= 2.0.1 && < 2.2,+ transformers >= 0.2.2 && < 0.4 - exposed-modules: Control.Isomorphic+ exposed-modules: Control.Indexed+ Control.Isomorphic Control.Lens Control.Lens.Internal Control.Lens.Representable- -- base exposed-modules: Control.Exception.Lens Data.Bits.Lens Data.Complex.Lens Data.Dynamic.Lens+ Data.Either.Lens Data.List.Lens+ Data.Pair.Lens -- containers exposed-modules: Data.IntMap.Lens@@ -186,26 +188,29 @@ Control.Lens.TH -- platform- build-depends: array == 0.4.*+ build-depends: array >= 0.3.0.2 && < 0.5 exposed-modules: Data.Array.Lens - build-depends: bytestring == 0.9.*+ build-depends: bytestring >= 0.9.1.10 && < 0.10 exposed-modules: Data.ByteString.Lens Data.ByteString.Lazy.Lens - build-depends: text == 0.11.*+ build-depends: text >= 0.11.1.5 && < 0.12 exposed-modules: Data.Text.Lens Data.Text.Lazy.Lens - build-depends: parallel == 3.2.*+ build-depends: parallel >= 3.1.0.1 && < 3.3 exposed-modules: Control.Parallel.Strategies.Lens Control.Seq.Lens other-extensions: CPP DeriveDataTypeable+ FlexibleContexts+ FlexibleInstances LiberalTypeSynonyms MultiParamTypeClasses Rank2Types RankNTypes TemplateHaskell+ TypeFamilies TypeOperators if (impl(ghc>=7.4))
+ src/Control/Indexed.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+-----------------------------------------------------------------------------+-- |+-- Module : Control.Indexed+-- Copyright : (C) 2012 Edward Kmett+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : rank 2 types, MPTCs, TFs, flexible+--+----------------------------------------------------------------------------+module Control.Indexed+ (+ -- * Overloading indexed functions+ Indexed(..)+ , Indexable+ , Index(..)+ , (.@)+ , composeWithIndex+ , reindex+ ) where++-- | Permit overloading of function application for things that also admit a notion of a key or index.++-- | Provides overloading for indexed functions.+class Indexed i k where+ -- | Build a function from an indexed function+ index :: ((i -> a) -> b) -> k a b++-- | Type alias for passing around polymorphic indexed functions.+type Indexable i a b = forall k. Indexed i k => k a b++instance Indexed i (->) where+ index f = f . const+ {-# INLINE index #-}++-- | A function with access to a index. This constructor may be useful when you need to store+-- a 'HasIndex'.+newtype Index i a b = Index { withIndex :: (i -> a) -> b }++-- | Using an equality witness to avoid potential overlapping instances+-- and aid dispatch.+instance i ~ j => Indexed i (Index j) where+ index = Index+ {-# INLINE index #-}++-- | Remap the index.+reindex :: Indexed j k => (i -> j) -> Index i a b -> k a b+reindex ij (Index iab) = index $ \ ja -> iab $ \i -> ja (ij i)+{-# SPECIALIZE reindex :: (i -> j) -> Index i a b -> Index j a b #-}+{-# SPECIALIZE reindex :: (i -> j) -> Index i a b -> a -> b #-}++infixr 9 .@+-- | Composition of indexed functions+(.@) :: Indexed (i, j) k => Index i b c -> Index j a b -> k a c+f .@ g = composeWithIndex (,) f g+{-# INLINE (.@) #-}+{-# SPECIALIZE (.@) :: Index i b c -> Index j a b -> Index (i,j) a c #-}+{-# SPECIALIZE (.@) :: Index i b c -> Index j a b -> a -> c #-}++-- | Composition of indexed functions with a user supplied function for combining indexs+composeWithIndex :: Indexed k r => (i -> j -> k) -> Index i b c -> Index j a b -> r a c+composeWithIndex ijk (Index ibc) (Index jab) = index $ \ka -> ibc $ \i -> jab $ \j -> ka (ijk i j)+{-# INLINE composeWithIndex #-}+{-# SPECIALIZE composeWithIndex :: (i -> j -> k) -> Index i b c -> Index j a b -> a -> c #-}+
src/Control/Lens.hs view
@@ -1,6 +1,8 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE LiberalTypeSynonyms #-}+{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens@@ -67,8 +69,8 @@ -- * Isomorphisms , Iso , SimpleIso- , IsoLike- , SimpleIsoLike+ , Overloaded+ , SimpleOverloaded , iso , isos , Isomorphic(..)@@ -144,9 +146,6 @@ -- * Common Traversals , Traversable(traverse) , traverseNothing- , traverseLeft- , traverseRight- , traverseValue -- * Transforming Traversals , backwards@@ -159,11 +158,25 @@ -- ** Common Isomorphisms , identity , konst++ -- * Indexed Folds+ , Index(..)+ , Indexed(..)+ , IndexedFold+ , foldMapWithIndexOf+ , foldrWithIndexOf++ -- * Indexed Traversals+ , IndexedTraversal+ , SimpleIndexedTraversal+ , traverseWithIndexOf+ , mapMWithIndexOf ) where import Control.Applicative as Applicative import Control.Applicative.Backwards import Control.Category+import Control.Indexed import Control.Isomorphic import Control.Lens.Internal import Control.Monad@@ -185,6 +198,8 @@ infix 4 ^=, +=, *=, -=, //=, &&=, ||=, %=, <>=, %%= infixr 0 ^$ ++ -------------------------- -- Lenses --------------------------@@ -344,7 +359,14 @@ -- > (%%=) :: MonadState a m => Lens a a c d -> (c -> (e, d) -> m e -- > (%%=) :: (MonadState a m, Monoid e) => Traversal a a c d -> (c -> (e, d) -> m e (%%=) :: MonadState a m => LensLike ((,) e) a a c d -> (c -> (e, d)) -> m e+#if MIN_VERSION_mtl(2,1,1) l %%= f = State.state (l f)+#else+l %%= f = do+ (e, b) <- State.gets (l f)+ State.put b+ return e+#endif {-# INLINE (%%=) #-} -- | This class allows us to use 'focus' on a number of different monad transformers.@@ -743,7 +765,7 @@ -- | Modify the target of a monoidally valued by 'mappend'ing another value. (<>~) :: Monoid c => Setter a b c c -> c -> a -> b-l <>~ n = adjust l (<> n)+l <>~ n = adjust l (mappend n) {-# INLINE (<>~) #-} ---------------@@ -1119,7 +1141,7 @@ -- -- > repeat = toListOf repeated repeated :: Fold a a-repeated f a = Const as where as = getConst (f a) <> as+repeated f a = Const as where as = getConst (f a) `mappend` as -- | A fold that replicates its input @n@ times. --@@ -1128,7 +1150,7 @@ replicated n0 f a = Const (go n0) where m = getConst (f a) go 0 = mempty- go n = m <> go (n - 1)+ go n = m `mappend` go (n - 1) {-# INLINE replicated #-} -- | Transform a fold into a fold that loops over its elements over and over.@@ -1136,7 +1158,7 @@ -- > ghci> toListOf (cycled traverse) [1,2,3] -- > [1,2,3,1,2,3,..] cycled :: Monoid m => Getting m a b c d -> Getting m a b c d-cycled l f a = Const as where as = getConst (l f a) <> as+cycled l f a = Const as where as = getConst (l f a) `mappend` as -- | Build a fold that unfolds its values from a seed. --@@ -1753,42 +1775,13 @@ -- Traversals ------------------------------------------------------------------------------ --- | This is the traversal that never succeeds at returning any values+-- | This is the traversal that just doesn't return anything -- -- > traverseNothing :: Applicative f => (c -> f d) -> a -> f a traverseNothing :: Traversal a a c d traverseNothing = const pure {-# INLINE traverseNothing #-} --- | A traversal for tweaking the left-hand value in an Either:------ > traverseLeft :: Applicative f => (a -> f b) -> Either a c -> f (Either b c)-traverseLeft :: Traversal (Either a c) (Either b c) a b-traverseLeft f (Left a) = Left <$> f a-traverseLeft _ (Right c) = pure $ Right c-{-# INLINE traverseLeft #-}---- | traverse the right-hand value in an Either:------ > traverseRight = traverse------ Unfortunately the instance for 'Traversable (Either c)' is still missing--- from base, so this can't just be 'traverse'------ > traverseRight :: Applicative f => (a -> f b) -> Either c a -> f (Either c a)-traverseRight :: Traversal (Either c a) (Either c b) a b-traverseRight _ (Left c) = pure $ Left c-traverseRight f (Right a) = Right <$> f a-{-# INLINE traverseRight #-}---- | This provides a 'Traversal' that checks a predicate on a key before--- allowing you to traverse into a value.-traverseValue :: (k -> Bool) -> Simple Traversal (k, v) v-traverseValue p f kv@(k,v)- | p k = (,) k <$> f v- | otherwise = pure kv-{-# INLINE traverseValue #-}- ------------------------------------------------------------------------------ -- Transforming Traversals ------------------------------------------------------------------------------@@ -1804,13 +1797,13 @@ -- -- A backwards 'Iso' is the same 'Iso'. If you reverse the direction of -- the isomorphism use 'from' instead.-backwards :: Isomorphic k => IsoLike k (Backwards f) a b c d -> IsoLike k f a b c d+backwards :: Isomorphic k => Overloaded k (Backwards f) a b c d -> Overloaded k f a b c d backwards = isomap (\l f -> forwards . l (Backwards . f)) (\l f -> forwards . l (Backwards . f)) {-# INLINE backwards #-} {-# SPECIALIZE backwards :: LensLike (Backwards f) a b c d -> LensLike f a b c d #-}-{-# SPECIALIZE backwards :: IsoLike Isomorphism (Backwards f) a b c d -> IsoLike Isomorphism f a b c d #-}+{-# SPECIALIZE backwards :: Overloaded Isomorphism (Backwards f) a b c d -> Overloaded Isomorphism f a b c d #-} -- | Merge two lenses, getters, setters, folds or traversals. merged :: Functor f => LensLike f a b c c -> LensLike f a' b' c c -> LensLike f (Either a a') (Either b b') c c@@ -1826,6 +1819,16 @@ {-# INLINE bothLenses #-} -----------------------------------------------------------------------------+-- Overloading function application+-----------------------------------------------------------------------------++-- | > type LensLike f a b c d = Overloaded (->) f a b c d+type Overloaded k f a b c d = k (c -> f d) (a -> f b)++-- | > type SimpleOverloaded k f a b = Simple (Overloaded k f) a b+type SimpleOverloaded k f a b = Overloaded k f a a b b++----------------------------------------------------------------------------- -- Isomorphisms families as Lenses ----------------------------------------------------------------------------- @@ -1837,37 +1840,31 @@ -- > import Control.Category -- > import Prelude hiding ((.),id) ----- > type Iso a b c d = forall k f. (Isomorphic k, Functor f) => IsoLike k f a b c d+-- > type Iso a b c d = forall k f. (Isomorphic k, Functor f) => Overloaded k f a b c d type Iso a b c d = forall k f. (Isomorphic k, Functor f) => k (c -> f d) (a -> f b) -- | > type SimpleIso a b = Simple Iso a b type SimpleIso a b = Iso a a b b --- | > type LensLike f a b c d = IsoLike (->) f a b c d-type IsoLike k f a b c d = k (c -> f d) (a -> f b)---- | > type SimpleIsoLike k f a b = Simple (IsoLike k f) a b-type SimpleIsoLike k f a b = IsoLike k f a a b b- -- | Build an isomorphism family from two pairs of inverse functions -- -- > isos :: (a -> c) -> (c -> a) -> (b -> d) -> (d -> b) -> Iso a b c d-isos :: (Isomorphic k, Functor f) => (a -> c) -> (c -> a) -> (b -> d) -> (d -> b) -> IsoLike k f a b c d+isos :: (Isomorphic k, Functor f) => (a -> c) -> (c -> a) -> (b -> d) -> (d -> b) -> Overloaded k f a b c d isos ac ca bd db = isomorphic (\cfd a -> db <$> cfd (ac a)) (\afb c -> bd <$> afb (ca c)) {-# INLINE isos #-} {-# SPECIALIZE isos :: Functor f => (a -> c) -> (c -> a) -> (b -> d) -> (d -> b) -> LensLike f a b c d #-}-{-# SPECIALIZE isos :: Functor f => (a -> c) -> (c -> a) -> (b -> d) -> (d -> b) -> IsoLike Isomorphism f a b c d #-}+{-# SPECIALIZE isos :: Functor f => (a -> c) -> (c -> a) -> (b -> d) -> (d -> b) -> Overloaded Isomorphism f a b c d #-} -- | Build a simple isomorphism from a pair of inverse functions -- -- > iso :: (a -> b) -> (b -> a) -> Simple Iso a b-iso :: (Isomorphic k, Functor f) => (a -> b) -> (b -> a) -> SimpleIsoLike k f a b+iso :: (Isomorphic k, Functor f) => (a -> b) -> (b -> a) -> SimpleOverloaded k f a b iso ab ba = isos ab ba ab ba {-# INLINE iso #-} {-# SPECIALIZE iso :: Functor f => (a -> b) -> (b -> a) -> SimpleLensLike f a b #-}-{-# SPECIALIZE iso :: Functor f => (a -> b) -> (b -> a) -> SimpleIsoLike Isomorphism f a b #-}+{-# SPECIALIZE iso :: Functor f => (a -> b) -> (b -> a) -> SimpleOverloaded Isomorphism f a b #-} ----------------------------------------------------------------------------- -- Isomorphism@@ -1909,3 +1906,64 @@ IndexedStore db c -> db <$> cfd c {-# INLINE clone #-} +------------------------------------------------------------------------------+-- Indexed Folds+------------------------------------------------------------------------------++-- | Every 'IndexedFold' is a valid 'Fold'+type IndexedFold i a c = forall k m b d. (Indexed i k, Monoid m) => k (c -> Const m d) (a -> Const m b)++type IndexedFolding i m a b c d = Index i (c -> Const m d) (a -> Const m b)++-- |+--+-- > foldMapWithIndexOf :: Monoid m => IndexedFold i a c -> (i -> c -> m) -> a -> m+-- > foldMapWithIndexOf :: Monoid m => IndexedTraversal i a b c d -> (i -> c -> m) -> a -> m+foldMapWithIndexOf :: IndexedFolding i m a b c d -> (i -> c -> m) -> a -> m+foldMapWithIndexOf l f = getConst . withIndex l (\i -> Const . f i)+{-# INLINE foldMapWithIndexOf #-}++-- |+-- Right-associative fold of parts of a structure that are viewed through a 'Lens', 'Getter', 'Fold' or 'Traversal'.+--+-- > foldrWithIndexOf :: IndexedFold i a c -> (i -> c -> e -> e) -> e -> a -> e+-- > foldrWithIndexOf :: IndexedTraversal i a b c d -> (i -> c -> e -> e) -> e -> a -> e+foldrWithIndexOf :: IndexedFolding i (Endo e) a b c d -> (i -> c -> e -> e) -> e -> a -> e+foldrWithIndexOf l f z t = appEndo (foldMapWithIndexOf l (\i -> Endo . f i) t) z+{-# INLINE foldrWithIndexOf #-}++------------------------------------------------------------------------------+-- Indexed Traversals+------------------------------------------------------------------------------+++-- | Every indexed traversal is a valid Traversal or indexed fold.+--+-- The Traversal laws are still required to hold. Moreover, each index should be distinct.+type IndexedTraversal i a b c d = forall f k. (Indexed i k, Applicative f) => k (c -> f d) (a -> f b)++-- | @type 'SimpleIdexedTraversal i = 'Simple' ('IndexedTraversal' i)@+type SimpleIndexedTraversal i a b = IndexedTraversal i a a b b++-- |+-- > traverseWithIndexOf :: IndexedTraversal i a b c d -> (i -> c -> f d) -> a -> f b+traverseWithIndexOf :: Overloaded (Index i) f a b c d -> (i -> c -> f d) -> a -> f b+traverseWithIndexOf = withIndex+{-# INLINE traverseWithIndexOf #-}++-- | Map each element of a structure targeted by a lens to a monadic action,+-- evaluate these actions from left to right, and collect the results, with access+-- its position.+--+-- > mapMWithIndexOf :: Monad m => IndexedTraversal a b c d -> (i -> c -> m d) -> a -> m b+mapMWithIndexOf :: Overloaded (Index i) (WrappedMonad m) a b c d -> (i -> c -> m d) -> a -> m b+mapMWithIndexOf l f = unwrapMonad . withIndex l (\i -> WrapMonad . f i)+{-# INLINE mapMWithIndexOf #-}++{-+traverseList :: IndexedTraversal Int [a] [b] a b+traverseList = index $ go (0::Int) where+ go n f (x:xs) = (:) <$> f n x <*> go (n + 1) f xs+ go _ _ [] = pure []+ {-# INLINE traverseList #-}+-}
src/Control/Lens/TH.hs view
@@ -15,23 +15,28 @@ ---------------------------------------------------------------------------- module Control.Lens.TH ( LensRules(LensRules)- , isoLensRule- , fieldLensRule- , defaultLensRules- -- ** Constructing Lenses Automatically- , makeLenses+ , lensIso+ , lensField+ , lensClass+ , lensFlags+ , LensFlag(..)+ , simpleLenses, handleSingletons, singletonIso, singletonRequired, createClass, createInstance, classRequired+ -- * Constructing Lenses Automatically+ , makeClassy, makeClassyFor+ , makeIso+ , makeLenses, makeLensesFor , makeLensesWith- , makeLensesFor ) where import Control.Applicative import Control.Lens+import Control.Monad import Data.Char (toLower) import Data.Foldable import Data.List as List import Data.Map as Map hiding (toList,map,filter) import Data.Map.Lens-import Data.Maybe (isNothing)+import Data.Maybe (isNothing,isJust) import Data.Monoid import Data.Set as Set hiding (toList,map,filter) import Data.Set.Lens@@ -39,32 +44,90 @@ import Language.Haskell.TH import Language.Haskell.TH.Lens +-- | Flags for lens construction+data LensFlag+ = SimpleLenses++ | SingletonAndField+ | SingletonIso+ | HandleSingletons+ | SingletonRequired++ | CreateClass+ | CreateInstance+ | ClassRequired+ deriving (Eq,Ord,Show,Read)++-- | Only Generate valid 'Simple' 'Lens' lenses+simpleLenses :: Simple Lens LensRules Bool+simpleLenses = lensFlags.contains SimpleLenses++-- | Handle singleton constructors specially+handleSingletons :: Simple Lens LensRules Bool+handleSingletons = lensFlags.contains HandleSingletons++-- | When building an singleton iso (or lens) for a record constructor, build both+singletonAndField :: Simple Lens LensRules Bool+singletonAndField = lensFlags.contains SingletonAndField++-- | Use Iso for singleton constructors+singletonIso :: Simple Lens LensRules Bool+singletonIso = lensFlags.contains SingletonIso++-- | Expect a single constructor, single field newtype or data type.+singletonRequired :: Simple Lens LensRules Bool+singletonRequired = lensFlags.contains SingletonRequired++-- | Create the class if the constructor is simple and the 'lensClass' rule matches+createClass :: Simple Lens LensRules Bool+createClass = lensFlags.contains CreateClass++-- | Create the instance if the constructor is simple and the 'lensClass' rule matches+createInstance :: Simple Lens LensRules Bool+createInstance = lensFlags.contains CreateInstance++-- | Die if the 'lensClass' fails to match+classRequired :: Simple Lens LensRules Bool+classRequired = lensFlags.contains ClassRequired+ -- | This configuration describes the options we'll be using to make isomorphisms or lenses data LensRules = LensRules- { _isoLensRule :: String -> Maybe String -- ^ used to name the top level isomorphism for single constructor, single field data types and newtypes- , _fieldLensRule :: String -> Maybe String -- ^ used to name the lens, given the name of the basic field- , _addBothLensRule :: Bool+ { _lensIso :: String -> Maybe String+ , _lensField :: String -> Maybe String+ , _lensClass :: String -> Maybe (String, String)+ , _lensFlags :: Set LensFlag } -- | Lens to access the convention for naming top level isomorphisms in our lens rules-isoLensRule :: Simple Lens LensRules (String -> Maybe String)-isoLensRule f (LensRules i n b) = (\i' -> LensRules i' n b) <$> f i+--+-- Defaults to lowercasing the first letter of the constructor.+lensIso :: Simple Lens LensRules (String -> Maybe String)+lensIso f (LensRules i n c o) = (\i' -> LensRules i' n c o) <$> f i -- | Lens to access the convention for naming fields in our lens rules-fieldLensRule :: Simple Lens LensRules (String -> Maybe String)-fieldLensRule f (LensRules i n b) = (\n' -> LensRules i n' b) <$> f n+--+-- Defaults to stripping the _ off of the field name and lowercasing the name and+-- rejecting the field if it doesn't start with an '_'.+lensField :: Simple Lens LensRules (String -> Maybe String)+lensField f (LensRules i n c o) = (\n' -> LensRules i n' c o) <$> f n --- | This flag indicates whether or not we should attempt to add both an isomorphism lens and a top level accessor-addBothLensRule :: Simple Lens LensRules Bool-addBothLensRule f (LensRules i n b) = LensRules i n <$> f b+-- | Retrieve options such as the name of the class and method to put in it to build a class around monomorphic data types.+lensClass :: Simple Lens LensRules (String -> Maybe (String, String))+lensClass f (LensRules i n c o) = (\c' -> LensRules i n c' o) <$> f c +-- | Retrieve options such as the name of the class and method to put in it to build a class around monomorphic data types.+lensFlags :: Simple Lens LensRules (Set LensFlag)+lensFlags f (LensRules i n c o) = LensRules i n c <$> f o+ -- | Default lens rules-defaultLensRules :: LensRules-defaultLensRules = LensRules top field True where- top (c:cs) = Just (toLower c:cs)- top _ = Nothing- field ('_':c:cs) = Just (toLower c:cs)- field _ = Nothing+defaultRules :: LensRules+defaultRules = LensRules top field (const Nothing) $+ Set.fromList [SingletonIso, SingletonAndField, CreateClass, CreateInstance]+ where+ top (c:cs) = Just (toLower c:cs)+ top _ = Nothing+ field ('_':c:cs) = Just (toLower c:cs)+ field _ = Nothing -- | Given a set of names, build a map from those names to a set of fresh names based on them. freshMap :: Set Name -> Q (Map Name Name)@@ -91,6 +154,9 @@ , g conName ] +makeLensBody :: Name -> Name -> (Name -> ExpQ) -> (Name -> ExpQ) -> DecQ+makeLensBody lensName conName f _ = funD lensName [clause [] (normalB (f conName)) []]+ appArgs :: Type -> [TyVarBndr] -> Type appArgs t [] = t appArgs t (x:xs) = appArgs (AppT t (VarT (x^.name))) xs@@ -99,6 +165,10 @@ apps t [] = t apps t (x:xs) = apps (t `AppT` x) xs +appsT :: TypeQ -> [TypeQ] -> TypeQ+appsT t [] = t+appsT t (x:xs) = appsT (t `appT` x) xs+ -- | Given -- -- > newtype Cxt b => Foo a b c d = Foo { _baz :: Bar a b }@@ -114,35 +184,41 @@ -- > baz = isomorphic (\f (Foo a) -> fmap Foo (f a)) -- > (\f a -> fmap (\(Foo b) -> b) (f (Foo a))) -- > {-# INLINE baz #-}-makeIso :: LensRules- -> Cxt- -> Name- -> [TyVarBndr]- -> Name- -> Maybe Name- -> Type- -> Q [Dec]-makeIso cfg ctx tyConName tyArgs dataConName maybeFieldName partTy = do+makeIsoLenses :: LensRules+ -> Cxt+ -> Name+ -> [TyVarBndr]+ -> Name+ -> Maybe Name+ -> Type+ -> Q [Dec]+makeIsoLenses cfg ctx tyConName tyArgs dataConName maybeFieldName partTy = do m <- freshMap $ setOf typeVars tyArgs let aty = partTy bty = substTypeVars m aty cty = appArgs (ConT tyConName) tyArgs dty = substTypeVars m cty quantified = ForallT (tyArgs ++ substTypeVars m tyArgs) (ctx ++ substTypeVars m ctx)- maybeIsoName = mkName <$> view isoLensRule cfg (nameBase dataConName)+ maybeIsoName = mkName <$> view lensIso cfg (nameBase dataConName)+ lensOnly = not $ cfg^.singletonIso+ isoCon | lensOnly = ConT (mkName "Control.Lens.Body")+ | otherwise = ConT (mkName "Control.Lens.Iso")+ makeBody | lensOnly = makeLensBody+ | otherwise = makeIsoBody isoDecls <- flip (maybe (return [])) maybeIsoName $ \isoName -> do- let decl = SigD isoName $ quantified $- ConT (mkName "Control.Lens.Iso") `apps` [aty,bty,cty,dty]- body <- makeIsoBody isoName dataConName makeIsoFrom makeIsoTo- inlining <- pragInlD isoName (inlineSpecNoPhase True False)+ let decl = SigD isoName $ quantified $ isoCon `apps`+ if cfg^.simpleLenses then [aty,aty,cty,cty] else [aty,bty,cty,dty]+ body <- makeBody isoName dataConName makeIsoFrom makeIsoTo+ inlining <- pragInlD isoName $ inlineSpecNoPhase True False return [decl, body, inlining]- accessorDecls <- case mkName <$> (maybeFieldName >>= view fieldLensRule cfg . nameBase) of+ accessorDecls <- case mkName <$> (maybeFieldName >>= view lensField cfg . nameBase) of jfn@(Just lensName)- | (jfn /= maybeIsoName) && (isNothing maybeIsoName || view addBothLensRule cfg) -> do- let decl = SigD lensName $ quantified $- ConT (mkName "Control.Lens.Iso") `apps` [cty,dty,aty,bty]- body <- makeIsoBody lensName dataConName makeIsoTo makeIsoFrom- inlining <- pragInlD lensName (inlineSpecNoPhase True False)+ | (jfn /= maybeIsoName) && (isNothing maybeIsoName || cfg^.singletonAndField) -> do+ let decl = SigD lensName $ quantified $ isoCon `apps`+ if cfg^.simpleLenses then [cty,cty,aty,aty]+ else [cty,dty,aty,bty]+ body <- makeBody lensName dataConName makeIsoTo makeIsoFrom+ inlining <- pragInlD lensName $ inlineSpecNoPhase True False return [decl, body, inlining] _ -> return [] return $ isoDecls ++ accessorDecls@@ -157,7 +233,9 @@ thd (_,_,c) = c fieldDescs :: Set Name -> [(Name,Strict,Type)] -> [FieldDesc]-fieldDescs acc ((nm,_,ty):rest) = FieldDesc nm ty (acc <> setOf typeVars (map thd rest)) : fieldDescs (acc <> setOf typeVars ty) rest+fieldDescs acc ((nm,_,ty):rest) =+ FieldDesc nm ty (acc `Set.union` setOf typeVars (map thd rest)) :+ fieldDescs (acc `Set.union` setOf typeVars ty) rest fieldDescs _ [] = [] conFieldDescs :: Con -> [FieldDesc]@@ -168,30 +246,40 @@ commonFieldDescs = toList . Prelude.foldr walk mempty where walk con m = Prelude.foldr step m (conFieldDescs con) step d@(FieldDesc nm ty bds) m = case m^.at nm of- Just (FieldDesc _ _ bds') -> at nm <~ Just (FieldDesc nm ty (bds <> bds')) $ m- Nothing -> at nm <~ Just d $ m+ Just (FieldDesc _ _ bds') -> at nm <~ Just (FieldDesc nm ty (bds `Set.union` bds')) $ m+ Nothing -> at nm <~ Just d $ m errorClause :: Name -> Name -> Name -> ClauseQ-errorClause lensName fieldName conName = clause [] (normalB (varE (mkName "error") `appE` litE (stringL err))) [] where- err = show lensName ++ ": no matching field " ++ show fieldName ++ " in constructor " ++ show conName+errorClause lensName fieldName conName+ = clause [] (normalB (varE (mkName "error") `appE` litE (stringL err))) []+ where+ err = show lensName ++ ": no matching field "+ ++ show fieldName ++ " in constructor "+ ++ show conName -makeFieldLensBody :: Name -> Name -> [Con] -> Q Dec-makeFieldLensBody lensName fieldName = funD lensName . map clauses where- clauses (RecC conName fields) = case List.findIndex (\(n,_,_) -> n == fieldName) fields of- Just i -> do- names <- for fields $ \(n,_,_) -> newName (nameBase n)- f <- newName "f"- nm <- newName "x"- clause [varP f, conP conName $ map varP names] (normalB- (appsE [ varE (mkName "fmap")- , lamE [varP nm] $ appsE (conE conName : map varE (element i <~ nm $ names))- , varE (mkName "f") `appE` varE (names^.element i)- ])) []- Nothing -> errorClause lensName fieldName conName- clauses con = errorClause lensName fieldName (con^.name)+makeFieldLensBody :: Name -> Name -> [Con] -> Maybe Name -> Q Dec+makeFieldLensBody lensName fieldName cons maybeMethodName = case maybeMethodName of+ Just methodName -> do+ go <- newName "go"+ funD lensName [ clause [] (normalB (infixApp (varE methodName) (varE (mkName ".")) (varE go))) [funD go (map clauses cons)]]+ Nothing -> funD lensName (map clauses cons)+ where+ clauses (RecC conName fields) = case List.findIndex (\(n,_,_) -> n == fieldName) fields of+ Just i -> do+ names <- for fields $ \(n,_,_) -> newName (nameBase n)+ f <- newName "f"+ x <- newName "y"+ clause [varP f, conP conName $ map varP names] (normalB+ (appsE [ varE (mkName "fmap")+ , lamE [varP x] $ appsE $ conE conName : map varE (element i <~ x $ names)+ , varE (mkName "f") `appE` varE (names^.element i)+ ])) []+ Nothing -> errorClause lensName fieldName conName+ clauses con = errorClause lensName fieldName (con^.name) -- TODO: When there are constructors with missing fields, turn that field into a _traversal_ not a lens. -- TODO: When the supplied mapping function maps multiple different fields to the same name, try to unify them into a Traversal.+-- TODO: Add support for precomposing a lens from a class onto all constructed lenses makeFieldLenses :: LensRules -> Cxt -- ^ surrounding cxt driven by the data type context -> Name -- ^ data/newtype constructor name@@ -199,48 +287,133 @@ -> [Con] -> Q [Dec] makeFieldLenses cfg ctx tyConName tyArgs cons = do- let aty = appArgs (ConT tyConName) tyArgs+ x <- newName "x"+ let maybeLensClass = do+ guard $ tyArgs == []+ view lensClass cfg (nameBase tyConName)+ maybeClassName = fmap (^._1.to mkName) maybeLensClass+ aty | isJust maybeClassName = VarT x+ | otherwise = appArgs (ConT tyConName) tyArgs vs = setOf typeVars tyArgs fieldMap = commonFieldDescs cons- fmap Prelude.concat . for (toList fieldMap) $ \ (FieldDesc nm cty bds) ->- case mkName <$> view fieldLensRule cfg (nameBase nm) of+ classDecls <- case maybeLensClass of+ Nothing -> return []+ Just (clsNameString, methodNameString) -> do+ let clsName = mkName clsNameString+ methodName = mkName methodNameString+ t <- newName "t"+ a <- newName "a"+ Prelude.sequence $+ filter (\_ -> cfg^.createClass)+ [ classD (return []) clsName [PlainTV t] []+ [ sigD methodName $ conT (mkName "Control.Lens.Lens") `appsT` [varT t,varT t, conT tyConName, conT tyConName]]]+ ++ filter (\_ -> cfg^.createInstance)+ [ instanceD (return []) (conT clsName `appT` conT tyConName)+ [ funD methodName [clause [varP a] (normalB (varE a)) []]+ , pragInlD methodName $ inlineSpecNoPhase True False ]]+ bodies <- for (toList fieldMap) $ \ (FieldDesc nm cty bds) ->+ case mkName <$> view lensField cfg (nameBase nm) of Nothing -> return [] Just lensName -> do m <- freshMap $ Set.difference vs bds let bty = substTypeVars m aty dty = substTypeVars m cty- s = setOf folded m -- get the target values+ s = setOf folded m relevantBndr b = s^.contains (b^.name) relevantCtx = not . Set.null . Set.intersection s . setOf typeVars tvs = tyArgs ++ filter relevantBndr (substTypeVars m tyArgs) ps = ctx ++ filter relevantCtx (substTypeVars m ctx)- let decl = SigD lensName $ ForallT tvs ps $ ConT (mkName "Control.Lens.Lens") `apps` [aty,bty,cty,dty]- body <- makeFieldLensBody lensName nm cons- inlining <- pragInlD lensName (inlineSpecNoPhase True False)+ qs = case maybeClassName of+ Just n -> ClassP n [VarT x] : ps+ _ -> ps+ tvs' | isJust maybeClassName = PlainTV x : tvs+ | otherwise = tvs+ let decl = SigD lensName $ ForallT tvs' qs $ ConT (mkName "Control.Lens.Lens") `apps`+ if cfg^.simpleLenses then [aty,aty,cty,cty]+ else [aty,bty,cty,dty]+ body <- makeFieldLensBody lensName nm cons $ fmap (mkName . view _2) maybeLensClass+ inlining <- pragInlD lensName $ inlineSpecNoPhase True False return [decl, body, inlining]+ return $ classDecls ++ Prelude.concat bodies -- | Build lenses with a custom configuration makeLensesWith :: LensRules -> Name -> Q [Dec] makeLensesWith cfg nm = reify nm >>= \inf -> case inf of TyConI dt -> case dt of- NewtypeD ctx tyConName args (NormalC dataConName [(_,ty)]) _ -> makeIso cfg ctx tyConName args dataConName Nothing ty- DataD ctx tyConName args [NormalC dataConName [(_,ty)]] _ -> makeIso cfg ctx tyConName args dataConName Nothing ty- NewtypeD ctx tyConName args (RecC dataConName [(fld,_,ty)]) _ -> makeIso cfg ctx tyConName args dataConName (Just fld) ty- DataD ctx tyConName args [RecC dataConName [(fld,_,ty)]] _ -> makeIso cfg ctx tyConName args dataConName (Just fld) ty- DataD ctx tyConName args dataCons _ -> makeFieldLenses cfg ctx tyConName args dataCons- _ -> error "Unsupported data type"- _ -> error "Expected the name of a data type or newtype"+ NewtypeD ctx tyConName args (NormalC dataConName [(_,ty)]) _ | cfg^.handleSingletons ->+ makeIsoLenses cfg ctx tyConName args dataConName Nothing ty+ DataD ctx tyConName args [NormalC dataConName [(_,ty)]] _ | cfg^.handleSingletons ->+ makeIsoLenses cfg ctx tyConName args dataConName Nothing ty+ NewtypeD ctx tyConName args (RecC dataConName [(fld,_,ty)]) _ | cfg^.handleSingletons ->+ makeIsoLenses cfg ctx tyConName args dataConName (Just fld) ty+ DataD ctx tyConName args [RecC dataConName [(fld,_,ty)]] _ | cfg^.handleSingletons ->+ makeIsoLenses cfg ctx tyConName args dataConName (Just fld) ty+ _ | cfg^.singletonRequired -> fail "makeLensesWith: A single-constructor single-argument data type is required"+ DataD ctx tyConName args dataCons _ ->+ makeFieldLenses cfg ctx tyConName args dataCons+ _ -> fail "Unsupported data type"+ _ -> fail "Expected the name of a data type or newtype" -- | Build lenses with a sensible default configuration makeLenses :: Name -> Q [Dec]-makeLenses = makeLensesWith defaultLensRules+makeLenses = makeLensesWith+ $ lensIso <~ const Nothing+ $ lensClass <~ const Nothing+ $ handleSingletons <~ True -- generate an Iso for the field if its the only one+ $ defaultRules +-- | Make a top level isomorphism injecting _into_ the type+--+-- The supplied name is required to be for a type with a single constructor that has a single argument+makeIso :: Name -> Q [Dec]+makeIso = makeLensesWith+ $ singletonRequired <~ True+ $ singletonAndField <~ True+ $ defaultRules++-- | Make 'classy lenses' for a type+makeClassy :: Name -> Q [Dec]+makeClassy = makeLensesWith+ $ lensIso <~ const Nothing+ $ handleSingletons <~ False+ $ lensClass <~ classy+ $ classRequired <~ True+ $ defaultRules++classy :: String -> Maybe (String, String)+classy n@(a:as) = Just ("Has" ++ n, toLower a:as)+classy _ = Nothing+ -- | Derive lenses, specifying explicit pairings of @(fieldName, lensName)@. -- -- Example usage: -- -- > makeLensesFor [("_foo", "fooLens"), ("bar", "lbar")] ''Foo makeLensesFor :: [(String, String)] -> Name -> Q [Dec]-makeLensesFor fields = makeLensesWith $ fieldLensRule <~ (`Prelude.lookup` fields)- $ isoLensRule <~ const Nothing- $ defaultLensRules+makeLensesFor fields = makeLensesWith+ $ lensField <~ (`Prelude.lookup` fields)+ $ lensIso <~ const Nothing+ $ lensClass <~ const Nothing+ $ handleSingletons <~ True+ $ defaultRules++-- | Derive lenses, specifying explicit pairings of @(fieldName, lensName)@+-- using a wrapper class.+--+-- Example usage:+--+-- > makeClassyFor "HasFoo" "foo" [("_foo", "fooLens"), ("bar", "lbar")] ''Foo+makeClassyFor :: String -> String -> [(String, String)] -> Name -> Q [Dec]+makeClassyFor clsName funName fields = makeLensesWith+ $ lensField <~ (`Prelude.lookup` fields)+ $ lensIso <~ const Nothing+ $ lensClass <~ const (Just (clsName,funName))+ $ handleSingletons <~ False+ $ defaultRules++-- The orphan instance for old versions is bad, but programing without Applicative is worse.+#if !(MIN_VERSION_template_haskell(2,7,0))+instance Applicative Q where+ pure = return+ (<*>) = ap+#endif
src/Control/Seq/Lens.hs view
@@ -16,8 +16,8 @@ import Control.Lens import Control.Seq --- | Evaluate the elements targeted by a Lens, Traversal, Getter or Fold--- according to the given strategy.+-- | Evaluate the elements targeted by a 'Lens', 'Traversal', 'Iso', +-- 'Getter' or 'Fold' according to the given strategy. -- -- > seqFoldable = seqOf folded seqOf :: Getting [c] a b c d -> Strategy c -> Strategy a
src/Data/Complex/Lens.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Complex.Lens@@ -20,13 +21,21 @@ -- | Access the real part of a complex number -- -- > real :: Functor f => (a -> f a) -> Complex a -> f (Complex a)+#if MIN_VERSION_base(4,4,0) real :: Simple Lens (Complex a) a+#else+real :: RealFloat a => Simple Lens (Complex a) a+#endif real f (a :+ b) = (:+ b) <$> f a -- | Access the imaginary part of a complex number -- -- > imaginary :: Functor f => (a -> f a) -> Complex a -> f (Complex a)+#if MIN_VERSION_base(4,4,0) imaginary :: Simple Lens (Complex a) a+#else+imaginary :: RealFloat a => Simple Lens (Complex a) a+#endif imaginary f (a :+ b) = (a :+) <$> f b -- | This isn't /quite/ a legal lens. Notably the @view l (set l b a) = b@ law@@ -41,5 +50,9 @@ -- | Traverse both the real and imaginary parts of a complex number. -- -- > traverseComplex :: Applicative f => (a -> f b) -> Complex a -> f (Complex b)+#if MIN_VERSION_base(4,4,0) traverseComplex :: Traversal (Complex a) (Complex b) a b+#else+traverseComplex :: (RealFloat a, RealFloat b) => Traversal (Complex a) (Complex b) a b+#endif traverseComplex f (a :+ b) = (:+) <$> f a <*> f b
+ src/Data/Either/Lens.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE LiberalTypeSynonyms #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Either.Lens+-- Copyright : (C) 2012 Edward Kmett+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+-- Lenses for working with sums+----------------------------------------------------------------------------+module Data.Either.Lens+ ( traverseLeft+ , traverseRight+ ) where++import Control.Applicative+import Control.Lens++-- | A traversal for tweaking the left-hand value in an Either:+--+-- > traverseLeft :: Applicative f => (a -> f b) -> Either a c -> f (Either b c)+traverseLeft :: Traversal (Either a c) (Either b c) a b+traverseLeft f (Left a) = Left <$> f a+traverseLeft _ (Right c) = pure $ Right c+{-# INLINE traverseLeft #-}++-- | traverse the right-hand value in an Either:+--+-- > traverseRight = traverse+--+-- Unfortunately the instance for 'Traversable (Either c)' is still missing+-- from base, so this can't just be 'traverse'+--+-- > traverseRight :: Applicative f => (a -> f b) -> Either c a -> f (Either c a)+traverseRight :: Traversal (Either c a) (Either c b) a b+traverseRight _ (Left c) = pure $ Left c+traverseRight f (Right a) = Right <$> f a+{-# INLINE traverseRight #-}
+ src/Data/Pair/Lens.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE LiberalTypeSynonyms #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Pair.Lens+-- Copyright : (C) 2012 Edward Kmett+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+-- Lenses for working with products.+--+-- Due to their ubiquity, '_1' and '_2' are defined in @Control.Lens@.+----------------------------------------------------------------------------+module Data.Pair.Lens+ ( both+ , value+ ) where++import Control.Applicative+import Control.Lens++-- | Traverse both parts of a tuple with matching types.+both :: Traversal (a,a) (b,b) a b+both f (a,a') = (,) <$> f a <*> f a'+{-# INLINE both #-}++-- | This provides a 'Traversal' that checks a predicate on a key before+-- allowing you to traverse into a value.+value :: (k -> Bool) -> Simple Traversal (k, v) v+value p f kv@(k,v)+ | p k = (,) k <$> f v+ | otherwise = pure kv+{-# INLINE value #-}
src/Data/Sequence/Lens.hs view
@@ -26,7 +26,7 @@ -- Note: This is only a legal lens if there is such an element! -- at :: Int -> Simple Lens (Seq a) a-at i f m = (\a -> update i a m) <$> f (index m i)+at i f m = (\a -> update i a m) <$> f (Seq.index m i) -- * Sequence isomorphisms
src/Language/Haskell/TH/Lens.hs view
@@ -68,7 +68,7 @@ typeVarsEx s f (AppT l r) = AppT <$> typeVarsEx s f l <*> typeVarsEx s f r typeVarsEx s f (SigT t k) = (`SigT` k) <$> typeVarsEx s f t typeVarsEx s f (ForallT bs ctx ty) = ForallT bs <$> typeVarsEx s' f ctx <*> typeVarsEx s' f ty- where s' = s <> foldMapOf typeVars Set.singleton bs+ where s' = s `Set.union` setOf typeVars bs typeVarsEx _ _ t = pure t instance HasTypeVars Pred where