Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: e7054934 by Simon Jakobi at 2026-03-11T15:05:16-04:00 Add regression test for #12694 Closes #12694. - - - - - 4756d9f6 by Simon Jakobi at 2026-03-11T15:05:16-04:00 Add regression test for #16275 Closes #16275. - - - - - 34b7e2c1 by Simon Jakobi at 2026-03-11T15:05:16-04:00 Add regression test for #14908 Closes #14908. - - - - - 4243db3d by Simon Jakobi at 2026-03-11T15:05:16-04:00 Add regression test for #14151 Closes #14151. - - - - - 0e9f1453 by Simon Jakobi at 2026-03-11T15:05:16-04:00 Add regression test for #12640 Closes #12640. - - - - - ae606c7f by Simon Jakobi at 2026-03-11T15:05:16-04:00 Add regression test for #15588 Closes #15588. - - - - - 5a38ce4e by Simon Jakobi at 2026-03-11T15:05:16-04:00 Add regression test for #9445 Closes #9445. - - - - - 18 changed files: - + testsuite/tests/dependent/should_fail/T15588.hs - + testsuite/tests/dependent/should_fail/T15588.stderr - testsuite/tests/dependent/should_fail/all.T - + testsuite/tests/simplCore/should_compile/T12640.hs - + testsuite/tests/simplCore/should_compile/T12640.stderr - + testsuite/tests/simplCore/should_compile/T14908.hs - + testsuite/tests/simplCore/should_compile/T14908_Deps.hs - + testsuite/tests/simplCore/should_compile/T9445.hs - testsuite/tests/simplCore/should_compile/all.T - + testsuite/tests/typecheck/should_compile/T14151.hs - testsuite/tests/typecheck/should_compile/all.T - + testsuite/tests/typecheck/should_fail/T12694.hs - + testsuite/tests/typecheck/should_fail/T12694.stderr - + testsuite/tests/typecheck/should_fail/T16275.stderr - + testsuite/tests/typecheck/should_fail/T16275A.hs - + testsuite/tests/typecheck/should_fail/T16275B.hs - + testsuite/tests/typecheck/should_fail/T16275B.hs-boot - testsuite/tests/typecheck/should_fail/all.T Changes: ===================================== testsuite/tests/dependent/should_fail/T15588.hs ===================================== @@ -0,0 +1,25 @@ +{- This program used to cause a panic (#15588), but it should possibly even be +accepted. See #15589. -} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module T15588 where + +import Data.Proxy +import Data.Type.Equality +import Data.Type.Bool +import Data.Kind + +data SameKind :: forall k. k -> k -> Type +type family IfK (e :: Proxy (j :: Bool)) (f :: m) (g :: n) :: If j m n where + IfK (_ :: Proxy True) f _ = f + IfK (_ :: Proxy False) _ g = g + +y :: forall ck (c :: ck). ck :~: Proxy True -> () +y Refl = let x :: forall a b (d :: a). SameKind (IfK c b d) d + x = undefined + in () + ===================================== testsuite/tests/dependent/should_fail/T15588.stderr ===================================== @@ -0,0 +1,7 @@ +T15588.hs:18:9: error: [GHC-25897] + • Couldn't match kind ‘j’ with ‘True’ + Expected kind ‘Proxy j’, + but ‘_ :: Proxy True’ has kind ‘Proxy True’ + • In the first argument of ‘IfK’, namely ‘(_ :: Proxy True)’ + In the type family declaration for ‘IfK’ + ===================================== testsuite/tests/dependent/should_fail/all.T ===================================== @@ -34,6 +34,7 @@ test('T15215', normal, compile_fail, ['']) test('T15308', normal, compile_fail, ['-fno-print-explicit-kinds']) test('T15343', normal, compile_fail, ['']) test('T15380', normal, compile_fail, ['']) +test('T15588', normal, compile_fail, ['']) test('T15591b', normal, compile_fail, ['']) test('T15591c', normal, compile_fail, ['']) test('T15743c', normal, compile_fail, ['']) ===================================== testsuite/tests/simplCore/should_compile/T12640.hs ===================================== @@ -0,0 +1,18 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} +module T12640 where + +class Ex2 a b c | a b -> c where + (+++) :: a -> b -> c + +instance Ex2 Bool Bool Bool where + (+++) = ex_or + +{-# INLINE [2] ex_or #-} +ex_or = (||) + +{-# RULES +"force-inline" forall a b . ex_or a b = a || b + #-} + +main = print (True +++ True) + ===================================== testsuite/tests/simplCore/should_compile/T12640.stderr ===================================== @@ -0,0 +1,2 @@ +Rule fired: Class op show (BUILTIN) +Rule fired: force-inline (T12640) ===================================== testsuite/tests/simplCore/should_compile/T14908.hs ===================================== @@ -0,0 +1,58 @@ +{-# LANGUAGE OverloadedStrings, LambdaCase #-} +import Data.String +import T14908_Deps +import Data.List (nub, sort) +import System.Environment + +data Expr = Var String | Not Expr | Expr :|: Expr | Expr :&: Expr deriving Eq + +nfd e = if e == e' then e else nfd e' + where e' = rec e + rec x@(Var _) = x + rec x@(Not (Var _)) = x + rec (Not (Not x)) = x + rec (Not (a :|: b)) = rec $ Not a :&: Not b + rec (Not (a :&: b)) = rec $ Not a :|: Not b + rec ((a :|: b) :&: c) = rec $ (a :&: c) :|: (b :&: c) + rec (a :&: (b :|: c)) = rec $ (a :&: b) :|: (a :&: c) + rec (a :&: b) = rec a :&: rec b + rec (a :|: b) = rec a :|: rec b + +eval :: Expr -> Reader [(String, Bool)] Bool +eval (Var x) = asks (lookup x) >>= maybe (error $ "Var `" ++ x ++ "` not defined!") return +eval (Not x) = not <$> eval x +eval (a :&: b) = (&&) <$> eval a <*> eval b +eval (a :|: b) = (||) <$> eval a <*> eval b + +instance Show Expr where + show (Var x) = x + show (Not (Var x)) = "¬" ++ x + show (Not x) = "¬(" ++ show x ++ ")" + show (a :|: b) = show' a ++ " ∨ " ++ show' b where show' c@(_ :&: _) = "(" ++ show c ++ ")"; show' c = show c + show (a :&: b) = show' a ++ " ∧ " ++ show' b where show' c@(_ :|: _) = "(" ++ show c ++ ")"; show' c = show c + +instance IsString Expr where + fromString = Var + +fullImage e = (runReader (eval e) . zipWith (,) vs) <$> bits (length vs) + where vs = nub $ sort $ vars e + vars (Var x) = [x] + vars (Not x) = vars x + vars (a :&: b) = vars a ++ vars b + vars (a :|: b) = vars a ++ vars b + bits 0 = [[]] + bits n = ((False:) <$> xs) ++ ((True:) <$> xs) where xs = bits (n - 1) + +testNFD e = fullImage e == fullImage (nfd e) + +instance Arbitrary Expr where + arbitrary = sized gen + where gen n = choose (1, max 1 (min 4 n)) >>= \case + 1 -> (Var . (:"") . (['a'..]!!)) <$> choose (1, 5) -- no más de 5 vars + 2 -> (:&:) <$> gen (n-1) <*> gen (n-1) + 3 -> (:|:) <$> gen (n-1) <*> gen (n-1) + 4 -> Not <$> gen (n-1) + +main = do + [a,b] <- map (read :: String -> Int) <$> getArgs + quickCheckWith (stdArgs {maxSize = fromIntegral 10, maxSuccess = fromIntegral 1000}) testNFD ===================================== testsuite/tests/simplCore/should_compile/T14908_Deps.hs ===================================== @@ -0,0 +1,100 @@ +module T14908_Deps + ( Reader + , runReader + , asks + , Arbitrary(..) + , Gen + , sized + , choose + , Args(..) + , stdArgs + , quickCheckWith + ) where + +import System.CPUTime (getCPUTime) + +newtype Reader r a = Reader { runReader :: r -> a } + +instance Functor (Reader r) where + fmap f (Reader g) = Reader (f . g) + +instance Applicative (Reader r) where + pure x = Reader (\_ -> x) + Reader f <*> Reader g = Reader (\r -> f r (g r)) + +instance Monad (Reader r) where + return = pure + Reader g >>= f = Reader (\r -> runReader (f (g r)) r) + +asks :: (r -> a) -> Reader r a +asks f = Reader f + +newtype Gen a = Gen { runGen :: Int -> Int -> (a, Int) } + +instance Functor Gen where + fmap f (Gen g) = Gen $ \n s -> + let (x, s') = g n s + in (f x, s') + +instance Applicative Gen where + pure x = Gen (\_ s -> (x, s)) + Gen f <*> Gen g = Gen $ \n s -> + let (h, s1) = f n s + (x, s2) = g n s1 + in (h x, s2) + +instance Monad Gen where + return = pure + Gen g >>= f = Gen $ \n s -> + let (x, s1) = g n s + in runGen (f x) n s1 + +class Arbitrary a where + arbitrary :: Gen a + +sized :: (Int -> Gen a) -> Gen a +sized f = Gen $ \n s -> runGen (f n) n s + +choose :: (Int, Int) -> Gen Int +choose (lo, hi) = Gen $ \_ s -> + let s' = nextSeed s + width = hi - lo + 1 + offset = if width <= 0 then 0 else abs s' `mod` width + in (lo + offset, s') + +data Args = Args + { maxSize :: Int + , maxSuccess :: Int + } + +stdArgs :: Args +stdArgs = Args + { maxSize = 100 + , maxSuccess = 100 + } + +quickCheckWith :: (Arbitrary a, Show a) => Args -> (a -> Bool) -> IO () +quickCheckWith args prop = do + seed0 <- seedFromCPUTime + loop 0 seed0 + where + total = max 0 (maxSuccess args) + maxN = max 1 (maxSize args) + + loop n seed + | n >= total = putStrLn ("+++ OK, passed " ++ show total ++ " tests.") + | otherwise = + let size = (n `mod` maxN) + 1 + (x, seed') = runGen arbitrary size seed + in if prop x + then loop (n + 1) seed' + else putStrLn ("*** Failed! Falsified with input: " ++ show x) + +seedFromCPUTime :: IO Int +seedFromCPUTime = do + t <- getCPUTime + return (fromInteger (t `mod` 2147483647)) + +nextSeed :: Int -> Int +nextSeed x = + fromInteger ((1103515245 * toInteger x + 12345) `mod` 2147483647) ===================================== testsuite/tests/simplCore/should_compile/T9445.hs ===================================== @@ -0,0 +1,13 @@ +module T9445 (Transform) where + +data Transform = Transform + { m00 :: !Float, m10 :: !Float, m20 :: !Float + , m01 :: !Float, m11 :: !Float, m21 :: !Float + , m02 :: !Float, m12 :: !Float, m22 :: !Float + } + +instance Num Transform where + abs (Transform a00 a01 a02 a03 a04 a05 a06 a07 a08) = + (Transform (abs a00) (abs a01) (abs a02) (abs a03) + (abs a04) (abs a05) (abs a06) (abs a07) (abs a08)) + ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -190,6 +190,7 @@ test('T9400', only_ways(['optasm']), compile, ['-O0 -ddump-simpl -dsuppress-uniq test('T9441a', [only_ways(['optasm']), check_errmsg(r'f1 = f2') ], compile, ['-ddump-simpl -dsuppress-ticks']) test('T9441b', [only_ways(['optasm']), check_errmsg(r'Rec {') ], compile, ['-ddump-simpl']) test('T9441c', [only_ways(['optasm']), check_errmsg(r'Rec {') ], compile, ['-ddump-simpl']) +test('T9445', only_ways(['optasm']), compile, ['-Wno-missing-methods']) test('T9583', only_ways(['optasm']), compile, ['']) test('T9565', only_ways(['optasm']), compile, ['']) test('T5821', only_ways(['optasm']), compile, ['']) @@ -227,6 +228,7 @@ test('T9509', test('T12603', normal, makefile_test, ['T12603']) +test('T12640', [grep_errmsg(r'force-inline')], compile, ['-O2 -ddump-rule-firings']) test('T12877', normal, makefile_test, ['T12877']) test('T13027', normal, compile, ['']) test('T13025', @@ -279,6 +281,7 @@ test('T14152a', [extra_files(['T14152.hs']), pre_cmd('cp T14152.hs T14152a.hs'), compile, ['-fno-exitification -ddump-simpl']) test('T13990', normal, compile, ['-dcore-lint -O']) test('T14650', normal, compile, ['-O2']) +test('T14908', normal, multimod_compile, ['T14908', '-O2 -v0']) test('T14959', normal, compile, ['-O']) test('T14978', normal, ===================================== testsuite/tests/typecheck/should_compile/T14151.hs ===================================== @@ -0,0 +1,20 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +module T14151 where + +newtype HFix h a = HFix (h (HFix h) a) + +class EqForall f where + eqForall :: f a -> f a -> Bool + +class EqHetero h where + eqHetero :: (forall x. f x -> f x -> Bool) -> h f a -> h f a -> Bool + +instance EqHetero h => EqForall (HFix h) where + eqForall (HFix a) (HFix b) = eqHetero eqForall a b + +instance EqHetero h => Eq (HFix h a) where + (==) = eqForall ===================================== testsuite/tests/typecheck/should_compile/all.T ===================================== @@ -601,6 +601,7 @@ test('T13915b', expect_broken(15245), compile, ['']) test('T13984', normal, compile, ['']) test('T14128', normal, multimod_compile, ['T14128Main', '-v0']) test('T14149', normal, compile_fail, ['']) +test('T14151', normal, compile, ['']) test('T14154', normal, compile, ['']) test('T14158', normal, compile, ['']) test('T13943', normal, compile, ['-fsolve-constant-dicts']) ===================================== testsuite/tests/typecheck/should_fail/T12694.hs ===================================== @@ -0,0 +1,5 @@ +{-# LANGUAGE GADTs #-} +module T12694 where + +f :: Bool ~ Int => a -> b +f x = x ===================================== testsuite/tests/typecheck/should_fail/T12694.stderr ===================================== @@ -0,0 +1,20 @@ +T12694.hs:5:7: error: [GHC-25897] + • Could not deduce ‘a ~ b’ + from the context: Bool ~ Int + bound by the type signature for: + f :: forall a b. (Bool ~ Int) => a -> b + at T12694.hs:4:1-25 + ‘a’ is a rigid type variable bound by + the type signature for: + f :: forall a b. (Bool ~ Int) => a -> b + at T12694.hs:4:1-25 + ‘b’ is a rigid type variable bound by + the type signature for: + f :: forall a b. (Bool ~ Int) => a -> b + at T12694.hs:4:1-25 + • In the expression: x + In an equation for ‘f’: f x = x + • Relevant bindings include + x :: a (bound at T12694.hs:5:3) + f :: a -> b (bound at T12694.hs:5:1) + ===================================== testsuite/tests/typecheck/should_fail/T16275.stderr ===================================== @@ -0,0 +1,5 @@ +T16275B.hs-boot:4:10: error: [GHC-65507] + • Wildcard ‘_’ not allowed + • In the first argument of ‘T’, namely ‘_’ + In the type signature: foo :: T _ + ===================================== testsuite/tests/typecheck/should_fail/T16275A.hs ===================================== @@ -0,0 +1,3 @@ +module T16275A where + +import {-# SOURCE #-} T16275B ===================================== testsuite/tests/typecheck/should_fail/T16275B.hs ===================================== @@ -0,0 +1 @@ +module T16275B where ===================================== testsuite/tests/typecheck/should_fail/T16275B.hs-boot ===================================== @@ -0,0 +1,4 @@ +module T16275B where + +data T a +foo :: T _ ===================================== testsuite/tests/typecheck/should_fail/all.T ===================================== @@ -430,6 +430,7 @@ test('T12589', normal, compile_fail, ['']) test('T12529', normal, compile_fail, ['']) test('T12563', normal, compile, ['']) # Turns out we can accept this one after all! test('T12648', normal, compile_fail, ['']) +test('T12694', normal, compile_fail, ['']) test('T12729', normal, compile_fail, ['']) test('T12785b', normal, compile_fail, ['']) test('T12803', normal, compile_fail, ['']) @@ -518,6 +519,8 @@ test('T16059e', [extra_files(['T16059b.hs'])], multimod_compile_fail, ['T16059e', '-v0']) test('T16255', normal, compile_fail, ['']) test('T16204c', normal, compile_fail, ['']) +test('T16275', [extra_files(['T16275A.hs', 'T16275B.hs', 'T16275B.hs-boot'])], + multimod_compile_fail, ['T16275A', '-v0']) test('T16394', normal, compile_fail, ['']) test('T16414', normal, compile_fail, ['']) test('T16453E1', extra_files(['T16453T.hs', 'T16453S.hs']), multimod_compile_fail, View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d3690ae808d75f63a2f682bb44a7af8... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d3690ae808d75f63a2f682bb44a7af8... You're receiving this email because of your account on gitlab.haskell.org.