From a0937359a0f76a9b888c4662ca6e917dfda8c3df Mon Sep 17 00:00:00 2001
From: Nurlan Alkuatov <alkuatovnurlan@gmail.com>
Date: Mon, 27 Jun 2022 02:38:28 +0600
Subject: [PATCH] [#15] Add lenses for config-related types

Problem: It's quite unconvenient to access config-related records'
fields by hand, especially when it comes to nested ones.

Solution: Implement simple `makeLenses` function to derive lenses
for an arbitrary product type and add common lenses operators & types.
---
 core/nyan-interpolation-core.cabal            |  6 +-
 .../Interpolation/Nyan/Core/Internal/Base.hs  |  8 +++
 core/src/Text/Interpolation/Nyan/Lens.hs      | 52 ++++++++++++++++
 core/src/Text/Interpolation/Nyan/Lens/TH.hs   | 53 +++++++++++++++++
 core/src/Text/Interpolation/Nyan/Lens/Type.hs | 17 ++++++
 core/tests/Test/Lens.hs                       | 59 +++++++++++++++++++
 6 files changed, 193 insertions(+), 2 deletions(-)
 create mode 100644 core/src/Text/Interpolation/Nyan/Lens.hs
 create mode 100644 core/src/Text/Interpolation/Nyan/Lens/TH.hs
 create mode 100644 core/src/Text/Interpolation/Nyan/Lens/Type.hs
 create mode 100644 core/tests/Test/Lens.hs

diff --git a/core/nyan-interpolation-core.cabal b/core/nyan-interpolation-core.cabal
index b4765ae..833a1d9 100644
--- a/core/nyan-interpolation-core.cabal
+++ b/core/nyan-interpolation-core.cabal
@@ -3,8 +3,6 @@ cabal-version: 2.0
 -- This file has been generated from package.yaml by hpack version 0.35.0.
 --
 -- see: https://github.com/sol/hpack
---
--- hash: 454835beb066a76fcd19ff1540bc89d3e2f2732ac9d7164ec5903d0eb782bebd
 
 name:           nyan-interpolation-core
 version:        0.9
@@ -34,6 +32,9 @@ library
       Text.Interpolation.Nyan.Core.Internal.Processor
       Text.Interpolation.Nyan.Core.Internal.RMode
       Text.Interpolation.Nyan.Core.Internal.Splice
+      Text.Interpolation.Nyan.Lens
+      Text.Interpolation.Nyan.Lens.TH
+      Text.Interpolation.Nyan.Lens.Type
       Text.Interpolation.Nyan.RModes.Buildable
       Text.Interpolation.Nyan.RModes.CommonExtra
       Text.Interpolation.Nyan.RModes.Show
@@ -91,6 +92,7 @@ test-suite nyan-interpolation-core-tests
   other-modules:
       Test.Customization
       Test.Interpolator
+      Test.Lens
       Test.Parser
       Test.Processor
       Test.Util
diff --git a/core/src/Text/Interpolation/Nyan/Core/Internal/Base.hs b/core/src/Text/Interpolation/Nyan/Core/Internal/Base.hs
index ecbcde2..a84ee47 100644
--- a/core/src/Text/Interpolation/Nyan/Core/Internal/Base.hs
+++ b/core/src/Text/Interpolation/Nyan/Core/Internal/Base.hs
@@ -10,6 +10,8 @@ import Data.Monoid (Endo (..))
 import Data.Text (Text)
 import Language.Haskell.TH (ExpQ)
 
+import Text.Interpolation.Nyan.Lens (makeLenses)
+
 {- $setup
 
 > import Data.Text
@@ -93,6 +95,8 @@ data SwitchesOptions = SwitchesOptions
   , previewLevel            :: PreviewLevel
   } deriving stock (Show, Eq)
 
+makeLenses ''SwitchesOptions
+
 -- | Default switches options set in the interpolator, those that are used
 -- in @[int||...|]@.
 --
@@ -108,6 +112,8 @@ data DefaultSwitchesOptions = DefaultSwitchesOptions
   , defMonadic                 :: Maybe Bool
   } deriving stock (Show)
 
