[Git][ghc/ghc][master] Add regression test for #16234

[Marge Bot (@marge-bot)]

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
fa66fa64 by Ryan Scott at 2024-11-14T19:05:00-05:00
Add regression test for #16234

Issue #16234 was likely fixed by !9765. This adds a regression test to ensure
that it remains fixed.

Fixes #16234.

- - - - -


10 changed files:

- + testsuite/tests/typecheck/should_compile/T16234/ControlMonadClasses.hs
- + testsuite/tests/typecheck/should_compile/T16234/ControlMonadClassesCore.hs
- + testsuite/tests/typecheck/should_compile/T16234/ControlMonadClassesEffects.hs
- + testsuite/tests/typecheck/should_compile/T16234/ControlMonadClassesReader.hs
- + testsuite/tests/typecheck/should_compile/T16234/ControlMonadClassesState.hs
- + testsuite/tests/typecheck/should_compile/T16234/ControlMonadPrimitive.hs
- + testsuite/tests/typecheck/should_compile/T16234/DataPeano.hs
- + testsuite/tests/typecheck/should_compile/T16234/Main.hs
- + testsuite/tests/typecheck/should_compile/T16234/Makefile
- + testsuite/tests/typecheck/should_compile/T16234/all.T


Changes:

=====================================
testsuite/tests/typecheck/should_compile/T16234/ControlMonadClasses.hs
=====================================
@@ -0,0 +1,7 @@
+module ControlMonadClasses
+  ( -- * Reader
+    MonadReader
+  ) where
+
+import ControlMonadClassesReader
+import ControlMonadClassesState ()


=====================================
testsuite/tests/typecheck/should_compile/T16234/ControlMonadClassesCore.hs
=====================================
@@ -0,0 +1,23 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+module ControlMonadClassesCore where
+
+import Data.Kind (Type)
+import DataPeano
+
+type family CanDo (m :: Type -> Type) (eff :: k) :: Bool
+
+type family MapCanDo (eff :: k) (stack :: Type -> Type) :: [Bool] where
+  MapCanDo eff (t m) = CanDo (t m) eff ': MapCanDo eff m
+  MapCanDo eff m = '[ CanDo m eff ]
+
+type family FindTrue
+  (bs :: [Bool])
+  :: Peano
+  where
+  FindTrue ('True ': t) = 'Zero
+  FindTrue ('False ': t) = 'Succ (FindTrue t)
+
+type Find eff (m :: Type -> Type) =
+  FindTrue (MapCanDo eff m)


=====================================
testsuite/tests/typecheck/should_compile/T16234/ControlMonadClassesEffects.hs
=====================================
@@ -0,0 +1,5 @@
+module ControlMonadClassesEffects where
+
+import Data.Kind (Type)
+
+data EffReader (e :: Type)


=====================================
testsuite/tests/typecheck/should_compile/T16234/ControlMonadClassesReader.hs
=====================================
@@ -0,0 +1,17 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+module ControlMonadClassesReader where
+
+import qualified Control.Monad.Trans.State.Lazy as SL
+import ControlMonadClassesCore
+import ControlMonadClassesEffects
+import Control.Monad.Trans.Class
+import Data.Kind (Type)
+import DataPeano
+
+class Monad m => MonadReaderN (n :: Peano) (r :: Type) m
+instance Monad m => MonadReaderN 'Zero r (SL.StateT r m)
+instance (MonadTrans t, Monad (t m), MonadReaderN n r m, Monad m)
+  => MonadReaderN ('Succ n) r (t m)
+
+type MonadReader e m = MonadReaderN (Find (EffReader e) m) e m


=====================================
testsuite/tests/typecheck/should_compile/T16234/ControlMonadClassesState.hs
=====================================
@@ -0,0 +1,13 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+module ControlMonadClassesState where
+
+import qualified Control.Monad.Trans.State.Lazy as SL
+import ControlMonadClassesCore
+import ControlMonadClassesEffects
+
+type instance CanDo (SL.StateT s m) eff = StateCanDo s eff
+
+type family StateCanDo s eff where
+  StateCanDo s (EffReader s) = 'True
+  StateCanDo s eff = 'False


=====================================
testsuite/tests/typecheck/should_compile/T16234/ControlMonadPrimitive.hs
=====================================
@@ -0,0 +1,9 @@
+{-# LANGUAGE TypeFamilies #-}
+module ControlMonadPrimitive (PrimMonad(..)) where
+
+import Control.Monad.Trans.State (StateT)
+
+class Monad m => PrimMonad m where
+  type PrimState m
+instance PrimMonad m => PrimMonad (StateT s m) where
+  type PrimState (StateT s m) = PrimState m


=====================================
testsuite/tests/typecheck/should_compile/T16234/DataPeano.hs
=====================================
@@ -0,0 +1,3 @@
+module DataPeano where
+
+data Peano = Zero | Succ Peano


=====================================
testsuite/tests/typecheck/should_compile/T16234/Main.hs
=====================================
@@ -0,0 +1,9 @@
+{-# LANGUAGE TypeFamilies #-}
+module Main where
+
+import ControlMonadClasses (MonadReader)
+--import ControlMonadPrimitive ()
+import Control.Monad.Trans.State.Lazy (StateT)
+
+main :: (n ~ StateT () IO, MonadReader () n) => IO ()
+main = undefined


=====================================
testsuite/tests/typecheck/should_compile/T16234/Makefile
=====================================
@@ -0,0 +1,17 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+clean:
+	rm -f *.o *.hi
+
+T16234:
+	$(MAKE) -s --no-print-directory clean
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c DataPeano.hs
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c ControlMonadPrimitive.hs
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c ControlMonadClassesCore.hs
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c ControlMonadClassesEffects.hs
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c ControlMonadClassesReader.hs
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c ControlMonadClassesState.hs
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c ControlMonadClasses.hs
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c Main.hs


=====================================
testsuite/tests/typecheck/should_compile/T16234/all.T
=====================================
@@ -0,0 +1 @@
+test('T16234', [extra_files(['DataPeano.hs', 'ControlMonadPrimitive.hs', 'ControlMonadClassesCore.hs', 'ControlMonadClassesEffects.hs', 'ControlMonadClassesReader.hs', 'ControlMonadClassesState.hs', 'ControlMonadClasses.hs', 'Main.hs'])], makefile_test, ['T16234'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fa66fa64f27c6069a618dada0b4414f31d37a575

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fa66fa64f27c6069a618dada0b4414f31d37a575
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20241114/f8ffa906/attachment-0001.html>