toki/idris2-lens
1
0
Fork 0
Code Issues Pull requests Activity

Document everything

Browse source
This commit is contained in:
Kiana Sheibani 2023-04-12 22:41:23 -04:00
parent fd4eb7dd00
commit 2585e9eb04
Signed by: toki
GPG key ID: 6CB106C25E86A9F7
12 changed files with 360 additions and 38 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
src/Control/Applicative/Backwards.idr
View file

@ -3,6 +3,8 @@ module Control.Applicative.Backwards
%default total
||| Wrap an `Applicative` type constructor so that its actions are executed
||| in the opposite order.
public export
record Backwards {0 k : Type} (f : k -> Type) a where
constructor MkBackwards

39
src/Control/Lens/Equality.idr
View file

@ -5,46 +5,69 @@ import Control.Lens.Optic
%default total
------------------------------------------------------------------------------
-- Type definitions
------------------------------------------------------------------------------
-- This type is trivial and thus really isn't necessary;
-- it's only defined and used in order to assist Idris with optic coersion.
public export
record IsEquality {0 k,k' : _} (p : k -> k' -> Type) where
constructor MkIsEquality
||| An `Equality s t a b` is a witness that `(s = a, t = b)` that can be used
||| as an optic.
|||
||| The canonical `Equality` is `id : Equality a b a b`.
|||
||| An `Equality` can be coerced to any other optic.
public export
0 Equality : k -> k' -> k -> k' -> Type
Equality s t a b = forall p. IsEquality p => p a b -> p s t
||| An `Equality' s a` is a witness that `s = a` that can be used as an optic.
||| This is the `Simple` version of `Equality`.
public export
0 Equality' : k -> k -> Type
0 Equality' : (s,a : k) -> Type
Equality' = Simple Equality
------------------------------------------------------------------------------
-- Utilities for Equality
------------------------------------------------------------------------------
||| Extract the two `Equal` values from an `Equality`.
public export
runEq : Equality s t a b -> (s = a, t = b)
runEq l = (l {p = \x,_ => x = a} Refl,
l {p = \_,y => y = b} Refl)
||| Extract an `Equal` value from an `Equality`.
public export
runEq' : Equality s t a b -> s = a
runEq' l = l {p = \x,_ => x = a} Refl
public export
substEq : forall p. Equality s t a b -> p a b a b -> p s t a b
substEq {p} l = l {p = \x,y => p x y a b}
||| `Equality` is a congruence.
public export
congEq : forall f,g. Equality s t a b -> Equality (f s) (g t) (f a) (g b)
congEq l {p} = l {p = \x,y => p (f x) (g y)}
||| Symmetry of an `Equality` optic.
public export
symEq : Equality s t a b -> Equality b a t s
symEq l = case runEq l of (Refl, Refl) => id
public export
refl : Equality a b a b
refl = id
substEq : forall p. Equality s t a b -> p a b a b -> p s t a b
substEq {p} l = l {p = \x,y => p x y a b}
||| A trivial `Simple Equality`.
||| Composing this optic with any other can force it to be a `Simple` optic.
public export
simple : Equality' a a
simple = id

68
src/Control/Lens/Fold.idr
View file

