From 3430c56eff5b67523e921f3f54992436edb58cce Mon Sep 17 00:00:00 2001
From: Anton Sorokin <anton.sorokin@serokell.io>
Date: Mon, 11 Sep 2023 17:26:21 +0300
Subject: [PATCH] [#290] Add `Universum.Lens` module

Problem:
As in #290, we want to export lens-related operators
like `(^.)` or `(^?)`, but we don't want to depend on
`microlens` or `lens`.

Solution:
Implement those operators by ourselves, export them in
a separate module to avoid names conflict.

Remove those operators from `Universum` reexports.
---
 README.md             |  6 +++-
 src/Universum.hs      | 79 ++++++-------------------------------------
 src/Universum/Lens.hs | 79 +++++++++++++++++++++++++++++++++++++++++++
 universum.cabal       |  1 +
 4 files changed, 96 insertions(+), 69 deletions(-)
 create mode 100644 src/Universum/Lens.hs

diff --git a/README.md b/README.md
index 4a3b9cf..bd2f943 100644
--- a/README.md
+++ b/README.md
@@ -178,7 +178,11 @@ Then, some commonly used types: `Map/HashMap/IntMap`, `Set/HashSet/IntSet`, `Seq
 `deepseq` is exported. For instance, if you want to force deep evaluation of some value (in IO),
 you can write `evaluateNF a`. WHNF evaluation is possible with `evaluateWHNF a`.
 
-We also reexport big chunks of these libraries: `mtl`, `stm`, `microlens`, `microlens-mtl`.
+`(.^)`, `(.~)` and some other optics-related functions and operators are exported in
+`Universum.Lens` module.
+This module is not included in `Universum` module so it requires explicit `import`.
+
+We also reexport big chunks of `mtl`, `stm`.
 
 [`Bifunctor`](http://hackage.haskell.org/package/base-4.9.1.0/docs/Data-Bifunctor.html)
 type class with useful instances is exported.
diff --git a/src/Universum.hs b/src/Universum.hs
index edf2fc2..6826f66 100644
--- a/src/Universum.hs
+++ b/src/Universum.hs
@@ -43,6 +43,9 @@ Below is a short description of what you can find under different modules:
 * __"Universum.Function"__: almost everything from "Data.Function" module.
 * __"Universum.Functor"__: reexports from "Data.Functor", "Data.Bifunctor",
   other useful 'Functor' combinators.
+* __"Universum.Lens"__: Some operators and functions for using lenses.
+  Not exported by "Universum" module by default, so, if more functionality is needed,
+  @microlens@ or @lens@ packages can be used without conflicts of names.
 * __"Universum.Lifted"__: lifted to 'MonadIO' functions to work with console,
   files, 'IORef's, 'MVar's, etc.
 * __"Universum.List"__: big chunk of "Data.List", 'NonEmpty' type and
@@ -80,18 +83,7 @@ module Universum
        , module Universum.TypeOps
        , module Universum.VarArg
 
-         -- * Lenses
-       , Lens
-       , Lens'
-       , Traversal
-       , Traversal'
-       , over
-       , set
-       , (%~)
-       , (.~)
-       , (^.)
-       , (^..)
-       , (^?)
+         -- * Lenses, see also __"Universum.Lens"__
        , _1
        , _2
        , _3
@@ -123,24 +115,12 @@ import Universum.TypeOps
 import Universum.VarArg
 
 -- Lenses
-import qualified Lens.Micro (ASetter, Getting, over, set, (%~), (.~), (^.),
-                             (^..), (^?), _1, _2, _3, _4, _5)
+import qualified Lens.Micro (Getting, Lens, _1, _2, _3, _4, _5)
 import qualified Lens.Micro.Mtl (preuse, preview, use, view)
 import Lens.Micro.Internal (Field1, Field2, Field3, Field4, Field5)
 
 {-# DEPRECATED
-    Lens
-  , Lens'
-  , Traversal
-  , Traversal'
-  , over
-  , set
-  , (%~)
-  , (.~)
-  , (^.)
-  , (^..)
-  , (^?)
-  , _1
+    _1
   , _2
   , _3
   , _4
@@ -152,56 +132,19 @@ import Lens.Micro.Internal (Field1, Field2, Field3, Field4, Field5)
   "Use corresponding function from 'lens' or 'microlens' package"
 #-}
 
-type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t
-type Lens' s a = Lens s s a a
-
-type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t
-type Traversal' s a = Traversal s s a a
-
-over :: Lens.Micro.ASetter s t a b -> (a -> b) -> s -> t
-over = Lens.Micro.over
-
-set :: Lens.Micro.ASetter s t a b -> b -> s -> t
-set = Lens.Micro.set
-
-(%~) :: Lens.Micro.ASetter s t a b -> (a -> b) -> s -> t
-(%~) = (Lens.Micro.%~)
-
-infixr 4 %~
-
-(.~) :: Lens.Micro.ASetter s t a b -> b -> s -> t
-(.~) = (Lens.Micro..~)
-
-infixr 4 .~
-
-(^.) :: s -> Lens.Micro.Getting a s a -> a
-(^.) = (Lens.Micro.^.)
-
-infixl 8 ^.
-
-(^..) :: s -> Lens.Micro.Getting (Endo [a]) s a -> [a]
-(^..) = (Lens.Micro.^..)
-
-infixl 8 ^..
-
-(^?) :: s -> Lens.Micro.Getting (First a) s a -> Maybe a
-(^?) = (Lens.Micro.^?)
-
-infixl 8 ^?
-
-_1 :: Field1 s t a b => Lens s t a b
+_1 :: Field1 s t a b => Lens.Micro.Lens s t a b
 _1 = Lens.Micro._1
 
-_2 :: Field2 s t a b => Lens s t a b
+_2 :: Field2 s t a b => Lens.Micro.Lens s t a b
 _2 = Lens.Micro._2
 
-_3 :: Field3 s t a b => Lens s t a b
+_3 :: Field3 s t a b => Lens.Micro.Lens s t a b
 _3 = Lens.Micro._3
 
-_4 :: Field4 s t a b => Lens s t a b
+_4 :: Field4 s t a b => Lens.Micro.Lens s t a b
 _4 = Lens.Micro._4
 
-_5 :: Field5 s t a b => Lens s t a b
+_5 :: Field5 s t a b => Lens.Micro.Lens s t a b
 _5 = Lens.Micro._5
 
 preuse :: MonadState s m => Lens.Micro.Getting (First a) s a -> m (Maybe a)
diff --git a/src/Universum/Lens.hs b/src/Universum/Lens.hs
new file mode 100644
index 0000000..abad66a
--- /dev/null
+++ b/src/Universum/Lens.hs
@@ -0,0 +1,79 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE Safe       #-}
+
+-- | Operators and functions compatible with lens constructed with
+-- any of `lens` and `microlens` packages. Both those packages contain
+-- operators, types, and functions defined here, so you can find all related
+-- documentation there.
+
+module Universum.Lens
+       ( Lens
+       , Lens'
+       , Traversal
+       , Traversal'
+
+       , ASetter
+       , Getting
+
+       , over
+       , set
+       , get
+       , (%~)
+       , (.~)
+       , (^.)
+       , (^..)
+       , (^?)
+       ) where
+
+
+import Data.Maybe (Maybe (..))
+import Universum.Applicative
+import Universum.Function
+import Universum.Functor
+import Universum.Monoid
+
+type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t
+type Lens' s a = Lens s s a a
+
+type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t
+type Traversal' s a = Traversal s s a a
+
+type ASetter s t a b = (a -> Identity b) -> s -> Identity t
+
+type Getting r s a = (a -> Const r a) -> s -> Const r s
+
+over :: ASetter s t a b -> (a -> b) -> s -> t
+over setter f = runIdentity . setter (Identity . f)
+
+set :: ASetter s t a b -> b -> s -> t
+set setter f = over setter (const f)
+
+get :: s -> Getting a s a -> a
+get s getter = getConst $ getter Const s
+
+(%~) ::ASetter s t a b -> (a -> b) -> s -> t
+(%~) = over
+
+infixr 4 %~
+
+(.~) :: ASetter s t a b -> b -> s -> t
+(.~) = set
+
+infixr 4 .~
+
+(^.) :: s -> Getting a s a -> a
+(^.) = get
+
+infixl 8 ^.
+
+(^..) :: s -> Getting (Endo [a]) s a -> [a]
+s ^.. getter =
+  let endo = getConst $ getter (\x -> Const $ Endo (x :)) s in
+  appEndo endo []
+
+infixl 8 ^..
+
+(^?) :: s -> Getting (First a) s a -> Maybe a
+s ^? getter = getFirst $ getConst $ getter (Const . pure) s
+
+infixl 8 ^?
diff --git a/universum.cabal b/universum.cabal
index f23e429..473dbc5 100644
--- a/universum.cabal
+++ b/universum.cabal
@@ -70,6 +70,7 @@ library
                            Universum.Functor
                                Universum.Functor.Fmap
                                Universum.Functor.Reexport
+                           Universum.Lens
                            Universum.Lifted
                                Universum.Lifted.Concurrent
                                Universum.Lifted.Env