0 | module Control.Lens.Traversal
  1 |
  2 | import Control.Monad.State
  3 | import Data.List
  4 | import Data.Profunctor
  5 | import Data.Profunctor.Traversing
  6 | import Control.Applicative.Backwards
  7 | import Control.Applicative.Indexing
  8 | import Control.Lens.Optic
  9 | import Control.Lens.Indexed
 10 | import Control.Lens.Optional
 11 | import Control.Lens.Lens
 12 | import Control.Lens.Prism
 13 |
 14 | %default total
 15 |
 16 |
 17 | ------------------------------------------------------------------------------
 18 | -- Type definitions
 19 | ------------------------------------------------------------------------------
 20 |
 21 |
 22 | public export
 23 | record IsTraversal p where
 24 |   constructor MkIsTraversal
 25 |   runIsTraversal : Traversing p
 26 |
 27 | export %hint
 28 | traversalToOptional : IsTraversal p => IsOptional p
 29 | traversalToOptional @{MkIsTraversal _} = MkIsOptional %search
 30 |
 31 | export %hint
 32 | indexedTraversal : IsTraversal p => IsTraversal (Indexed i p)
 33 | indexedTraversal @{MkIsTraversal _} = MkIsTraversal %search
 34 |
 35 |
 36 | ||| A traversal is a lens that may have more than one focus.
 37 | public export
 38 | 0 Traversal : (s,t,a,b : Type) -> Type
 39 | Traversal = Optic IsTraversal
 40 |
 41 | ||| `Traversal'` is the `Simple` version of `Traversal`.
 42 | public export
 43 | 0 Traversal' : (s,a : Type) -> Type
 44 | Traversal' = Simple Traversal
 45 |
 46 | ||| An indexed traversal allows access to the indices of the values as they are
 47 | ||| being modified.
 48 | public export
 49 | 0 IndexedTraversal : (i,s,t,a,b : Type) -> Type
 50 | IndexedTraversal = IndexedOptic IsTraversal
 51 |
 52 | ||| `IndexedTraversal'` is the `Simple` version of `IndexedTraversal`.
 53 | public export
 54 | 0 IndexedTraversal' : (i,s,a : Type) -> Type
 55 | IndexedTraversal' = Simple . IndexedTraversal
 56 |
 57 |
 58 | ------------------------------------------------------------------------------
 59 | -- Utilities for traversals
 60 | ------------------------------------------------------------------------------
 61 |
 62 | ||| Construct a traversal from a `traverse`-like function.
 63 | public export
 64 | traversal : (forall f. Applicative f => (a -> f b) -> s -> f t) -> Traversal s t a b
 65 | traversal f @{MkIsTraversal _} = wander f
 66 |
 67 | ||| Construct an indexed traversal from a `traverse`-like function.
 68 | public export
 69 | itraversal : (forall f. Applicative f => (i -> a -> f b) -> s -> f t) -> IndexedTraversal i s t a b
 70 | itraversal f @{MkIsTraversal _} @{ind} = wander (f . curry) . indexed @{ind}
 71 |
 72 |
 73 | ||| Convert a traversal into an indexed traversal, adding an index for the
 74 | ||| ordinal position of the focus.
 75 | public export
 76 | iordinal : Num i => Traversal s t a b -> IndexedTraversal i s t a b
 77 | iordinal l = itraversal func
 78 |   where
 79 |     func : Applicative f => (i -> a -> f b) -> s -> f t
 80 |     func = indexing $ applyStar . l . MkStar {f = Indexing i f}
 81 |
 82 |
 83 | ||| Derive a traversal from a `Traversable` implementation.
 84 | public export
 85 | traversed : Traversable t => Traversal (t a) (t b) a b
 86 | traversed @{_} @{MkIsTraversal _} = traverse'
 87 |
 88 | ||| Derive an indexed traversal from a `Traversable` implementation.
 89 | public export
 90 | itraversed : Num i => Traversable t => IndexedTraversal i (t a) (t b) a b
 91 | itraversed = iordinal traversed
 92 |
 93 | ||| Contstruct a traversal over a `Bitraversable` container with matching types.
 94 | public export
 95 | both : Bitraversable t => Traversal (t a a) (t b b) a b
 96 | both = traversal (\f => bitraverse f f)
 97 |
 98 |
 99 | ||| Reverse the order of a traversal's focuses.