@ -12,6 +12,13 @@ import Control.Lens.Traversal
%default total
------------------------------------------------------------------------------
-- Type definitions
------------------------------------------------------------------------------
-- IsFold
public export
record IsFold p where
constructor MkIsFold
@ -26,15 +33,29 @@ foldToTraversal : IsFold p => IsTraversal p
foldToTraversal @{MkIsFold _} = MkIsTraversal %search
-- Fold
||| A fold is a getter that accesses multiple focus elements.
||| `Fold s a` is equivalent to `s -> List a`.
public export
0 Fold : (s,a : Type) -> Type
Fold s a = Optic IsFold s s a a
------------------------------------------------------------------------------
-- Utilities for folds
------------------------------------------------------------------------------
||| Derive a fold from a `Foldable` implementation.
public export
folded : Foldable f => Fold (f a) a
folded @{_} @{MkIsFold _} = rphantom . wander traverse_
||| Construct a fold from an unfolding function.
|||
||| This function is not total, as it may result in an infinite amount
||| of focuses.
public export covering
unfolded : (s -> Maybe (a, s)) -> Fold s a
unfolded coalg @{MkIsFold _} = rphantom . wander loop
@ -42,13 +63,15 @@ unfolded coalg @{MkIsFold _} = rphantom . wander loop
loop : Applicative f => (a -> f a) -> s -> f ()
loop f = maybe (pure ()) (uncurry $ \x,y => f x *> loop f y) . coalg
||| Construct a fold from a function into a foldable container.
public export
folding : Foldable f => (s -> f a) -> Fold s a
folding @{_} f @{MkIsFold _} = rphantom . contramapFst f . wander traverse_
||| Reverse the order of a fold's focuses.
public export
backwards : Fold s a -> Fold s a
backwards l @{MkIsFold _} = rphantom . wander func
backwardsFold : Fold s a -> Fold s a
backwardsFold l @{MkIsFold _} = rphantom . wander func
where
traversing : Applicative f => Traversing (Forget (f ()))
traversing =
@ -60,83 +83,108 @@ backwards l @{MkIsFold _} = rphantom . wander func
forwards . runForget (l $ MkForget (MkBackwards {f} . ignore . fn))
||| Map each focus of an optic to a monoid value and combine them.
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
||| Combine the focuses of an optic using the provided function, starting from
||| the right.
public export
foldrOf : Fold s a -> (a -> acc -> acc) -> acc -> s -> acc
foldrOf l = flip . foldMapByOf l (.) id
foldrOf l = flip . foldMapOf @{MkMonoid @{MkSemigroup (.)} id} l
||| Combine the focuses of an optic using the provided function, starting from
||| the left.
public export
foldlOf : Fold s a -> (acc -> a -> acc) -> acc -> s -> acc
foldlOf l = flip . foldMapByOf l (flip (.)) id . flip
foldlOf l = flip . foldMapOf @{MkMonoid @{MkSemigroup $ flip (.)} id} l . flip
||| Combine each focus value of an optic using a monoid structure.
public export
concatOf : Monoid m => Fold s m -> s -> m
concatOf l = foldMapOf l id
||| Evaluate each computation of an optic and discard the results.
public export
sequenceOf_ : Applicative f => Fold s (f a) -> s -> f ()
sequenceOf_ l =
let _ = MkMonoid @{MkSemigroup (*>)} (pure ())
in foldMapOf l ignore
||| Map each focus of an optic to a computation, evaluate those
||| computations and discard the results.
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)
||| A version of `traverseOf_` with the arguments flipped.
public export
forOf_ : Applicative f => Fold s a -> s -> (a -> f b) -> f ()
forOf_ = flip . traverseOf_
||| The conjunction of an optic containing lazy boolean values.
public export
andOf : Fold s (Lazy Bool) -> s -> Bool
andOf = force .: concatOf @{All}
||| The disjunction of an optic containing lazy boolean values.
public export
orOf : Fold s (Lazy Bool) -> s -> Bool
orOf = force .: concatOf @{Any}
||| Return `True` if all focuses of the optic satisfy the predicate.
public export
allOf : Fold s a -> (a -> Bool) -> s -> Bool
allOf = foldMapOf @{All}
||| Return `True` if any focuses of the optic satisfy the predicate.
public export
anyOf : Fold s a -> (a -> Bool) -> s -> Bool
anyOf = foldMapOf @{Any}
------------------------------------------------------------------------------
-- Accessing folds
------------------------------------------------------------------------------
||| Return `True` if the optic focuses on any values.
public export
has : Fold s a -> s -> Bool
has l = anyOf l (const True)
||| Return `True` if the optic does not focus on any values.
public export
hasn't : Fold s a -> s -> Bool
hasn't l = allOf l (const False)
||| Access the first focus value of an optic and apply a function to it,
||| returning `Nothing` if there are no focuses.
public export
previews : Fold s a -> (a -> r) -> s -> Maybe r
previews l f = foldMapOf @{MonoidAlternative} l (Just . f)
||| Access the first focus value of an optic, returning `Nothing` if there are
||| no focuses.
public export
preview : Fold s a -> s -> Maybe a
preview l = foldMapOf @{MonoidAlternative} l Just
infixl 8 ^?
||| Access the first focus value of an optic, returning `Nothing` if there are
||| no focuses.
|||
||| This is the operator form of `preview`.
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 (::) []

22
src/Control/Lens/Getter.idr
View file

