Permalink
Browse files

more work on zippers

  • Loading branch information...
1 parent 608cde9 commit f71a70473720f955bd39fe339efbe52a311d0f49 @ekmett committed Dec 29, 2012
Showing with 76 additions and 60 deletions.
  1. +3 −3 src/Control/Lens/Lens.hs
  2. +24 −33 src/Control/Lens/Loupe.hs
  3. +5 −0 src/Control/Lens/Traversal.hs
  4. +44 −24 src/Control/Lens/Zipper/Internal.hs
View
@@ -154,7 +154,7 @@ infixr 2 <<~
-- vary fully independently. For more on how they interact, read the \"Why is
-- it a Lens Family?\" section of <http://comonad.com/reader/2012/mirrored-lenses/>.
-type Loupe s t a b = LensLike (Context a b) s t a b
+type Loupe s t a b = LensLike (Pretext (->) a b) s t a b
-- | @type 'Loupe'' = 'Simple' 'Loupe'@
type Loupe' s a = Loupe s s a a
@@ -316,8 +316,8 @@ chosen f (Right a) = Right <$> f a
--
-- @'alongside' :: 'Lens' s t a b -> 'Lens' s' t' a' b' -> 'Lens' (s,s') (t,t') (a,a') (b,b')@
alongside :: Loupe s t a b -> Loupe s' t' a' b' -> Lens (s,s') (t,t') (a,a') (b,b')
-alongside l r f (s, s') = case l (Context id) s of
- Context bt a -> case r (Context id) s' of
+alongside l r f (s, s') = case context (l sell s) of
+ Context bt a -> case context (r sell s') of
Context bt' a' -> f (a,a') <&> \(b,b') -> (bt b, bt' b')
{-# INLINE alongside #-}
View
@@ -32,7 +32,6 @@ module Control.Lens.Loupe
, SimpleLoupe
) where
-import Control.Applicative as Applicative
import Control.Lens.Internal
import Control.Lens.Lens
import Control.Monad.State.Class as State
@@ -48,98 +47,90 @@ infix 4 <#=, #=, #%=, <#%=, #%%=
-- Lenses
-------------------------------------------------------------------------------
-
-- | A 'Loupe'-specific version of ('Control.Lens.Getter.^.')
--
-- >>> ("hello","world")^#_2
-- "world"
-(^#) :: s -> Loupe s t a b -> a
-s ^# l = case l (Context id) s of
- Context _ a -> a
+(^#) :: s -> ALens s t a b -> a
+s ^# l = ipos (l sell s)
{-# INLINE (^#) #-}
-- | A 'Loupe'-specific version of 'Control.Lens.Setter.set'
--
-- >>> storing _2 "world" ("hello","there")
-- ("hello","world")
-storing :: Loupe s t a b -> b -> s -> t
-storing l b s = case l (Context id) s of
- Context g _ -> g b
+storing :: ALens s t a b -> b -> s -> t
+storing l b s = ipeek b (l sell s)
{-# INLINE storing #-}
-- | A 'Loupe'-specific version of ('Control.Lens.Setter..~')
--
-- >>> ("hello","there") & _2 #~ "world"
-- ("hello","world")
-( #~ ) :: Loupe s t a b -> b -> s -> t
-( #~ ) l b s = case l (Context id ) s of
- Context g _ -> g b
+( #~ ) :: ALens s t a b -> b -> s -> t
+( #~ ) l b s = ipeek b (l sell s)
{-# INLINE ( #~ ) #-}
-- | A 'Loupe'-specific version of ('Control.Lens.Setter.%~')
--
-- >>> ("hello","world") & _2 #%~ length
-- ("hello",5)
-( #%~ ) :: Loupe s t a b -> (a -> b) -> s -> t
-( #%~ ) l f s = case l (Context id) s of
- Context g a -> g (f a)
+( #%~ ) :: ALens s t a b -> (a -> b) -> s -> t
+( #%~ ) l f s = ipeeks f (l sell s)
{-# INLINE ( #%~ ) #-}
-- | A 'Loupe'-specific version of ('Control.Lens.Type.%%~')
--
-- >>> ("hello","world") & _2 #%%~ \x -> (length x, x ++ "!")
-- (5,("hello","world!"))
-( #%%~ ) :: Functor f => Loupe s t a b -> (a -> f b) -> s -> f t
-( #%%~ ) l f s = case l (Context id) s of
- Context g a -> g <$> f a
+( #%%~ ) :: Functor f => ALens s t a b -> (a -> f b) -> s -> f t
+( #%%~ ) l f s = runPretext (l sell s) f
{-# INLINE ( #%%~ ) #-}
-- | A 'Loupe'-specific version of ('Control.Lens.Setter..=')
-( #= ) :: MonadState s m => Loupe s s a b -> b -> m ()
+( #= ) :: MonadState s m => ALens s s a b -> b -> m ()
l #= f = modify (l #~ f)
{-# INLINE ( #= ) #-}
-- | A 'Loupe'-specific version of ('Control.Lens.Setter.%=')
-( #%= ) :: MonadState s m => Loupe s s a b -> (a -> b) -> m ()
+( #%= ) :: MonadState s m => ALens s s a b -> (a -> b) -> m ()
l #%= f = modify (l #%~ f)
{-# INLINE ( #%= ) #-}
-- | Modify the target of a 'Loupe' and return the result.
--
-- >>> ("hello","world") & _2 <#%~ length
-- (5,("hello",5))
-(<#%~) :: Loupe s t a b -> (a -> b) -> s -> (b, t)
-l <#%~ f = \s -> case l (Context id) s of
- Context g a -> let b = f a in (b, g b)
+(<#%~) :: ALens s t a b -> (a -> b) -> s -> (b, t)
+l <#%~ f = \s -> runPretext (l sell s) $ \a -> let b = f a in (b, b)
{-# INLINE (<#%~) #-}
-- | Modify the target of a 'Loupe' into your monad's state by a user supplied function and return the result.
-(<#%=) :: MonadState s m => Loupe s s a b -> (a -> b) -> m b
-l <#%= f = l #%%= \a -> let b = f a in (b,b)
+(<#%=) :: MonadState s m => ALens s s a b -> (a -> b) -> m b
+l <#%= f = l #%%= \a -> let b = f a in (b, b)
{-# INLINE (<#%=) #-}
-- | Modify the target of a 'Loupe' in the current monadic state, returning an auxiliary result.
-( #%%= ) :: MonadState s m => Loupe s s a b -> (a -> (r, b)) -> m r
+( #%%= ) :: MonadState s m => ALens s s a b -> (a -> (r, b)) -> m r
#if MIN_VERSION_mtl(2,1,1)
-l #%%= f = State.state $ \s -> case l (Context id) s of
- Context g a -> g <$> f a
+l #%%= f = State.state $ \s -> runPretext (l sell s) f
#else
l #%%= f = do
- Context g a <- State.gets (l (Context id))
- let (r, b) = f a
- State.put (g b)
+ p <- State.gets (l sell)
+ let (r, t) = runPretext p f
+ State.put t
return r
#endif
-- | Replace the target of a 'Loupe' and return the new value.
--
-- >>> ("hello","there") & _2 <#~ "world"
-- ("world",("hello","world"))
-(<#~) :: Loupe s t a b -> b -> s -> (b, t)
+(<#~) :: ALens s t a b -> b -> s -> (b, t)
l <#~ b = \s -> (b, storing l b s)
-- | Replace the target of a 'Loupe' in the current monadic state, returning the new value.
-(<#=) :: MonadState s m => Loupe s s a b -> b -> m b
+(<#=) :: MonadState s m => ALens s s a b -> b -> m b
l <#= b = do
l #= b
return b
@@ -150,4 +141,4 @@ l <#= b = do
-- | @type 'SimpleLoupe' = 'Simple' 'Loupe'@
type SimpleLoupe s a = Loupe s s a a
-{-# DEPRECATED SimpleLoupe "use Loupe'" #-}
+{-# DEPRECATED SimpleLoupe "use ALens'" #-}
@@ -61,6 +61,7 @@ module Control.Lens.Traversal
-- * Monomorphic Traversals
, cloneTraversal
+ , cloneIndexedTraversal
-- * Parts and Holes
, partsOf, partsOf'
@@ -641,6 +642,10 @@ cloneTraversal :: ATraversal s t a b -> Traversal s t a b
cloneTraversal l f s = runBazaar (l sell s) f
{-# INLINE cloneTraversal #-}
+cloneIndexedTraversal :: AnIndexedTraversal i s t a b -> IndexedTraversal i s t a b
+cloneIndexedTraversal l f s = runBazaar (l sell s) (Indexed (indexed f))
+{-# INLINE cloneIndexedTraversal #-}
+
------------------------------------------------------------------------------
-- Indexed Traversals
------------------------------------------------------------------------------
@@ -6,6 +6,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ExistentialQuantification #-}
@@ -37,8 +38,10 @@ import Control.Lens.Magma
import Control.Lens.Getter
import Control.Lens.Internal
import Control.Lens.Lens
+import Control.Lens.Loupe
import Control.Lens.Setter
import Control.Lens.Traversal
+import Control.Lens.Type
import Data.Functor.Identity
import Data.Maybe
import Data.Monoid
@@ -194,9 +197,12 @@ type instance Zipped (Zipper h i s) a = Zipped h s
#ifndef HLINT
data Coil t i a where
Coil :: Coil Top Int a
- Snoc :: !(Coil h i s) -> AnIndexedTraversal' i s a -> !(Path i s) -> i -> (Magma j a -> s) -> Coil (Zipper h i s) j a
+ Snoc :: !(Coil h j s) -> AnIndexedTraversal' i s a -> !(Path j s) -> j -> (Magma i a -> s) -> Coil (Zipper h j s) i a
#endif
+--downward :: forall j h s a. ALens' s a -> h :> s:@j -> h :> s:@j :> a:@Int
+--downward l (Zipper h p j s) = Zipper (Snoc h l' p j go) Start 0 (s^.l')
+
-- | This 'Lens' views the current target of the 'Zipper'.
focus :: IndexedLens' i (Zipper h i a) a
focus f (Zipper h p i a) = Zipper h p i <$> indexed f i a
@@ -425,24 +431,32 @@ tugTo n z = case compare k n of
where k = tooth z
{-# INLINE tugTo #-}
+lensed :: ALens' s a -> IndexedLens' Int s a
+lensed l f = cloneLens l (indexed f (0 :: Int))
+{-# INLINE lensed #-}
+
-- | Step down into a 'Lens'. This is a constrained form of 'fromWithin' for when you know
-- there is precisely one target that can never fail.
--
-- @
-- 'downward' :: 'Lens'' s a -> (h :> s) -> h :> s :> a
-- 'downward' :: 'Iso'' s a -> (h :> s) -> h :> s :> a
-- @
-downward :: ALens' s a -> h :> s:@j -> h :> s:@j :>> a
-downward = undefined
-
---downward l (Zipper h p s) = case context (l sell s) of
--- Context k a -> Zipper (Snoc h (cloneLens l) p $ \xs -> case xs of Leaf _ b -> k b; _ -> error "downward: rezipping") Start a
+downward :: forall j h s a. ALens' s a -> h :> s:@j -> h :> s:@j :>> a
+downward l (Zipper h p j s) = Zipper (Snoc h l' p j go) Start 0 (s^.l')
+ where l' :: IndexedLens' Int s a
+ l' = lensed l
+ go (Leaf _ b) = set l' b s
+ go _ = error "downward: rezipping"
{-# INLINE downward #-}
-idownward :: AnIndexedLens' i s a -> h :> s:@j -> h :> s:@j :> a:@i
-idownward = undefined
---idownward l (Zipper h p j s) = case l sell s of
--- Context k a -> Zipper (Snoc h (cloneLens l) p j $ \xs -> case xs of Leaf _ b -> k b; _ -> error "downward: rezipping") Start a
+idownward :: forall i j h s a. AnIndexedLens' i s a -> h :> s:@j -> h :> s:@j :> a:@i
+idownward l (Zipper h p j s) = Zipper (Snoc h l' p j go) Start i a
+ where l' :: IndexedLens' i s a
+ l' = cloneIndexedLens l
+ (i, a) = iview l' s
+ go (Leaf _ b) = set l' b s
+ go _ = error "idownward: rezipping"
{-# INLINE idownward #-}
-- | Step down into the 'leftmost' entry of a 'Traversal'.
@@ -453,14 +467,19 @@ idownward = undefined
-- 'within' :: 'Lens'' s a -> (h :> s) -> Maybe (h :> s :> a)
-- 'within' :: 'Iso'' s a -> (h :> s) -> Maybe (h :> s :> a)
-- @
-within :: MonadPlus m => ATraversal' s a -> (h :> s:@j) -> m (h :> s:@j :>> a)
-within = undefined
---within l (Zipper h p s) = case magma l (Context id) s of -- case partsOf' l (Context id) s of
--- Context k xs -> startl Start xs mzero $ \q a -> return $ Zipper (Snoc h l p k) q a
+
+-- within :: MonadPlus m => ATraversal' s a -> (h :> s:@j) -> m (h :> s:@j :>> a)
+within :: MonadPlus m => LensLike' (Indexing (Bazaar' (Indexed Int) a)) s a -> (h :> s:@j) -> m (h :> s:@j :>> a)
+within = iwithin . indexing
{-# INLINE within #-}
iwithin :: MonadPlus m => AnIndexedTraversal' i s a -> (h :> s:@j) -> m (h :> s:@j :> a:@i)
iwithin = undefined
+{-
+iwithin l (Zipper h p j s) = case context (magma l sell s) of
+ Context k xs -> startl Start xs mzero $ \q i a -> return $ Zipper (Snoc h l p j k) q i a
+-}
+{-# INLINE iwithin #-}
-- | Step down into every entry of a 'Traversal' simultaneously.
--
@@ -472,20 +491,21 @@ iwithin = undefined
-- 'withins' :: 'Lens'' s a -> (h :> s) -> [h :> s :> a]
-- 'withins' :: 'Iso'' s a -> (h :> s) -> [h :> s :> a]
-- @
-withins :: MonadPlus m => ATraversal' s a -> (h :> s:@j) -> m (h :> s:@j :>> a)
+withins :: MonadPlus m => LensLike' (Indexing (Bazaar' (Indexed Int) a)) s a -> (h :> s:@j) -> m (h :> s:@j :>> a)
withins = undefined
+{-
+withins = iwithins . indexing
+{-# INLINE withins #-}
iwithins :: MonadPlus m => AnIndexedTraversal' i s a -> (h :> s:@j) -> m (h :> s:@j :> a:@i)
-iwithins = undefined
-{-
-withins t (Zipper h p s) = case magma t (Context id) s of
- Context k xs -> let up = Snoc h t p k
- go q (Ap m nl nr l r) = go (ApL m nl nr q r) l `mplus` go (ApR m nl nr l q) r
- go q (Leaf (Identity a)) = return $ Zipper up q a
- go _ Pure = mzero
+iwithins t (Zipper h p j s) = case context (magma t sell s) of
+ Context k xs -> let up = Snoc h t p j k
+ go q (Ap m nl nr li l r) = go (ApL m nl nr li q r) l `mplus` go (ApR m nl nr li l q) r
+ go q (Leaf i a) = return $ Zipper up q i a
+ go _ Pure = mzero
in go Start xs
+{-# INLINE iwithins #-}
-}
-{-# INLINE withins #-}
-- | Unsafely step down into a 'Traversal' that is /assumed/ to be non-empty.
--
@@ -587,7 +607,7 @@ peel (Snoc h l _ i _) = Fork (peel h) i l
-- | The 'Track' forms the bulk of a 'Tape'.
data Track t i a where
Top :: Track Top Int a
- Fork :: Track h j s -> j -> AnIndexedTraversal' j s a -> Track (Zipper h j s) i a
+ Fork :: Track h j s -> j -> AnIndexedTraversal' i s a -> Track (Zipper h j s) i a
-- | Restore ourselves to a previously recorded position precisely.
--

0 comments on commit f71a704

Please sign in to comment.