diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,26 @@ +3.6 +----- +* Added `upon` (along with variants of it) to `Data.Data.Lens`, which can be used to generate a `Traversal` from a field accessor or any function that returns, unmodified, + a single field that would be visited by `template`. +* Added some missing `examples/` files to the distribution. +* Renamed `Data.Bits.Lens.traverseBits` to `bits`. +* Removed `(^!?)`, which was an alias for `(^?!)`. +* Removed the need for `Trustworthy` by changing the implementation of `coerce` for `BazaarT`. +* Moved BazaarT to `Control.Lens.Internal`. +* Added `(<&>)` to `Control.Lens.Combinators`. +* `element` and `elementOf` are now indexed traversals rather than lenses and have moved to `Control.Lens.IndexedTraversal`. This both fixes their former partiality and lets you use chain indexed combinators with them. +* Added `elements` and `elementsOf` as indexed traversals for ordinal indexing into regular traversals that generalize `element` and `elementOf`. +* Renamed `Data.Complex.Lens.traverseComplex` to `complex`. +* Changed `Data.Complex.Lens.polarize` to a `Simple Iso`, due to the `RealFloat` constraint causing inference problems. +* Renamed `traverseLeft` and `traverseRight` to `_left` and `_right` respectively. +* Renamed `traverseSlice`, `traverseFrom`, and `traverseTo` in `Data.Sequence.Lens` to `sliced`, `slicedFrom`, and `slicedTo` respectively. +* Renamed `traverseAt` to `_at` in `Control.Lens.IndexedTraversal`. +* Renamed `traverseArray` to `_array` in `Data.Array.Lens`. +* Renamed and made the combinators in `Control.Lens.Zipper` more compositional to reduce third-party naming conflicts down to just `left` and `right`. +* Renamed `&=` and `|=` to `.&.=` and `.|.=` for consistency, mutatis mutandis their related operations. +* Added a `Plated` instances for `Language.Haskell.TH` types. +* Renamed `atIndex` and `atIndices` in `Data.Vector.Lens` and `Data.Vector.Generic.Lens` to `ordinal` and `ordinals` to match `Data.Sequence.Lens` + 3.5.1 ----- * Improved SafeHaskell inference. diff --git a/examples/Setup.lhs b/examples/Setup.lhs new file mode 100644 --- /dev/null +++ b/examples/Setup.lhs @@ -0,0 +1,7 @@ +#!/usr/bin/runhaskell +> module Main (main) where + +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/examples/Turtle.hs b/examples/Turtle.hs new file mode 100644 --- /dev/null +++ b/examples/Turtle.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveDataTypeable #-} +-- | A simple Turtle-graphics demonstration for modeling the location of a turtle. +-- +-- This is based on the code presented by Seth Tisue at the Boston Area Scala +-- Enthusiasts meeting during his lens talk. +-- +-- Usage: +-- +-- > def & forward 10 & down & color .~ red % turn (pi/2) & forward 5 +module Turtle where + +import Control.Lens hiding (up, down) +import Data.Default + +data Point = Point + { _x, _y :: Double + } deriving (Eq,Show) + +makeClassy ''Point + +instance Default Point where + def = Point def def + +data Color = Color + { _r, _g, _b :: Int + } deriving (Eq,Show) + +makeClassy ''Color + +red :: Color +red = Color 255 0 0 + +instance Default Color where + def = Color def def def + +data Turtle = Turtle + { _tPoint :: Point + , _tColor :: Color + , _heading :: Double + , _penDown :: Bool + } deriving (Eq,Show) + +makeClassy ''Turtle + +instance Default Turtle where + def = Turtle def def def False + +instance HasPoint Turtle where + point = tPoint + +instance HasColor Turtle where + color = tColor + +forward :: Double -> Turtle -> Turtle +forward d t = + t & y +~ d * cos (t^.heading) + & x +~ d * sin (t^.heading) + +turn :: Double -> Turtle -> Turtle +turn d = heading +~ d + +up, down :: Turtle -> Turtle +up = penDown .~ False +down = penDown .~ True diff --git a/lens.cabal b/lens.cabal --- a/lens.cabal +++ b/lens.cabal @@ -1,6 +1,6 @@ name: lens category: Data, Lenses -version: 3.5.1 +version: 3.6 license: BSD3 cabal-version: >= 1.8 license-file: LICENSE @@ -37,7 +37,7 @@ . The core of this hierarchy looks like: . - <> + <> . You can compose any two elements of the hierarchy above using (.) from the Prelude, and you can use any element of the hierarchy as any type it links to above it. @@ -91,10 +91,8 @@ config examples/LICENSE examples/lens-examples.cabal - examples/Pong.hs - examples/Plates.hs - examples/Aeson.hs - examples/Brainfuck.hs + examples/*.hs + examples/*.lhs examples/bf-examples/*.bf README.markdown CHANGELOG.markdown @@ -172,6 +170,7 @@ Control.Lens.IndexedSetter Control.Lens.IndexedTraversal Control.Lens.Internal + Control.Lens.Internal.Zipper Control.Lens.Iso Control.Lens.Isomorphic Control.Lens.Loupe @@ -183,7 +182,6 @@ Control.Lens.Traversal Control.Lens.Tuple Control.Lens.Type - Control.Lens.Unsafe Control.Lens.WithIndex Control.Lens.Zipper Control.Lens.Zoom @@ -210,7 +208,6 @@ Data.Vector.Generic.Lens other-modules: - Control.Lens.Internal.BazaarT Control.Lens.Internal.Combinators if flag(template-haskell) diff --git a/src/Control/Lens.hs b/src/Control/Lens.hs --- a/src/Control/Lens.hs +++ b/src/Control/Lens.hs @@ -44,7 +44,7 @@ -- -- -- --- <> +-- <> ---------------------------------------------------------------------------- module Control.Lens ( module Control.Lens.Type diff --git a/src/Control/Lens/Action.hs b/src/Control/Lens/Action.hs --- a/src/Control/Lens/Action.hs +++ b/src/Control/Lens/Action.hs @@ -36,7 +36,7 @@ import Control.Monad.Trans.Class -- $setup --- >>> import Control.Lens +-- >>> :m + Control.Lens infixr 8 ^! @@ -59,7 +59,7 @@ -- | Perform an 'Action'. -- --- > perform = flip (^!) +-- @'perform' ≡ 'flip' ('^!')@ perform :: Monad m => Acting m a s t a b -> s -> m a perform l = getEffect# (l (effect# return)) {-# INLINE perform #-} @@ -78,6 +78,9 @@ {-# INLINE (^!) #-} -- | Construct an 'Action' from a monadic side-effect +-- +-- >>> ["hello","world"]^!folded.act (\x -> [x,x ++ "!"]) +-- ["helloworld","helloworld!","hello!world","hello!world!"] act :: Monad m => (s -> m a) -> Action m s a act sma afb a = effective (sma a >>= ineffective . afb) {-# INLINE act #-} diff --git a/src/Control/Lens/Classes.hs b/src/Control/Lens/Classes.hs --- a/src/Control/Lens/Classes.hs +++ b/src/Control/Lens/Classes.hs @@ -32,7 +32,6 @@ import Control.Applicative import Control.Applicative.Backwards import Control.Lens.Isomorphic -import Control.Lens.Unsafe import Control.Monad (liftM) import Data.Functor.Compose import Data.Functor.Identity @@ -55,22 +54,8 @@ -- -- Which is equivalent to making a @'Gettable' f@ an \"anyvariant\" functor. -- --- Due to the structure of this library, if you built an illegal 'Gettable' --- instance that defined @'coerce' = 'undefined'@, it would be possible to --- produce code that would 'unsafeCoerce'. --- --- This would violate the promises of @SafeHaskell@. --- --- That said, the existing instances are all safe. To verify that any --- additional instances that *you* provide are safe, you must --- --- > import Control.Lens.Unsafe --- --- and provide an instance of @Trustworthy@ for your data type. That module --- does not make @SafeHaskell@ guarantees, so by doing so you've taken the --- @SafeHaskell@ proof obligation into your own hands. -class (Functor f, Trustworthy f) => Gettable f where +class Functor f => Gettable f where -- | Replace the phantom type argument. coerce :: f a -> f b diff --git a/src/Control/Lens/Combinators.hs b/src/Control/Lens/Combinators.hs --- a/src/Control/Lens/Combinators.hs +++ b/src/Control/Lens/Combinators.hs @@ -9,11 +9,13 @@ -- ------------------------------------------------------------------------------- module Control.Lens.Combinators - ( (<$!>), (<$!) + ( (<$!>), (<$!), (<&>) ) where -infixr 4 <$!>, <$! +import Data.Functor +infixr 4 <$!>, <$!, <&> + -- | A strict version of ('Data.Functor.<$>') for monads. -- -- >>> (+1) <$!> [1,2,3,4] @@ -33,3 +35,10 @@ _ <- m return $! b {-# INLINE (<$!) #-} + +-- | Infix flipped fmap. +-- +-- @('<&>') = 'flip' 'fmap'@ +(<&>) :: Functor f => f a -> (a -> b) -> f b +as <&> f = f <$> as +{-# INLINE (<&>) #-} diff --git a/src/Control/Lens/Fold.hs b/src/Control/Lens/Fold.hs --- a/src/Control/Lens/Fold.hs +++ b/src/Control/Lens/Fold.hs @@ -40,7 +40,7 @@ Fold , (^..) , (^?) - , (^?!), (^!?) + , (^?!) -- ** Building Folds --, folds , folding @@ -94,7 +94,7 @@ -- $setup -- >>> import Control.Lens -infixl 8 ^.., ^?, ^?!, ^!? +infixl 8 ^.., ^?, ^?! -------------------------- -- Folds @@ -760,21 +760,6 @@ (^?!) :: s -> Getting (First a) s t a b -> a a ^?! l = fromMaybe (error "(^?!): empty Fold") $ getFirst (foldMapOf l (first# Just) a) {-# INLINE (^?!) #-} - --- | Perform an *UNSAFE* 'head' of a 'Fold' or 'Control.Lens.Traversal.Traversal' assuming that it is there. --- --- This is an alias for ('^?!'). --- --- @ --- ('^!?') :: s -> 'Getter' s a -> a --- ('^!?') :: s -> 'Fold' s a -> a --- ('^!?') :: s -> 'Simple' 'Lens' s a -> a --- ('^!?') :: s -> 'Simple' 'Control.Lens.Iso.Iso' s a -> a --- ('^!?') :: s -> 'Simple' 'Control.Lens.Traversal.Traversal' s a -> a --- @ -(^!?) :: s -> Getting (First a) s t a b -> a -a ^!? l = fromMaybe (error "(^!?): empty Fold") $ getFirst (foldMapOf l (first# Just) a) -{-# INLINE (^!?) #-} -- | Perform a safe 'last' of a 'Fold' or 'Control.Lens.Traversal.Traversal' or retrieve 'Just' the result -- from a 'Getter' or 'Lens'. diff --git a/src/Control/Lens/Getter.hs b/src/Control/Lens/Getter.hs --- a/src/Control/Lens/Getter.hs +++ b/src/Control/Lens/Getter.hs @@ -100,7 +100,7 @@ -- >>> "hello" ^& length -- 5 -- >>> import Data.List.Lens --- >>> ("hello","world")^._1^&reverse^!?_head +-- >>> ("hello","world")^._1^&reverse^?!_head -- 'o' (^&) :: a -> (a -> b) -> b a ^& f = f a diff --git a/src/Control/Lens/IndexedTraversal.hs b/src/Control/Lens/IndexedTraversal.hs --- a/src/Control/Lens/IndexedTraversal.hs +++ b/src/Control/Lens/IndexedTraversal.hs @@ -30,13 +30,17 @@ IndexedTraversal -- * Common Indexed Traversals - , traverseAt + , _at , iwhereOf , value , ignored , TraverseMin(..) , TraverseMax(..) , traversed + , elementOf + , element + , elementsOf + , elements -- * Indexed Traversal Combinators , itraverseOf @@ -58,6 +62,7 @@ import Control.Applicative.Backwards import Control.Lens.Indexed import Control.Lens.IndexedLens +import Control.Lens.Internal import Control.Lens.Type import Control.Monad.Trans.State.Lazy as Lazy import Data.Traversable @@ -186,7 +191,7 @@ -- | Access the element of an 'IndexedTraversal' where the index matches a predicate. -- --- >>> over (iwhereOf (indexed traverse) (>0)) reverse $ ["He","was","stressed","o_O"] +-- >>> over (iwhereOf traversed (>0)) reverse ["He","was","stressed","o_O"] -- ["He","saw","desserts","O_o"] -- -- @ @@ -200,12 +205,12 @@ iwhereOf l p = index $ \f s -> withIndex l (\i a -> if p i then f i a else pure a) s {-# INLINE iwhereOf #-} --- | Traverse the value at a given key in a map +-- | This simple indexed traversal lets you 'traverse' the value at a given key in a map. -- --- @'traverseAt' k = 'at' k '<.' 'traverse'@ -traverseAt :: At k m => k -> SimpleIndexedTraversal k (m v) v -traverseAt k = at k <. traverse -{-# INLINE traverseAt #-} +-- @'_at' k = 'at' k '<.' 'traverse'@ +_at :: At k m => k -> SimpleIndexedTraversal k (m v) v +_at k = at k <. traverse +{-# INLINE _at #-} -- | Traverse any 'Traversable' container. This is an 'IndexedTraversal' that is indexed by ordinal position. traversed :: Traversable f => IndexedTraversal Int (f a) (f b) a b @@ -267,6 +272,53 @@ Just ((k, a), _) -> (\v -> Map.updateMax (const (Just v)) m) <$> f k a Nothing -> pure m {-# INLINE traverseMax #-} + +-- | Traverse the /nth/ element 'elementOf' a 'Traversal', 'Lens' or 'Control.Lens.Iso.Iso' if it exists. +-- +-- >>> [[1],[3,4]] & elementOf (traverse.traverse) 1 .~ 5 +-- [[1],[5,4]] +-- +-- >>> [[1],[3,4]] ^? elementOf (folded.folded) 1 +-- Just 3 +-- +-- >>> [0..] ^?! elementOf folded 5 +-- 5 +-- +-- >>> take 10 $ elementOf traverse 3 .~ 16 $ [0..] +-- [0,1,2,16,4,5,6,7,8,9] +-- +-- @ +-- 'elementOf' :: 'Simple' 'Traversal' s a -> Int -> 'SimpleIndexedTraversal' 'Int' s a +-- 'elementOf' :: 'Fold' s a -> Int -> 'IndexedFold' 'Int' s a +-- @ +elementOf :: (Applicative f, Indexed Int k) => LensLike (Indexing f) s t a a -> Int -> Overloaded k f s t a a +elementOf l = elementsOf l . (==) +{-# INLINE elementOf #-} + +-- | Traverse the /nth/ element of a 'Traversable' container. +-- +-- @'element' ≡ 'elementOf' 'traverse'@ +element :: Traversable t => Int -> SimpleIndexedTraversal Int (t a) a +element = elementOf traverse +{-# INLINE element #-} + +-- | Traverse (or fold) selected elements of a 'Traversal' (or 'Fold') where their ordinal positions match a predicate. +-- +-- @ +-- 'elementsOf' :: 'Simple' 'Traversal' s a -> ('Int' -> 'Bool') -> 'SimpleIndexedTraversal' 'Int' s a +-- 'elementsOf' :: 'Fold' s a -> ('Int' -> 'Bool') -> 'IndexedFold' 'Int' s a +-- @ +elementsOf :: (Applicative f, Indexed Int k) => LensLike (Indexing f) s t a a -> (Int -> Bool) -> Overloaded k f s t a a +elementsOf l p = index $ \iafb s -> case runIndexing (l (\a -> Indexing (\i -> (if p i then iafb i a else pure a, i + 1))) s) 0 of + (r, _) -> r +{-# INLINE elementsOf #-} + +-- | Traverse elements of a 'Traversable' container where their ordinal positions matches a predicate. +-- +-- @'elements' ≡ 'elementsOf' 'traverse'@ +elements :: Traversable t => (Int -> Bool) -> SimpleIndexedTraversal Int (t a) a +elements = elementsOf traverse +{-# INLINE elements #-} ------------------------------------------------------------------------------ -- Reifying Indexed Traversals diff --git a/src/Control/Lens/Internal.hs b/src/Control/Lens/Internal.hs --- a/src/Control/Lens/Internal.hs +++ b/src/Control/Lens/Internal.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} @@ -44,39 +45,24 @@ , FocusingErr(..) , Mutator(..) , Bazaar(..), bazaar, duplicateBazaar, sell + , BazaarT(..), bazaarT, duplicateBazaarT, sellT , Context(..) , Max(..), getMax , Min(..), getMin - , ElementOfResult(..), ElementOf(..) , Indexing(..) - , Level(..) - , levelWidth - , leftLevel, left1Level, leftmostLevel - , rightmostLevel, rightLevel, right1Level - , focusLevel - , rezipLevel - -- * Hidden implementations - , BazaarT ) where import Control.Applicative -import Control.Applicative.Backwards import Control.Category import Control.Comonad import Control.Comonad.Store.Class import Control.Lens.Isomorphic -import Control.Lens.Internal.BazaarT import Control.Lens.Classes -import Control.Lens.Unsafe import Control.Monad import Prelude hiding ((.),id) -import Data.Foldable import Data.Functor.Compose import Data.Functor.Identity -import Data.List.NonEmpty as NonEmpty -import Data.Maybe import Data.Monoid -import Data.Traversable import Unsafe.Coerce ----------------------------------------------------------------------------- @@ -185,8 +171,6 @@ (ff, j) -> case ma j of ~(fa, k) -> (ff <*> fa, k) -instance Trustworthy f => Trustworthy (Indexing f) - instance Gettable f => Gettable (Indexing f) where coerce (Indexing m) = Indexing $ \i -> case m i of (ff, j) -> (coerce ff, j) @@ -305,7 +289,6 @@ duplicateBazaar :: Bazaar a c t -> Bazaar a b (Bazaar b c t) duplicateBazaar (Bazaar m) = getCompose (m (Compose . fmap sell . sell)) {-# INLINE duplicateBazaar #-} --- duplicateBazaar' (Bazaar m) = Bazaar (\g -> getCompose (m (Compose . fmap sell . g))) -- | A trivial 'Bazaar'. sell :: a -> Bazaar a b b @@ -329,8 +312,6 @@ pure _ = Effect (return mempty) Effect ma <*> Effect mb = Effect (liftM2 mappend ma mb) -instance Trustworthy (Effect m r) - instance Gettable (Effect m r) where coerce (Effect m) = Effect m @@ -344,8 +325,6 @@ instance Functor (EffectRWS w st m s) where fmap _ (EffectRWS m) = EffectRWS m -instance Trustworthy (EffectRWS w st m s) - instance Gettable (EffectRWS w st m s) where coerce (EffectRWS m) = EffectRWS m @@ -389,8 +368,6 @@ pure _ = Accessor mempty Accessor a <*> Accessor b = Accessor (mappend a b) -instance Trustworthy (Accessor r) - instance Gettable (Accessor r) where coerce (Accessor m) = Accessor m @@ -431,119 +408,48 @@ tainted# = unsafeCoerce {-# INLINE tainted# #-} ------------------------------------------------------------------------------ --- Level ------------------------------------------------------------------------------ - --- | A basic non-empty list zipper --- --- All combinators assume the invariant that the length stored matches the number --- of elements in list of items to the left, and the list of items to the left is --- stored reversed. -data Level a = Level {-# UNPACK #-} !Int [a] a [a] - --- | How many entries are there in this level? -levelWidth :: Level a -> Int -levelWidth (Level n _ _ rs) = n + 1 + length rs -{-# INLINE levelWidth #-} - --- | Pull the non-emtpy list zipper left one entry -leftLevel :: Level a -> Maybe (Level a) -leftLevel (Level _ [] _ _ ) = Nothing -leftLevel (Level n (l:ls) a rs) = Just (Level (n - 1) ls l (a:rs)) -{-# INLINE leftLevel #-} - --- | Pull the non-empty list zipper left one entry, stopping at the first entry. -left1Level :: Level a -> Level a -left1Level z = fromMaybe z (leftLevel z) -{-# INLINE left1Level #-} - --- | Pull the non-empty list zipper all the way to the left. -leftmostLevel :: Level a -> Level a -leftmostLevel (Level _ ls m rs) = case Prelude.reverse ls ++ m : rs of - (c:cs) -> Level 0 [] c cs - _ -> error "the impossible happened" -{-# INLINE leftmostLevel #-} - --- | Pul the non-empty list zipper all the way to the right. --- /NB:/, when given an infinite list this may not terminate. -rightmostLevel :: Level a -> Level a -rightmostLevel (Level _ ls m rs) = go 0 [] (Prelude.head xs) (Prelude.tail xs) where - xs = Prelude.reverse ls ++ m : rs - go n zs y [] = Level n zs y [] - go n zs y (w:ws) = (go $! n + 1) (y:zs) w ws -{-# INLINE rightmostLevel #-} - --- | Pull the non-empty list zipper right one entry. -rightLevel :: Level a -> Maybe (Level a) -rightLevel (Level _ _ _ [] ) = Nothing -rightLevel (Level n ls a (r:rs)) = Just (Level (n + 1) (a:ls) r rs) -{-# INLINE rightLevel #-} - --- | Pull the non-empty list zipper right one entry, stopping at the last entry. -right1Level :: Level a -> Level a -right1Level z = fromMaybe z (rightLevel z) -{-# INLINE right1Level #-} - --- | This is a 'Lens' targeting the value that we would 'extract' from the non-empty list zipper. +-- | 'BazaarT' is like 'Bazaar', except that it provides a questionable 'Gettable' instance +-- To protect this instance it relies on the soundness of another 'Gettable' type, and usage conventions. -- --- @'view' 'focusLevel' ≡ 'extract'@ +-- For example. This lets us write a suitably polymorphic and lazy 'Control.Lens.Traversal.taking', but there +-- must be a better way! -- --- @'focusLevel' :: 'Control.Lens.Type.Simple' 'Control.Lens.Type.Lens' ('Level' a) a@ -focusLevel :: Functor f => (a -> f a) -> Level a -> f (Level a) -focusLevel f (Level n ls a rs) = (\b -> Level n ls b rs) <$> f a -{-# INLINE focusLevel #-} - -instance Functor Level where - fmap f (Level n ls a rs) = Level n (f <$> ls) (f a) (f <$> rs) - -instance Foldable Level where - foldMap f (Level _ ls a rs) = foldMap f (Prelude.reverse ls) <> f a <> foldMap f rs - -instance Traversable Level where - traverse f (Level n ls a rs) = Level n <$> forwards (traverse (Backwards . f) ls) <*> f a <*> traverse f rs - --- | Zip a non-empty list zipper back up, and return the result. -rezipLevel :: Level a -> NonEmpty a -rezipLevel (Level _ ls a rs) = NonEmpty.fromList (Prelude.reverse ls ++ a : rs) -{-# INLINE rezipLevel #-} - -instance Comonad Level where - extract (Level _ _ a _) = a - extend f w@(Level n ls m rs) = Level n (gol (n - 1) (m:rs) ls) (f w) (gor (n + 1) (m:ls) rs) where - gol k zs (y:ys) = f (Level k ys y zs) : (gol $! k - 1) (y:zs) ys - gol _ _ [] = [] - gor k ys (z:zs) = f (Level k ys z zs) : (gor $! k + 1) (z:ys) zs - gor _ _ [] = [] +newtype BazaarT a b (g :: * -> *) t = BazaarT { runBazaarT :: forall f. Applicative f => (a -> f b) -> f t } -instance ComonadStore Int Level where - pos (Level n _ _ _) = n - peek n (Level m ls a rs) = case compare n m of - LT -> ls Prelude.!! (m - n) - EQ -> a - GT -> rs Prelude.!! (n - m) +instance Functor (BazaarT a b g) where + fmap f (BazaarT k) = BazaarT (fmap f . k) + {-# INLINE fmap #-} --- | The result of searching for a particular element in a Traversal. -data ElementOfResult f a = Searching Int a (Maybe (f a)) +instance Applicative (BazaarT a b g) where + pure a = BazaarT (\_ -> pure a) + {-# INLINE pure #-} + BazaarT mf <*> BazaarT ma = BazaarT (\k -> mf k <*> ma k) + {-# INLINE (<*>) #-} -instance Functor f => Functor (ElementOfResult f) where - fmap f (Searching i a as) = Searching i (f a) (fmap f <$> as) +instance (a ~ b) => Comonad (BazaarT a b g) where + extract (BazaarT m) = runIdentity (m Identity) + {-# INLINE extract #-} + duplicate = duplicateBazaarT + {-# INLINE duplicate #-} --- | Searches for a particular element in a Traversal. -newtype ElementOf f a = ElementOf { getElementOf :: Int -> ElementOfResult f a } +instance Gettable g => Gettable (BazaarT a b g) where + coerce = (<$) (error "coerced BazaarT") + {-# INLINE coerce #-} -instance Functor f => Functor (ElementOf f) where - fmap f (ElementOf m) = ElementOf (fmap f . m) +-- | Extract from a 'BazaarT'. +-- +-- @'bazaarT' = 'flip' 'runBazaarT'@ +bazaarT :: Applicative f => (a -> f b) -> BazaarT a b g t -> f t +bazaarT afb (BazaarT m) = m afb +{-# INLINE bazaarT #-} -instance Functor f => Applicative (ElementOf f) where - pure a = ElementOf $ \i -> Searching i a Nothing - ElementOf mf <*> ElementOf ma = ElementOf $ \i -> case mf i of - Searching j f mff -> case ma j of - ~(Searching k a maa) -> Searching k (f a) $ fmap ($ a) <$> mff - <|> fmap f <$> maa +-- | 'BazaarT' is an indexed 'Comonad'. +duplicateBazaarT :: BazaarT a c f t -> BazaarT a b f (BazaarT b c f t) +duplicateBazaarT (BazaarT m) = getCompose (m (Compose . fmap sellT . sellT)) +{-# INLINE duplicateBazaarT #-} -instance Trustworthy f => Trustworthy (ElementOf f) +-- | A trivial 'BazaarT'. +sellT :: a -> BazaarT a b f b +sellT i = BazaarT (\k -> k i) +{-# INLINE sellT #-} -instance Gettable f => Gettable (ElementOf f) where - coerce (ElementOf m) = ElementOf $ \i -> case m i of - Searching j _ mas -> Searching j (error "coerced while searching") (coerce <$> mas) diff --git a/src/Control/Lens/Internal/BazaarT.hs b/src/Control/Lens/Internal/BazaarT.hs deleted file mode 100644 --- a/src/Control/Lens/Internal/BazaarT.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE KindSignatures #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE Trustworthy #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Control.Lens.Internal.BazaarT --- Copyright : (C) 2012 Edward Kmett, Shachaf Ben-Kiki --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett --- Stability : provisional --- Portability : Rank2Types, KindSignatures --- --- This module is not exported from this package. However, the 'BazaarT' --- type (and only the type) is re-exported from @Control.Lens.Internal@. --- ----------------------------------------------------------------------------- -module Control.Lens.Internal.BazaarT - ( BazaarT(..) - , bazaarT - , sellT - ) where - -import Control.Applicative -import Control.Lens.Unsafe -import Control.Lens.Classes -import Unsafe.Coerce - --- | 'BazaarT' is like 'Control.Lens.Internal.Bazaar', except that it provides a questionable 'Gettable' instance --- where @'Control.Lens.Internal.coerce' = 'Unsafe.Coerce.unsafeCoerce'@. To protect this instance it relies on --- a combination of the fact that we do not export the tools for working with this type, beyond its type signature --- to user code, and the fact that it borrows a proof obligation that the 'Gettable' instance is sound from another --- 'Getter'. --- --- For example. This lets us write a suitably polymorphic and lazy 'Control.Lens.Traversal.taking', but there --- must be a better way! --- --- @g@ is a phantom type used in the 'Control.Lens.Internal.Gettable' instance. - -newtype BazaarT a b (g :: * -> *) s = BazaarT (forall f. Applicative f => (a -> f b) -> f s) - -instance Functor (BazaarT a b g) where - fmap f (BazaarT k) = BazaarT (fmap f . k) - {-# INLINE fmap #-} - -instance Applicative (BazaarT a b g) where - pure a = BazaarT (\_ -> pure a) - {-# INLINE pure #-} - BazaarT mf <*> BazaarT ma = BazaarT (\k -> mf k <*> ma k) - {-# INLINE (<*>) #-} - --- | Extract from a 'BazaarT'. --- --- @'bazaarT' = 'flip' 'runBazaarT'@ -bazaarT :: Applicative f => (a -> f b) -> BazaarT a b g s -> f s -bazaarT afb (BazaarT m) = m afb -{-# INLINE bazaarT #-} - --- | A trivial 'BazaarT'. -sellT :: a -> BazaarT a b f b -sellT i = BazaarT (\k -> k i) -{-# INLINE sellT #-} - -instance Trustworthy g => Trustworthy (BazaarT a b g) - -instance Gettable g => Gettable (BazaarT a b g) where - coerce = unsafeCoerce diff --git a/src/Control/Lens/Internal/Zipper.hs b/src/Control/Lens/Internal/Zipper.hs new file mode 100644 --- /dev/null +++ b/src/Control/Lens/Internal/Zipper.hs @@ -0,0 +1,414 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Lens.Internal.Zipper +-- Copyright : (C) 2012 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : non-portable +-- +-- This module provides internal types and functions used in the implementation +-- of Control.Lens.Zipper. You shouldn't need to import it directly, and the +-- exported types can be used to break Zipper invariants. +-- +---------------------------------------------------------------------------- +module Control.Lens.Internal.Zipper where + +import Control.Applicative +import Control.Applicative.Backwards +import Control.Category +import Control.Comonad +import Control.Comonad.Store.Class +import Control.Monad ((>=>)) +import Control.Lens.Fold +import Control.Lens.Indexed +import Control.Lens.IndexedLens +import Control.Lens.Internal +import Control.Lens.Traversal +import Control.Lens.Type +import Data.Foldable +import Data.List.NonEmpty as NonEmpty +import Data.Maybe +import Data.Monoid +import Prelude hiding ((.),id) + +----------------------------------------------------------------------------- +-- * Zippers +----------------------------------------------------------------------------- + +-- | This is used to represent the 'Top' of the 'Zipper'. +-- +-- Every 'Zipper' starts with 'Top'. +-- +-- /e.g./ @'Top' ':>' a@ is the trivial zipper. +data Top + +infixl 9 :> + +-- | This is the type of a 'Zipper'. It visually resembes a 'breadcrumb trail' as +-- used in website navigation. Each breadcrumb in the trail represents a level you +-- can move up to. +-- +-- This type operator associates to the left, so you can use a type like +-- +-- @'Top' ':>' ('String','Double') ':>' 'String' ':>' 'Char'@ +-- +-- to represent a zipper from @('String','Double')@ down to 'Char' that has an intermediate +-- crumb for the 'String' containing the 'Char'. +data p :> a = Zipper (Coil p a) {-# UNPACK #-} !(Level a) + +-- | This represents the type a zipper will have when it is fully 'Zipped' back up. +type family Zipped h a +type instance Zipped Top a = a +type instance Zipped (h :> b) a = Zipped h b + +-- | 'Coil' is used internally in the definition of a 'Zipper'. +data Coil :: * -> * -> * where + Coil :: Coil Top a + Snoc :: Coil h b -> + {-# UNPACK #-} !Int -> + SimpleLensLike (Bazaar a a) b a -> + [b] -> (NonEmpty a -> b) -> [b] -> + Coil (h :> b) a + +-- | This 'Lens' views the current target of the 'zipper'. +focus :: SimpleIndexedLens (Tape (h :> a)) (h :> a) a +focus = index $ \f (Zipper h (Level n l a r)) -> (\a' -> Zipper h (Level n l a' r)) <$> f (Tape (peel h) n) a +{-# INLINE focus #-} + +-- | Construct a 'zipper' that can explore anything. +zipper :: a -> Top :> a +zipper a = Zipper Coil (Level 0 [] a []) +{-# INLINE zipper #-} + +-- | Return the index into the current 'Traversal' within the current level of the zipper. +-- +-- @'jerkTo' ('tooth' l) l = Just'@ +tooth :: (a :> b) -> Int +tooth (Zipper _ (Level n _ _ _)) = n +{-# INLINE tooth #-} + +-- | Move the 'zipper' 'up', closing the current level and focusing on the parent element. +up :: (a :> b :> c) -> a :> b +up (Zipper (Snoc h n _ ls k rs) w) = Zipper h (Level n ls (k (rezipLevel w)) rs) +{-# INLINE up #-} + +-- | Pull the 'zipper' 'left' within the current 'Traversal'. +left :: (a :> b) -> Maybe (a :> b) +left (Zipper h w) = Zipper h <$> leftLevel w +{-# INLINE left #-} + +-- | Pull the entry one entry to the 'right' +right :: (a :> b) -> Maybe (a :> b) +right (Zipper h w) = Zipper h <$> rightLevel w +{-# INLINE right #-} + +-- | This allows you to safely 'tug left' or 'tug right' on a 'zipper'. +-- +-- The more general signature allows its use in other circumstances, however. +tug :: (a -> Maybe a) -> a -> a +tug f a = fromMaybe a (f a) +{-# INLINE tug #-} + +-- | This allows you to safely 'tug left' or 'tug right' on a 'zipper', moving multiple steps in a given direction, +-- stopping at the last place you couldn't move from. +tugs :: (a -> Maybe a) -> Int -> a -> a +tugs f n0 + | n0 < 0 = error "tugs: negative tug count" + | otherwise = go n0 + where + go 0 a = a + go n a = maybe a (go (n - 1)) (f a) +{-# INLINE tugs #-} + +-- | Move in a direction as far as you can go, then stop. +farthest :: (a -> Maybe a) -> a -> a +farthest f = go where + go a = maybe a go (f a) +{-# INLINE farthest #-} + +-- | This allows for you to repeatedly pull a 'zipper' in a given direction, failing if it falls of the end. +jerks :: (a -> Maybe a) -> Int -> a -> Maybe a +jerks f n0 + | n0 < 0 = error "jerks: negative jerk count" + | otherwise = go n0 + where + go 0 a = Just a + go n a = f a >>= go (n - 1) +{-# INLINE jerks #-} + +-- | Returns the number of siblings at the current level in the 'zipper'. +-- +-- @'teeth' z '>=' 1@ +-- +-- /NB:/ If the current 'Traversal' targets an infinite number of elements then this may not terminate. +teeth :: (a :> b) -> Int +teeth (Zipper _ w) = levelWidth w +{-# INLINE teeth #-} + +-- | Move the 'zipper' horizontally to the element in the @n@th position in the current level, absolutely indexed, starting with the @'farthest' 'left'@ as @0@. +-- +-- This returns 'Nothing' if the target element doesn't exist. +-- +-- @'jerkTo' n ≡ 'jerks' 'right' n . 'farthest' 'left'@ +jerkTo :: Int -> (a :> b) -> Maybe (a :> b) +jerkTo n z = case compare k n of + LT -> jerks left (n - k) z + EQ -> Just z + GT -> jerks right (k - n) z + where k = tooth z +{-# INLINE jerkTo #-} + +-- | Move the 'zipper' horizontally to the element in the @n@th position of the current level, absolutely indexed, starting with the @'farthest' 'left'@ as @0@. +-- +-- If the element at that position doesn't exist, then this will clamp to the range @0 <= n < 'teeth'@. +-- +-- @'tugTo' n ≡ 'tugs' 'right' n . 'farthest' 'left'@ +tugTo :: Int -> (a :> b) -> a :> b +tugTo n z = case compare k n of + LT -> tugs left (n - k) z + EQ -> z + GT -> tugs right (k - n) z + where k = tooth z +{-# INLINE tugTo #-} + +-- | Step down into a 'Lens'. This is a constrained form of 'fromWithin' for when you know +-- there is precisely one target. +-- +-- @ +-- 'down' :: 'Simple' 'Lens' b c -> (a :> b) -> a :> b :> c +-- 'down' :: 'Simple' 'Iso' b c -> (a :> b) -> a :> b :> c +-- @ +down :: SimpleLensLike (Context c c) b c -> (a :> b) -> a :> b :> c +down l (Zipper h (Level n ls b rs)) = case l (Context id) b of + Context k c -> Zipper (Snoc h n (cloneLens l) ls (k . extract) rs) (Level 0 [] c []) +{-# INLINE down #-} + +-- | Step down into the 'leftmost' entry of a 'Traversal'. +-- +-- @ +-- 'within' :: 'Simple' 'Traversal' b c -> (a :> b) -> Maybe (a :> b :> c) +-- 'within' :: 'Simple' 'Lens' b c -> (a :> b) -> Maybe (a :> b :> c) +-- 'within' :: 'Simple' 'Iso' b c -> (a :> b) -> Maybe (a :> b :> c) +-- @ +within :: SimpleLensLike (Bazaar c c) b c -> (a :> b) -> Maybe (a :> b :> c) +within l (Zipper h (Level n ls b rs)) = case partsOf' l (Context id) b of + Context _ [] -> Nothing + Context k (c:cs) -> Just (Zipper (Snoc h n l ls (k . NonEmpty.toList) rs) (Level 0 [] c cs)) +{-# INLINE within #-} + +-- | Unsafely step down into a 'Traversal' that is /assumed/ to be non-empty. +-- +-- If this invariant is not met then this will usually result in an error! +-- +-- @ +-- 'fromWithin' :: 'Simple' 'Traversal' b c -> (a :> b) -> a :> b :> c +-- 'fromWithin' :: 'Simple' 'Lens' b c -> (a :> b) -> a :> b :> c +-- 'fromWithin' :: 'Simple' 'Iso' b c -> (a :> b) -> a :> b :> c +-- @ +-- +-- You can reason about this function as if the definition was: +-- +-- @'fromWithin' l ≡ 'fromJust' '.' 'within' l@ +-- +-- but it is lazier in such a way that if this invariant is violated, some code +-- can still succeed if it is lazy enough in the use of the focused value. +fromWithin :: SimpleLensLike (Bazaar c c) b c -> (a :> b) -> a :> b :> c +fromWithin l (Zipper h (Level n ls b rs)) = case partsOf' l (Context id) b of + Context k cs -> Zipper (Snoc h n l ls (k . NonEmpty.toList) rs) + (Level 0 [] (Prelude.head cs) (Prelude.tail cs)) +{-# INLINE fromWithin #-} + +-- | This enables us to pull the 'zipper' back up to the 'Top'. +class Zipper h a where + recoil :: Coil h a -> NonEmpty a -> Zipped h a + +instance Zipper Top a where + recoil Coil = extract + +instance Zipper h b => Zipper (h :> b) c where + recoil (Snoc h _ _ ls k rs) as = recoil h (NonEmpty.fromList (Prelude.reverse ls ++ k as : rs)) + +-- | Close something back up that you opened as a 'zipper'. +rezip :: Zipper h a => (h :> a) -> Zipped h a +rezip (Zipper h w) = recoil h (rezipLevel w) +{-# INLINE rezip #-} + +----------------------------------------------------------------------------- +-- * Tapes +----------------------------------------------------------------------------- + +-- | A 'Tape' is a recorded path through the 'Traversal' chain of a 'Zipper'. +data Tape k where + Tape :: Track h a -> {-# UNPACK #-} !Int -> Tape (h :> a) + +-- | Save the current path as as a 'Tape' we can play back later. +saveTape :: (a :> b) -> Tape (a :> b) +saveTape (Zipper h (Level n _ _ _)) = Tape (peel h) n +{-# INLINE saveTape #-} + +-- | Restore ourselves to a previously recorded position precisely. +-- +-- If the position does not exist, then fail. +restoreTape :: Tape (h :> a) -> Zipped h a -> Maybe (h :> a) +restoreTape (Tape h n) = restoreTrack h >=> jerks right n +{-# INLINE restoreTape #-} + +-- | Restore ourselves to a location near our previously recorded position. +-- +-- When moving left to right through a 'Traversal', if this will clamp at each level to the range @0 <= k < teeth@, +-- so the only failures will occur when one of the sequence of downward traversals find no targets. +restoreNearTape :: Tape (h :> a) -> Zipped h a -> Maybe (h :> a) +restoreNearTape (Tape h n) a = tugs right n <$> restoreNearTrack h a +{-# INLINE restoreNearTape #-} + +-- | Restore ourselves to a previously recorded position. +-- +-- This *assumes* that nothing has been done in the meantime to affect the existence of anything on the entire path. +-- +-- Motions left or right are clamped, but all traversals included on the 'Tape' are assumed to be non-empty. +-- +-- Violate these assumptions at your own risk! +unsafelyRestoreTape :: Tape (h :> a) -> Zipped h a -> h :> a +unsafelyRestoreTape (Tape h n) = unsafelyRestoreTrack h >>> tugs right n +{-# INLINE unsafelyRestoreTape #-} + +----------------------------------------------------------------------------- +-- * Tracks +----------------------------------------------------------------------------- + +-- | This is used to peel off the path information from a 'Coil' for use when saving the current path for later replay. +peel :: Coil h a -> Track h a +peel Coil = Track +peel (Snoc h n l _ _ _) = Fork (peel h) n l + +-- | The 'Track' forms the bulk of a 'Tape'. +data Track :: * -> * -> * where + Track :: Track Top a + Fork :: Track h b -> {-# UNPACK #-} !Int -> SimpleLensLike (Bazaar a a) b a -> Track (h :> b) a + +-- | Restore ourselves to a previously recorded position precisely. +-- +-- If the position does not exist, then fail. +restoreTrack :: Track h a -> Zipped h a -> Maybe (h :> a) +restoreTrack Track = Just . zipper +restoreTrack (Fork h n l) = restoreTrack h >=> jerks right n >=> within l + +-- | Restore ourselves to a location near our previously recorded position. +-- +-- When moving left to right through a 'Traversal', if this will clamp at each level to the range @0 <= k < teeth@, +-- so the only failures will occur when one of the sequence of downward traversals find no targets. +restoreNearTrack :: Track h a -> Zipped h a -> Maybe (h :> a) +restoreNearTrack Track = Just . zipper +restoreNearTrack (Fork h n l) = restoreNearTrack h >=> tugs right n >>> within l + +-- | Restore ourselves to a previously recorded position. +-- +-- This *assumes* that nothing has been done in the meantime to affect the existence of anything on the entire path. +-- +-- Motions left or right are clamped, but all traversals included on the 'Tape' are assumed to be non-empty. +-- +-- Violate these assumptions at your own risk! +unsafelyRestoreTrack :: Track h a -> Zipped h a -> h :> a +unsafelyRestoreTrack Track = zipper +unsafelyRestoreTrack (Fork h n l) = unsafelyRestoreTrack h >>> tugs right n >>> fromWithin l + +----------------------------------------------------------------------------- +-- * Levels +----------------------------------------------------------------------------- + +-- | A basic non-empty list zipper +-- +-- All combinators assume the invariant that the length stored matches the number +-- of elements in list of items to the left, and the list of items to the left is +-- stored reversed. +data Level a = Level {-# UNPACK #-} !Int [a] a [a] + +-- | How many entries are there in this level? +levelWidth :: Level a -> Int +levelWidth (Level n _ _ rs) = n + 1 + length rs +{-# INLINE levelWidth #-} + +-- | Pull the non-empty list zipper left one entry +leftLevel :: Level a -> Maybe (Level a) +leftLevel (Level _ [] _ _ ) = Nothing +leftLevel (Level n (l:ls) a rs) = Just (Level (n - 1) ls l (a:rs)) +{-# INLINE leftLevel #-} + +-- | Pull the non-empty list zipper left one entry, stopping at the first entry. +left1Level :: Level a -> Level a +left1Level z = fromMaybe z (leftLevel z) +{-# INLINE left1Level #-} + +-- | Pull the non-empty list zipper all the way to the left. +leftmostLevel :: Level a -> Level a +leftmostLevel (Level _ ls m rs) = case Prelude.reverse ls ++ m : rs of + (c:cs) -> Level 0 [] c cs + _ -> error "the impossible happened" +{-# INLINE leftmostLevel #-} + +-- | Pul the non-empty list zipper all the way to the right. +-- /NB:/, when given an infinite list this may not terminate. +rightmostLevel :: Level a -> Level a +rightmostLevel (Level _ ls m rs) = go 0 [] (Prelude.head xs) (Prelude.tail xs) where + xs = Prelude.reverse ls ++ m : rs + go n zs y [] = Level n zs y [] + go n zs y (w:ws) = (go $! n + 1) (y:zs) w ws +{-# INLINE rightmostLevel #-} + +-- | Pull the non-empty list zipper right one entry. +rightLevel :: Level a -> Maybe (Level a) +rightLevel (Level _ _ _ [] ) = Nothing +rightLevel (Level n ls a (r:rs)) = Just (Level (n + 1) (a:ls) r rs) +{-# INLINE rightLevel #-} + +-- | Pull the non-empty list zipper right one entry, stopping at the last entry. +right1Level :: Level a -> Level a +right1Level z = fromMaybe z (rightLevel z) +{-# INLINE right1Level #-} + +-- | This is a 'Lens' targeting the value that we would 'extract' from the non-empty list zipper. +-- +-- @'view' 'focusLevel' ≡ 'extract'@ +-- +-- @'focusLevel' :: 'Simple' 'Lens' ('Level' a) a@ +focusLevel :: Functor f => (a -> f a) -> Level a -> f (Level a) +focusLevel f (Level n ls a rs) = (\b -> Level n ls b rs) <$> f a +{-# INLINE focusLevel #-} + +instance Functor Level where + fmap f (Level n ls a rs) = Level n (f <$> ls) (f a) (f <$> rs) + +instance Foldable Level where + foldMap f (Level _ ls a rs) = foldMapOf (backwards folded) f ls <> f a <> foldMap f rs + +instance Traversable Level where + traverse f (Level n ls a rs) = Level n <$> forwards (traverse (Backwards . f) ls) <*> f a <*> traverse f rs + +-- | Zip a non-empty list zipper back up, and return the result. +rezipLevel :: Level a -> NonEmpty a +rezipLevel (Level _ ls a rs) = NonEmpty.fromList (Prelude.reverse ls ++ a : rs) +{-# INLINE rezipLevel #-} + +instance Comonad Level where + extract (Level _ _ a _) = a + extend f w@(Level n ls m rs) = Level n (gol (n - 1) (m:rs) ls) (f w) (gor (n + 1) (m:ls) rs) where + gol k zs (y:ys) = f (Level k ys y zs) : (gol $! k - 1) (y:zs) ys + gol _ _ [] = [] + gor k ys (z:zs) = f (Level k ys z zs) : (gor $! k + 1) (z:ys) zs + gor _ _ [] = [] + +instance ComonadStore Int Level where + pos (Level n _ _ _) = n + peek n (Level m ls a rs) = case compare n m of + LT -> ls Prelude.!! (m - n) + EQ -> a + GT -> rs Prelude.!! (n - m) diff --git a/src/Control/Lens/Plated.hs b/src/Control/Lens/Plated.hs --- a/src/Control/Lens/Plated.hs +++ b/src/Control/Lens/Plated.hs @@ -1,9 +1,13 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} +#ifndef MIN_VERSION_template_haskell +#define MIN_VERSION_template_haskell(x,y,z) 1 +#endif ------------------------------------------------------------------------------- -- | -- Module : Control.Lens.Plated @@ -69,17 +73,18 @@ ) where -import Control.Applicative -import Control.Lens.Fold -import Control.Lens.Getter -import Control.Lens.Internal -import Control.Lens.Setter -import Control.Lens.Traversal -import Control.Lens.Type -import Data.Data -import Data.Data.Lens -import Data.Monoid -import Data.Tree +import Control.Applicative +import Control.Lens.Fold +import Control.Lens.Getter +import Control.Lens.Internal +import Control.Lens.Setter +import Control.Lens.Traversal +import Control.Lens.Type +import qualified Language.Haskell.TH as TH +import Data.Data +import Data.Data.Lens +import Data.Monoid +import Data.Tree -- | A 'Plated' type is one where we know how to extract its immediate self-similar children. -- @@ -181,6 +186,16 @@ instance Plated (Tree a) where plate f (Node a as) = Node a <$> traverse f as + +instance Plated TH.Exp +instance Plated TH.Dec +instance Plated TH.Con +instance Plated TH.Type +#if !(MIN_VERSION_template_haskell(2,8,0)) +instance Plated TH.Kind -- in 2.8 Kind is an alias for Type +#endif +instance Plated TH.Stmt +instance Plated TH.Pat ------------------------------------------------------------------------------- -- Children diff --git a/src/Control/Lens/Simple.hs b/src/Control/Lens/Simple.hs --- a/src/Control/Lens/Simple.hs +++ b/src/Control/Lens/Simple.hs @@ -10,6 +10,8 @@ -- Portability : Rank2Types -- -- Infix type operators for simple lenses and traversals. +-- +-- These type aliases are not re-exported from @Control.Lens@. ---------------------------------------------------------------------------- module Control.Lens.Simple 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 @@ -174,13 +174,13 @@ -- | Default lens rules defaultRules :: LensRules -defaultRules = LensRules top field (const Nothing) $ +defaultRules = LensRules top fld (const Nothing) $ Set.fromList [SingletonIso, SingletonAndField, CreateClass, CreateInstance, BuildTraversals, GenerateSignatures] where top (c:cs) = Just (toLower c:cs) top _ = Nothing - field ('_':c:cs) = Just (toLower c:cs) - field _ = Nothing + fld ('_':c:cs) = Just (toLower c:cs) + fld _ = Nothing -- | Rules for making fairly simple partial lenses, ignoring the special cases -- for isomorphisms and traversals, and not making any classes. @@ -430,10 +430,10 @@ clauses = map buildClause conList buildClause (con, fields) = do f <- newName "_f" - vars <- for (con^..conNamedFields._1) $ \field -> - if field `List.elem` fields - then Left <$> ((,) <$> newName ('_':(nameBase field++"'")) <*> newName ('_':nameBase field)) - else Right <$> newName ('_':nameBase field) + vars <- for (con^..conNamedFields._1) $ \fld -> + if fld `List.elem` fields + then Left <$> ((,) <$> newName ('_':(nameBase fld++"'")) <*> newName ('_':nameBase fld)) + else Right <$> newName ('_':nameBase fld) let cpats = map (varP . either fst id) vars -- Deconstruction cvals = map (varE . either snd id) vars -- Reconstruction fpats = map (varP . snd) $ lefts vars -- Lambda patterns diff --git a/src/Control/Lens/Traversal.hs b/src/Control/Lens/Traversal.hs --- a/src/Control/Lens/Traversal.hs +++ b/src/Control/Lens/Traversal.hs @@ -1,7 +1,7 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE Rank2Types #-} -{-# LANGUAGE LiberalTypeSynonyms #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE LiberalTypeSynonyms #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Traversal @@ -15,11 +15,11 @@ -- 'Traversable'. It allows you to traverse over a structure and change out -- its contents with monadic or applicative side-effects. Starting from -- --- @'traverse' :: ('Traversable' t, 'Applicative' f) => (a -> f b) -> t a -> f (t b)@, +-- @'traverse' :: ('Traversable' t, 'Applicative' f) => (a -> f b) -> t a -> f (t b)@ -- -- we monomorphize the contents and result to obtain -- --- > type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t +-- @type 'Traversal' s t a b = forall f. 'Applicative' f => (a -> f b) -> s -> f t@ -- -- While a 'Traversal' isn't quite a 'Fold', it _can_ be used for 'Getting' -- like a 'Fold', because given a 'Monoid' @m@, we have an 'Applicative' @@ -32,9 +32,6 @@ -- * Lenses Traversal - -- ** Lensing Traversals - , element, elementOf - -- * Traversing and Lensing , traverseOf, forOf, sequenceAOf , mapMOf, forMOf, sequenceOf @@ -51,8 +48,8 @@ -- * Common Traversals , Traversable(traverse) - , traverseLeft - , traverseRight + , _left + , _right , both , beside , taking @@ -74,14 +71,13 @@ import Control.Applicative.Backwards import Control.Lens.Fold import Control.Lens.Internal -import Control.Lens.Internal.BazaarT import Control.Lens.Internal.Combinators import Control.Lens.Type import Control.Monad.State.Class as State import Control.Monad.Trans.State.Lazy as Lazy -import Data.Maybe import Data.Traversable + -- $setup -- >>> import Control.Lens @@ -391,36 +387,6 @@ f (x:xs) g = Context (g . (:xs)) x : f xs (g . (x:)) {-# INLINE holesOf #-} --- | A 'Lens' to 'Control.Lens.Getter.view'/'Control.Lens.Setter.set' the nth element 'elementOf' a 'Traversal', 'Lens' or 'Control.Lens.Iso.Iso'. --- --- Attempts to access beyond the range of the 'Traversal' will cause an error. This also works transparently --- with Folds, returning a getter. --- --- >>> [[1],[3,4]] & elementOf (traverse.traverse) 1 .~ 5 --- [[1],[5,4]] --- --- >>> [[1],[3,4]]^.elementOf (folded.folded) 1 --- 3 --- --- >>> [0..]^.elementOf folded 5 --- 5 --- --- >>> take 10 $ (elementOf traverse 3 .~ 16) [0..] --- [0,1,2,16,4,5,6,7,8,9] -elementOf :: Functor f => LensLike (ElementOf f) s t a a -> Int -> LensLike f s t a a -elementOf l i f s = case getElementOf (l go s) 0 of - Searching _ _ mft -> fromMaybe (error "elOf: index out of range") mft - where - go a = ElementOf $ \j -> Searching (j + 1) a (if i == j then Just (f a) else Nothing) - --- | Access the /nth/ element of a 'Traversable' container. --- --- Attempts to access beyond the range of the 'Traversal' will cause an error. --- --- @'element' ≡ 'elementOf' 'traverse'@ -element :: Traversable t => Int -> Simple Lens (t a) a -element = elementOf traverse - ------------------------------------------------------------------------------ -- Internal functions used by 'partsOf', 'holesOf', etc. ------------------------------------------------------------------------------ @@ -441,7 +407,7 @@ insT = toListOf bazaarT {-# INLINE insT #-} -outsT :: BazaarT a a f s -> [a] -> s +outsT :: BazaarT a a f t -> [a] -> t outsT = evalState . bazaarT (\oldVal -> State.state (unconsWithDefault oldVal)) {-# INLINE outsT #-} @@ -463,8 +429,10 @@ -- -- >>> both *~ 10 $ (1,2) -- (10,20) +-- -- >>> over both length ("hello","world") -- (5,5) +-- -- >>> ("hello","world")^.both -- "helloworld" both :: Traversal (a,a) (b,b) a b @@ -481,50 +449,56 @@ -- | A traversal for tweaking the left-hand value of an 'Either': -- --- >>> over traverseLeft (+1) (Left 2) +-- >>> over _left (+1) (Left 2) -- Left 3 --- >>> over traverseLeft (+1) (Right 2) +-- +-- >>> over _left (+1) (Right 2) -- Right 2 --- >>> Right 42 ^.traverseLeft :: String +-- +-- >>> Right 42 ^._left :: String -- "" --- >>> Left "hello" ^.traverseLeft +-- +-- >>> Left "hello" ^._left -- "hello" -- --- @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 #-} +-- @_left :: 'Applicative' f => (a -> f b) -> 'Either' a c -> f ('Either' b c)@ +_left :: Traversal (Either a c) (Either b c) a b +_left f (Left a) = Left <$> f a +_left _ (Right c) = pure $ Right c +{-# INLINE _left #-} -- | traverse the right-hand value of an 'Either': -- --- @'traverseRight' ≡ 'Data.Traversable.traverse'@ +-- @'_right' ≡ 'Data.Traversable.traverse'@ -- -- Unfortunately the instance for -- @'Data.Traversable.Traversable' ('Either' c)@ is still missing from base, -- so this can't just be 'Data.Traversable.traverse' -- --- >>> over traverseRight (+1) (Left 2) +-- >>> over _right (+1) (Left 2) -- Left 2 --- >>> over traverseRight (+1) (Right 2) +-- +-- >>> over _right (+1) (Right 2) -- Right 3 --- >>> Right "hello" ^.traverseRight +-- +-- >>> Right "hello" ^._right -- "hello" --- >>> Left "hello" ^.traverseRight :: [Double] +-- +-- >>> Left "hello" ^._right :: [Double] -- [] -- --- @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 #-} +-- @_right :: 'Applicative' f => (a -> f b) -> 'Either' c a -> f ('Either' c a)@ +_right :: Traversal (Either c a) (Either c b) a b +_right _ (Left c) = pure $ Left c +_right f (Right a) = Right <$> f a +{-# INLINE _right #-} -- | Visit the first /n/ targets of a 'Traversal', 'Fold', 'Getter' or 'Lens'. -- -- >>> [("hello","world"),("!!!","!!!")]^.. taking 2 (traverse.both) -- ["hello","world"] -- --- >>> [1..]^.. taking 3 traverse +-- >>> [1..] ^.. taking 3 traverse -- [1,2,3] -- -- >>> over (taking 5 traverse) succ "hello world" @@ -538,7 +512,7 @@ -- >>> ("hello","world") ^? dropping 1 both -- Just "world" -- --- Dropping works on infinite traversals as well. +-- Dropping works on infinite traversals as well: -- -- >>> [1..]^? dropping 1 folded -- Just 2 @@ -578,3 +552,4 @@ -- | @type SimpleReifiedTraversal = 'Simple' 'ReifiedTraversal'@ type SimpleReifiedTraversal s a = ReifiedTraversal s s a a + diff --git a/src/Control/Lens/Tuple.hs b/src/Control/Lens/Tuple.hs --- a/src/Control/Lens/Tuple.hs +++ b/src/Control/Lens/Tuple.hs @@ -44,6 +44,13 @@ -- >>> _1 .~ "hello" $ (1,2) -- ("hello",2) -- + -- >>> (1,2) & _1 .~ "hello" + -- ("hello",2) + -- + -- >>> _1 putStrLn ("hello","world") + -- hello + -- ((),"world") + -- -- This can also be used on larger tuples as well -- -- >>> _1 +~ 41 $ (1,2,3,4,5) @@ -58,6 +65,7 @@ -- @ _1 :: Lens s t a b +-- | @'_1' k ~(a,b) = (\a' -> (a',b)) '<$>' k a@ instance Field1 (a,b) (a',b) a a' where _1 k ~(a,b) = (\a' -> (a',b)) <$> k a {-# INLINE _1 #-} @@ -97,6 +105,13 @@ -- >>> _2 .~ "hello" $ (1,(),3,4) -- (1,"hello",3,4) -- + -- >>> (1,2,3,4) & _2 *~ 3 + -- (1,6,3,4) + -- + -- >>> _2 print (1,2) + -- 2 + -- (1,()) + -- -- @ -- 'Control.Lens.Fold.anyOf' '_2' :: (s -> 'Bool') -> (a, s) -> 'Bool' -- 'Data.Traversable.traverse' '.' '_2' :: ('Applicative' f, 'Data.Traversable.Traversable' t) => (a -> f b) -> t (s, a) -> f (t (s, b)) @@ -104,6 +119,7 @@ -- @ _2 :: Lens s t a b +-- | @'_2' k ~(a,b) = (\b' -> (a,b')) '<$>' k b@ instance Field2 (a,b) (a,b') b b' where _2 k ~(a,b) = (\b' -> (a,b')) <$> k b {-# INLINE _2 #-} diff --git a/src/Control/Lens/Type.hs b/src/Control/Lens/Type.hs --- a/src/Control/Lens/Type.hs +++ b/src/Control/Lens/Type.hs @@ -97,7 +97,7 @@ import Control.Applicative as Applicative import Control.Lens.Internal -import Control.Monad.State.Class as State +import Control.Monad.State as State -- $setup -- >>> import Control.Lens diff --git a/src/Control/Lens/Unsafe.hs b/src/Control/Lens/Unsafe.hs deleted file mode 100644 --- a/src/Control/Lens/Unsafe.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE KindSignatures #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE Unsafe #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Control.Lens.Unsafe --- Copyright : (C) 2012 Edward Kmett --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett --- Stability : provisional --- Portability : Rank2Types --- ----------------------------------------------------------------------------- -module Control.Lens.Unsafe - ( Trustworthy - ) where - -import Control.Applicative -import Control.Applicative.Backwards -import Data.Functor.Identity -import Data.Functor.Compose - --- | This class is only exported by this untrustworthy module, but is a superclass of 'Gettable'. --- --- This is required because otherwise you could construct 'Unsafe.Coerce.unsafeCoerce' using 'Control.Lens.Internal.BazaarT.BazaarT' and --- an illegal 'Control.Lens.Classes.Gettable' instance that uses @'Control.Lens.Classes.coerce' = 'undefined'@. - -class Trustworthy (f :: * -> *) -instance Trustworthy (Const a) -instance Trustworthy Identity -instance Trustworthy f => Trustworthy (Backwards f) -instance Trustworthy g => Trustworthy (Compose f g) diff --git a/src/Control/Lens/WithIndex.hs b/src/Control/Lens/WithIndex.hs --- a/src/Control/Lens/WithIndex.hs +++ b/src/Control/Lens/WithIndex.hs @@ -403,7 +403,7 @@ -- -- >>> over (iwhere (>0)) Prelude.reverse $ ["He","was","stressed","o_O"] -- ["He","saw","desserts","O_o"] -iwhere :: (TraversableWithIndex i t) => (i -> Bool) -> SimpleIndexedTraversal i (t a) a +iwhere :: TraversableWithIndex i t => (i -> Bool) -> SimpleIndexedTraversal i (t a) a iwhere p = index $ \f a -> itraverse (\i c -> if p i then f i c else pure c) a {-# INLINE iwhere #-} diff --git a/src/Control/Lens/Zipper.hs b/src/Control/Lens/Zipper.hs --- a/src/Control/Lens/Zipper.hs +++ b/src/Control/Lens/Zipper.hs @@ -1,16 +1,3 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 -{-# LANGUAGE Trustworthy #-} -#endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Zipper @@ -30,7 +17,7 @@ -- -- [@'Top' ':>' a@] represents a trivial 'Zipper' with its focus at the root. -- --- [@'Top' ':>' 'Data.Tree.Tree' a ':>' a@] represents a zipper that starts with a +-- [@'Top' ':>' 'Data.Tree.Tree' a ':>' a@] represents a zipper that starts with a -- 'Data.Tree.Tree' and descends in a single step to values of type @a@. -- -- [@'Top' ':>' 'Data.Tree.Tree' a ':>' 'Data.Tree.Tree' a ':>' 'Data.Tree.Tree' a@] represents a 'Zipper' into a @@ -40,7 +27,7 @@ -- Since individual levels of a zipper are managed by an arbitrary 'Traversal', -- you can move left and right through the 'Traversal' selecting neighboring elements. -- --- >>> zipper ("hello","world") & down _1 & fromWithin traverse & focus .~ 'J' & rightmost & focus .~ 'y' & rezip +-- >>> zipper ("hello","world") & down _1 & fromWithin traverse & focus .~ 'J' & farthest right & focus .~ 'y' & rezip -- ("Jelly","world") -- -- This is particularly powerful when compiled with 'Control.Lens.Plated.plate', @@ -55,313 +42,38 @@ , zipper -- ** Focusing , focus - -- ** Horizontal movement + -- ** Horizontal Movement , up , down - , within, fromWithin - -- ** Lateral movement - , left, left1, lefts, lefts1, leftmost - , right, right1, rights, rights1, rightmost - , goto, goto1, coordinate, width - -- ** Closing the Zipper + , within + -- ** Lateral Movement + , left + , right + -- ** Movement Combinators + , tug + , tugs + , jerks + , farthest + -- ** Absolute Positioning + , tooth + , teeth + , jerkTo + , tugTo + -- ** Closing the zipper , rezip , Zipped , Zipper() - -- ** Saving your Progress + -- ** Recording , Tape() - , save - , restore - , restore1 - , unsafelyRestore + , saveTape + , restoreTape + , restoreNearTape + -- ** Unsafe Movement + , fromWithin + , unsafelyRestoreTape ) where -import Control.Applicative -import Control.Category -import Control.Comonad -import Control.Monad ((>=>)) -import Control.Lens.Indexed -import Control.Lens.IndexedLens -import Control.Lens.Internal -import Control.Lens.Traversal -import Control.Lens.Type -import Data.List.NonEmpty as NonEmpty -import Prelude hiding ((.),id) +import Control.Lens.Internal.Zipper -- $setup -- >>> :m + Control.Lens - --- | This is used to represent the 'Top' of the 'Zipper'. --- --- Every 'Zipper' starts with 'Top'. --- --- /e.g./ @'Top' ':>' a@ is the trivial zipper. -data Top - -infixl 9 :> - --- | This is the type of a 'Zipper'. It visually resembes a 'breadcrumb trail' as --- used in website navigation. Each breadcrumb in the trail represents a level you --- can move up to. --- --- This type operator associates to the left, so you can use a type like --- --- @'Top' ':>' ('String','Double') ':>' 'String' ':>' 'Char'@ --- --- to represent a zipper from @('String','Double')@ down to 'Char' that has an intermediate --- crumb for the 'String' containing the 'Char'. -data p :> a = Zipper (Coil p a) {-# UNPACK #-} !(Level a) - --- | This represents the type a zipper will have when it is fully 'Zipped' back up. -type family Zipped h a -type instance Zipped Top a = a -type instance Zipped (h :> b) a = Zipped h b - --- | 'Coil' is used internally in the definition of a 'Zipper'. -data Coil :: * -> * -> * where - Coil :: Coil Top a - Snoc :: Coil h b -> - {-# UNPACK #-} !Int -> - SimpleLensLike (Bazaar a a) b a -> - [b] -> (NonEmpty a -> b) -> [b] -> - Coil (h :> b) a - --- | This 'Lens' views the current target of the 'zipper'. -focus :: SimpleIndexedLens (Tape (h :> a)) (h :> a) a -focus = index $ \f (Zipper h (Level n l a r)) -> (\a' -> Zipper h (Level n l a' r)) <$> f (Tape (peel h) n) a -{-# INLINE focus #-} - --- | Construct a 'zipper' that can explore anything. -zipper :: a -> Top :> a -zipper a = Zipper Coil (Level 0 [] a []) -{-# INLINE zipper #-} - --- | Return the index into the current 'Traversal'. --- --- @'goto' ('coordinate' l) l = Just'@ -coordinate :: (a :> b) -> Int -coordinate (Zipper _ (Level n _ _ _)) = n -{-# INLINE coordinate #-} - --- | Move the 'zipper' 'up', closing the current level and focusing on the parent element. -up :: (a :> b :> c) -> a :> b -up (Zipper (Snoc h n _ ls k rs) w) = Zipper h (Level n ls (k (rezipLevel w)) rs) -{-# INLINE up #-} - --- | Pull the 'zipper' 'left' within the current 'Traversal'. -left :: (a :> b) -> Maybe (a :> b) -left (Zipper h w) = Zipper h <$> leftLevel w -{-# INLINE left #-} - --- | Try to pull the 'zipper' one entry to the 'left'. --- --- If the entry to the left doesn't exist, then stay still. -left1 :: (a :> b) -> a :> b -left1 (Zipper h w) = Zipper h $ left1Level w -{-# INLINE left1 #-} - --- | Pull the entry one entry to the 'right' -right :: (a :> b) -> Maybe (a :> b) -right (Zipper h w) = Zipper h <$> rightLevel w -{-# INLINE right #-} - --- | Try to pull the 'zipper' one entry to the 'right'. --- --- If the entry doesn't exist, then stay still. -right1 :: (a :> b) -> a :> b -right1 (Zipper h w) = Zipper h $ right1Level w -{-# INLINE right1 #-} - --- | Try to pull the 'zipper' @n@ entries to the 'right', returning 'Nothing' if you pull too far and run out of entries. --- --- Passing a negative @n@ will move @-n@ entries to the 'left'. -rights :: Int -> (h :> a) -> Maybe (h :> a) -rights n z - | n < 0 = lefts (-n) z - | otherwise = go n z - where go 0 c = Just c - go k c = case right c of - Nothing -> Nothing - Just c' -> go (k - 1) c' - --- | Try to pull the 'zipper' @n@ entries to the 'left', returning 'Nothing' if you pull too far and run out of entries. -lefts :: Int -> (h :> a) -> Maybe (h :> a) -lefts k z - | coordinate z < k = Nothing - | otherwise = Just (lefts1 k z) - --- | Try to pull the 'zipper' @n@ entries to the 'left'. Stopping at the first entry if you run out of entries. --- --- Passing a negative @n@ will move to @-n@ entries the right, and will return the last entry if you run out of entries. -lefts1 :: Int -> (h :> a) -> h :> a -lefts1 n z - | n < 0 = rights1 (-n) z - | otherwise = go n z - where go 0 c = c - go k c = case left c of - Nothing -> c - Just c' -> go (k - 1) c' - --- | Try to pull the 'zipper' @n@ entries to the 'right'. Stopping at the last entry if you run out of entries. --- --- Passing a negative number will move to the left and will return the first entry if you run out of entries. -rights1 :: Int -> (h :> a) -> h :> a -rights1 n z - | n < 0 = lefts1 (-n) z - | otherwise = go n z - where go 0 c = c - go k c = case right c of - Nothing -> c - Just c' -> go (k - 1) c' - --- | Returns the number of siblings at the current level in the 'zipper'. --- --- @'width' z '>=' 1@ --- --- /NB:/ If the current 'Traversal' targets an infinite number of elements then this may not terminate. -width :: (a :> b) -> Int -width (Zipper _ w) = levelWidth w -{-# INLINE width #-} - --- | Move the 'zipper' horizontally to the element in the @n@th position in the current level. (absolutely indexed, starting with the 'leftmost' as @0@) --- --- This returns 'Nothing' if the target element doesn't exist. --- --- @'goto' n = 'rights' n . 'leftmost'@ -goto :: Int -> (a :> b) -> Maybe (a :> b) -goto n = rights n . leftmost -{-# INLINE goto #-} - --- | Move the 'zipper' horizontally to the element in the @n@th position of the current level. (absolutely indexed, starting with the 'leftmost' as @0@) --- --- If the element at that position doesn't exist, then this will clamp to the range @0 <= n < 'width' z@ and return the element there. -goto1 :: Int -> (a :> b) -> a :> b -goto1 n = rights1 n . leftmost -{-# INLINE goto1 #-} - --- | Move to the left-most position of the current 'Traversal'. -leftmost :: (a :> b) -> a :> b -leftmost (Zipper h w) = Zipper h $ leftmostLevel w -{-# INLINE leftmost #-} - --- | Move to the right-most position of the current 'Traversal'. -rightmost :: (a :> b) -> a :> b -rightmost (Zipper h w) = Zipper h $ rightmostLevel w -{-# INLINE rightmost #-} - --- | Step down into a 'Lens'. This is a constrained form of 'fromWithin' for when you know --- there is precisely one target. --- --- @ --- 'down' :: 'Simple' 'Lens' b c -> (a :> b) -> a :> b :> c --- 'down' :: 'Simple' 'Iso' b c -> (a :> b) -> a :> b :> c --- @ -down :: SimpleLensLike (Context c c) b c -> (a :> b) -> a :> b :> c -down l (Zipper h (Level n ls b rs)) = case l (Context id) b of - Context k c -> Zipper (Snoc h n (cloneLens l) ls (k . extract) rs) (Level 0 [] c []) -{-# INLINE down #-} - --- | Step down into the 'leftmost' entry of a 'Traversal'. --- --- @ --- 'within' :: 'Simple' 'Traversal' b c -> (a :> b) -> Maybe (a :> b :> c) --- 'within' :: 'Simple' 'Lens' b c -> (a :> b) -> Maybe (a :> b :> c) --- 'within' :: 'Simple' 'Iso' b c -> (a :> b) -> Maybe (a :> b :> c) --- @ -within :: SimpleLensLike (Bazaar c c) b c -> (a :> b) -> Maybe (a :> b :> c) -within l (Zipper h (Level n ls b rs)) = case partsOf' l (Context id) b of - Context _ [] -> Nothing - Context k (c:cs) -> Just (Zipper (Snoc h n l ls (k . NonEmpty.toList) rs) (Level 0 [] c cs)) -{-# INLINE within #-} - --- | Unsafely step down into a 'Traversal' that is /assumed/ to be non-empty. --- --- If this invariant is not met then this will usually result in an error! --- --- @ --- 'fromWithin' :: 'Simple' 'Traversal' b c -> (a :> b) -> a :> b :> c --- 'fromWithin' :: 'Simple' 'Lens' b c -> (a :> b) -> a :> b :> c --- 'fromWithin' :: 'Simple' 'Iso' b c -> (a :> b) -> a :> b :> c --- @ --- --- You can reason about this function as if the definition was: --- --- @'fromWithin' l ≡ 'fromJust' '.' 'within' l@ --- --- but it is lazier in such a way that if this invariant is violated, some code --- can still succeed if it is lazy enough in the use of the focused value. -fromWithin :: SimpleLensLike (Bazaar c c) b c -> (a :> b) -> a :> b :> c -fromWithin l (Zipper h (Level n ls b rs)) = case partsOf' l (Context id) b of - Context k cs -> Zipper (Snoc h n l ls (k . NonEmpty.toList) rs) - (Level 0 [] (Prelude.head cs) (Prelude.tail cs)) -{-# INLINE fromWithin #-} - --- | This enables us to pull the 'zipper' back up to the 'Top'. -class Zipper h a where - recoil :: Coil h a -> NonEmpty a -> Zipped h a - -instance Zipper Top a where - recoil Coil = extract - -instance Zipper h b => Zipper (h :> b) c where - recoil (Snoc h _ _ ls k rs) as = recoil h (NonEmpty.fromList (Prelude.reverse ls ++ k as : rs)) - --- | Close something back up that you opened as a 'zipper'. -rezip :: Zipper h a => (h :> a) -> Zipped h a -rezip (Zipper h w) = recoil h (rezipLevel w) -{-# INLINE rezip #-} - --- | This is used to peel off the path information from a 'Coil' for use when saving the current path for later replay. -peel :: Coil h a -> Track h a -peel Coil = Track -peel (Snoc h n l _ _ _) = Fork (peel h) n l - -data Track :: * -> * -> * where - Track :: Track Top a - Fork :: Track h b -> {-# UNPACK #-} !Int -> SimpleLensLike (Bazaar a a) b a -> Track (h :> b) a - -restoreTrack :: Track h a -> Zipped h a -> Maybe (h :> a) -restoreTrack Track = Just . zipper -restoreTrack (Fork h n l) = restoreTrack h >=> rights n >=> within l - -restoreTrack1 :: Track h a -> Zipped h a -> Maybe (h :> a) -restoreTrack1 Track = Just . zipper -restoreTrack1 (Fork h n l) = restoreTrack1 h >=> rights1 n >>> within l - -unsafelyRestoreTrack :: Track h a -> Zipped h a -> h :> a -unsafelyRestoreTrack Track = zipper -unsafelyRestoreTrack (Fork h n l) = unsafelyRestoreTrack h >>> rights1 n >>> fromWithin l - --- | A 'Tape' is a recorded path through the 'Traversal' chain of a 'Zipper'. -data Tape k where - Tape :: Track h a -> {-# UNPACK #-} !Int -> Tape (h :> a) - --- | Save the current path as as a 'Tape' we can play back later. -save :: (a :> b) -> Tape (a :> b) -save (Zipper h (Level n _ _ _)) = Tape (peel h) n -{-# INLINE save #-} - --- | Restore ourselves to a previously recorded position precisely. --- --- If the position does not exist, then fail. -restore :: Tape (h :> a) -> Zipped h a -> Maybe (h :> a) -restore (Tape h n) = restoreTrack h >=> rights n -{-# INLINE restore #-} - --- | Restore ourselves to a previously recorded position. --- --- When moving left to right through a 'Traversal', if this will clamp at each level to the range @0 <= k < width@, --- so the only failures will occur when one of the sequence of downward traversals find no targets. -restore1 :: Tape (h :> a) -> Zipped h a -> Maybe (h :> a) -restore1 (Tape h n) a = rights1 n <$> restoreTrack1 h a -{-# INLINE restore1 #-} - --- | Restore ourselves to a previously recorded position. --- --- This assumes that nothing has been done in the meantime to affect the existence of anything on the entire path. --- --- Motions left or right are clamped, but all traversals included on the 'Tape' are assumed to be non-empty. --- --- Violate these assumptions at your own risk. -unsafelyRestore :: Tape (h :> a) -> Zipped h a -> h :> a -unsafelyRestore (Tape h n) = unsafelyRestoreTrack h >>> rights1 n -{-# INLINE unsafelyRestore #-} diff --git a/src/Data/Array/Lens.hs b/src/Data/Array/Lens.hs --- a/src/Data/Array/Lens.hs +++ b/src/Data/Array/Lens.hs @@ -18,7 +18,7 @@ -- * Setters , ixmapped -- * Traversal - , traverseArray + , _array ) where import Control.Applicative @@ -58,7 +58,7 @@ -- | An 'IndexedTraversal' of the elements of an 'IArray', using the -- index into the array as the index of the traversal. -- --- @'amap' ≡ 'over' 'traverseArray'@ -traverseArray :: (IArray arr a, IArray arr b, Ix i) => IndexedTraversal i (arr i a) (arr i b) a b -traverseArray = index $ \f arr -> array (bounds arr) <$> traverse (\(i,a) -> (,) i <$> f i a) (assocs arr) -{-# INLINE traverseArray #-} +-- @'amap' ≡ 'over' '_array'@ +_array :: (IArray arr a, IArray arr b, Ix i) => IndexedTraversal i (arr i a) (arr i b) a b +_array = index $ \f arr -> array (bounds arr) <$> traverse (\(i,a) -> (,) i <$> f i a) (assocs arr) +{-# INLINE _array #-} diff --git a/src/Data/Bits/Lens.hs b/src/Data/Bits/Lens.hs --- a/src/Data/Bits/Lens.hs +++ b/src/Data/Bits/Lens.hs @@ -12,125 +12,140 @@ -- ---------------------------------------------------------------------------- module Data.Bits.Lens - ( (|~), (&~), (<|~), (<&~) - , (|=), (&=), (<|=), (<&=) + ( (.|.~), (.&.~), (<.|.~), (<.&.~) + , (.|.=), (.&.=), (<.|.=), (<.&.=) , bitAt - , traverseBits + , bits ) where import Control.Lens -import Control.Monad.State.Class +import Control.Monad.State import Data.Bits import Data.Functor -infixr 4 |~, &~, <|~, <&~ -infix 4 |=, &=, <|=, <&= +-- $setup +-- >>> import Data.Word +infixr 4 .|.~, .&.~, <.|.~, <.&.~ +infix 4 .|.=, .&.=, <.|.=, <.&.= + -- | Bitwise '.|.' the target(s) of a 'Lens' or 'Setter' -- --- >>> _2 |~ 6 $ ("hello",3) +-- >>> _2 .|.~ 6 $ ("hello",3) -- ("hello",7) -- -- @ --- ('|~') :: 'Bits' a => 'Setter' s t a a -> a -> s -> t --- ('|~') :: 'Bits' a => 'Iso' s t a a -> a -> s -> t --- ('|~') :: 'Bits' a => 'Lens' s t a a -> a -> s -> t --- ('|~') :: ('Monoid a', 'Bits' a) => 'Traversal' s t a a -> a -> s -> t +-- ('.|.~') :: 'Bits' a => 'Setter' s t a a -> a -> s -> t +-- ('.|.~') :: 'Bits' a => 'Iso' s t a a -> a -> s -> t +-- ('.|.~') :: 'Bits' a => 'Lens' s t a a -> a -> s -> t +-- ('.|.~') :: ('Monoid a', 'Bits' a) => 'Traversal' s t a a -> a -> s -> t -- @ -(|~):: Bits a => Setting s t a a -> a -> s -> t -l |~ n = over l (.|. n) -{-# INLINE (|~) #-} +(.|.~):: Bits a => Setting s t a a -> a -> s -> t +l .|.~ n = over l (.|. n) +{-# INLINE (.|.~) #-} -- | Bitwise '.&.' the target(s) of a 'Lens' or 'Setter' -- --- >>> _2 &~ 7 $ ("hello",254) +-- >>> _2 .&.~ 7 $ ("hello",254) -- ("hello",6) -- -- @ --- ('&~') :: 'Bits' a => 'Setter' s t a a -> a -> s -> t --- ('&~') :: 'Bits' a => 'Iso' s t a a -> a -> s -> t --- ('&~') :: 'Bits' a => 'Lens' s t a a -> a -> s -> t --- ('&~') :: ('Monoid a', 'Bits' a) => 'Traversal' s t a a -> a -> s -> t +-- ('.&.~') :: 'Bits' a => 'Setter' s t a a -> a -> s -> t +-- ('.&.~') :: 'Bits' a => 'Iso' s t a a -> a -> s -> t +-- ('.&.~') :: 'Bits' a => 'Lens' s t a a -> a -> s -> t +-- ('.&.~') :: ('Monoid a', 'Bits' a) => 'Traversal' s t a a -> a -> s -> t -- @ -(&~) :: Bits a => Setting s t a a -> a -> s -> t -l &~ n = over l (.&. n) -{-# INLINE (&~) #-} +(.&.~) :: Bits a => Setting s t a a -> a -> s -> t +l .&.~ n = over l (.&. n) +{-# INLINE (.&.~) #-} -- | Modify the target(s) of a 'Simple' 'Lens', 'Setter' or 'Traversal' by computing its bitwise '.&.' with another value. -- +-- >>> execState (do _1 .&.= 15; _2 .&.= 3) (7,7) +-- (7,3) +-- -- @ --- ('&=') :: ('MonadState' s m, 'Bits' a) => 'Simple' 'Setter' s a -> a -> m () --- ('&=') :: ('MonadState' s m, 'Bits' a) => 'Simple' 'Iso' s a -> a -> m () --- ('&=') :: ('MonadState' s m, 'Bits' a) => 'Simple' 'Lens' s a -> a -> m () --- ('&=') :: ('MonadState' s m, 'Bits' a) => 'Simple' 'Traversal' s a -> a -> m () +-- ('.&.=') :: ('MonadState' s m, 'Bits' a) => 'Simple' 'Setter' s a -> a -> m () +-- ('.&.=') :: ('MonadState' s m, 'Bits' a) => 'Simple' 'Iso' s a -> a -> m () +-- ('.&.=') :: ('MonadState' s m, 'Bits' a) => 'Simple' 'Lens' s a -> a -> m () +-- ('.&.=') :: ('MonadState' s m, 'Bits' a) => 'Simple' 'Traversal' s a -> a -> m () -- @ -(&=):: (MonadState s m, Bits a) => Simple Setting s a -> a -> m () -l &= a = modify (l &~ a) -{-# INLINE (&=) #-} +(.&.=):: (MonadState s m, Bits a) => Simple Setting s a -> a -> m () +l .&.= a = modify (l .&.~ a) +{-# INLINE (.&.=) #-} -- | Modify the target(s) of a 'Simple' 'Lens', 'Setter' or 'Traversal' by computing its bitwise '.|.' with another value. -- +-- >>> execState (do _1 .|.= 15; _2 .|.= 3) (7,7) +-- (15,7) +-- -- @ --- ('|=') :: ('MonadState' s m, 'Bits' a) => 'Simple' 'Setter' s a -> a -> m () --- ('|=') :: ('MonadState' s m, 'Bits' a) => 'Simple' 'Iso' s a -> a -> m () --- ('|=') :: ('MonadState' s m, 'Bits' a) => 'Simple' 'Lens' s a -> a -> m () --- ('|=') :: ('MonadState' s m, 'Bits' a) => 'Simple' 'Traversal' s a -> a -> m () +-- ('.|.=') :: ('MonadState' s m, 'Bits' a) => 'Simple' 'Setter' s a -> a -> m () +-- ('.|.=') :: ('MonadState' s m, 'Bits' a) => 'Simple' 'Iso' s a -> a -> m () +-- ('.|.=') :: ('MonadState' s m, 'Bits' a) => 'Simple' 'Lens' s a -> a -> m () +-- ('.|.=') :: ('MonadState' s m, 'Bits' a) => 'Simple' 'Traversal' s a -> a -> m () -- @ -(|=) :: (MonadState s m, Bits a) => Simple Setting s a -> a -> m () -l |= a = modify (l |~ a) -{-# INLINE (|=) #-} +(.|.=) :: (MonadState s m, Bits a) => Simple Setting s a -> a -> m () +l .|.= a = modify (l .|.~ a) +{-# INLINE (.|.=) #-} -- | Bitwise '.|.' the target(s) of a 'Lens' (or 'Traversal'), returning the result -- (or a monoidal summary of all of the results). -- --- >>> _2 <|~ 6 $ ("hello",3) +-- >>> _2 <.|.~ 6 $ ("hello",3) -- (7,("hello",7)) -- -- @ --- ('<|~') :: 'Bits' a => 'Iso' s t a a -> a -> s -> (a, t) --- ('<|~') :: 'Bits' a => 'Lens' s t a a -> a -> s -> (a, t) --- ('<|~') :: ('Bits' a, 'Monoid a) => 'Traversal' s t a a -> a -> s -> (a, t) +-- ('<.|.~') :: 'Bits' a => 'Iso' s t a a -> a -> s -> (a, t) +-- ('<.|.~') :: 'Bits' a => 'Lens' s t a a -> a -> s -> (a, t) +-- ('<.|.~') :: ('Bits' a, 'Monoid a) => 'Traversal' s t a a -> a -> s -> (a, t) -- @ -(<|~):: Bits a => LensLike ((,) a) s t a a -> a -> s -> (a, t) -l <|~ n = l <%~ (.|. n) -{-# INLINE (<|~) #-} +(<.|.~):: Bits a => LensLike ((,) a) s t a a -> a -> s -> (a, t) +l <.|.~ n = l <%~ (.|. n) +{-# INLINE (<.|.~) #-} -- | Bitwise '.&.' the target(s) of a 'Lens' or 'Traversal', returning the result -- (or a monoidal summary of all of the results). -- --- >>> _2 <&~ 7 $ ("hello",254) +-- >>> _2 <.&.~ 7 $ ("hello",254) -- (6,("hello",6)) -- -- @ --- ('<&~') :: 'Bits' a => 'Iso' s t a a -> a -> s -> (a, t) --- ('<&~') :: 'Bits' a => 'Lens' s t a a -> a -> s -> (a, t) --- ('<&~') :: ('Bits' a, 'Monoid a) => 'Traversal' s t a a -> a -> s -> (a, t) +-- ('<.&.~') :: 'Bits' a => 'Iso' s t a a -> a -> s -> (a, t) +-- ('<.&.~') :: 'Bits' a => 'Lens' s t a a -> a -> s -> (a, t) +-- ('<.&.~') :: ('Bits' a, 'Monoid a) => 'Traversal' s t a a -> a -> s -> (a, t) -- @ -(<&~) :: Bits a => LensLike ((,) a) s t a a -> a -> s -> (a, t) -l <&~ n = l <%~ (.&. n) -{-# INLINE (<&~) #-} +(<.&.~) :: Bits a => LensLike ((,) a) s t a a -> a -> s -> (a, t) +l <.&.~ n = l <%~ (.&. n) +{-# INLINE (<.&.~) #-} -- | Modify the target(s) of a 'Simple' 'Lens' (or 'Traversal') by computing its bitwise '.&.' with another value, -- returning the result (or a monoidal summary of all of the results traversed) -- +-- >>> runState (_1 <.&.= 15) (31,0) +-- (15,(15,0)) +-- -- @ --- ('<&=') :: ('MonadState' s m, 'Bits' a) => 'Simple' 'Lens' s a -> a -> m a --- ('<&=') :: ('MonadState' s m, 'Bits' a, 'Monoid' a) => 'Simple' 'Traversal' s a -> a -> m a +-- ('<.&.=') :: ('MonadState' s m, 'Bits' a) => 'Simple' 'Lens' s a -> a -> m a +-- ('<.&.=') :: ('MonadState' s m, 'Bits' a, 'Monoid' a) => 'Simple' 'Traversal' s a -> a -> m a -- @ -(<&=):: (MonadState s m, Bits a) => SimpleLensLike ((,)a) s a -> a -> m a -l <&= b = l <%= (.&. b) -{-# INLINE (<&=) #-} +(<.&.=):: (MonadState s m, Bits a) => SimpleLensLike ((,)a) s a -> a -> m a +l <.&.= b = l <%= (.&. b) +{-# INLINE (<.&.=) #-} -- | Modify the target(s) of a 'Simple' 'Lens', (or 'Traversal') by computing its bitwise '.|.' with another value, -- returning the result (or a monoidal summary of all of the results traversed) -- +-- >>> runState (_1 <.|.= 7) (28,0) +-- (31,(31,0)) +-- -- @ --- ('<|=') :: ('MonadState' s m, 'Bits' a) => 'Simple' 'Lens' s a -> a -> m a --- ('<|=') :: ('MonadState' s m, 'Bits' a, 'Monoid' a) => 'Simple' 'Traversal' s a -> a -> m a +-- ('<.|.=') :: ('MonadState' s m, 'Bits' a) => 'Simple' 'Lens' s a -> a -> m a +-- ('<.|.=') :: ('MonadState' s m, 'Bits' a, 'Monoid' a) => 'Simple' 'Traversal' s a -> a -> m a -- @ -(<|=) :: (MonadState s m, Bits a) => SimpleLensLike ((,)a) s a -> a -> m a -l <|= b = l <%= (.|. b) -{-# INLINE (<|=) #-} +(<.|.=) :: (MonadState s m, Bits a) => SimpleLensLike ((,)a) s a -> a -> m a +l <.|.= b = l <%= (.|. b) +{-# INLINE (<.|.=) #-} -- | This lens can be used to access the value of the nth bit in a number. -- @@ -141,6 +156,12 @@ -- -- >>> 15^.bitAt 4 -- False +-- +-- >>> 15 & bitAt 4 .~ True +-- 31 +-- +-- >>> 16 & bitAt 4 .~ False +-- 0 bitAt :: Bits b => Int -> SimpleIndexedLens Int b Bool bitAt n = index $ \f b -> (\x -> if x then setBit b n else clearBit b n) <$> f n (testBit b n) {-# INLINE bitAt #-} @@ -149,18 +170,17 @@ -- -- The bit position is available as the index. -- --- >>> import Data.Word --- >>> toListOf traverseBits (5 :: Word8) +-- >>> toListOf bits (5 :: Word8) -- [True,False,True,False,False,False,False,False] -- --- If you supply this an 'Integer', the result will --- be an infinite 'Traversal' that can be productively consumed. -traverseBits :: (Num b, Bits b) => SimpleIndexedTraversal Int b Bool -traverseBits = index $ \f b -> let +-- If you supply this an 'Integer', the result will be an infinite 'Traversal', which +-- can be productively consumed, but not reassembled. +bits :: (Num b, Bits b) => SimpleIndexedTraversal Int b Bool +bits = index $ \f b -> let g n = (,) n <$> f n (testBit b n) - bits = Prelude.takeWhile hasBit [0..] + bs = Prelude.takeWhile hasBit [0..] hasBit n = complementBit b n /= b -- test to make sure that complementing this bit actually changes the value step (n,True) r = setBit r n step _ r = r - in Prelude.foldr step 0 <$> traverse g bits -{-# INLINE traverseBits #-} + in Prelude.foldr step 0 <$> traverse g bs +{-# INLINE bits #-} diff --git a/src/Data/ByteString/Lens.hs b/src/Data/ByteString/Lens.hs --- a/src/Data/ByteString/Lens.hs +++ b/src/Data/ByteString/Lens.hs @@ -41,7 +41,7 @@ -- | Traverse each 'Word8' in a strict or lazy 'ByteString' -- - -- @'bytes' = 'from' 'packedBytes' '.>' 'traverseList'@ + -- @'bytes' = 'from' 'packedBytes' '.>' 'itraversed'@ -- -- @'anyOf' 'bytes' ('==' 0x80) :: 'ByteString' -> 'Bool'@ bytes :: SimpleIndexedTraversal Int t Word8 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 @@ -11,10 +11,14 @@ -- Stability : experimental -- Portability : Rank2Types -- +-- Lenses and traversals for complex numbers +-- ---------------------------------------------------------------------------- module Data.Complex.Lens - ( real, imaginary, polarize - , traverseComplex + ( real + , imaginary + , polarize + , complex ) where import Control.Applicative @@ -26,6 +30,9 @@ -- >>> (1.0 :+ 0.0)^.real -- 1.0 -- +-- >>> 3 :+ 1 & real *~ 2 +-- 6 :+ 1 +-- -- @'real' :: 'Functor' f => (a -> f a) -> 'Complex' a -> f ('Complex' a)@ #if MIN_VERSION_base(4,4,0) real :: Simple Lens (Complex a) a @@ -55,16 +62,24 @@ -- as the 'phase' information is lost. So don't do that! -- -- Otherwise, this is a perfectly cromulent 'Lens'. -polarize :: (RealFloat a, RealFloat b) => Iso (Complex a) (Complex b) (a,a) (b,b) -polarize = isos polar (uncurry mkPolar) - polar (uncurry mkPolar) +polarize :: RealFloat a => Simple Iso (Complex a) (a,a) +polarize = iso polar (uncurry mkPolar) --- | Traverse both the real and imaginary parts of a 'Complex' number. +-- | Traverse both the 'real' and 'imaginary' parts of a 'Complex' number. -- --- > traverseComplex :: Applicative f => (a -> f b) -> Complex a -> f (Complex b) +-- >>> 0 & complex .~ 1 +-- 1 :+ 1 +-- +-- >>> 3 :+ 4 & complex *~ 2 +-- 6 :+ 8 +-- +-- >>> sumOf complex (1 :+ 2) +-- 3 +-- +-- @'complex' :: '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 +complex :: Traversal (Complex a) (Complex b) a b #else -traverseComplex :: (RealFloat a, RealFloat b) => Traversal (Complex a) (Complex b) a b +complex :: (RealFloat a, RealFloat b) => Traversal (Complex a) (Complex b) a b #endif -traverseComplex f (a :+ b) = (:+) <$> f a <*> f b +complex f (a :+ b) = (:+) <$> f a <*> f b diff --git a/src/Data/Data/Lens.hs b/src/Data/Data/Lens.hs --- a/src/Data/Data/Lens.hs +++ b/src/Data/Data/Lens.hs @@ -1,8 +1,12 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE LiberalTypeSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ExistentialQuantification #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 @@ -24,17 +28,31 @@ -- ---------------------------------------------------------------------------- module Data.Data.Lens - ( template + ( + -- * Generic Traversal + template , tinplate , uniplate , biplate - -- * Traversal of Data + -- * Field Accessor Traversal + , upon + , upon' + , uponTheDeep + , uponTheDeep' + -- * Data Traversal , gtraverse ) where import Control.Applicative import Control.Arrow ((&&&)) import Control.Exception as E +import Control.Lens.Getter +import Control.Lens.Indexed +import Control.Lens.IndexedLens +import Control.Lens.IndexedSetter +import Control.Lens.IndexedTraversal +import Control.Lens.Internal +import Control.Lens.Setter import Control.Lens.Traversal import Control.Lens.Type import Data.Data @@ -49,6 +67,9 @@ import GHC.Exts (realWorld#) import Unsafe.Coerce as Unsafe +-- $setup +-- >>> import Control.Lens + ------------------------------------------------------------------------------- -- Generic Traversal ------------------------------------------------------------------------------- @@ -105,6 +126,139 @@ biplate = biplateData (fromOracle answer) where answer = hitTest (undefined :: s) (undefined :: a) {-# INLINE biplate #-} + +------------------------------------------------------------------------------ +-- Automatic Traversal construction from field accessors +------------------------------------------------------------------------------ + +data FieldException a = FieldException !Int a deriving Typeable + +instance Show (FieldException a) where + showsPrec d (FieldException i _) = showParen (d > 10) $ + showString "' + +instance Typeable a => Exception (FieldException a) + +lookupon :: Typeable a => SimpleLensLike (Indexing Mutator) s a -> (s -> a) -> s -> Maybe (Int, Context a a s) +lookupon l field s = case unsafePerformIO $ E.try $ evaluate $ field $ s & indexed l %@~ \i (a::a) -> E.throw (FieldException i a) of + Right _ -> Nothing + Left e -> case fromException e of + Nothing -> Nothing + Just (FieldException i a) -> Just (i, Context (\a' -> set (elementOf l i) a' s) a) +{-# INLINE lookupon #-} + +-- | This automatically constructs a 'Simple' 'Traversal' from a field accessor. +-- +-- >>> (2,4) & upon fst *~ 5 +-- (10,4) +-- +-- There are however, a few caveats on how this function can be used: +-- +-- First, the user supplied function must access one of the \"immediate descendants\" of the structure as attempts +-- to access deeper structures or use non-field accessor functions will generate an empty 'Traversal'. +-- +-- A more rigorous way to say \"immediate descendants\" is that the function must only inspect one value that would +-- be visited by 'template'. +-- +-- Note: this even permits some functions to be used directly. +-- +-- >>> [1,2,3,4] & upon head .~ 0 +-- [0,2,3,4] +-- +-- >>> [1,2,3,4] & upon last .~ 5 +-- [1,2,3,5] +-- +-- >>> [1,2,3,4] ^? upon tail +-- Just [2,3,4] +-- +-- >>> "" ^? upon tail +-- Nothing +-- +-- Second, the structure must not contain strict or unboxed fields of the same type that will be visited by 'Data' +-- +-- If the supplied function is not a descendant that would be visible to 'template', the resulting 'Traversal' +-- will traverse no elements. +-- +-- If the field you name isn't visible to 'template', but is a "descendant" of a field visible to 'template', then +-- upon will return the *ancestor* it can visit, not the field you asked for! Be careful. +-- +-- >>> upon (tail.tail) .~ [10,20] $ [1,2,3,4] -- BAD +-- [1,10,20] +-- +-- To resolve this when you need deep self-similar recursion, use 'uponTheDeep'. However, 'upon' terminates for +-- more inputs, while 'uponTheDeep' can get lost in structures that are infinitely depth-recursive through @a@. +-- +-- >>> uponTheDeep (tail.tail) .~ [10,20] $ [1,2,3,4] -- GOOD +-- [1,2,10,20] +-- +-- The index of the 'Traversal' can be used as an offset into @'elementOf' ('indexed' 'template')@ or into the list +-- returned by @'holesOf' 'template'@. +upon :: forall s a. (Data s, Typeable a) => (s -> a) -> SimpleIndexedTraversal Int s a +upon field = index $ \f s -> case lookupon template field s of + Nothing -> pure s + Just (i, Context k a) -> k <$> f i a +{-# INLINE upon #-} + +-- | This more trusting version of 'upon' uses your function directly as the getter for a 'Lens'. +-- +-- This means that reading from 'upon'' is considerably faster than 'upon'. +-- +-- However, you pay for faster access in two ways: +-- +-- 1. When passed an illegal field accessor, 'upon'' will give you a 'Lens' that quietly violates +-- the laws unlike 'upon' will will give you a legal 'Traversal', that avoids modifying the target. +-- +-- 2. Modifying with the lens is slightly slower, since it has to go back and calculate the index after the fact. +-- +-- When given a legal field accessor, the index of the 'Lens' can be used as an offset into +-- @'elementOf' ('indexed' 'template')@ or into the list returned by @'holesOf' 'template'@. +upon' :: forall s a. (Data s, Typeable a) => (s -> a) -> SimpleIndexedLens Int s a +upon' field = index $ \f s -> let + ~(i, Context k _) = case lookupon template field s of + Nothing -> error "upon': no index, not a member" + Just ip -> ip + in k <$> f i (field s) +{-# INLINE upon' #-} + +-- | The design of 'upon' doesn't allow it to search inside of values of type 'a' for other values of type 'a'. +-- uponTheDeep provides this additional recursion. +-- +-- >>> uponTheDeep (tail.tail) .~ [10,20] $ [1,2,3,4] +-- [1,2,10,20] +-- +-- @'uponTheDeep' :: ('Data' s, 'Data' a) => (s -> a) -> 'SimpleIndexedTraversal' [Int] s a@ +uponTheDeep :: forall k f s a. (Indexed [Int] k, Applicative f, Data s, Data a) => (s -> a) -> k (a -> f a) (s -> f s) +uponTheDeep field = index $ \ f s -> case lookupon template field s of + Nothing -> pure s + Just (i, Context k0 a0) -> + let + go :: [Int] -> SimpleTraversal s a -> (a -> s) -> a -> f s + go is l k a = case lookupon (l.uniplate) field s of + Nothing -> k <$> f (reverse is) a + Just (j, Context k' a') -> go (j:is) (l.elementOf uniplate j) k' a' + in go [i] (elementOf template i) k0 a0 +{-# INLINE uponTheDeep #-} + +-- | The design of 'upon'' doesn't allow it to search inside of values of type 'a' for other values of type 'a'. +-- 'uponTheDeep'' provides this additional recursion. +-- +-- Like 'upon'', 'uponTheDeep'' trusts the user supplied function more than 'uponTheDeep' using it directly +-- as the accessor. This enables reading from the resulting 'Lens' to be considerably faster at the risk of +-- generating an illegal lens. +-- +-- >>> uponTheDeep' (tail.tail) .~ [10,20] $ [1,2,3,4] +-- [1,2,10,20] +uponTheDeep' :: forall s a. (Data s, Data a) => (s -> a) -> SimpleIndexedLens [Int] s a +uponTheDeep' field = index $ \ f s -> let + ~(isn, kn) = case lookupon template field s of + Nothing -> (error "uponTheDeep': no index, not a member", const s) + Just (i, Context k0 _) -> go [i] (elementOf template i) k0 + go :: [Int] -> SimpleTraversal s a -> (a -> s) -> ([Int], a -> s) + go is l k = case lookupon (l.uniplate) field s of + Nothing -> (reverse is, k) + Just (j, Context k' _) -> go (j:is) (l.elementOf uniplate j) k' + in kn <$> f isn (field s) +{-# INLINE uponTheDeep' #-} ------------------------------------------------------------------------------- -- Data Box diff --git a/src/Data/List/Lens.hs b/src/Data/List/Lens.hs --- a/src/Data/List/Lens.hs +++ b/src/Data/List/Lens.hs @@ -26,10 +26,26 @@ import Control.Applicative import Control.Lens + -- | A 'Traversal' reading and writing to the 'head' of a /non-empty/ list. -- --- >>> [1,2,3]^!?_head +-- >>> [1,2,3]^?!_head -- 1 +-- +-- >>> []^?_head +-- Nothing +-- +-- >>> [1,2]^?_head +-- Just 1 +-- +-- >>> [] & _head .~ 1 +-- [] +-- +-- >>> [0] & _head .~ 2 +-- [2] +-- +-- >>> [0,1] & _head .~ 2 +-- [2,1] _head :: SimpleIndexedTraversal Int [a] a _head = index $ \f aas -> case aas of (a:as) -> (:as) <$> f (0 :: Int) a @@ -38,8 +54,23 @@ -- | A 'Traversal' reading and writing to the 'tail' of a /non-empty/ list -- --- >>> _tail .~ [3,4,5] $ [1,2] +-- >>> [1,2] & _tail .~ [3,4,5] -- [1,3,4,5] +-- +-- >>> [] & _tail .~ [1,2] +-- [] +-- +-- >>> [1,2,3]^?_tail +-- Just [2,3] +-- +-- >>> [1,2]^?!_tail +-- [2] +-- +-- >>> "hello"^._tail +-- "ello" +-- +-- >>> ""^._tail +-- "" _tail :: Simple Traversal [a] [a] _tail f (a:as) = (a:) <$> f as _tail _ as = pure as @@ -47,8 +78,23 @@ -- | A 'Traversal' reading and writing to the last element of a /non-empty/ list -- --- >>> [1,2]^!?_last --- 2 +-- >>> [1,2,3]^?!_last +-- 3 +-- +-- >>> []^?_last +-- Nothing +-- +-- >>> [1,2]^?_last +-- Just 2 +-- +-- >>> [] & _last .~ 1 +-- [] +-- +-- >>> [0] & _last .~ 2 +-- [2] +-- +-- >>> [0,1] & _last .~ 2 +-- [0,2] _last :: SimpleIndexedTraversal Int [a] a _last = index $ \f aas -> case aas of [] -> pure aas @@ -59,8 +105,26 @@ -- | A 'Traversal' reading and replacing all but the a last element of a /non-empty/ list -- --- >>> [1,2,3,4]^!?_init +-- >>> [1,2,3,4]^?!_init -- [1,2,3] +-- +-- >>> [1,2] & _init .~ [3,4,5] +-- [3,4,5,2] +-- +-- >>> [] & _init .~ [1,2] +-- [] +-- +-- >>> [1,2,3]^?_init +-- Just [1,2] +-- +-- >>> [1,2]^?!_init +-- [1] +-- +-- >>> "hello"^._init +-- "hell" +-- +-- >>> ""^._init +-- "" _init :: Simple Traversal [a] [a] _init _ [] = pure [] _init f as = (++ [Prelude.last as]) <$> f (Prelude.init as) diff --git a/src/Data/Monoid/Lens.hs b/src/Data/Monoid/Lens.hs --- a/src/Data/Monoid/Lens.hs +++ b/src/Data/Monoid/Lens.hs @@ -9,14 +9,17 @@ -- ---------------------------------------------------------------------------- module Data.Monoid.Lens - ( (<>~), (<<>~) + ( + -- * Monoid Lens Operators + (<>~), (<<>~) , (<>=), (<<>=) + -- * Isomorphisms for Monoidal Wrappers , _dual, _endo, _all, _any, _sum, _product, _first, _last ) where import Data.Monoid import Control.Lens -import Control.Monad.State.Class as State +import Control.Monad.State as State -- $setup -- >>> :m + Control.Lens Data.Monoid.Lens Data.Foldable @@ -40,6 +43,9 @@ {-# INLINE (<>~) #-} -- | Modify the target(s) of a 'Simple' 'Lens', 'Iso', 'Setter' or 'Traversal' by 'mappend'ing a value. +-- +-- >>> execState (both <>= "!!!") ("hello","world") +-- ("hello!!!","world!!!") -- -- @ -- ('<>=') :: ('MonadState' s m, 'Monoid' a) => 'Simple' 'Setter' s a -> a -> m () 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 @@ -11,11 +11,11 @@ -- ---------------------------------------------------------------------------- module Data.Sequence.Lens - ( ordinal, viewL, viewR + ( ordinal + , viewL, viewR , _head, _tail , _last, _init - , traverseTo, traverseFrom - , traverseSlice + , sliced, slicedTo, slicedFrom ) where import Control.Applicative @@ -84,20 +84,20 @@ {-# INLINE _init #-} -- | Traverse the first @n@ elements of a 'Seq' -traverseTo :: Int -> SimpleIndexedTraversal Int (Seq a) a -traverseTo n = Lens.index $ \f m -> case Seq.splitAt n m of +slicedTo :: Int -> SimpleIndexedTraversal Int (Seq a) a +slicedTo n = Lens.index $ \f m -> case Seq.splitAt n m of (l,r) -> (>< r) <$> itraverse f l -{-# INLINE traverseTo #-} +{-# INLINE slicedTo #-} -- | Traverse all but the first @n@ elements of a 'Seq' -traverseFrom :: Int -> SimpleIndexedTraversal Int (Seq a) a -traverseFrom n = Lens.index $ \ f m -> case Seq.splitAt n m of +slicedFrom :: Int -> SimpleIndexedTraversal Int (Seq a) a +slicedFrom n = Lens.index $ \ f m -> case Seq.splitAt n m of (l,r) -> (l ><) <$> itraverse (f . (+n)) r -{-# INLINE traverseFrom #-} +{-# INLINE slicedFrom #-} -- | Travere all the elements numbered from @i@ to @j@ of a 'Seq' -traverseSlice :: Int -> Int -> SimpleIndexedTraversal Int (Seq a) a -traverseSlice i j = Lens.index $ \ f s -> case Seq.splitAt i s of +sliced :: Int -> Int -> SimpleIndexedTraversal Int (Seq a) a +sliced i j = Lens.index $ \ f s -> case Seq.splitAt i s of (l,mr) -> case Seq.splitAt (j-i) mr of (m, r) -> (\n -> l >< n >< r) <$> itraverse (f . (+i)) m -{-# INLINE traverseSlice #-} +{-# INLINE sliced #-} diff --git a/src/Data/Vector/Generic/Lens.hs b/src/Data/Vector/Generic/Lens.hs --- a/src/Data/Vector/Generic/Lens.hs +++ b/src/Data/Vector/Generic/Lens.hs @@ -34,8 +34,8 @@ , _init , sliced -- * Traversal of individual indices - , atIndex - , atIndices + , ordinal + , ordinals ) where import Control.Applicative @@ -138,18 +138,18 @@ -- | This is a more efficient version of 'element' that works for any 'Vector'. -- --- @atIndex n@ is only a valid 'Lens' into a 'Vector' with 'length' at least @n + 1@. -atIndex :: Vector v a => Int -> SimpleIndexedLens Int (v a) a -atIndex i = index $ \ f v -> (\ a -> v // [(i, a)]) <$> f i (v ! i) -{-# INLINE atIndex #-} +-- @ordinal n@ is only a valid 'Lens' into a 'Vector' with 'length' at least @n + 1@. +ordinal :: Vector v a => Int -> SimpleIndexedLens Int (v a) a +ordinal i = index $ \ f v -> (\ a -> v // [(i, a)]) <$> f i (v ! i) +{-# INLINE ordinal #-} -- | This 'Traversal' will ignore any duplicates in the supplied list of indices. -- --- >>> toListOf (atIndices [1,3,2,5,9,10]) $ Vector.fromList [2,4..40] +-- >>> toListOf (ordinals [1,3,2,5,9,10]) $ Vector.fromList [2,4..40] -- [4,8,6,12,20,22] -atIndices :: Vector v a => [Int] -> SimpleIndexedTraversal Int (v a) a -atIndices is = index $ \ f v -> let +ordinals :: Vector v a => [Int] -> SimpleIndexedTraversal Int (v a) a +ordinals is = index $ \ f v -> let l = length v is' = nub $ filter ( SimpleIndexedLens Int (Vector a) a -atIndex i = index $ \ f v -> (\ a -> v // [(i, a)]) <$> f i (v ! i) -{-# INLINE atIndex #-} +-- @ordinal n@ is only a valid 'Lens' into a 'Vector' with 'length' at least @n + 1@. +ordinal :: Int -> SimpleIndexedLens Int (Vector a) a +ordinal i = index $ \ f v -> (\ a -> v // [(i, a)]) <$> f i (v ! i) +{-# INLINE ordinal #-} -- | This 'Traversal' will ignore any duplicates in the supplied list of indices. -- --- >>> toListOf (atIndices [1,3,2,5,9,10]) $ Vector.fromList [2,4..40] +-- >>> toListOf (ordinals [1,3,2,5,9,10]) $ Vector.fromList [2,4..40] -- [4,8,6,12,20,22] -atIndices :: [Int] -> SimpleIndexedTraversal Int (Vector a) a -atIndices is = index $ \ f v -> let +ordinals :: [Int] -> SimpleIndexedTraversal Int (Vector a) a +ordinals is = index $ \ f v -> let l = length v is' = nub $ filter (~), (<~), (<.>~), (<<.>~) + ( + -- * Operators + (~), (<~), (<.>~), (<<.>~) , (=), (<=), (<.>=), (<<.>=) + -- * Lenses , basename, directory, extension, filename ) where import Control.Applicative ((<$>)) -import Control.Monad.State.Class as State +import Control.Monad.State as State import System.FilePath ( (), (<.>), splitExtension , takeBaseName, takeDirectory @@ -30,9 +33,8 @@ -- | Modify the path by adding another path. -- --- >>> :m + Control.Lens --- >>> both ~ "!!!" $ ("hello","world") --- ("hello/!!!","world/!!!") +-- >>> both ~ "bin" $ ("hello","world") +-- ("hello/bin","world/bin") -- -- @ -- ('~') :: 'Setter' s a 'FilePath' 'FilePath' -> 'FilePath' -> s -> a @@ -47,6 +49,9 @@ -- | Modify the target(s) of a 'Simple' 'Lens', 'Iso', 'Setter' or 'Traversal' by adding a path. -- +-- >>> execState (both = "bin") ("hello","world") +-- ("hello/bin","world/bin") +-- -- @ -- ('=') :: 'MonadState' s m => 'Simple' 'Setter' s 'FilePath' -> 'FilePath' -> m () -- ('=') :: 'MonadState' s m => 'Simple' 'Iso' s 'FilePath' -> 'FilePath' -> m () @@ -77,9 +82,8 @@ -- | Modify the path by adding extension. -- --- >>> :m + Control.Lens --- >>> both <.>~ "!!!" $ ("hello","world") --- ("hello.!!!","world.!!!") +-- >>> both <.>~ "txt" $ ("hello","world") +-- ("hello.txt","world.txt") -- -- @ -- ('<.>~') :: 'Setter' s a 'FilePath' 'FilePath' -> 'String' -> s -> a @@ -91,9 +95,11 @@ l <.>~ n = over l (<.> n) {-# INLINE (<.>~) #-} - -- | Modify the target(s) of a 'Simple' 'Lens', 'Iso', 'Setter' or 'Traversal' by adding an extension. -- +-- >>> execState (both <.>= "txt") ("hello","world") +-- ("hello.txt","world.txt") +-- -- @ -- ('<.>=') :: 'MonadState' s m => 'Simple' 'Setter' s 'FilePath' -> 'String' -> m () -- ('<.>=') :: 'MonadState' s m => 'Simple' 'Iso' s 'FilePath' -> 'String' -> m () @@ -104,9 +110,11 @@ l <.>= b = State.modify (l <.>~ b) {-# INLINE (<.>=) #-} - -- | Add an extension onto the end of the target of a 'Lens' and return the result -- +-- >>> _1 <<.>~ "txt" $ ("hello","world") +-- ("hello.txt",("hello.txt","world")) +-- -- When you do not need the result of the operation, ('<.>~') is more flexible. (<<.>~) :: LensLike ((,)FilePath) s a FilePath FilePath -> String -> s -> (FilePath, a) l <<.>~ m = l <%~ (<.> m) @@ -116,13 +124,16 @@ -- | Add an extension onto the end of the target of a 'Lens' into -- your monad's state and return the result. -- +-- >>> evalState (_1 <<.>= "txt") $("hello","world") +-- "hello.txt" +-- -- When you do not need the result of the operation, ('<.>=') is more flexible. (<<.>=) :: MonadState s m => SimpleLensLike ((,)FilePath) s FilePath -> String -> m FilePath l <<.>= r = l <%= (<.> r) {-# INLINE (<<.>=) #-} --- | A lens reading and writing to the basename. +-- | A 'Lens' for reading and writing to the basename -- -- >>> basename .~ "filename" $ "path/name.png" -- "path/filename.png" @@ -131,7 +142,7 @@ {-# INLINE basename #-} --- | A lens reading and writing to the directory. +-- | A 'Lens' for reading and writing to the directory -- -- >>> "long/path/name.txt" ^. directory -- "long/path" @@ -140,7 +151,7 @@ {-# INLINE directory #-} --- | A lens reading and writing to the extension. +-- | A 'Lens' for reading and writing to the extension -- -- >>> extension .~ ".png" $ "path/name.txt" -- "path/name.png" @@ -151,7 +162,7 @@ {-# INLINE extension #-} --- | A lens reading and writing to the full filename. +-- | A 'Lens' for reading and writing to the full filename -- -- >>> filename .~ "name.txt" $ "path/name.png" -- "path/name.txt" diff --git a/tests/hunit.hs b/tests/hunit.hs --- a/tests/hunit.hs +++ b/tests/hunit.hs @@ -224,13 +224,13 @@ runState test trig @?= (Just "Origin", trig) where test = use $ labels.at origin -case_read_map_entry = trig^.labels.traverseAt origin @?= "Origin" +case_read_map_entry = trig^.labels._at origin @?= "Origin" case_read_state_map_entry = runState test trig @?= ("Origin", trig) - where test = use $ labels.traverseAt origin + where test = use $ labels._at origin case_modify_map_entry = - (trig & labels.traverseAt origin %~ List.map toUpper) + (trig & labels._at origin %~ List.map toUpper) @?= trig { _labels = fromList [ (Point { _x = 0, _y = 0 }, "ORIGIN") , (Point { _x = 4, _y = 7 }, "Peak") ] } @@ -245,8 +245,8 @@ @?= trig { _labels = fromList [ (Point { _x = 4, _y = 7 }, "Peak") ] } case_read_list_entry = - (trig^.points.element 0) - @?= origin + (trig ^? points.element 0) + @?= Just origin case_write_list_entry = (trig & points.element 0 .~ Point { _x = 2, _y = 0 }) diff --git a/tests/properties.hs b/tests/properties.hs --- a/tests/properties.hs +++ b/tests/properties.hs @@ -76,10 +76,10 @@ prop_mapped = isSetter (mapped :: Simple Setter [Int] Int) prop_mapped_mapped = isSetter (mapped.mapped :: Simple Setter [Maybe Int] Int) -prop_both = isTraversal (both :: Simple Traversal (Int,Int) Int) +prop_both = isTraversal (both :: Simple Traversal (Int,Int) Int) prop_value (Fun _ k :: Fun Int Bool) = isTraversal (value k :: Simple Traversal (Int,Int) Int) -prop_traverseLeft = isTraversal (traverseLeft :: Simple Traversal (Either Int Bool) Int) -prop_traverseRight = isTraversal (traverseRight:: Simple Traversal (Either Int Bool) Bool) +prop_traverseLeft = isTraversal (_left :: Simple Traversal (Either Int Bool) Int) +prop_traverseRight = isTraversal (_right :: Simple Traversal (Either Int Bool) Bool) -- Data.Text.Lens prop_text s = s^.packed.from packed == s