@ -9,6 +9,11 @@ import Control.Lens.Lens
%default total
------------------------------------------------------------------------------
-- Type definitions
------------------------------------------------------------------------------
public export
record IsGetter p where
constructor MkIsGetter
@ -19,26 +24,41 @@ getterToLens : IsGetter p => IsLens p
getterToLens @{MkIsGetter _} = MkIsLens %search
||| A getter is an optic that only supports getting, not setting.
|||
||| `Getter s a` is equivalent to a simple function `s -> a`.
public export
0 Getter : (s,a : Type) -> Type
Getter = Simple (Optic IsGetter)
------------------------------------------------------------------------------
-- Utilities for getters
------------------------------------------------------------------------------
||| Construct a getter from a function.
public export
to : (s -> a) -> Getter s a
to f @{MkIsGetter _} = lmap f . rphantom
||| Access the value of an optic and apply a function to it, returning the result.
public export
views : Getter s a -> (a -> r) -> (s -> r)
views l = runForget . l . MkForget
||| Access the focus value of an optic, particularly a `Getter`.
public export
view : Getter s a -> (s -> a)
view : Getter s a -> s -> a
view l = views l id
infixl 8 ^.
||| Access the focus value of an optic, particularly a `Getter`.
|||
||| This is the operator form of `view`.
public export
(^.) : s -> Getter s a -> a
(^.) x l = view l x

64
src/Control/Lens/Iso.idr
View file

