From 26f7b12cd1d893a9214affad7900a0e3eac5eaa9 Mon Sep 17 00:00:00 2001
From: Kirill Elagin <kirelagin@gmail.com>
Date: Tue, 14 Aug 2018 04:43:27 +0300
Subject: [PATCH] LTB-39 Reorganise HasLens to make naming more predictable

* Bring the naming of `HasLens` & Co into line with the `lens` lib:
    * Rename weird `HasLens` to `HasTaggedLens`
    * Add `HasLens` that can change the type
* Add `HasTaggedGetter` and similarly `HasGetter`
* Create a relationship between `HasLens` and `HasGetter`
  (probably we should add `HasSetter` as well, make it a superclass
  of `HasLens` with a default implementation and then provide a
  default implementation for `HasLens` in terms of the other two).

This change breaks Log and Network. Fixes for them are coming in a
future commit.
---
 code/base/lib/Loot/Base/HasLens.hs  | 57 +++++++++++++++++++++++------
 code/base/package.yaml              |  1 +
 code/config/lib/Loot/Config/Lens.hs | 14 ++++---
 3 files changed, 55 insertions(+), 17 deletions(-)

diff --git a/code/base/lib/Loot/Base/HasLens.hs b/code/base/lib/Loot/Base/HasLens.hs
index 2f211c3..357c131 100644
--- a/code/base/lib/Loot/Base/HasLens.hs
+++ b/code/base/lib/Loot/Base/HasLens.hs
@@ -1,33 +1,66 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE ConstraintKinds     #-}
 {-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE DefaultSignatures   #-}
 {-# LANGUAGE TypeFamilies        #-}
 {-# LANGUAGE TypeOperators       #-}
 
 -- | Basic "has" lenses, extracted from the 'ether' package.
 module Loot.Base.HasLens
-    ( HasLens(..)
+    ( HasTaggedGetter (getterOf)
+    , HasGetter
+
+    , HasTaggedLens (lensOf)
+    , HasLens
     , HasLens'
-    , HasLenses
-    , HasCtx
+
+    , HasLenses'
+
+    , HasCtx'
     ) where
 
 import Data.Coerce (coerce)
 import Data.Tagged (Tagged (..))
+import Lens.Micro (SimpleGetter)
+
+
+-- | Class for those @s@ that contain read-only @a@ in them.
+--
+-- You can use the default implementation of this class if
+-- you implement 'HasLens'.
+class HasTaggedGetter tag s a | tag s -> a where
+    getterOf :: SimpleGetter s a
+
+    default getterOf :: HasTaggedLens tag s s a a => SimpleGetter s a
+    getterOf = lensOf @tag
+
+instance HasTaggedGetter a a a where
+    getterOf = id
 
-class HasLens tag outer inner | tag outer -> inner where
-    lensOf :: Lens' outer inner
+instance HasTaggedGetter t (Tagged t a) a where
+    getterOf = \f -> fmap coerce . f . coerce
 
-instance HasLens a a a where
+type HasGetter s a = HasTaggedGetter a s a
+
+
+-- | Class for those @s@ that contain a modifiable @a@ in them.
+class HasTaggedGetter tag s a => HasTaggedLens tag s t a b | tag s b -> t a where
+    lensOf :: Lens s t a b
+
+instance HasTaggedLens a a a a a where
     lensOf = id
 
-instance HasLens t (Tagged t a) a where
+instance HasTaggedLens t (Tagged t a) (Tagged t b) a b where
     lensOf = \f -> fmap coerce . f . coerce
 
-type HasLens' s a = HasLens a s a
+type HasLens s t a b = HasTaggedLens a s t a b
+
+type HasLens' s a = HasLens s s a a
+
+
+type family HasLenses' s as :: Constraint where
+    HasLenses' s '[] = ()
+    HasLenses' s (a : as) = (HasLens' s a, HasLenses' s as)
 
-type family HasLenses s as :: Constraint where
-    HasLenses s '[] = ()
-    HasLenses s (a : as) = (HasLens' s a, HasLenses s as)
 
-type HasCtx ctx m subs = (MonadReader ctx m, HasLenses ctx subs)
+type HasCtx' ctx m subs = (MonadReader ctx m, HasLenses' ctx subs)
diff --git a/code/base/package.yaml b/code/base/package.yaml
index dd597ba..04de5b2 100644
--- a/code/base/package.yaml
+++ b/code/base/package.yaml
@@ -6,6 +6,7 @@ library:
   <<: *lib-common
 
   dependencies:
+    - microlens
     - tagged
 
 tests:
diff --git a/code/config/lib/Loot/Config/Lens.hs b/code/config/lib/Loot/Config/Lens.hs
index b3db660..e31d6c9 100644
--- a/code/config/lib/Loot/Config/Lens.hs
+++ b/code/config/lib/Loot/Config/Lens.hs
@@ -16,7 +16,7 @@ module Loot.Config.Lens
 import Data.Vinyl (Label (..))
 import GHC.TypeLits (ErrorMessage (Text), Symbol, TypeError)
 
-import Loot.Base.HasLens (HasLens (..))
+import Loot.Base.HasLens (HasTaggedGetter (..), HasTaggedLens (..))
 import Loot.Config.Record
 
 ----------------------------------------------------------------------------
@@ -91,14 +91,18 @@ instance (HasSub l is us, HierarchyLens lx us v) =>
             (hlens @lx :: Lens' (ConfigRec 'Final us) v)
 
 ----------------------------------------------------------------------------
--- HasLens Instance
+-- HasTaggedLens Instance
 ----------------------------------------------------------------------------
 
-instance
-         ( ItemTypeUnique v is
+instance ( ItemTypeUnique v is
          , HierarchyLens (LabelOfTypeS v is) is v
          ) =>
-         HasLens v (ConfigRec 'Final is) v where
+         HasTaggedGetter v (ConfigRec 'Final is) v
+
+instance ( ItemTypeUnique v is
+         , HierarchyLens (LabelOfTypeS v is) is v
+         ) =>
+         HasTaggedLens v (ConfigRec 'Final is) (ConfigRec 'Final is) v v where
     lensOf = hlens @(LabelOfTypeS v is)
 
 -- | Like 'HasLens', but with record key.