From cbe168c3ec587b3c6d3969a3795bfcbb46ec97c1 Mon Sep 17 00:00:00 2001
From: lrworth <luke@worth.id.au>
Date: Fri, 5 Apr 2024 01:10:05 +1100
Subject: [PATCH] Add instance AsType a a (#149)

* Add instance AsType a a

Resolves #146

* Update ChangeLog.mds

* docs: expand definition of {As,Has}Type; document reflexive instances

* docs: make generic-optics/ChangeLog.md mirror generic-lens/ChangeLog.md

* format: remove trailing newlines
---
 generic-lens/ChangeLog.md                       |  4 ++++
 generic-lens/generic-lens.cabal                 |  3 ++-
 generic-lens/src/Data/Generics/Product/Typed.hs |  4 +++-
 generic-lens/src/Data/Generics/Sum/Typed.hs     |  8 +++++++-
 generic-lens/test/Spec.hs                       |  1 +
 generic-lens/test/Test146.hs                    | 17 +++++++++++++++++
 generic-optics/ChangeLog.md                     |  6 ++++++
 generic-optics/generic-optics.cabal             |  3 ++-
 .../src/Data/Generics/Product/Typed.hs          |  4 +++-
 generic-optics/src/Data/Generics/Sum/Typed.hs   |  8 +++++++-
 generic-optics/test/Spec.hs                     |  1 +
 generic-optics/test/Test146.hs                  | 17 +++++++++++++++++
 12 files changed, 70 insertions(+), 6 deletions(-)
 create mode 100644 generic-lens/test/Test146.hs
 create mode 100644 generic-optics/test/Test146.hs

diff --git a/generic-lens/ChangeLog.md b/generic-lens/ChangeLog.md
index 08cc599..6ad73f8 100644
--- a/generic-lens/ChangeLog.md
+++ b/generic-lens/ChangeLog.md
@@ -2,6 +2,10 @@
 - Add `OverloadedLabels` support for positional lenses, e.g. `#3` as an
   abbreviation for `position @3`, starting with GHC 9.6.
 
+### Breaking API changes:
+- `AsType` now includes a reflexive case for consistency with `HasType`: every
+  type can be treated 'as' itself.
+
 ## generic-lens-2.2.2.0 (2023-04-15)
 - Support unprefixed constructor prisms on GHC 9.6 (#152)
 
diff --git a/generic-lens/generic-lens.cabal b/generic-lens/generic-lens.cabal
index b7bc101..2b05ed8 100644
--- a/generic-lens/generic-lens.cabal
+++ b/generic-lens/generic-lens.cabal
@@ -69,11 +69,12 @@ test-suite inspection-tests
   type:               exitcode-stdio-1.0
   hs-source-dirs:     test
   main-is:            Spec.hs
-  other-modules:      Util Test24 Test88 Test25 Test40 Test62 Test63 CustomChildren
+  other-modules:      Util Test24 Test88 Test25 Test40 Test62 Test63 Test146 CustomChildren
 
   build-depends:      base
                     , generic-lens
                     , lens
+                    , mtl
                     , profunctors
                     , inspection-testing >= 0.2
                     , HUnit
diff --git a/generic-lens/src/Data/Generics/Product/Typed.hs b/generic-lens/src/Data/Generics/Product/Typed.hs
index 969ddf8..b543b04 100644
--- a/generic-lens/src/Data/Generics/Product/Typed.hs
+++ b/generic-lens/src/Data/Generics/Product/Typed.hs
@@ -57,7 +57,8 @@ import "generic-lens-core" Data.Generics.Internal.Void
 -- human = Human "Tunyasz" 50 "London" False
 -- :}
 
--- |Records that have a field with a unique type.
+-- |Types that contain another type, either by being a record with a field
+-- with that type, or by actually being that type.
 class HasType a s where
   -- |A lens that focuses on a field with a unique type in its parent type.
   --  Compatible with the lens package's 'Control.Lens.Lens' type.
@@ -102,6 +103,7 @@ instance Core.Context a s => HasType a s where
   typed = VL.ravel Core.derived
   {-# INLINE typed #-}
 
+-- |Every type 'has' itself.
 instance {-# OVERLAPPING #-} HasType a a where
     getTyped = id
     {-# INLINE getTyped #-}
diff --git a/generic-lens/src/Data/Generics/Sum/Typed.hs b/generic-lens/src/Data/Generics/Sum/Typed.hs
index 54f37eb..ca3c79d 100644
--- a/generic-lens/src/Data/Generics/Sum/Typed.hs
+++ b/generic-lens/src/Data/Generics/Sum/Typed.hs
@@ -64,7 +64,8 @@ import "generic-lens-core" Data.Generics.Internal.Void
 -- :}
 
 
--- |Sums that have a constructor with a field of the given type.
+-- |Types that can represent another type, either by being a sum with a
+-- constructor containing that type, or by actually being that type.
 class AsType a s where
   -- |A prism that projects a constructor uniquely identifiable by the type of
   --  its field. Compatible with the lens package's 'Control.Lens.Prism' type.
@@ -97,6 +98,11 @@ class AsType a s where
 
   {-# MINIMAL (injectTyped, projectTyped) | _Typed #-}
 
+-- |Every type can be treated 'as' itself.
+instance {-# OVERLAPPING #-} AsType a a where
+  injectTyped = id
+  projectTyped = Just
+
 instance Core.Context a s => AsType a s where
   _Typed eta = prism2prismvl Core.derived eta
   {-# INLINE _Typed #-}
diff --git a/generic-lens/test/Spec.hs b/generic-lens/test/Spec.hs
index 0f64a86..7414026 100644
--- a/generic-lens/test/Spec.hs
+++ b/generic-lens/test/Spec.hs
@@ -33,6 +33,7 @@ import Data.Generics.Labels ()
 import Test24 ()
 import Test25 ()
 import Test88 ()
+import Test146 ()
 
 import CustomChildren (customTypesTest)
 
diff --git a/generic-lens/test/Test146.hs b/generic-lens/test/Test146.hs
new file mode 100644
index 0000000..0b31f95
--- /dev/null
+++ b/generic-lens/test/Test146.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module Test146 where
+
+import Control.Monad.Except
+import Data.Generics.Sum
+import GHC.Generics
+
+data Error = Error
+  deriving (Generic)
+
+poly :: (AsType Error e, MonadError e m) => m ()
+poly = undefined
+
+mono :: ExceptT Error IO ()
+mono = poly
diff --git a/generic-optics/ChangeLog.md b/generic-optics/ChangeLog.md
index 5d7f9ad..6d29789 100644
--- a/generic-optics/ChangeLog.md
+++ b/generic-optics/ChangeLog.md
@@ -1,3 +1,9 @@
+## Unreleased
+
+### Breaking API changes:
+- `AsType` now includes a reflexive case for consistency with `HasType`: every
+  type can be treated 'as' itself.
+
 ## generic-optics-2.2.1.0 (2022-01-22)
 - GHC 9.2 compatibility
 
diff --git a/generic-optics/generic-optics.cabal b/generic-optics/generic-optics.cabal
index 53a3444..96135b0 100644
--- a/generic-optics/generic-optics.cabal
+++ b/generic-optics/generic-optics.cabal
@@ -65,10 +65,11 @@ test-suite generic-optics-inspection-tests
   type:               exitcode-stdio-1.0
   hs-source-dirs:     test
   main-is:            Spec.hs
-  other-modules:      Util Test24 Test88 Test25 Test40 Test62 Test63 CustomChildren
+  other-modules:      Util Test24 Test88 Test25 Test40 Test62 Test63 Test146 CustomChildren
 
   build-depends:      base
                     , generic-optics
+                    , mtl
                     , optics-core
                     , inspection-testing >= 0.2
                     , HUnit
diff --git a/generic-optics/src/Data/Generics/Product/Typed.hs b/generic-optics/src/Data/Generics/Product/Typed.hs
index 3b3f5a9..0945f74 100644
--- a/generic-optics/src/Data/Generics/Product/Typed.hs
+++ b/generic-optics/src/Data/Generics/Product/Typed.hs
@@ -59,7 +59,8 @@ import "generic-lens-core" Data.Generics.Internal.Void
 -- human = Human "Tunyasz" 50 "London" False
 -- :}
 
--- |Records that have a field with a unique type.
+-- |Types that contain another type, either by being a record with a field
+-- with that type, or by actually being that type.
 class HasType a s where
   -- |A lens that focuses on a field with a unique type in its parent type.
   --
@@ -103,6 +104,7 @@ instance Core.Context a s => HasType a s where
   typed = normaliseLens (Optic Core.derived)
   {-# INLINE typed #-}
 
+-- |Every type 'has' itself.
 instance {-# OVERLAPPING #-} HasType a a where
     getTyped = id
     {-# INLINE getTyped #-}
diff --git a/generic-optics/src/Data/Generics/Sum/Typed.hs b/generic-optics/src/Data/Generics/Sum/Typed.hs
index 56db6a4..3d77103 100644
--- a/generic-optics/src/Data/Generics/Sum/Typed.hs
+++ b/generic-optics/src/Data/Generics/Sum/Typed.hs
@@ -64,7 +64,8 @@ import "generic-lens-core" Data.Generics.Internal.Void
 -- :}
 
 
--- |Sums that have a constructor with a field of the given type.
+-- |Types that can represent another type, either by being a sum with a
+-- constructor containing that type, or by actually being that type.
 class AsType a s where
   -- |A prism that projects a constructor uniquely identifiable by the type of
   --  its field.
@@ -97,6 +98,11 @@ class AsType a s where
 
   {-# MINIMAL (injectTyped, projectTyped) | _Typed #-}
 
+-- |Every type can be treated 'as' itself.
+instance {-# OVERLAPPING #-} AsType a a where
+  injectTyped = id
+  projectTyped = Just
+
 instance Core.Context a s => AsType a s where
   _Typed = normalisePrism (Optic Core.derived)
   {-# INLINE _Typed #-}
diff --git a/generic-optics/test/Spec.hs b/generic-optics/test/Spec.hs
index 62bfa24..a5b7604 100644
--- a/generic-optics/test/Spec.hs
+++ b/generic-optics/test/Spec.hs
@@ -29,6 +29,7 @@ import Optics.Core
 -- This is sufficient at we only want to test that they typecheck
 import Test24 ()
 import Test25 ()
+import Test146 ()
 
 -- import CustomChildren (customTypesTest)
 
diff --git a/generic-optics/test/Test146.hs b/generic-optics/test/Test146.hs
new file mode 100644
index 0000000..0b31f95
--- /dev/null
+++ b/generic-optics/test/Test146.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module Test146 where
+
+import Control.Monad.Except
+import Data.Generics.Sum
+import GHC.Generics
+
+data Error = Error
+  deriving (Generic)
+
+poly :: (AsType Error e, MonadError e m) => m ()
+poly = undefined
+
+mono :: ExceptT Error IO ()
+mono = poly