@ -10,22 +10,39 @@ import Control.Lens.Equality
%default total
------------------------------------------------------------------------------
-- Type definitions
------------------------------------------------------------------------------
public export
record IsIso p where
constructor MkIsIso
runIsIso : Profunctor p
||| An `Iso` is an isomorphism family between types. It allows a value to be
||| converted or updated across this isomorphism.
public export
0 Iso : (s,t,a,b : Type) -> Type
Iso = Optic IsIso
||| An `Iso'` is an isomorphism family between types. It allows a value to be
||| converted or updated across this isomorphism.
||| This is the `Simple` version of `Iso`.
public export
0 Iso' : (s,a : Type) -> Type
Iso' = Simple Iso
------------------------------------------------------------------------------
-- Utilities for isomorphisms
------------------------------------------------------------------------------
-- Eliminators
||| Extract the conversion functions from an `Iso`.
public export
getIso : Iso s t a b -> (s -> a, b -> t)
getIso l = l @{MkIsIso coexp} (id, id)
@ -33,109 +50,146 @@ getIso l = l @{MkIsIso coexp} (id, id)
[coexp] Profunctor (\x,y => (x -> a, b -> y)) where
dimap f g (f', g') = (f' . f, g . g')
||| Extract the conversion functions from an `Iso`.
public export
withIso : Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
withIso l f = uncurry f (getIso l)
public export
under : Iso s t a b -> (t -> s) -> (b -> a)
under l = let (f,g) = getIso l in (f .) . (. g)
-- Constructors
||| Construct an `Iso` from two inverse functions.
public export
iso : (s -> a) -> (b -> t) -> Iso s t a b
iso f g @{MkIsIso _} = dimap f g
||| Construct a simple `Iso` from an equivalence.
public export
fromEqv : s <=> a -> Iso' s a
fromEqv (MkEquivalence l r) = iso l r
||| Invert an isomorphism.
public export
from : Iso s t a b -> Iso b a t s
from l @{MkIsIso _} = withIso l (flip dimap)
-- `au`
||| Based on Epigram's `ala`.
public export
au : Functor f => Iso s t a b -> ((b -> t) -> f s) -> f a
au l f = withIso l $ \g,h => g <$> f h
||| Based on Epigram's `ala'`.
public export
auf : (Functor f, Functor g) => Iso s t a b -> (f t -> g s) -> f b -> g a
auf l f x = withIso l $ \g,h => g <$> f (h <$> x)
||| An alias for `au . from`.
public export
xplat : Functor f => Iso s t a b -> ((s -> a) -> f b) -> f t
xplat l f = withIso l $ \g,h => h <$> f g
||| an alias for `auf . from`.
public export
xplatf : (Functor f, Functor g) => Iso s t a b -> (f a -> g b) -> f s -> g t
xplatf l f x = withIso l $ \g,h => h <$> f (g <$> x)
-- Example Isos
||| Update a value under an `Iso`, as opposed to `over` it.
||| In other words, this is a convenient alias for `over . from`.
public export
under : Iso s t a b -> (t -> s) -> (b -> a)
under l = let (f,g) = getIso l in (f .) . (. g)
-- Examples of isomorphisms
||| An "isomorphism" between a function and its result type, assuming that
||| the parameter type is inhabited.
public export
constant : a -> Iso (a -> b) (a' -> b') b b'
constant x = iso ($ x) const
||| Construct an isomorphism given an involution.
public export
involuted : (a -> a) -> Iso' a a
involuted f = iso f f
||| Flipping a function's arguments forms an isomorphism.
public export
flipped : Iso (a -> b -> c) (a' -> b' -> c') (b -> a -> c) (b' -> a' -> c')
flipped = iso flip flip
||| Swapping a symmetric tensor product's parameters is an isomorphism.
public export
swapped : Symmetric f => Iso (f a b) (f a' b') (f b a) (f b' a')
swapped = iso swap' swap'
||| Casting between types forms an isomorphism.
||| WARNING: This is only a true isomorphism if casts in both directions are
||| lossless and mutually inverse.
public export
casted : (Cast s a, Cast b t) => Iso s t a b
casted = iso cast cast
||| The isomorphism `non x` converts between `Maybe a` and `a` sans the
||| element `x`.
|||
||| This is useful for working with optics whose focus type is `Maybe a`,
||| such as `at`.
public export
non : Eq a => a -> Iso' (Maybe a) a
non x = iso (fromMaybe x) (\y => guard (x /= y) $> y)
-- Mapping
||| Lift an isomorphism through a `Functor`.
public export
mapping : (Functor f, Functor g) => Iso s t a b -> Iso (f s) (g t) (f a) (g b)
mapping l = withIso l $ \f,g => iso (map f) (map g)
||| Lift an isomorphism through a `Contravariant` functor.
public export
contramapping : (Contravariant f, Contravariant g) => Iso s t a b -> Iso (f a) (g b) (f s) (g t)
contramapping l = withIso l $ \f,g => iso (contramap f) (contramap g)
||| Lift isomorphisms through a `Bifunctor`.
public export
bimapping : (Bifunctor f, Bifunctor g) => Iso s t a b -> Iso s' t' a' b' ->
Iso (f s s') (g t t') (f a a') (g b b')
bimapping l r = withIso l $ \f,g => withIso r $ \f',g' =>
iso (bimap f f') (bimap g g')
||| Lift an isomorphism through the first parameter of a `Bifunctor`.
public export
mappingFst : (Bifunctor f, Bifunctor g) => Iso s t a b ->
Iso (f s x) (g t y) (f a x) (g b y)
mappingFst l = withIso l $ \f,g => iso (mapFst f) (mapFst g)
||| Lift an isomorphism through the second parameter of a `Bifunctor`.
public export
mappingSnd : (Bifunctor f, Bifunctor g) => Iso s t a b ->
Iso (f x s) (g y t) (f x a) (g y b)
mappingSnd l = withIso l $ \f,g => iso (mapSnd f) (mapSnd g)
||| Lift isomorphisms through a `Profunctor`.
public export
dimapping : (Profunctor f, Profunctor g) => Iso s t a b -> Iso s' t' a' b' ->
Iso (f a s') (g b t') (f s a') (g t b')
dimapping l r = withIso l $ \f,g => withIso r $ \f',g' =>
iso (dimap f f') (dimap g g')
||| Lift an isomorphism through the first parameter of a `Profunctor`.
public export
lmapping : (Profunctor f, Profunctor g) => Iso s t a b ->
Iso (f a x) (g b y) (f s x) (g t y)
lmapping l = withIso l $ \f,g => iso (lmap f) (lmap g)
||| Lift an isomorphism through the second parameter of a `Profunctor`.
public export
rmapping : (Profunctor f, Profunctor g) => Iso s t a b ->
Iso (f x s) (g y t) (f x a) (g y b)

40
src/Control/Lens/Lens.idr
View file

@ -9,6 +9,11 @@ import Control.Lens.Iso
%default total
------------------------------------------------------------------------------
-- Type definitions
------------------------------------------------------------------------------
public export
record IsLens p where
constructor MkIsLens
@ -19,19 +24,45 @@ lensToIso : IsLens p => IsIso p
lensToIso @{MkIsLens _} = MkIsIso %search
||| A *lens* is a functional reference to a value within a larger data structure.
||| Lenses allow one to access or modify the value that they reference, called
||| the "focus" or "focus element".
|||
||| For example, the lens `fst_` from `Data.Tuple.Lens` focuses on the first
||| element of a pair. It has the type:
|||
||| ```idris
||| fst_ : Lens (a, c) (b, c) a b
||| ```
|||
||| The types `s, t` correspond to the type of the outside data structure, and
||| `a, b` correspond to the type of the focus element. Two of each type is
||| provided to allow for operations that change the type of the focus.
public export
0 Lens : (s,t,a,b : Type) -> Type
Lens = Optic IsLens
||| `Lens'` is the `Simple` version of `Lens`.
public export
0 Lens' : (s,a : Type) -> Type
Lens' = Simple Lens
------------------------------------------------------------------------------
-- Utilities for lenses
------------------------------------------------------------------------------
||| Construct a lens given getter and setter functions.
|||
||| @ get The getter function
||| @ set The setter function, where the first argument is the data structure
||| to modify and the second argument is the new focus value
public export
lens : (s -> a) -> (s -> b -> t) -> Lens s t a b
lens : (get : s -> a) -> (set : s -> b -> t) -> Lens s t a b
lens get set @{MkIsLens _} = dimap (\x => (x, get x)) (uncurry set) . second
||| Extract getter and setter functions from a lens.
public export
getLens : Lens s t a b -> (s -> a, s -> b -> t)
getLens l = l @{MkIsLens strong} (id, const id)
@ -43,21 +74,28 @@ getLens l = l @{MkIsLens strong} (id, const id)
strongl (get, set) = (get . fst, \(a,c),b => (set a b, c))
strongr (get, set) = (get . snd, \(c,a),b => (c, set a b))
||| Extract getter and setter functions from a lens.
public export
withLens : Lens s t a b -> ((s -> a) -> (s -> b -> t) -> r) -> r
withLens l f = uncurry f (getLens l)
||| `Void` vacuously "contains" a value of any other type.
public export
devoid : Lens Void Void a b
devoid @{MkIsLens _} = dimap absurd snd . first
||| All values contain a unit.
public export
united : Lens' a ()
united @{MkIsLens _} = dimap ((),) snd . first
||| Optimize a composition of optics by fusing their uses of `dimap` into one.
|||
||| This function exploits the Yoneda lemma. `fusing (a . b)` is essentially
||| equivalent to `a . b`, but the former will only call `dimap` once.
public export
fusing : IsIso p => Optic' (Yoneda p) s t a b -> Optic' p s t a b
fusing @{MkIsIso _} l = proextract . l . propure

