diff --git a/examples/Pong.hs b/examples/Pong.hs new file mode 100644 --- /dev/null +++ b/examples/Pong.hs @@ -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 diff --git a/examples/Pong2.hs b/examples/Pong2.hs new file mode 100644 --- /dev/null +++ b/examples/Pong2.hs @@ -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 diff --git a/examples/Test.hs b/examples/Test.hs new file mode 100644 --- /dev/null +++ b/examples/Test.hs @@ -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 diff --git a/lens.cabal b/lens.cabal --- a/lens.cabal +++ b/lens.cabal @@ -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)) diff --git a/src/Control/Indexed.hs b/src/Control/Indexed.hs new file mode 100644 --- /dev/null +++ b/src/Control/Indexed.hs @@ -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 +-- 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 #-} + diff --git a/src/Control/Lens.hs b/src/Control/Lens.hs --- a/src/Control/Lens.hs +++ b/src/Control/Lens.hs @@ -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 #-} +-} diff --git a/src/Control/Lens/TH.hs b/src/Control/Lens/TH.hs --- a/src/Control/Lens/TH.hs +++ b/src/Control/Lens/TH.hs @@ -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 diff --git a/src/Control/Seq/Lens.hs b/src/Control/Seq/Lens.hs --- a/src/Control/Seq/Lens.hs +++ b/src/Control/Seq/Lens.hs @@ -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 diff --git a/src/Data/Complex/Lens.hs b/src/Data/Complex/Lens.hs --- a/src/Data/Complex/Lens.hs +++ b/src/Data/Complex/Lens.hs @@ -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 diff --git a/src/Data/Either/Lens.hs b/src/Data/Either/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Data/Either/Lens.hs @@ -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 +-- 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 #-} diff --git a/src/Data/Pair/Lens.hs b/src/Data/Pair/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Data/Pair/Lens.hs @@ -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 +-- 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 #-} diff --git a/src/Data/Sequence/Lens.hs b/src/Data/Sequence/Lens.hs --- a/src/Data/Sequence/Lens.hs +++ b/src/Data/Sequence/Lens.hs @@ -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 diff --git a/src/Language/Haskell/TH/Lens.hs b/src/Language/Haskell/TH/Lens.hs --- a/src/Language/Haskell/TH/Lens.hs +++ b/src/Language/Haskell/TH/Lens.hs @@ -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