Implement basic optic functions

Most of these functions are taken from `fresnel`, but I intend to
implement more convenient utilities from `lens`.

src/Control/Lens.idr

@@ -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

src/Control/Lens/Fold.idr

@@ -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

src/Control/Lens/Getter.idr

@@ -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

src/Control/Lens/Internal/Backwards.idr

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

src/Control/Lens/Internal/Bicontravariant.idr

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

src/Control/Lens/Optional.idr

@@ -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

src/Control/Lens/OptionalFold.idr

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

src/Control/Lens/Prism.idr

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

src/Control/Lens/Review.idr

@@ -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

src/Control/Lens/Setter.idr

@@ -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

src/Control/Lens/Traversal.idr

@@ -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