42
src/Control/Lens/Optional.idr
View file

@ -7,6 +7,12 @@ import Control.Lens.Prism
%default total
------------------------------------------------------------------------------
-- Type definitions
------------------------------------------------------------------------------
public export
record IsOptional p where
constructor MkIsOptional
@ -21,15 +27,24 @@ optionalToPrism : IsOptional p => IsPrism p
optionalToPrism @{MkIsOptional _} = MkIsPrism %search
||| An `Optional` is a lens that may or may not contain the focus value.
||| As such, accesses will return a `Maybe` value.
public export
0 Optional : (s,t,a,b : Type) -> Type
Optional = Optic IsOptional
||| `Optional'` is the `Simple` version of `Optional`.
public export
0 Optional' : (s,a : Type) -> Type
Optional' = Simple Optional
------------------------------------------------------------------------------
-- Utilities for Optionals
------------------------------------------------------------------------------
||| Construct an optional from a projection and a setter function.
public export
optional : (s -> Either t a) -> (s -> b -> t) -> Optional s t a b
optional prj set @{MkIsOptional _} = dimap @{fromStrong}
@ -41,11 +56,25 @@ optional prj set @{MkIsOptional _} = dimap @{fromStrong}
fromStrong : Strong p => Profunctor p
fromStrong = %search
||| Construct a simple optional from a projection and a setter function.
public export
optional' : (s -> Maybe a) -> (s -> b -> s) -> Optional s s a b
optional' prj = optional (\x => maybe (Left x) Right (prj x))
||| The trivial optic that has no focuses.
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
||| Extract projection and setter functions from an optional.
public export
getOptional : Optional s t a b -> (s -> Either t a, s -> b -> t)
getOptional l = l @{MkIsOptional (strong,choice)} (Right, const id)
@ -63,18 +92,7 @@ getOptional l = l @{MkIsOptional (strong,choice)} (Right, const id)
strongr (prj, set) = (either (Left . Left) (either (Left . Right) Right . prj),
\e,b => mapSnd (`set` b) e)
||| Extract projection and setter functions from an optional.
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

