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:
Kiana Sheibani 2023-04-12 11:34:33 -04:00
parent 090b06a899
commit 69870ff394
Signed by: toki
GPG key ID: 6CB106C25E86A9F7
11 changed files with 636 additions and 0 deletions

14
src/Control/Lens.idr Normal file
View 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
View 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

View 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

View 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)

View 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 ())

View 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

View 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)

View 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 ==)

View 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

View 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

View 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