100 | public export
101 | backwards : Traversal s t a b -> Traversal s t a b
102 | backwards l = traversal func
103 |   where
104 |     func : Applicative f => (a -> f b) -> s -> f t
105 |     func fn = forwards . applyStar {f = Backwards f} (l $ MkStar (MkBackwards . fn))
106 |
107 |
108 | ||| Map each focus of a traversal to a computation, evaluate those computations
109 | ||| and combine the results.
110 | public export
111 | traverseOf : Applicative f => Traversal s t a b -> (a -> f b) -> s -> f t
112 | traverseOf l = applyStar . l . MkStar {f}
113 |
114 | ||| Map each focus of a traversal to a computation with acces to the index,
115 | ||| evaluate those computations and combine the results.
116 | public export
117 | itraverseOf : Applicative f => IndexedTraversal i s t a b -> (i -> a -> f b) -> s -> f t
118 | itraverseOf l = traverseOf (l @{%search} @{Idxed}) . uncurry
119 |
120 | ||| A version of `traverseOf` but with the arguments flipped.
121 | public export
122 | forOf : Applicative f => Traversal s t a b -> s -> (a -> f b) -> f t
123 | forOf = flip . traverseOf
124 |
125 | ||| A version of `itraverseOf` but with the arguments flipped.
126 | public export
127 | iforOf : Applicative f => IndexedTraversal i s t a b -> s -> (i -> a -> f b) -> f t
128 | iforOf = flip . itraverseOf
129 |
130 | ||| Evaluate each computation within the traversal and collect the results.
131 | public export
132 | sequenceOf : Applicative f => Traversal s t (f a) a -> s -> f t
133 | sequenceOf l = traverseOf l id
134 |
135 | ||| Fold across the focuses of a traversal from the leftmost focus, providing a
136 | ||| replacement value for each, and return the final accumulator along with the
137 | ||| new structure.
138 | public export
139 | mapAccumLOf : Traversal s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t)
140 | mapAccumLOf l f z =
141 |   let g = state . flip f
142 |   in runState z . traverseOf l g
143 |
144 | ||| Fold across the focuses of a traversal from the rightmost focus, providing a
145 | ||| replacement value for each, and return the final accumulator along with the
146 | ||| new structure.
147 | public export
148 | mapAccumROf : Traversal s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t)
149 | mapAccumROf l f z =
150 |   let g = MkBackwards {f=State acc} . state . flip f
151 |   in runState z . forwards . traverseOf l g
152 |
153 | ||| Fold across the focuses of a traversal from the left, returning each
154 | ||| intermediate value of the fold.
155 | public export
156 | scanl1Of : Traversal s t a a -> (a -> a -> a) -> s -> t
157 | scanl1Of l f =
158 |   let step : Maybe a -> a -> (Maybe a, a)
159 |       step Nothing  x = (Just x, x)
160 |       step (Just s) x = let r = f s x in (Just r, r)
161 |   in snd . mapAccumLOf l step Nothing
162 |
163 | ||| Fold across the focuses of a traversal from the right, returning each
164 | ||| intermediate value of the fold.
165 | public export
166 | scanr1Of : Traversal s t a a -> (a -> a -> a) -> s -> t
167 | scanr1Of l f =
168 |   let step : Maybe a -> a -> (Maybe a, a)
169 |       step Nothing  x = (Just x, x)
170 |       step (Just s) x = let r = f s x in (Just r, r)
171 |   in snd . mapAccumROf l step Nothing
172 |
173 |
174 | ||| Try to map over a traversal, failing if the traversal has no focuses.
175 | public export
176 | failover : Alternative f => Traversal s t a b -> (a -> b) -> s -> f t
177 | failover l f x =
178 |   let _ = Bool.Monoid.Any
179 |       (b, y) = traverseOf l ((True,) . f) x
180 |   in  guard b $> y
181 |
182 | ||| Try to map over an indexed traversal, failing if the traversal has no focuses.
183 | public export
184 | ifailover : Alternative f => IndexedTraversal i s t a b -> (i -> a -> b) -> s -> f t
185 | ifailover l = failover (l @{%search} @{Idxed}) . uncurry
186 |
187 |
188 | partsOf_update : a -> State (List a) a
189 | partsOf_update x = get >>= \case
190 |   x' :: xs' => put xs' $> x'
191 |   []        => pure x
192 |
193 | ||| Convert a traversal into a lens over a list of values.
194 | |||
195 | ||| Note that this is only a true lens if the invariant of the list's length is
196 | ||| maintained. You should avoid mapping `over` this lens with a function that
197 | ||| changes the list's length.
198 | public export
199 | partsOf : Traversal s t a a -> Lens s t (List a) (List a)
200 | partsOf l = lens (runForget $ l $ MkForget pure)
201 |                   (flip evalState . traverseOf l partsOf_update)
202 |
203 | ||| Convert an indexed traversal into an indexed lens over a list of values, with
204 | ||| access to a list of indices.
205 | |||
206 | ||| Note that this is only a true lens if the invariant of the list's length is
207 | ||| maintained. You should avoid mapping `over` this lens with a function that
208 | ||| changes the list's length.
209 | public export
210 | ipartsOf : IndexedTraversal i s t a a -> IndexedLens (List i) s t (List a) (List a)
211 | ipartsOf l = ilens (unzip . (runForget $ l @{%search} @{Idxed} $ MkForget pure))
212 |                    (flip evalState . itraverseOf l (const partsOf_update))
213 |
214 |
215 | ||| Construct an optional that focuses on the first value of a traversal.
216 | |||
217 | ||| For the fold version of this, see `pre`.
218 | public export
219 | singular : Traversal' s a -> Optional' s a
220 | singular l = optional' (runForget $ l (MkForget Just)) set
221 |   where
222 |     set : s -> a -> s
223 |     set str x = evalState True $ traverseOf l
224 |       (\y => if !get then put False $> x else pure y) str
225 |
226 | ||| Construct an indexed optional that focuses on the first value of an
227 | ||| indexed traversal.
228 | |||
229 | ||| For the fold version of this, see `ipre`.
230 | public export
231 | isingular : IndexedTraversal' i s a -> IndexedOptional' i s a
232 | isingular l = ioptional' (runForget $ l @{%search} @{Idxed} (MkForget Just)) set
233 |   where
234 |     set : s -> a -> s
235 |     set str x = evalState True $ itraverseOf l
236 |       (\_,y => if !get then put False $> x else pure y) str
237 |
238 | ||| Filter the focuses of a traversal by a predicate on their ordinal positions.
239 | public export
240 | elementsOf : Traversal s t a a -> (Nat -> Bool) -> Traversal s t a a
241 | elementsOf l p = traversal func
242 |   where
243 |     func : Applicative f => (a -> f a) -> s -> f t
244 |     func fn = indexing {f} (traverseOf l) $
245 |       \i,x => if p i then fn x else pure {f} x
246 |
247 | ||| Traverse over the elements of a `Traversable` container that satisfy a
248 | ||| predicate.
249 | public export
250 | elements : Traversable t => (Nat -> Bool) -> Traversal' (t a) a
251 | elements = elementsOf traversed
252 |
253 | ||| Construct an optional that focuses on the nth element of a traversal.
254 | public export
255 | elementOf : Traversal' s a -> Nat -> Optional' s a
256 | elementOf l n = singular $ elementsOf l (n ==)
257 |
258 | ||| Construct an optional that focuses on the nth element of a `Traversable`
259 | ||| container.
260 | public export
261 | element : Traversable t => Nat -> Optional' (t a) a
262 | element = elementOf traversed
263 |
264 |
265 | ||| Limit a traversal to its first `n` focuses.
266 | public export
267 | taking : Nat -> Traversal s t a a -> Traversal s t a a
268 | taking n l = elementsOf l (< n)
269 |
270 | ||| Remove the first `n` focuses from a traversal.
271 | public export
272 | dropping : Nat -> Traversal s t a a -> Traversal s t a a
273 | dropping n l = elementsOf l (>= n)
274 |