Skip to content
This repository
Browse code

more work on zippers

  • Loading branch information...
commit f71a70473720f955bd39fe339efbe52a311d0f49 1 parent 608cde9
Edward Kmett authored December 29, 2012
6  src/Control/Lens/Lens.hs
@@ -154,7 +154,7 @@ infixr 2 <<~
154 154
 -- vary fully independently. For more on how they interact, read the \"Why is
155 155
 -- it a Lens Family?\" section of <http://comonad.com/reader/2012/mirrored-lenses/>.
156 156
 
157  
-type Loupe s t a b = LensLike (Context a b) s t a b
  157
+type Loupe s t a b = LensLike (Pretext (->) a b) s t a b
158 158
 
159 159
 -- | @type 'Loupe'' = 'Simple' 'Loupe'@
160 160
 type Loupe' s a = Loupe s s a a
@@ -316,8 +316,8 @@ chosen f (Right a) = Right <$> f a
316 316
 --
317 317
 -- @'alongside' :: 'Lens' s t a b -> 'Lens' s' t' a' b' -> 'Lens' (s,s') (t,t') (a,a') (b,b')@
318 318
 alongside :: Loupe s t a b -> Loupe s' t' a' b' -> Lens (s,s') (t,t') (a,a') (b,b')
319  
-alongside l r f (s, s') = case l (Context id) s of
320  
-  Context bt a -> case r (Context id) s' of
  319
+alongside l r f (s, s') = case context (l sell s) of
  320
+  Context bt a -> case context (r sell s') of
321 321
     Context bt' a' -> f (a,a') <&> \(b,b') -> (bt b, bt' b')
322 322
 {-# INLINE alongside #-}
323 323
 
57  src/Control/Lens/Loupe.hs
@@ -32,7 +32,6 @@ module Control.Lens.Loupe
32 32
   , SimpleLoupe
33 33
   ) where
34 34
 
35  
-import Control.Applicative       as Applicative
36 35
 import Control.Lens.Internal
37 36
 import Control.Lens.Lens
38 37
 import Control.Monad.State.Class as State
@@ -48,59 +47,53 @@ infix  4 <#=, #=, #%=, <#%=, #%%=
48 47
 -- Lenses
49 48
 -------------------------------------------------------------------------------
50 49
 
51  
-
52 50
 -- | A 'Loupe'-specific version of ('Control.Lens.Getter.^.')
53 51
 --
54 52
 -- >>> ("hello","world")^#_2
55 53
 -- "world"
56  
-(^#) :: s -> Loupe s t a b -> a
57  
-s ^# l = case l (Context id) s of
58  
-  Context _ a -> a
  54
+(^#) :: s -> ALens s t a b -> a
  55
+s ^# l = ipos (l sell s)
59 56
 {-# INLINE (^#) #-}
60 57
 
61 58
 -- | A 'Loupe'-specific version of 'Control.Lens.Setter.set'
62 59
 --
63 60
 -- >>> storing _2 "world" ("hello","there")
64 61
 -- ("hello","world")
65  
-storing :: Loupe s t a b -> b -> s -> t
66  
-storing l b s = case l (Context id) s of
67  
-  Context g _ -> g b
  62
+storing :: ALens s t a b -> b -> s -> t
  63
+storing l b s = ipeek b (l sell s)
68 64
 {-# INLINE storing #-}
69 65
 
70 66
 -- | A 'Loupe'-specific version of ('Control.Lens.Setter..~')
71 67
 --
72 68
 -- >>> ("hello","there") & _2 #~ "world"
73 69
 -- ("hello","world")
74  
-( #~ ) :: Loupe s t a b -> b -> s -> t
75  
-( #~ ) l b s = case l (Context id ) s of
76  
-  Context g _ -> g b
  70
+( #~ ) :: ALens s t a b -> b -> s -> t
  71
+( #~ ) l b s = ipeek b (l sell s)
77 72
 {-# INLINE ( #~ ) #-}
78 73
 
79 74
 -- | A 'Loupe'-specific version of ('Control.Lens.Setter.%~')
80 75
 --
81 76
 -- >>> ("hello","world") & _2 #%~ length
82 77
 -- ("hello",5)
83  
-( #%~ ) :: Loupe s t a b -> (a -> b) -> s -> t
84  
-( #%~ ) l f s = case l (Context id) s of
85  
-  Context g a -> g (f a)
  78
+( #%~ ) :: ALens s t a b -> (a -> b) -> s -> t
  79
+( #%~ ) l f s = ipeeks f (l sell s)
86 80
 {-# INLINE ( #%~ ) #-}
87 81
 
88 82
 -- | A 'Loupe'-specific version of ('Control.Lens.Type.%%~')
89 83
 --
90 84
 -- >>> ("hello","world") & _2 #%%~ \x -> (length x, x ++ "!")
91 85
 -- (5,("hello","world!"))
92  
-( #%%~ ) :: Functor f => Loupe s t a b -> (a -> f b) -> s -> f t
93  
-( #%%~ ) l f s = case l (Context id) s of
94  
-  Context g a -> g <$> f a
  86
+( #%%~ ) :: Functor f => ALens s t a b -> (a -> f b) -> s -> f t
  87
+( #%%~ ) l f s = runPretext (l sell s) f
95 88
 {-# INLINE ( #%%~ ) #-}
96 89
 
97 90
 -- | A 'Loupe'-specific version of ('Control.Lens.Setter..=')
98  
-( #= ) :: MonadState s m => Loupe s s a b -> b -> m ()
  91
+( #= ) :: MonadState s m => ALens s s a b -> b -> m ()
99 92
 l #= f = modify (l #~ f)
100 93
 {-# INLINE ( #= ) #-}
101 94
 
102 95
 -- | A 'Loupe'-specific version of ('Control.Lens.Setter.%=')
103  
-( #%= ) :: MonadState s m => Loupe s s a b -> (a -> b) -> m ()
  96
+( #%= ) :: MonadState s m => ALens s s a b -> (a -> b) -> m ()
104 97
 l #%= f = modify (l #%~ f)
105 98
 {-# INLINE ( #%= ) #-}
106 99
 
@@ -108,26 +101,24 @@ l #%= f = modify (l #%~ f)
108 101
 --
109 102
 -- >>> ("hello","world") & _2 <#%~ length
110 103
 -- (5,("hello",5))
111  
-(<#%~) :: Loupe s t a b -> (a -> b) -> s -> (b, t)
112  
-l <#%~ f = \s -> case l (Context id) s of
113  
-  Context g a -> let b = f a in (b, g b)
  104
+(<#%~) :: ALens s t a b -> (a -> b) -> s -> (b, t)
  105
+l <#%~ f = \s -> runPretext (l sell s) $ \a -> let b = f a in (b, b)
114 106
 {-# INLINE (<#%~) #-}
115 107
 
116 108
 -- | Modify the target of a 'Loupe' into your monad's state by a user supplied function and return the result.
117  
-(<#%=) :: MonadState s m => Loupe s s a b -> (a -> b) -> m b
118  
-l <#%= f = l #%%= \a -> let b = f a in (b,b)
  109
+(<#%=) :: MonadState s m => ALens s s a b -> (a -> b) -> m b
  110
+l <#%= f = l #%%= \a -> let b = f a in (b, b)
119 111
 {-# INLINE (<#%=) #-}
120 112
 
121 113
 -- | Modify the target of a 'Loupe' in the current monadic state, returning an auxiliary result.
122  
-( #%%= ) :: MonadState s m => Loupe s s a b -> (a -> (r, b)) -> m r
  114
+( #%%= ) :: MonadState s m => ALens s s a b -> (a -> (r, b)) -> m r
123 115
 #if MIN_VERSION_mtl(2,1,1)
124  
-l #%%= f = State.state $ \s -> case l (Context id) s of
125  
-  Context g a -> g <$> f a
  116
+l #%%= f = State.state $ \s -> runPretext (l sell s) f
126 117
 #else
127 118
 l #%%= f = do
128  
-  Context g a <- State.gets (l (Context id))
129  
-  let (r, b) = f a
130  
-  State.put (g b)
  119
+  p <- State.gets (l sell)
  120
+  let (r, t) = runPretext p f
  121
+  State.put t
131 122
   return r
132 123
 #endif
133 124
 
@@ -135,11 +126,11 @@ l #%%= f = do
135 126
 --
136 127
 -- >>> ("hello","there") & _2 <#~ "world"
137 128
 -- ("world",("hello","world"))
138  
-(<#~) :: Loupe s t a b -> b -> s -> (b, t)
  129
+(<#~) :: ALens s t a b -> b -> s -> (b, t)
139 130
 l <#~ b = \s -> (b, storing l b s)
140 131
 
141 132
 -- | Replace the target of a 'Loupe' in the current monadic state, returning the new value.
142  
-(<#=) :: MonadState s m => Loupe s s a b -> b -> m b
  133
+(<#=) :: MonadState s m => ALens s s a b -> b -> m b
143 134
 l <#= b = do
144 135
   l #= b
145 136
   return b
@@ -150,4 +141,4 @@ l <#= b = do
150 141
 
151 142
 -- | @type 'SimpleLoupe' = 'Simple' 'Loupe'@
152 143
 type SimpleLoupe s a = Loupe s s a a
153  
-{-# DEPRECATED SimpleLoupe "use Loupe'" #-}
  144
+{-# DEPRECATED SimpleLoupe "use ALens'" #-}
5  src/Control/Lens/Traversal.hs
@@ -61,6 +61,7 @@ module Control.Lens.Traversal
61 61
 
62 62
   -- * Monomorphic Traversals
63 63
   , cloneTraversal
  64
+  , cloneIndexedTraversal
64 65
 
65 66
   -- * Parts and Holes
66 67
   , partsOf, partsOf'
@@ -641,6 +642,10 @@ cloneTraversal :: ATraversal s t a b -> Traversal s t a b
641 642
 cloneTraversal l f s = runBazaar (l sell s) f
642 643
 {-# INLINE cloneTraversal #-}
643 644
 
  645
+cloneIndexedTraversal :: AnIndexedTraversal i s t a b -> IndexedTraversal i s t a b
  646
+cloneIndexedTraversal l f s = runBazaar (l sell s) (Indexed (indexed f))
  647
+{-# INLINE cloneIndexedTraversal #-}
  648
+
644 649
 ------------------------------------------------------------------------------
645 650
 -- Indexed Traversals
646 651
 ------------------------------------------------------------------------------
68  src/Control/Lens/Zipper/Internal.hs
@@ -6,6 +6,7 @@
6 6
 {-# LANGUAGE FlexibleContexts #-}
7 7
 {-# LANGUAGE FlexibleInstances #-}
8 8
 {-# LANGUAGE StandaloneDeriving #-}
  9
+{-# LANGUAGE ScopedTypeVariables #-}
9 10
 {-# LANGUAGE UndecidableInstances #-}
10 11
 {-# LANGUAGE MultiParamTypeClasses #-}
11 12
 {-# LANGUAGE ExistentialQuantification #-}
@@ -37,8 +38,10 @@ import Control.Lens.Magma
37 38
 import Control.Lens.Getter
38 39
 import Control.Lens.Internal
39 40
 import Control.Lens.Lens
  41
+import Control.Lens.Loupe
40 42
 import Control.Lens.Setter
41 43
 import Control.Lens.Traversal
  44
+import Control.Lens.Type
42 45
 import Data.Functor.Identity
43 46
 import Data.Maybe
44 47
 import Data.Monoid
@@ -194,9 +197,12 @@ type instance Zipped (Zipper h i s) a = Zipped h s
194 197
 #ifndef HLINT
195 198
 data Coil t i a where
196 199
   Coil :: Coil Top Int a
197  
-  Snoc :: !(Coil h i s) -> AnIndexedTraversal' i s a -> !(Path i s) -> i -> (Magma j a -> s) -> Coil (Zipper h i s) j a
  200
+  Snoc :: !(Coil h j s) -> AnIndexedTraversal' i s a -> !(Path j s) -> j -> (Magma i a -> s) -> Coil (Zipper h j s) i a
198 201
 #endif
199 202
 
  203
+--downward :: forall j h s a. ALens' s a -> h :> s:@j -> h :> s:@j :> a:@Int
  204
+--downward l (Zipper h p j s) = Zipper (Snoc h l' p j go) Start 0 (s^.l')
  205
+
200 206
 -- | This 'Lens' views the current target of the 'Zipper'.
201 207
 focus :: IndexedLens' i (Zipper h i a) a
202 208
 focus f (Zipper h p i a) = Zipper h p i <$> indexed f i a
@@ -425,6 +431,10 @@ tugTo n z = case compare k n of
425 431
   where k = tooth z
426 432
 {-# INLINE tugTo #-}
427 433
 
  434
+lensed :: ALens' s a -> IndexedLens' Int s a
  435
+lensed l f = cloneLens l (indexed f (0 :: Int))
  436
+{-# INLINE lensed #-}
  437
+
428 438
 -- | Step down into a 'Lens'. This is a constrained form of 'fromWithin' for when you know
429 439
 -- there is precisely one target that can never fail.
430 440
 --
@@ -432,17 +442,21 @@ tugTo n z = case compare k n of
432 442
 -- 'downward' :: 'Lens'' s a -> (h :> s) -> h :> s :> a
433 443
 -- 'downward' :: 'Iso'' s a  -> (h :> s) -> h :> s :> a
434 444
 -- @
435  
-downward :: ALens' s a -> h :> s:@j -> h :> s:@j :>> a
436  
-downward = undefined
437  
-
438  
---downward l (Zipper h p s) = case context (l sell s) of
439  
---  Context k a -> Zipper (Snoc h (cloneLens l) p $ \xs -> case xs of Leaf _ b -> k b; _ -> error "downward: rezipping") Start a
  445
+downward :: forall j h s a. ALens' s a -> h :> s:@j -> h :> s:@j :>> a
  446
+downward l (Zipper h p j s) = Zipper (Snoc h l' p j go) Start 0 (s^.l')
  447
+  where l' :: IndexedLens' Int s a
  448
+        l' = lensed l
  449
+        go (Leaf _ b) = set l' b s
  450
+        go _ = error "downward: rezipping"
440 451
 {-# INLINE downward #-}
441 452
 
442  
-idownward :: AnIndexedLens' i s a -> h :> s:@j -> h :> s:@j :> a:@i
443  
-idownward = undefined
444  
---idownward l (Zipper h p j s) = case l sell s of
445  
---  Context k a -> Zipper (Snoc h (cloneLens l) p j $ \xs -> case xs of Leaf _ b -> k b; _ -> error "downward: rezipping") Start a
  453
+idownward :: forall i j h s a. AnIndexedLens' i s a -> h :> s:@j -> h :> s:@j :> a:@i
  454
+idownward l (Zipper h p j s) = Zipper (Snoc h l' p j go) Start i a
  455
+  where l' :: IndexedLens' i s a
  456
+        l' = cloneIndexedLens l
  457
+        (i, a) = iview l' s
  458
+        go (Leaf _ b) = set l' b s
  459
+        go _ = error "idownward: rezipping"
446 460
 {-# INLINE idownward #-}
447 461
 
448 462
 -- | Step down into the 'leftmost' entry of a 'Traversal'.
@@ -453,14 +467,19 @@ idownward = undefined
453 467
 -- 'within' :: 'Lens'' s a      -> (h :> s) -> Maybe (h :> s :> a)
454 468
 -- 'within' :: 'Iso'' s a       -> (h :> s) -> Maybe (h :> s :> a)
455 469
 -- @
456  
-within :: MonadPlus m => ATraversal' s a -> (h :> s:@j) -> m (h :> s:@j :>> a)
457  
-within = undefined
458  
---within l (Zipper h p s) = case magma l (Context id) s of -- case partsOf' l (Context id) s of
459  
---  Context k xs -> startl Start xs mzero $ \q a -> return $ Zipper (Snoc h l p k) q a
  470
+
  471
+-- within :: MonadPlus m => ATraversal' s a -> (h :> s:@j) -> m (h :> s:@j :>> a)
  472
+within :: MonadPlus m => LensLike' (Indexing (Bazaar' (Indexed Int) a)) s a -> (h :> s:@j) -> m (h :> s:@j :>> a)
  473
+within = iwithin . indexing
460 474
 {-# INLINE within #-}
461 475
 
462 476
 iwithin :: MonadPlus m => AnIndexedTraversal' i s a -> (h :> s:@j) -> m (h :> s:@j :> a:@i)
463 477
 iwithin = undefined
  478
+{-
  479
+iwithin l (Zipper h p j s) = case context (magma l sell s) of
  480
+  Context k xs -> startl Start xs mzero $ \q i a -> return $ Zipper (Snoc h l p j k) q i a
  481
+-}
  482
+{-# INLINE iwithin #-}
464 483
 
465 484
 -- | Step down into every entry of a 'Traversal' simultaneously.
466 485
 --
@@ -472,20 +491,21 @@ iwithin = undefined
472 491
 -- 'withins' :: 'Lens'' s a      -> (h :> s) -> [h :> s :> a]
473 492
 -- 'withins' :: 'Iso'' s a       -> (h :> s) -> [h :> s :> a]
474 493
 -- @
475  
-withins :: MonadPlus m => ATraversal' s a -> (h :> s:@j) -> m (h :> s:@j :>> a)
  494
+withins :: MonadPlus m => LensLike' (Indexing (Bazaar' (Indexed Int) a)) s a -> (h :> s:@j) -> m (h :> s:@j :>> a)
476 495
 withins = undefined
  496
+{-
  497
+withins = iwithins . indexing
  498
+{-# INLINE withins #-}
477 499
 
478 500
 iwithins :: MonadPlus m => AnIndexedTraversal' i s a -> (h :> s:@j) -> m (h :> s:@j :> a:@i)
479  
-iwithins = undefined
480  
-{-
481  
-withins t (Zipper h p s) = case magma t (Context id) s of
482  
-  Context k xs -> let up = Snoc h t p k
483  
-                      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
484  
-                      go q (Leaf (Identity a))     = return $ Zipper up q a
485  
-                      go _ Pure         = mzero
  501
+iwithins t (Zipper h p j s) = case context (magma t sell s) of
  502
+  Context k xs -> let up = Snoc h t p j k
  503
+                      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
  504
+                      go q (Leaf i a)       = return $ Zipper up q i a
  505
+                      go _ Pure             = mzero
486 506
                   in  go Start xs
  507
+{-# INLINE iwithins #-}
487 508
 -}
488  
-{-# INLINE withins #-}
489 509
 
490 510
 -- | Unsafely step down into a 'Traversal' that is /assumed/ to be non-empty.
491 511
 --
@@ -587,7 +607,7 @@ peel (Snoc h l _ i _) = Fork (peel h) i l
587 607
 -- | The 'Track' forms the bulk of a 'Tape'.
588 608
 data Track t i a where
589 609
   Top :: Track Top Int a
590  
-  Fork :: Track h j s -> j -> AnIndexedTraversal' j s a -> Track (Zipper h j s) i a
  610
+  Fork :: Track h j s -> j -> AnIndexedTraversal' i s a -> Track (Zipper h j s) i a
591 611
 
592 612
 -- | Restore ourselves to a previously recorded position precisely.
593 613
 --

0 notes on commit f71a704

Please sign in to comment.
Something went wrong with that request. Please try again.