18
src/Control/Lens/OptionalFold.idr
View file

@ -10,6 +10,11 @@ import Control.Lens.Getter
%default total
------------------------------------------------------------------------------
-- Type definitions
------------------------------------------------------------------------------
public export
record IsOptFold p where
constructor MkIsOptFold
@ -24,16 +29,29 @@ optFoldToGetter : IsOptFold p => IsGetter p
optFoldToGetter @{MkIsOptFold _} = MkIsGetter %search
||| An `OptionalFold` is a getter that may not return a focus value.
||| `OptionalFold s a` is equivalent to `s -> Maybe a`.
public export
0 OptionalFold : (s,a : Type) -> Type
OptionalFold = Simple (Optic IsOptFold)
------------------------------------------------------------------------------
-- Utilities for OptionalFolds
------------------------------------------------------------------------------
||| Construct an `OptionalFold` from a function.
public export
folding : (s -> Maybe a) -> OptionalFold s a
folding f @{MkIsOptFold _} =
contrabimap (\x => maybe (Left x) Right (f x)) Left . right
||| Construct an `OptionalFold` that can be used to filter the focuses
||| of another optic.
|||
||| To be more specific, this optic passes the value through unchanged if it
||| satisfies the predicate and returns no values if it does not.
public export
filtered : (a -> Bool) -> OptionalFold a a
filtered p = folding (\x => if p x then Just x else Nothing)

23
src/Control/Lens/Prism.idr
View file

@ -7,6 +7,11 @@ import Control.Lens.Iso
%default total
------------------------------------------------------------------------------
-- Type definitions
------------------------------------------------------------------------------
public export
record IsPrism p where
constructor MkIsPrism
@ -17,24 +22,39 @@ prismToIso : IsPrism p => IsIso p
prismToIso @{MkIsPrism _} = MkIsIso %search
||| A prism is a first-class reference to one of the cases of a sum type.
||| Prisms allow one to determine whether a value matches the focused case
||| and extract the corresponding data if it does.
|||
||| More precisely, a `Prism` is an `Optional` that can be flipped to obtain
||| a `Getter` in the opposite direction.
public export
0 Prism : (s,t,a,b : Type) -> Type
Prism = Optic IsPrism
||| `Prism'` is the `Simple` version of `Prism`.
public export
0 Prism' : (s,a : Type) -> Type
Prism' = Simple Prism
------------------------------------------------------------------------------
-- Utilities for prisms
------------------------------------------------------------------------------
||| Construct a prism from injection and projection functions.
public export
prism : (b -> t) -> (s -> Either t a) -> Prism s t a b
prism inj prj @{MkIsPrism _} = dimap prj (either id inj) . right
||| Construct a simple prism from injection and projection functions.
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))
||| Extract injection and projection functions from a prism.
public export
getPrism : Prism s t a b -> (b -> t, s -> Either t a)
getPrism l = l @{MkIsPrism choice} (id, Right)
@ -46,15 +66,18 @@ getPrism l = l @{MkIsPrism choice} (id, Right)
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))
||| Extract injection and projection functions from a prism.
public export
withPrism : Prism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
withPrism l f = uncurry f (getPrism l)
||| Construct a prism that uses a predicate to determine if a value matches.
public export
nearly : a -> (a -> Bool) -> Prism' a ()
nearly x p = prism' (const x) (guard . p)
||| Construct a prism that matches only one value.
public export
only : Eq a => a -> Prism' a ()
only x = nearly x (x ==)

29
src/Control/Lens/Review.idr
View file