+makeLenses ''DefaultSwitchesOptions
+
 -- | Default 'DefaultSwitchesOptions'.
 --
 -- This set of switches tries to leave the text as much unmodified as possible.
@@ -175,3 +181,5 @@ data InterpolatorOptions = InterpolatorOptions
     -- with invisibles being marked specially (@!!@), how to update the pieces
     -- of text.
   }
+
+makeLenses ''InterpolatorOptions
diff --git a/core/src/Text/Interpolation/Nyan/Lens.hs b/core/src/Text/Interpolation/Nyan/Lens.hs
new file mode 100644
index 0000000..f0c8b8a
--- /dev/null
+++ b/core/src/Text/Interpolation/Nyan/Lens.hs
@@ -0,0 +1,52 @@
+-- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io/>
+--
+-- SPDX-License-Identifier: MPL-2.0
+
+module Text.Interpolation.Nyan.Lens
+  ( module Text.Interpolation.Nyan.Lens.TH
+  , module Text.Interpolation.Nyan.Lens.Type
+  , (^.)
+
+  , (%~)
+  , (%=)
+
+  , (.~)
+  , (.=)
+
+  , (?~)
+  , (?=)
+
+  , (&~)
+  )
+  where
+
+import Control.Monad.State (MonadState, State, execState, modify)
+import Control.Applicative (Const(..))
+import Data.Functor.Identity (Identity(..))
+
+import Text.Interpolation.Nyan.Lens.TH
+import Text.Interpolation.Nyan.Lens.Type
+
+(^.) :: s -> Getting a s a -> a
+s ^. l = getConst $ l Const s
+
+(%~) :: ASetter s t a b -> (a -> b) -> s -> t
+l %~ f = runIdentity . l (Identity . f)
+
+(%=) :: MonadState s m => ASetter s s a b -> (a -> b) -> m ()
+l %= f = modify (l %~ f)
+
+(.~) :: ASetter s t a b -> b -> s -> t
+l .~ b = runIdentity . l (const $ Identity b)
+
+(.=) :: MonadState s m => ASetter s s a b -> b -> m ()
+l .= b = modify (l .~ b)
+
+(?~) :: ASetter s t a (Maybe b) -> b -> s -> t
+l ?~ b = l .~ (Just b)
+
+(?=) :: MonadState s m => ASetter s s a (Maybe b) -> b -> m ()
+l ?= b = modify (l ?~ b)
+
+(&~) :: s -> State s a -> s
+s &~ l = execState l s
diff --git a/core/src/Text/Interpolation/Nyan/Lens/TH.hs b/core/src/Text/Interpolation/Nyan/Lens/TH.hs
new file mode 100644
index 0000000..b361a43
--- /dev/null
+++ b/core/src/Text/Interpolation/Nyan/Lens/TH.hs
@@ -0,0 +1,53 @@
+-- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io/>
+--
+-- SPDX-License-Identifier: MPL-2.0
+
+module Text.Interpolation.Nyan.Lens.TH
+  ( makeLenses
+  )
+  where
+
+import Control.Monad ((<=<))
+import Language.Haskell.TH
+
+-- | Information about the record field the lenses will operate on.
+type RecordFieldInfo = (Name, Strict, Type)
+
+-- | Given a record datatype, derives lenses for all of its fields.
+makeLenses :: Name -> Q [Dec]
+makeLenses = mapM deriveLens <=< extractRecordFields
+
+extractRecordFields :: Name -> Q [RecordFieldInfo]
+extractRecordFields datatype = do
+  let datatypeStr = nameBase datatype
+  info <- reify datatype
+  return $ case info of
+    TyConI (DataD    _ _ _ _ [RecC _ fs] _) -> fs
+    TyConI (NewtypeD _ _ _ _ (RecC _ fs) _) -> fs
+    TyConI (DataD _ _ _ _ [_] _) ->
+      error $ "Can't derive lenses without record selectors: " ++ datatypeStr
+    TyConI NewtypeD{} ->
+      error $ "Can't derive lenses without record selectors: " ++ datatypeStr
+    TyConI TySynD{} ->
+      error $ "Can't derive lenses for type synonym: " ++ datatypeStr
+    TyConI DataD{} ->
+      error $ "Can't derive lenses for a sum type: " ++ datatypeStr
+    _ ->
+      error $ "Can't derive lenses for: "  ++ datatypeStr
+           ++ ", type name required."
+
+-- | Given a record field name,
+-- produces a single function declaration:
+-- @lensName f a = (\x -> a { field = x }) `fmap` f (field a)@
+deriveLens :: RecordFieldInfo -> Q Dec
+deriveLens (fieldName, _, _) = funD lensName [defLine]
+  where
+    lensName = mkName $ (nameBase fieldName) <> "L"
+    a = mkName "a"
+    f = mkName "f"
+    defLine = clause pats (normalB body) []
+    pats = [varP f, varP a]
+    body = [| (\x -> $(record a fieldName [|x|]))
+              `fmap` $(appE (varE f) (appE (varE fieldName) (varE a)))
+           |]
+    record rec fld val = val >>= \v -> recUpdE (varE rec) [return (fld, v)]
diff --git a/core/src/Text/Interpolation/Nyan/Lens/Type.hs b/core/src/Text/Interpolation/Nyan/Lens/Type.hs
new file mode 100644
index 0000000..d5c28f9
--- /dev/null
+++ b/core/src/Text/Interpolation/Nyan/Lens/Type.hs
@@ -0,0 +1,17 @@
+-- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io/>
+--
+-- SPDX-License-Identifier: MPL-2.0
+
+module Text.Interpolation.Nyan.Lens.Type where
+
+import Control.Applicative (Const)
+import Data.Functor.Identity (Identity)
+
+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 ASetter s t a b = (a -> Identity b) -> s -> Identity t
+type ASetter' s a = ASetter s s a a
+
+type Getting r s a = (a -> Const r a) -> s -> Const r s
+type SimpleGetter s a = forall r. Getting r s a
diff --git a/core/tests/Test/Lens.hs b/core/tests/Test/Lens.hs
new file mode 100644
index 0000000..c54286d
--- /dev/null
+++ b/core/tests/Test/Lens.hs
@@ -0,0 +1,59 @@
+-- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io/>
+--
+-- SPDX-License-Identifier: MPL-2.0
+
+module Test.Lens where
+
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit (testCase, (@?=))
+
+import Text.Interpolation.Nyan.Lens
+
+data Pair = Pair { first :: Int, second :: String }
+  deriving stock (Show, Eq)
+
+$(makeLenses ''Pair)
+
+newtype Single = Single { value :: Maybe String }
+  deriving stock (Show, Eq)
+
+$(makeLenses ''Single)
+
+test_makeLenses :: TestTree
+test_makeLenses = testGroup "Lenses produced by 'makeLenses' work as expected"
+  [ testGroup "Basic lenses operators work as expected"
+      [ testCase "(^.) operator works" do
+          (pair ^. firstL, pair ^. secondL)
+            @?= (100, "Hundred")
+
+      , testCase "(%~) operator works" do
+          pair & (firstL %~ (+ 1)) & (secondL %~ (<> " and one"))
+            @?= Pair 101 "Hundred and one"
+
+      , testCase "(.~) operator works" do
+          pair & (firstL .~ 102) & (secondL .~ "Hundred and two")
+            @?= Pair 102 "Hundred and two"
+
+      , testCase "(?~) operator works" do
+          single & (valueL ?~ "Some value")
+            @?= Single (Just "Some value")
+      ]
+
+  , testGroup "Operators leveraging 'MonadState', 'State' work as expected"
+      [ testCase "(&~) and (.=) work" do
+          (pair &~ do firstL .= 102)
+            @?= Pair 102 "Hundred"
+
+      , testCase "(&~) and (?=) work" do
+          (single &~ do valueL ?= "Some value")
+            @?= Single (Just "Some value")
+
+      , testCase "(&~) and (%=) work" do
+          (single &~ do valueL %= (const $ Just "Some value"))
+            @?= Single (Just "Some value")
+      ]
+  ]
+  where
+    a & f = f a
+    pair = Pair 100 "Hundred"
+    single = Single Nothing