Add instance AsType a a

Resolves #146
kcsongor · Oct 7, 2022 · 03c17bb · 03c17bb
1 parent e5a3907
commit 03c17bb
Show file tree

Hide file tree

Showing 8 changed files with 53 additions and 2 deletions.
diff --git a/generic-lens/generic-lens.cabal b/generic-lens/generic-lens.cabal
@@ -57,11 +57,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          >= 4.11 && <= 5.0
                     , generic-lens
                     , lens
+                    , mtl
                     , profunctors
                     , inspection-testing >= 0.2
                     , HUnit

diff --git a/generic-lens/src/Data/Generics/Sum/Typed.hs b/generic-lens/src/Data/Generics/Sum/Typed.hs
@@ -97,6 +97,10 @@ class AsType a s where
 
   {-# MINIMAL (injectTyped, projectTyped) | _Typed #-}
 
+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
@@ -32,6 +32,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
@@ -0,0 +1,19 @@
+{-# 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/generic-optics.cabal b/generic-optics/generic-optics.cabal
@@ -54,10 +54,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          >= 4.11 && <= 5.0
                     , generic-optics
+                    , mtl
                     , optics-core
                     , inspection-testing >= 0.2
                     , HUnit

diff --git a/generic-optics/src/Data/Generics/Sum/Typed.hs b/generic-optics/src/Data/Generics/Sum/Typed.hs
@@ -97,6 +97,10 @@ class AsType a s where
 
   {-# MINIMAL (injectTyped, projectTyped) | _Typed #-}
 
+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
@@ -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
@@ -0,0 +1,20 @@
+{-# 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
+
+
+