@ -9,6 +9,11 @@ import Control.Lens.Getter
%default total
------------------------------------------------------------------------------
-- Type definitions
------------------------------------------------------------------------------
public export
record IsReview p where
constructor MkIsReview
@ -19,37 +24,59 @@ reviewToPrism : IsReview p => IsPrism p
reviewToPrism @{MkIsReview _} = MkIsPrism %search
||| A review is an optic whose only capability is being flipped into a `Getter`
||| in the other direction.
|||
||| Any `Prism` or `Iso` can be used as a review.
public export
0 Review : (s,a : Type) -> Type
Review s a = Optic IsReview s s a a
Review = Simple (Optic IsReview)
------------------------------------------------------------------------------
-- Utilities for Reviews
------------------------------------------------------------------------------
lphantom : (Bifunctor p, Profunctor p) => p b c -> p a c
lphantom = mapFst absurd . lmap {a=Void} absurd
||| Construct a review from an injection function.
||| Analogous to `to` for getters.
public export
unto : (a -> s) -> Review s a
unto f @{MkIsReview _} = lphantom . rmap f
||| Flip a `Getter` to form a `Review`.
public export
un : Getter s a -> Review a s
un = unto . view
||| Turn an optic around to inject a focus value into the larger data structure
||| after applying a function to it.
||| This function takes a `Review`, which can also be a `Prism` or `Iso`.
public export
reviews : Review s a -> (e -> a) -> (e -> s)
reviews l = runCoforget . l . MkCoforget
||| Turn an optic around to inject a focus value into the larger data structure.
||| This function takes a `Review`, which can also be a `Prism` or `Iso`.
public export
review : Review s a -> a -> s
review l = reviews l id
infixr 8 >.
||| Turn an optic around to inject a focus value into the larger data structure.
||| This function takes a `Review`, which can also be a `Prism` or `Iso`.
|||
||| This is the operator form of `review`.
public export
(>.) : a -> Review s a -> s
(>.) x l = review l x
||| Flip a `Prism`, `Iso` or `Review` to form a `Getter` in the other direction.
public export
re : Review s a -> Getter a s
re = to . review

23
src/Control/Lens/Setter.idr
View file

@ -11,6 +11,11 @@ import Control.Lens.Traversal
%default total
------------------------------------------------------------------------------
-- Type definitions
------------------------------------------------------------------------------
public export
record IsSetter p where
constructor MkIsSetter
@ -22,32 +27,50 @@ setterToTraversal : IsSetter p => IsTraversal p
setterToTraversal @{MkIsSetter _} = MkIsTraversal %search
||| A setter is an optic that only supports setting, not getting.
|||
||| More specifically, a setter can modify zero or more focus elements. This
||| means that all traversals are setters.
|||
||| Setters can be thought of as a generalization of the `Functor` interface,
||| allowing one to map over the contents of a structure.
public export
0 Setter : (s,t,a,b : Type) -> Type
Setter = Optic IsSetter
||| `Setter'` is the `Simple` version of `Setter`.
public export
0 Setter' : (s,a : Type) -> Type
Setter' = Simple Setter
------------------------------------------------------------------------------
-- Utilities for setters
------------------------------------------------------------------------------
||| Construct a setter from a modifying function.
public export
sets : ((a -> b) -> s -> t) -> Setter s t a b
sets f @{MkIsSetter _} = roam f
||| Derive a setter from a `Functor` implementation.
public export
mapped : Functor f => Setter (f a) (f b) a b
mapped @{_} @{MkIsSetter _} = map'
||| Derive a setter from a `Contravariant` implementation.
public export
contramapped : Contravariant f => Setter (f a) (f b) b a
contramapped = sets contramap
||| Modify the focus or focuses of an optic.
public export
over : Setter s t a b -> (a -> b) -> s -> t
over l = l @{MkIsSetter Function}
||| Set the focus or focuses of an optic to a constant value.
public export
set : Setter s t a b -> b -> s -> t
set l = over l . const

28
src/Control/Lens/Traversal.idr
View file

@ -11,6 +11,11 @@ import Control.Lens.Optional
%default total
------------------------------------------------------------------------------
-- Type definitions
------------------------------------------------------------------------------
public export
record IsTraversal p where
constructor MkIsTraversal
@ -21,19 +26,28 @@ traversalToOptional : IsTraversal p => IsOptional p
traversalToOptional @{MkIsTraversal _} = MkIsOptional %search
||| 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
||| `Traversal'` is the `Simple` version of `Traversal`.
public export
0 Traversal' : (s,a : Type) -> Type
Traversal' = Simple Traversal
------------------------------------------------------------------------------
-- 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'
||| 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
@ -42,30 +56,42 @@ backwards l @{MkIsTraversal _} = wander func
func fn = forwards . applyStar {f = Backwards f} (l $ MkStar (MkBackwards . fn))
||| 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}
||| 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
||| 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
||| Fold across the focuses of a traversal from the leftmost focus, providing a
||| replacement value for each focus, 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
||| Fold across the focuses of a traversal from the rightmost focus, providing a
||| replacement value for each focus, 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
||| 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 =
@ -74,6 +100,8 @@ scanl1Of l f =
step (Just s) x = let r = f s x in (Just r, r)
in snd . mapAccumLOf l step Nothing
||| 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 =