[LTB-39] Reorganise HasLens to make naming more predictable

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)

code/base/package.yaml

@@ -6,6 +6,7 @@ library:
   <<: *lib-common
 
   dependencies:
+    - microlens
     - tagged
 
 tests:

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.