Implement basic optic functions
Most of these functions are taken from `fresnel`, but I intend to implement more convenient utilities from `lens`.
This commit is contained in:
parent
090b06a899
commit
69870ff394
14
src/Control/Lens.idr
Normal file
14
src/Control/Lens.idr
Normal file
|
@ -0,0 +1,14 @@
|
|||
module Control.Lens
|
||||
|
||||
import public Control.Lens.Equality
|
||||
import public Control.Lens.Fold
|
||||
import public Control.Lens.Getter
|
||||
import public Control.Lens.Iso
|
||||
import public Control.Lens.Lens
|
||||
import public Control.Lens.Optic
|
||||
import public Control.Lens.Optional
|
||||
import public Control.Lens.OptionalFold
|
||||
import public Control.Lens.Prism
|
||||
import public Control.Lens.Review
|
||||
import public Control.Lens.Setter
|
||||
import public Control.Lens.Traversal
|
148
src/Control/Lens/Fold.idr
Normal file
148
src/Control/Lens/Fold.idr
Normal file
|
@ -0,0 +1,148 @@
|
|||
module Control.Lens.Fold
|
||||
|
||||
import Data.Profunctor
|
||||
import Data.Profunctor.Costrong
|
||||
import Data.Profunctor.Traversing
|
||||
import Control.Lens.Internal.Bicontravariant
|
||||
import Control.Lens.Internal.Backwards
|
||||
import Control.Lens.Optic
|
||||
import Control.Lens.OptionalFold
|
||||
import Control.Lens.Traversal
|
||||
|
||||
%default total
|
||||
|
||||
|
||||
public export
|
||||
record IsFold p where
|
||||
constructor MkIsFold
|
||||
runIsFold : (Traversing p, Cochoice p, Bicontravariant p)
|
||||
|
||||
export %hint
|
||||
foldToOptFold : IsFold p => IsOptFold p
|
||||
foldToOptFold @{MkIsFold _} = MkIsOptFold %search
|
||||
|
||||
export %hint
|
||||
foldToTraversal : IsFold p => IsTraversal p
|
||||
foldToTraversal @{MkIsFold _} = MkIsTraversal %search
|
||||
|
||||
|
||||
public export
|
||||
0 Fold : (s,a : Type) -> Type
|
||||
Fold s a = Optic IsFold s s a a
|
||||
|
||||
|
||||
public export
|
||||
folded : Foldable f => Fold (f a) a
|
||||
folded @{_} @{MkIsFold _} = rphantom . wander traverse_
|
||||
|
||||
public export covering
|
||||
unfolded : (s -> Maybe (a, s)) -> Fold s a
|
||||
unfolded coalg @{MkIsFold _} = rphantom . wander loop
|
||||
where
|
||||
loop : Applicative f => (a -> f a) -> s -> f ()
|
||||
loop f = maybe (pure ()) (uncurry $ \x,y => f x *> loop f y) . coalg
|
||||
|
||||
public export
|
||||
folding : Foldable f => (s -> f a) -> Fold s a
|
||||
folding @{_} f @{MkIsFold _} = rphantom . contramapFst f . wander traverse_
|
||||
|
||||
public export
|
||||
backwards : Fold s a -> Fold s a
|
||||
backwards l @{MkIsFold _} = rphantom . wander func
|
||||
where
|
||||
traversing : Applicative f => Traversing (Forget (f ()))
|
||||
traversing =
|
||||
let _ = MkMonoid @{MkSemigroup (*>)} (pure ())
|
||||
in %search
|
||||
|
||||
func : Applicative f => (a -> f a) -> s -> f ()
|
||||
func fn = let _ = traversing in
|
||||
forwards . runForget (l $ MkForget (MkBackwards {f} . ignore . fn))
|
||||
|
||||
|
||||
public export
|
||||
foldMapOf : Monoid m => Fold s a -> (a -> m) -> s -> m
|
||||
foldMapOf l = runForget . l . MkForget
|
||||
|
||||
public export
|
||||
foldMapByOf : Fold s a -> (m -> m -> m) -> m -> (a -> m) -> (s -> m)
|
||||
foldMapByOf l fork nil =
|
||||
let _ = MkMonoid @{MkSemigroup fork} nil
|
||||
in foldMapOf l
|
||||
|
||||
public export
|
||||
foldrOf : Fold s a -> (a -> acc -> acc) -> acc -> s -> acc
|
||||
foldrOf l = flip . foldMapByOf l (.) id
|
||||
|
||||
public export
|
||||
foldlOf : Fold s a -> (acc -> a -> acc) -> acc -> s -> acc
|
||||
foldlOf l = flip . foldMapByOf l (flip (.)) id . flip
|
||||
|
||||
public export
|
||||
concatOf : Monoid m => Fold s m -> s -> m
|
||||
concatOf l = foldMapOf l id
|
||||
|
||||
public export
|
||||
sequenceOf_ : Applicative f => Fold s (f a) -> s -> f ()
|
||||
sequenceOf_ l =
|
||||
let _ = MkMonoid @{MkSemigroup (*>)} (pure ())
|
||||
in foldMapOf l ignore
|
||||
|
||||
public export
|
||||
traverseOf_ : Applicative f => Fold s a -> (a -> f b) -> s -> f ()
|
||||
traverseOf_ l f =
|
||||
let _ = MkMonoid @{MkSemigroup (*>)} (pure ())
|
||||
in foldMapOf l (ignore . f)
|
||||
|
||||
public export
|
||||
forOf_ : Applicative f => Fold s a -> s -> (a -> f b) -> f ()
|
||||
forOf_ = flip . traverseOf_
|
||||
|
||||
public export
|
||||
andOf : Fold s (Lazy Bool) -> s -> Bool
|
||||
andOf = force .: concatOf @{All}
|
||||
|
||||
public export
|
||||
orOf : Fold s (Lazy Bool) -> s -> Bool
|
||||
orOf = force .: concatOf @{Any}
|
||||
|
||||
public export
|
||||
allOf : Fold s a -> (a -> Bool) -> s -> Bool
|
||||
allOf = foldMapOf @{All}
|
||||
|
||||
public export
|
||||
anyOf : Fold s a -> (a -> Bool) -> s -> Bool
|
||||
anyOf = foldMapOf @{Any}
|
||||
|
||||
|
||||
public export
|
||||
has : Fold s a -> s -> Bool
|
||||
has l = anyOf l (const True)
|
||||
|
||||
public export
|
||||
hasn't : Fold s a -> s -> Bool
|
||||
hasn't l = allOf l (const False)
|
||||
|
||||
public export
|
||||
previews : Fold s a -> (a -> r) -> s -> Maybe r
|
||||
previews l f = foldMapOf @{MonoidAlternative} l (Just . f)
|
||||
|
||||
public export
|
||||
preview : Fold s a -> s -> Maybe a
|
||||
preview l = foldMapOf @{MonoidAlternative} l Just
|
||||
|
||||
infixl 8 ^?
|
||||
|
||||
public export
|
||||
(^?) : s -> Fold s a -> Maybe a
|
||||
(^?) s l = preview l s
|
||||
|
||||
public export
|
||||
toListOf : Fold s a -> s -> List a
|
||||
toListOf l = foldrOf l (::) []
|
||||
|
||||
infixl 8 ^..
|
||||
|
||||
public export
|
||||
(^..) : s -> Fold s a -> List a
|
||||
(^..) s l = toListOf l s
|
44
src/Control/Lens/Getter.idr
Normal file
44
src/Control/Lens/Getter.idr
Normal file
|
@ -0,0 +1,44 @@
|
|||
module Control.Lens.Getter
|
||||
|
||||
import Data.Profunctor
|
||||
import Data.Profunctor.Costrong
|
||||
import Control.Lens.Optic
|
||||
import Control.Lens.Lens
|
||||
import Control.Lens.Internal.Bicontravariant
|
||||
|
||||
%default total
|
||||
|
||||
|
||||
public export
|
||||
record IsGetter p where
|
||||
constructor MkIsGetter
|
||||
runIsGetter : (Strong p, Cochoice p, Bicontravariant p)
|
||||
|
||||
export %hint
|
||||
getterToLens : IsGetter p => IsLens p
|
||||
getterToLens @{MkIsGetter _} = MkIsLens %search
|
||||
|
||||
|
||||
public export
|
||||
0 Getter : (s,a : Type) -> Type
|
||||
Getter s a = Optic IsGetter s s a a
|
||||
|
||||
|
||||
public export
|
||||
to : (s -> a) -> Getter s a
|
||||
to f @{MkIsGetter _} = lmap f . rphantom
|
||||
|
||||
|
||||
public export
|
||||
views : Getter s a -> (a -> r) -> (s -> r)
|
||||
views l = runForget . l . MkForget
|
||||
|
||||
public export
|
||||
view : Getter s a -> (s -> a)
|
||||
view l = views l id
|
||||
|
||||
infixl 8 ^.
|
||||
|
||||
public export
|
||||
(^.) : s -> Getter s a -> a
|
||||
(^.) x l = view l x
|
19
src/Control/Lens/Internal/Backwards.idr
Normal file
19
src/Control/Lens/Internal/Backwards.idr
Normal file
|
@ -0,0 +1,19 @@
|
|||
module Control.Lens.Internal.Backwards
|
||||
|
||||
%default total
|
||||
|
||||
|
||||
public export
|
||||
record Backwards {0 k : Type} (f : k -> Type) a where
|
||||
constructor MkBackwards
|
||||
forwards : f a
|
||||
|
||||
|
||||
public export
|
||||
Functor f => Functor (Backwards f) where
|
||||
map f (MkBackwards x) = MkBackwards (map f x)
|
||||
|
||||
public export
|
||||
Applicative f => Applicative (Backwards f) where
|
||||
pure = MkBackwards . pure
|
||||
MkBackwards f <*> MkBackwards x = MkBackwards (flip apply <$> x <*> f)
|
41
src/Control/Lens/Internal/Bicontravariant.idr
Normal file
41
src/Control/Lens/Internal/Bicontravariant.idr
Normal file
|
@ -0,0 +1,41 @@
|
|||
module Control.Lens.Internal.Bicontravariant
|
||||
|
||||
import Data.Morphisms
|
||||
import Data.Contravariant
|
||||
import Data.Profunctor
|
||||
|
||||
%default total
|
||||
|
||||
|
||||
public export
|
||||
interface Bicontravariant f where
|
||||
contrabimap : (a -> b) -> (c -> d) -> f b d -> f a c
|
||||
contrabimap f g = contramapFst f . contramapSnd g
|
||||
|
||||
contramapFst : (a -> b) -> f b c -> f a c
|
||||
contramapFst f = contrabimap f id
|
||||
|
||||
contramapSnd : (b -> c) -> f a c -> f a b
|
||||
contramapSnd = contrabimap id
|
||||
|
||||
|
||||
public export
|
||||
Contravariant f => Bicontravariant (Star f) where
|
||||
contrabimap f g = MkStar . dimap @{Function} f (contramap g) . applyStar
|
||||
|
||||
public export
|
||||
Contravariant f => Bicontravariant (Kleislimorphism f) where
|
||||
contrabimap f g = Kleisli . dimap @{Function} f (contramap g) . applyKleisli
|
||||
|
||||
public export
|
||||
Bicontravariant (Forget {k=Type} r) where
|
||||
contrabimap f _ = MkForget . lmap @{Function} f . runForget
|
||||
|
||||
|
||||
public export
|
||||
rphantom : (Profunctor p, Bicontravariant p) => p a b -> p a c
|
||||
rphantom = contramapSnd (const ()) . rmap (const ())
|
||||
|
||||
public export
|
||||
biphantom : (Bifunctor p, Bicontravariant p) => p a b -> p c d
|
||||
biphantom = contrabimap (const ()) (const ()) . bimap (const ()) (const ())
|
80
src/Control/Lens/Optional.idr
Normal file
80
src/Control/Lens/Optional.idr
Normal file
|
@ -0,0 +1,80 @@
|
|||
module Control.Lens.Optional
|
||||
|
||||
import Data.Profunctor
|
||||
import Control.Lens.Optic
|
||||
import Control.Lens.Lens
|
||||
import Control.Lens.Prism
|
||||
|
||||
%default total
|
||||
|
||||
public export
|
||||
record IsOptional p where
|
||||
constructor MkIsOptional
|
||||
runIsOptional : (Strong p, Choice p)
|
||||
|
||||
export %hint
|
||||
optionalToLens : IsOptional p => IsLens p
|
||||
optionalToLens @{MkIsOptional _} = MkIsLens %search
|
||||
|
||||
export %hint
|
||||
optionalToPrism : IsOptional p => IsPrism p
|
||||
optionalToPrism @{MkIsOptional _} = MkIsPrism %search
|
||||
|
||||
|
||||
public export
|
||||
0 Optional : (s,t,a,b : Type) -> Type
|
||||
Optional = Optic IsOptional
|
||||
|
||||
public export
|
||||
0 Optional' : (s,a : Type) -> Type
|
||||
Optional' s a = Optional s s a a
|
||||
|
||||
|
||||
public export
|
||||
optional : (s -> Either t a) -> (s -> b -> t) -> Optional s t a b
|
||||
optional prj set @{MkIsOptional _} = dimap @{fromStrong}
|
||||
(\s => (prj s, set s))
|
||||
(\(e, f) => either id f e)
|
||||
. first . right
|
||||
where
|
||||
-- arbitrary choice of where to pull profunctor instance from
|
||||
fromStrong : Strong p => Profunctor p
|
||||
fromStrong = %search
|
||||
|
||||
public export
|
||||
optional' : (s -> Maybe a) -> (s -> b -> s) -> Optional s s a b
|
||||
optional' prj = optional (\x => maybe (Left x) Right (prj x))
|
||||
|
||||
|
||||
public export
|
||||
getOptional : Optional s t a b -> (s -> Either t a, s -> b -> t)
|
||||
getOptional l = l @{MkIsOptional (strong,choice)} (Right, const id)
|
||||
where
|
||||
Profunctor (\x,y => (x -> Either y a, x -> b -> y)) where
|
||||
dimap f g (prj, set) = (either (Left . g) Right . prj . f, (g .) . set . f)
|
||||
|
||||
[strong] GenStrong Pair (\x,y => (x -> Either y a, x -> b -> y)) where
|
||||
strongl (prj, set) = (\(a,c) => mapFst (,c) (prj a), \(a,c),b => (set a b, c))
|
||||
strongr (prj, set) = (\(c,a) => mapFst (c,) (prj a), \(c,a),b => (c, set a b))
|
||||
|
||||
[choice] GenStrong Either (\x,y => (x -> Either y a, x -> b -> y)) where
|
||||
strongl (prj, set) = (either (either (Left . Left) Right . prj) (Left . Right),
|
||||
\e,b => mapFst (`set` b) e)
|
||||
strongr (prj, set) = (either (Left . Left) (either (Left . Right) Right . prj),
|
||||
\e,b => mapSnd (`set` b) e)
|
||||
|
||||
public export
|
||||
withOptional : Optional s t a b -> ((s -> Either t a) -> (s -> b -> t) -> r) -> r
|
||||
withOptional l f = uncurry f (getOptional l)
|
||||
|
||||
|
||||
public export
|
||||
ignored : Optional s s a b
|
||||
ignored @{MkIsOptional _} = dimap @{fromStrong}
|
||||
(\x => (Left x, const x))
|
||||
(\(e, f) => either id (the (b -> s) f) e)
|
||||
. first . right
|
||||
where
|
||||
-- arbitrary choice of where to pull profunctor instance from
|
||||
fromStrong : Strong p => Profunctor p
|
||||
fromStrong = %search
|
39
src/Control/Lens/OptionalFold.idr
Normal file
39
src/Control/Lens/OptionalFold.idr
Normal file
|
@ -0,0 +1,39 @@
|
|||
module Control.Lens.OptionalFold
|
||||
|
||||
import Data.Profunctor
|
||||
import Data.Profunctor.Costrong
|
||||
import Control.Lens.Internal.Bicontravariant
|
||||
import Control.Lens.Optic
|
||||
import Control.Lens.Optional
|
||||
import Control.Lens.Getter
|
||||
|
||||
%default total
|
||||
|
||||
|
||||
public export
|
||||
record IsOptFold p where
|
||||
constructor MkIsOptFold
|
||||
runIsOptFold : (Strong p, Choice p, Cochoice p, Bicontravariant p)
|
||||
|
||||
export %hint
|
||||
optFoldToOptional : IsOptFold p => IsOptional p
|
||||
optFoldToOptional @{MkIsOptFold _} = MkIsOptional %search
|
||||
|
||||
export %hint
|
||||
optFoldToGetter : IsOptFold p => IsGetter p
|
||||
optFoldToGetter @{MkIsOptFold _} = MkIsGetter %search
|
||||
|
||||
|
||||
public export
|
||||
0 OptionalFold : (s,a : Type) -> Type
|
||||
OptionalFold s a = Optic IsOptFold s s a a
|
||||
|
||||
|
||||
public export
|
||||
folding : (s -> Maybe a) -> OptionalFold s a
|
||||
folding f @{MkIsOptFold _} =
|
||||
contrabimap (\x => maybe (Left x) Right (f x)) Left . right
|
||||
|
||||
public export
|
||||
filtered : (a -> Bool) -> OptionalFold a a
|
||||
filtered p = folding (\x => if p x then Just x else Nothing)
|
60
src/Control/Lens/Prism.idr
Normal file
60
src/Control/Lens/Prism.idr
Normal file
|
@ -0,0 +1,60 @@
|
|||
module Control.Lens.Prism
|
||||
|
||||
import Data.Profunctor
|
||||
import Control.Lens.Optic
|
||||
import Control.Lens.Iso
|
||||
|
||||
%default total
|
||||
|
||||
|
||||
public export
|
||||
record IsPrism p where
|
||||
constructor MkIsPrism
|
||||
runIsPrism : Choice p
|
||||
|
||||
export %hint
|
||||
prismToIso : IsPrism p => IsIso p
|
||||
prismToIso @{MkIsPrism _} = MkIsIso %search
|
||||
|
||||
|
||||
public export
|
||||
0 Prism : (s,t,a,b : Type) -> Type
|
||||
Prism = Optic IsPrism
|
||||
|
||||
public export
|
||||
0 Prism' : (s,a : Type) -> Type
|
||||
Prism' s a = Prism s s a a
|
||||
|
||||
|
||||
public export
|
||||
prism : (b -> t) -> (s -> Either t a) -> Prism s t a b
|
||||
prism inj prj @{MkIsPrism _} = dimap prj (either id inj) . right
|
||||
|
||||
public export
|
||||
prism' : (b -> s) -> (s -> Maybe a) -> Prism s s a b
|
||||
prism' inj prj = prism inj (\x => maybe (Left x) Right (prj x))
|
||||
|
||||
|
||||
public export
|
||||
getPrism : Prism s t a b -> (b -> t, s -> Either t a)
|
||||
getPrism l = l @{MkIsPrism choice} (id, Right)
|
||||
where
|
||||
Profunctor (\x,y => (b -> y, x -> Either y a)) where
|
||||
dimap f g (inj, prj) = (g . inj, either (Left . g) Right . prj . f)
|
||||
|
||||
[choice] GenStrong Either (\x,y => (b -> y, x -> Either y a)) where
|
||||
strongl (inj, prj) = (Left . inj, either (either (Left . Left) Right . prj) (Left . Right))
|
||||
strongr (inj, prj) = (Right . inj, either (Left . Left) (either (Left . Right) Right . prj))
|
||||
|
||||
public export
|
||||
withPrism : Prism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
|
||||
withPrism l f = uncurry f (getPrism l)
|
||||
|
||||
|
||||
public export
|
||||
nearly : a -> (a -> Bool) -> Prism' a ()
|
||||
nearly x p = prism' (const x) (guard . p)
|
||||
|
||||
public export
|
||||
only : Eq a => a -> Prism' a ()
|
||||
only x = nearly x (x ==)
|
55
src/Control/Lens/Review.idr
Normal file
55
src/Control/Lens/Review.idr
Normal file
|
@ -0,0 +1,55 @@
|
|||
module Control.Lens.Review
|
||||
|
||||
import Data.Profunctor
|
||||
import Data.Profunctor.Costrong
|
||||
import Control.Lens.Optic
|
||||
import Control.Lens.Prism
|
||||
import Control.Lens.Getter
|
||||
|
||||
%default total
|
||||
|
||||
|
||||
public export
|
||||
record IsReview p where
|
||||
constructor MkIsReview
|
||||
runIsReview : (Bifunctor p, Costrong p, Choice p)
|
||||
|
||||
export %hint
|
||||
reviewToPrism : IsReview p => IsPrism p
|
||||
reviewToPrism @{MkIsReview _} = MkIsPrism %search
|
||||
|
||||
|
||||
public export
|
||||
0 Review : (s,a : Type) -> Type
|
||||
Review s a = Optic IsReview s s a a
|
||||
|
||||
|
||||
lphantom : (Bifunctor p, Profunctor p) => p b c -> p a c
|
||||
lphantom = mapFst absurd . lmap {a=Void} absurd
|
||||
|
||||
public export
|
||||
unto : (a -> s) -> Review s a
|
||||
unto f @{MkIsReview _} = lphantom . rmap f
|
||||
|
||||
public export
|
||||
un : Getter s a -> Review a s
|
||||
un = unto . view
|
||||
|
||||
|
||||
public export
|
||||
reviews : Review s a -> (e -> a) -> (e -> s)
|
||||
reviews l = runCoforget . l . MkCoforget
|
||||
|
||||
public export
|
||||
review : Review s a -> a -> s
|
||||
review l = reviews l id
|
||||
|
||||
infixr 8 >.
|
||||
|
||||
public export
|
||||
(>.) : a -> Review s a -> s
|
||||
(>.) x l = review l x
|
||||
|
||||
public export
|
||||
re : Review s a -> Getter a s
|
||||
re = to . review
|
53
src/Control/Lens/Setter.idr
Normal file
53
src/Control/Lens/Setter.idr
Normal file
|
@ -0,0 +1,53 @@
|
|||
module Control.Lens.Setter
|
||||
|
||||
import Data.Contravariant
|
||||
import Data.Profunctor
|
||||
import Data.Profunctor.Costrong
|
||||
import Data.Profunctor.Traversing
|
||||
import Data.Profunctor.Mapping
|
||||
import Control.Lens.Optic
|
||||
import Control.Lens.Traversal
|
||||
|
||||
%default total
|
||||
|
||||
|
||||
public export
|
||||
record IsSetter p where
|
||||
constructor MkIsSetter
|
||||
runIsSetter : Mapping p
|
||||
|
||||
|
||||
export %hint
|
||||
setterToTraversal : IsSetter p => IsTraversal p
|
||||
setterToTraversal @{MkIsSetter _} = MkIsTraversal %search
|
||||
|
||||
|
||||
public export
|
||||
0 Setter : (s,t,a,b : Type) -> Type
|
||||
Setter = Optic IsSetter
|
||||
|
||||
public export
|
||||
0 Setter' : (s,a : Type) -> Type
|
||||
Setter' s a = Optic IsSetter s s a a
|
||||
|
||||
|
||||
public export
|
||||
sets : ((a -> b) -> s -> t) -> Setter s t a b
|
||||
sets f @{MkIsSetter _} = roam f
|
||||
|
||||
public export
|
||||
mapped : Functor f => Setter (f a) (f b) a b
|
||||
mapped @{_} @{MkIsSetter _} = map'
|
||||
|
||||
public export
|
||||
contramapped : Contravariant f => Setter (f a) (f b) b a
|
||||
contramapped = sets contramap
|
||||
|
||||
|
||||
public export
|
||||
over : Setter s t a b -> (a -> b) -> s -> t
|
||||
over l = l @{MkIsSetter Function}
|
||||
|
||||
public export
|
||||
set : Setter s t a b -> b -> s -> t
|
||||
set l = over l . const
|
83
src/Control/Lens/Traversal.idr
Normal file
83
src/Control/Lens/Traversal.idr
Normal file
|
@ -0,0 +1,83 @@
|
|||
module Control.Lens.Traversal
|
||||
|
||||
import Control.Monad.State
|
||||
import Data.Zippable
|
||||
import Data.Profunctor
|
||||
import Data.Profunctor.Traversing
|
||||
import Control.Lens.Internal.Backwards
|
||||
import Control.Lens.Optic
|
||||
import Control.Lens.Optional
|
||||
|
||||
%default total
|
||||
|
||||
|
||||
public export
|
||||
record IsTraversal p where
|
||||
constructor MkIsTraversal
|
||||
runIsTraversal : Traversing p
|
||||
|
||||
export %hint
|
||||
traversalToOptional : IsTraversal p => IsOptional p
|
||||
traversalToOptional @{MkIsTraversal _} = MkIsOptional %search
|
||||
|
||||
|
||||
public export
|
||||
0 Traversal : (s,t,a,b : Type) -> Type
|
||||
Traversal = Optic IsTraversal
|
||||
|
||||
public export
|
||||
0 Traversal' : (s,a : Type) -> Type
|
||||
Traversal' s a = Traversal s s a a
|
||||
|
||||
|
||||
public export
|
||||
traversed : Traversable t => Traversal (t a) (t b) a b
|
||||
traversed @{_} @{MkIsTraversal _} = traverse'
|
||||
|
||||
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))
|
||||
|
||||
|
||||
public export
|
||||
traverseOf : Applicative f => Traversal s t a b -> (a -> f b) -> s -> f t
|
||||
traverseOf l = applyStar . l . MkStar {f}
|
||||
|
||||
public export
|
||||
forOf : Applicative f => Traversal s t a b -> s -> (a -> f b) -> f t
|
||||
forOf l = flip $ traverseOf l
|
||||
|
||||
public export
|
||||
sequenceOf : Applicative f => Traversal s t (f a) a -> s -> f t
|
||||
sequenceOf l = traverseOf l id
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
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
|
Loading…
Reference in a new issue