Simon Peyton Jones pushed to branch wip/T23162-part2 at Glasgow Haskell Compiler / GHC Commits: 98aecdda by Simon Peyton Jones at 2025-11-11T09:59:58+00:00 Wibbles - - - - - 3 changed files: - compiler/GHC/Tc/Solver/FunDeps.hs - testsuite/tests/indexed-types/should_compile/CEqCanOccursCheck.hs - testsuite/tests/indexed-types/should_fail/T12522a.hs Changes: ===================================== compiler/GHC/Tc/Solver/FunDeps.hs ===================================== @@ -25,7 +25,7 @@ import GHC.Core.FamInstEnv import GHC.Core.Coercion import GHC.Core.Predicate( EqRel(..) ) import GHC.Core.TyCon -import GHC.Core.Unify( tcUnifyTyForInjectivity, typeListsAreApart, typesAreApart, tcUnifyTy ) +import GHC.Core.Unify( tcUnifyTyForInjectivity, typeListsAreApart, typesAreApart ) import GHC.Core.Coercion.Axiom import GHC.Core.TyCo.Subst( elemSubst ) @@ -38,7 +38,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Data.Pair -import Data.Maybe( mapMaybe, isJust ) +import Data.Maybe( mapMaybe ) {- Note [Overview of functional dependencies in type inference] @@ -500,7 +500,8 @@ tryFamEqFunDeps fam_tc args work_item@(EqCt { eq_ev = ev, eq_rhs = rhs }) | Just ax <- isClosedFamilyTyCon_maybe fam_tc = -- Closed type families do { -- Note [Do local fundeps before top-level instances] - case tyConInjectivityInfo fam_tc of + simpleStage $ traceTcS "fundep closed" (ppr fam_tc) + ; case tyConInjectivityInfo fam_tc of NotInjective -> nopStage() Injective inj -> tryFDEqns fam_tc args work_item $ mkLocalUserFamEqFDs fam_tc inj args rhs @@ -531,7 +532,9 @@ tryFDEqns fam_tc work_args work_item@(EqCt { eq_ev = ev, eq_rhs= rhs }) mk_fd_eq ----------------------------------------- mkTopClosedFamEqFDs :: CoAxiom Branched -> [TcType] -> Xi -> TcS [FunDepEqns] mkTopClosedFamEqFDs ax work_args work_rhs - = return (go (fromBranches (coAxiomBranches ax))) + = do { let branches = fromBranches (coAxiomBranches ax) + ; traceTcS "mkTopClosed" (ppr branches $$ ppr work_args $$ ppr work_rhs) + ; return (go branches) } where go :: [CoAxBranch] -> [FunDepEqns] go [] = [] @@ -539,18 +542,19 @@ mkTopClosedFamEqFDs ax work_args work_rhs go (branch : later_branches) | CoAxBranch { cab_tvs = qtvs, cab_lhs = lhs_tys , cab_rhs = rhs_ty, cab_incomps = incomps } <- branch - , not (work_args `typeListsAreApart` lhs_tys) - , isJust (tcUnifyTy work_rhs rhs_ty) - = if all ok incomps && all ok later_branches + , not (no_match lhs_tys rhs_ty) + = if all no_match_branch incomps && all no_match_branch later_branches then [FDEqns { fd_qtvs = qtvs, fd_eqs = zipWith Pair lhs_tys work_args }] else [] | otherwise = go later_branches - ok (CoAxBranch { cab_lhs = lhs_tys, cab_rhs = rhs_ty }) - = work_args `typeListsAreApart` lhs_tys || - work_rhs `typesAreApart` rhs_ty + no_match_branch (CoAxBranch { cab_lhs = lhs_tys, cab_rhs = rhs_ty }) + = no_match lhs_tys rhs_ty + + no_match lhs_tys rhs_ty = work_args `typeListsAreApart` lhs_tys || + work_rhs `typesAreApart` rhs_ty mkTopOpenFamEqFDs :: TyCon -> [Bool] -> [TcType] -> Xi -> TcS [FunDepEqns] -- Implements (INJFAM:Wanted/top) ===================================== testsuite/tests/indexed-types/should_compile/CEqCanOccursCheck.hs ===================================== @@ -8,10 +8,13 @@ type family F a where type family G a b where G a a = a -{- +{- Ambiguity check for foo +[G] F a ~ a +[G] F a ~ b + [W] F alpha ~ alpha [W] F alpha ~ beta -[W] G alpha beta ~ Int +[W] G alpha beta ~ G a b -} foo :: (F a ~ a, F a ~ b) => G a b -> () ===================================== testsuite/tests/indexed-types/should_fail/T12522a.hs ===================================== @@ -21,3 +21,9 @@ def = undefined -- test :: Uncurried [Int, String] String test = def $ \n s -> I $ show n ++ s + +{- +Arg to `def` has type (alpha -> String -> String) +So we get + [W] Curry as0 b0 ~ (alpha -> String -> String) +-} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/98aecddaeaa0b699f13771a3ac7891fd... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/98aecddaeaa0b699f13771a3ac7891fd... You're receiving this email because of your account on gitlab.haskell.org.