idris2-lens/src/Control/Lens/Traversal.idr

194 lines
6.3 KiB
Idris
Raw Normal View History

module Control.Lens.Traversal
import Control.Monad.State
import Data.Zippable
import Data.Profunctor
import Data.Profunctor.Traversing
2023-04-12 11:55:22 -04:00
import Control.Applicative.Backwards
2023-04-14 13:16:08 -04:00
import Control.Applicative.Indexing
import Control.Lens.Optic
import Control.Lens.Optional
2023-04-15 21:44:56 -04:00
import Control.Lens.Lens
2023-04-14 13:16:08 -04:00
import Control.Lens.Prism
%default total
2023-04-12 22:41:23 -04:00
------------------------------------------------------------------------------
-- Type definitions
------------------------------------------------------------------------------
public export
record IsTraversal p where
constructor MkIsTraversal
runIsTraversal : Traversing p
export %hint
traversalToOptional : IsTraversal p => IsOptional p
traversalToOptional @{MkIsTraversal _} = MkIsOptional %search
2023-04-12 22:41:23 -04:00
||| A traversal is a lens that may have more than one focus.
public export
0 Traversal : (s,t,a,b : Type) -> Type
Traversal = Optic IsTraversal
2023-04-12 22:41:23 -04:00
||| `Traversal'` is the `Simple` version of `Traversal`.
public export
0 Traversal' : (s,a : Type) -> Type
2023-04-12 11:59:51 -04:00
Traversal' = Simple Traversal
2023-04-12 22:41:23 -04:00
------------------------------------------------------------------------------
-- Utilities for traversals
------------------------------------------------------------------------------
||| Derive a traversal from a `Traversable` implementation.
public export
traversed : Traversable t => Traversal (t a) (t b) a b
traversed @{_} @{MkIsTraversal _} = traverse'
2023-04-14 13:16:08 -04:00
||| Contstruct a traversal over a `Bitraversable` container with matching types.
public export
both : Bitraversable t => Traversal (t a a) (t b b) a b
both @{_} @{MkIsTraversal _} = wander (\f => bitraverse f f)
2023-04-12 22:41:23 -04:00
||| Reverse the order of a traversal's focuses.
public export
backwards : Traversal s t a b -> Traversal s t a b
backwards l @{MkIsTraversal _} = wander func
where
func : Applicative f => (a -> f b) -> s -> f t
func fn = forwards . applyStar {f = Backwards f} (l $ MkStar (MkBackwards . fn))
2023-04-12 22:41:23 -04:00
||| Map each focus of a traversal to a computation, evaluate those computations
||| and combine the results.
public export
traverseOf : Applicative f => Traversal s t a b -> (a -> f b) -> s -> f t
traverseOf l = applyStar . l . MkStar {f}
2023-04-12 22:41:23 -04:00
||| A version of `traverseOf` but with the arguments flipped.
public export
forOf : Applicative f => Traversal s t a b -> s -> (a -> f b) -> f t
forOf l = flip $ traverseOf l
2023-04-12 22:41:23 -04:00
||| Evaluate each computation within the traversal and collect the results.
public export
sequenceOf : Applicative f => Traversal s t (f a) a -> s -> f t
sequenceOf l = traverseOf l id
2023-04-12 22:41:23 -04:00
||| Fold across the focuses of a traversal from the leftmost focus, providing a
2023-04-14 13:16:08 -04:00
||| replacement value for each, and return the final accumulator along with the
||| new structure.
public export
mapAccumLOf : Traversal s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t)
mapAccumLOf l f z =
let g = state . flip f
in runState z . traverseOf l g
2023-04-12 22:41:23 -04:00
||| Fold across the focuses of a traversal from the rightmost focus, providing a
2023-04-14 13:16:08 -04:00
||| replacement value for each, and return the final accumulator along with the
||| new structure.
public export
mapAccumROf : Traversal s t a b -> (acc -> a -> (acc, b)) -> acc -> s -> (acc, t)
mapAccumROf l f z =
let g = MkBackwards {f=State acc} . state . flip f
in runState z . forwards . traverseOf l g
2023-04-12 22:41:23 -04:00
||| Fold across the focuses of a traversal from the left, returning each
||| intermediate value of the fold.
public export
scanl1Of : Traversal s t a a -> (a -> a -> a) -> s -> t
scanl1Of l f =
let step : Maybe a -> a -> (Maybe a, a)
step Nothing x = (Just x, x)
step (Just s) x = let r = f s x in (Just r, r)
in snd . mapAccumLOf l step Nothing
2023-04-12 22:41:23 -04:00
||| Fold across the focuses of a traversal from the right, returning each
||| intermediate value of the fold.
public export
scanr1Of : Traversal s t a a -> (a -> a -> a) -> s -> t
scanr1Of l f =
let step : Maybe a -> a -> (Maybe a, a)
step Nothing x = (Just x, x)
step (Just s) x = let r = f s x in (Just r, r)
in snd . mapAccumROf l step Nothing
2023-04-14 13:16:08 -04:00
||| Try to map over a traversal, failing if the traversal has no focuses.
public export
failover : Alternative f => Traversal s t a b -> (a -> b) -> s -> f t
failover l f x =
let _ = Bool.Monoid.Any
(b, y) = traverseOf l ((True,) . f) x
in guard b $> y
2023-04-15 21:44:56 -04:00
||| Convert a traversal into a lens over a list of values.
|||
||| Note that this is only a true lens if the invariant of the list's length is
||| maintained. You should avoid mapping `over` this lens with a function that
||| changes the list's length.
public export
partsOf : Traversal s t a a -> Lens s t (List a) (List a)
partsOf l = lens (runForget $ l $ MkForget pure)
(flip evalState . traverseOf l update)
where
update : a -> State (List a) a
update x = get >>= \case
x' :: xs' => put xs' >> pure x'
[] => pure x
2023-04-14 13:16:08 -04:00
||| Construct an optional that focuses on the first value of a traversal.
|||
||| For the fold version of this, see `pre`.
public export
singular : Traversal' s a -> Optional' s a
singular l = optional' (runForget $ l (MkForget Just)) set
where
set : s -> a -> s
set str x = evalState True $ traverseOf l
(\y => if !get then put False $> x else pure y) str
||| Filter the focuses of a traversal by a predicate on their ordinal positions.
public export
elementsOf : Traversal s t a a -> (Nat -> Bool) -> Traversal s t a a
elementsOf l p @{MkIsTraversal _} = wander func
where
func : Applicative f => (a -> f a) -> s -> f t
func fn = indexing {f} (traverseOf l) $
\i,x => if p i then fn x else pure {f} x
||| Traverse over the elements of a `Traversable` container that satisfy a
||| predicate.
public export
elements : Traversable t => (Nat -> Bool) -> Traversal' (t a) a
elements = elementsOf traversed
||| Construct an optional that focuses on the nth element of a traversal.
public export
elementOf : Traversal' s a -> Nat -> Optional' s a
elementOf l n = singular $ elementsOf l (n ==)
||| Construct an optional that focuses on the nth element of a `Traversable`
||| container.
public export
element : Traversable t => Nat -> Optional' (t a) a
element = elementOf traversed
||| Limit a traversal to its first n focuses.
public export
taking : Nat -> Traversal s t a a -> Traversal s t a a
taking n l = elementsOf l (< n)
||| Remove the first n focuses from a traversal.
public export
dropping : Nat -> Traversal s t a a -> Traversal s t a a
dropping i l = elementsOf l (>= i)