packages feed

lens 2.9 → 3.0

raw patch · 9 files changed

+534/−15 lines, 9 filesdep +semigroupsdep ~doctest

Dependencies added: semigroups

Dependency ranges changed: doctest

Files

CHANGELOG.markdown view
@@ -1,5 +1,11 @@+3.0+---+* Added `Control.Lens.Zipper`.+* Added `<<~`, a version of `<~` that supports chaining assignment.+* Added `:->`, `:=>`, and `:<->` as type operator aliases for `Simple Lens`, `Simple Traversal`, and `Simple Iso`  respectively.+ 2.9------+--- * Added `<<%~`, `<<.~`, `<<%=` and `<<.=` for accessing the old values targeted by a `Lens` (or a summary of those targeted by a `Traversal`) * Renamed `|>` to `%`, as `%~` is the lensed version of `%`, and moved it to `Control.Lens.Getter` along with a version `^%` with tighter   precedence that can be interleaved with `^.`
lens.cabal view
@@ -1,6 +1,6 @@ name:          lens category:      Data, Lenses-version:       2.9+version:       3.0 license:       BSD3 cabal-version: >= 1.8 license-file:  LICENSE@@ -37,7 +37,7 @@   .   The core of this hierarchy looks like:   .-  <<https://github.com/ekmett/lens/wiki/images/Hierarchy-2.9.png>>+  <<https://github.com/ekmett/lens/wiki/images/Hierarchy-3.0.png>>   .   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.@@ -55,7 +55,7 @@   If you want to provide lenses and traversals for your own types in your own libraries, then you   can do so without incurring a dependency on this (or any other) lens package at all.   .-  e.g. for a data type:+  /e.g./ for a data type:   .   > data Foo a = Foo Int Int a   .@@ -79,7 +79,7 @@   .   What is provided in this library is a number of stock lenses and traversals for   common haskell types, a wide array of combinators for working them, and more-  exotic functionality, (e.g. getters, setters, indexed folds, isomorphisms).+  exotic functionality, (/e.g./ getters, setters, indexed folds, isomorphisms).  build-type:    Simple tested-with:   GHC == 7.4.1, GHC == 7.6.0, GHC == 7.7.20120822, GHC == 7.7.20120830@@ -148,6 +148,7 @@     containers           >= 0.4.2    && < 0.6,     hashable             == 1.1.*,     mtl                  >= 2.1.1    && < 2.2,+    semigroups           >= 0.8.4    && < 0.9,     text                 >= 0.11     && < 0.12,     transformers         >= 0.3      && < 0.4,     unordered-containers >= 0.2      && < 0.3@@ -176,6 +177,7 @@     Control.Lens.Tuple     Control.Lens.Type     Control.Lens.WithIndex+    Control.Lens.Zipper     Control.Lens.Zoom     Data.Bits.Lens     Data.ByteString.Lens@@ -275,7 +277,7 @@   build-depends:     base,     directory >= 1.0 && < 1.3,-    doctest >= 0.9 && <= 0.10,+    doctest >= 0.9.1 && <= 0.10,     filepath   ghc-options: -Wall -threaded   if impl(ghc<7.6.1)
src/Control/Lens.hs view
@@ -41,7 +41,7 @@ -- -- <http://github.com/ekmett/lens/wiki> ----- <<http://github.com/ekmett/lens/wiki/images/Hierarchy-2.9.png>>+-- <<http://github.com/ekmett/lens/wiki/images/Hierarchy-3.0.png>> ---------------------------------------------------------------------------- module Control.Lens   ( module Control.Lens.Type@@ -66,6 +66,7 @@ #endif   , module Control.Lens.Tuple   , module Control.Lens.WithIndex+  , module Control.Lens.Zipper   , module Control.Lens.Zoom   ) where @@ -91,4 +92,5 @@ import Control.Lens.Tuple import Control.Lens.Type import Control.Lens.WithIndex+import Control.Lens.Zipper import Control.Lens.Zoom
src/Control/Lens/Internal.hs view
@@ -42,9 +42,16 @@   , Bazaar(..), bazaar, duplicateBazaar, sell   , Effect(..)   , EffectRWS(..)-  -- , EffectS(..)+  -- * Getter internals   , Gettable(..), Accessor(..), Effective(..), ineffective, noEffect, Folding(..)+  -- * Setter internals   , Settable(..), Mutator(..)+  -- * Zipper internals+  , Level(..), levelWidth+  , leftLevel, left1Level, leftmostLevel+  , rightLevel, right1Level, rightmostLevel+  , rezipLevel+  , focusLevel   ) where  import Control.Applicative@@ -55,9 +62,13 @@ import Control.Lens.Isomorphic 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  ----------------------------------------------------------------------------- -- Functors@@ -485,4 +496,96 @@ instance Applicative Mutator where   pure = Mutator   Mutator f <*> Mutator a = Mutator (f a)++-----------------------------------------------------------------------------+-- 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.+--+-- @'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 = foldMap f . rezipLevel++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)
src/Control/Lens/Iso.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeOperators #-} ----------------------------------------------------------------------------- -- | -- Module      :  Control.Lens.Iso@@ -13,6 +14,7 @@   (   -- * Isomorphism Lenses     Iso+  , (:<->)   , iso   , isos   , ala@@ -46,6 +48,8 @@ -- $setup -- >>> import Control.Lens +infixr 0 :<->+ ----------------------------------------------------------------------------- -- Isomorphisms families as Lenses -----------------------------------------------------------------------------@@ -66,6 +70,9 @@ -- | -- @type 'SimpleIso' = 'Control.Lens.Type.Simple' 'Iso'@ type SimpleIso a b = Iso a a b b++-- | An commonly used infix alias for @'Control.Lens.Type.Simple' 'Iso'@+type a :<-> b = Iso a a b b  -- | Build an isomorphism family from two pairs of inverse functions --
src/Control/Lens/Traversal.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE LiberalTypeSynonyms #-}+{-# LANGUAGE TypeOperators #-} ----------------------------------------------------------------------------- -- | -- Module      :  Control.Lens.Traversal@@ -29,6 +30,7 @@   (   -- * Lenses     Traversal+  , (:=>)    -- ** Lensing Traversals   , element@@ -69,6 +71,8 @@ -- $setup -- >>> import Control.Lens +infixr 0 :=>+ ------------------------------------------------------------------------------ -- Traversals ------------------------------------------------------------------------------@@ -103,6 +107,9 @@ -- | @type SimpleTraversal = 'Simple' 'Traversal'@ type SimpleTraversal a b = Traversal a a b b +-- | This is a commonly-used infix alias for a @'Simple' 'Traversal'@.+type a :=> b = forall f. Applicative f => (b -> f b) -> a -> f a+ -------------------------- -- Traversal Combinators --------------------------@@ -319,7 +326,7 @@ -- 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 :: Traversable t => Int -> t a :-> a element = elementOf traverse  ------------------------------------------------------------------------------@@ -408,6 +415,8 @@ -- >>> let foo l a = (view (cloneTraversal l) a, set (cloneTraversal l) 10 a) -- >>> foo both ("hello","world") -- ("helloworld",(10,10))+--+-- @'cloneTraversal' :: 'LensLike' ('Bazaar' c d) a b c d -> 'Traversal' a b c d@ cloneTraversal :: Applicative f => ((c -> Bazaar c d d) -> a -> Bazaar c d b) -> (c -> f d) -> a -> f b cloneTraversal l f = bazaar f . l sell {-# INLINE cloneTraversal #-}
src/Control/Lens/Type.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeOperators #-}  #ifndef MIN_VERSION_mtl #define MIN_VERSION_mtl(x,y,z) 1@@ -56,6 +57,8 @@   -- * Lenses     Lens   , Simple+  , (:->)+   , lens   , (%%~)   , (%%=)@@ -78,6 +81,7 @@   , (<^=), (<^^=), (<**=)   , (<||=), (<&&=)   , (<<%=), (<<.=)+  , (<<~)    -- * Cloning Lenses   , cloneLens@@ -99,11 +103,15 @@ -- $setup -- >>> import Control.Lens +-- types+infixr 0 :->++-- terms infixr 4 %%~ infix  4 %%= infixr 4 <+~, <*~, <-~, <//~, <^~, <^^~, <**~, <&&~, <||~, <%~, <<%~, <<.~ infix  4 <+=, <*=, <-=, <//=, <^=, <^^=, <**=, <&&=, <||=, <%=, <<%=, <<.=-+infixr 2 <<~  ------------------------------------------------------------------------------- -- Lenses@@ -162,6 +170,9 @@ -- 'Control.Lens.Setter.Setter', you may have to turn on @LiberalTypeSynonyms@. type Simple f a b = f a a b b +-- | This is a commonly used infix alias for a @'Simple' 'Lens'@.+type a :-> b = forall f. Functor f => (b -> f b) -> a -> f a+ -- | @type 'SimpleLens' = 'Simple' 'Lens'@ type SimpleLens a b = Lens a a b b @@ -264,7 +275,7 @@  -- | This lens can be used to change the result of a function but only where -- the arguments match the key given.-resultAt :: Eq e => e -> Simple Lens (e -> a) a+resultAt :: Eq e => e -> (e -> a) :-> a resultAt e afa ea = go <$> afa a where   a = ea e   go a' e' | e == e'   = a'@@ -675,6 +686,22 @@ (<<.=) :: MonadState a m => LensLike ((,)c) a a c d -> d -> m c l <<.= d = l %%= \c -> (c,d) {-# INLINE (<<.=) #-}++-- | Run a monadic action, and set the target of 'Lens' to its result.+--+-- @+-- ('<<~') :: 'MonadState' a m => 'Control.Lens.Iso.Iso' a a c d   -> m d -> m d+-- ('<<~') :: 'MonadState' a m => 'Control.Lens.Type.Lens' a a c d  -> m d -> m d+-- @+--+-- NB: This is limited to taking an actual 'Lens' than admitting a 'Control.Lens.Traversal.Traversal' because+-- there are potential loss of state issues otherwise.+(<<~) :: MonadState a m => LensLike (Context c d) a a c d -> m d -> m d+l <<~ md = do+  d <- md+  modify $ \a -> case l (Context id) a of Context f _ -> f d+  return d+{-# INLINE (<<~) #-}  -- | Useful for storing lenses in containers. newtype ReifiedLens a b c d = ReifyLens { reflectLens :: Lens a b c d }
+ src/Control/Lens/Zipper.hs view
@@ -0,0 +1,363 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Lens.Zipper+-- Copyright   :  (C) 2012 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- This module provides a 'Zipper' with fairly strong type checking guarantees.+--+-- The code here is inspired by Brandon Simmons' @zippo@ package, but uses+-- a slightly different approach to represent the 'Zipper' that makes the whole thing+-- look like his breadcrumb trail, and can move side-to-side through traversals.+--+-- Some examples types:+--+-- [@'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 +--   '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+--   'Data.Tree.Tree' with an intermediate bookmarked 'Data.Tree.Tree',+--   focusing in yet another 'Data.Tree.Tree'.+--+-- 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+-- ("Jelly","world")+--+-- This is particularly powerful when compiled with 'Control.Lens.Plated.plate',+-- 'Data.Data.Lens.uniplate' or 'Data.Data.Lens.biplate' for walking down into+-- self-similar children in syntax trees and other structures.+-----------------------------------------------------------------------------+module Control.Lens.Zipper+  (+  -- * Zippers+    Top()+  , (:>)()+  , zipper+  -- ** Focusing+  , focus+  -- ** 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+  , rezip+  , Zipped+  , Zipper()+  -- ** Saving your Progress+  , Tape()+  , save+  , restore+  , restore1+  , unsafelyRestore+  ) 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.Plated+import Control.Lens.Type+import Data.List.NonEmpty as NonEmpty+import Prelude hiding ((.),id)++-- $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 right, 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 ≡ 'fromMaybe' '.' '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 #-}
tests/templates.hs view
@@ -5,10 +5,6 @@ import Control.Lens -- import Test.QuickCheck (quickCheck) --- newtype Foo a = Foo a--- makeIso ''Foo--- foo :: Iso a b (Foo a) (Foo b)- data Bar a b c = Bar { _baz :: (a, b) } makeLenses ''Bar -- baz :: Lens (Bar a b c) (Bar a' b' c) (a,b) (a',b')@@ -76,6 +72,10 @@  instance HasMono Nucleosis where   mono = nuclear++-- Dodek's example+data Foo = Foo { _fooX, _fooY :: Int }+makeClassy ''Foo  main :: IO () main = putStrLn "test/templates.hs: ok"