[Git][ghc/ghc][wip/T24978] Fix glitch

[Simon Peyton Jones (@simonpj)]

Simon Peyton Jones pushed to branch wip/T24978 at Glasgow Haskell Compiler / GHC


Commits:
2a272b3e by Simon Peyton Jones at 2024-07-01T09:56:59+01:00
Fix glitch

- - - - -


2 changed files:

- compiler/GHC/Builtin/Types/Literals.hs
- compiler/GHC/Core/FamInstEnv.hs


Changes:

=====================================
compiler/GHC/Builtin/Types/Literals.hs
=====================================
@@ -1,7 +1,7 @@
 {-# LANGUAGE LambdaCase #-}
 
 module GHC.Builtin.Types.Literals
-  ( tryInteractInertFam, tryInteractTopFam
+  ( tryInteractInertFam, tryInteractTopFam, tryMatchFam
 
   , typeNatTyCons
   , typeNatCoAxiomRules
@@ -70,6 +70,7 @@ import GHC.Utils.Outputable
 
 import Control.Monad ( guard )
 import Data.List  ( isPrefixOf, isSuffixOf )
+import Data.Maybe ( listToMaybe )
 import qualified Data.Char as Char
 
 {-
@@ -163,15 +164,25 @@ tryInteractInertFam :: BuiltInSynFamily -> TyCon
                     -> [Type] -> Type  -- F tys1 ~ ty1
                     -> [Type] -> Type  -- F tys2 ~ ty2
                     -> [(CoAxiomRule, TypeEqn)]
-tryInteractInertFam fam fam_tc tys1 ty1 tys2 ty2
+tryInteractInertFam builtin_fam fam_tc tys1 ty1 tys2 ty2
   = [(BuiltInFamInteract ax_rule, eqn)
-    | ax_rule  <- sfInteractInert fam
+    | ax_rule  <- sfInteractInert builtin_fam
     , Just eqn <- [bifint_proves ax_rule [eqn1,eqn2]] ]
   where
     eqn1 = Pair (mkTyConApp fam_tc tys1) ty1
     eqn2 = Pair (mkTyConApp fam_tc tys2) ty2
 
-
+tryMatchFam :: BuiltInSynFamily -> TyCon -> [Type]
+            -> Maybe (CoAxiomRule, [Type], Type)
+-- Does this reduce on the given arguments?
+-- If it does, returns (CoAxiomRule, types to instantiate the rule at, rhs type)
+-- That is: mkAxiomRuleCo coax (zipWith mkReflCo (coaxrAsmpRoles coax) ts)
+--              :: F tys ~r rhs,
+tryMatchFam builtin_fam fam_tc arg_tys
+  = listToMaybe $   -- Pick first rule to match
+    [ (BuiltInFamRewrite rw_ax, [inst_tys], res_ty)
+    | rw_ax <- sfMatchFam builtin_fam
+    , Just ([inst_tys],res_ty) <- [bifrw_match rw_ax arg_tys] ]
 
 -------------------------------------------------------------------------------
 --     Built-in type constructors for functions on type-level nats


=====================================
compiler/GHC/Core/FamInstEnv.hs
=====================================
@@ -49,26 +49,30 @@ import GHC.Core.Coercion.Axiom
 import GHC.Core.Reduction
 import GHC.Core.RoughMap
 import GHC.Core.FVs( orphNamesOfAxiomLHS )
+
+import GHC.Builtin.Types.Literals( tryMatchFam )
+
 import GHC.Types.Var.Set
 import GHC.Types.Var.Env
 import GHC.Types.Name
-import GHC.Data.FastString
-import GHC.Data.Maybe
 import GHC.Types.Var
 import GHC.Types.SrcLoc
-import Control.Monad
-import Data.List( mapAccumL )
-import Data.Array( Array, assocs )
+import GHC.Types.Name.Set
 
 import GHC.Utils.Misc
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
 
-import GHC.Types.Name.Set
+import GHC.Data.FastString
+import GHC.Data.Maybe
 import GHC.Data.Bag
 import GHC.Data.List.Infinite (Infinite (..))
 import qualified GHC.Data.List.Infinite as Inf
 
+import Control.Monad
+import Data.List( mapAccumL )
+import Data.Array( Array, assocs )
+
 {-
 ************************************************************************
 *                                                                      *
@@ -1192,8 +1196,8 @@ reduceTyFamApp_maybe envs role tc tys
   = let co = mkAxInstCo role ax ind inst_tys inst_cos
     in Just $ coercionRedn co
 
-  | Just ax           <- isBuiltInSynFamTyCon_maybe tc
-  , Just (coax,ts,ty) <- sfMatchFam ax tys
+  | Just builtin_fam  <- isBuiltInSynFamTyCon_maybe tc
+  , Just (coax,ts,ty) <- tryMatchFam builtin_fam tc tys
   , role == coaxrRole coax
   = let co = mkAxiomRuleCo coax (zipWith mkReflCo (coaxrAsmpRoles coax) ts)
     in Just $ mkReduction co ty



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2a272b3ef10720fdb95dce0bdaeb9bfe95dcda51
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/20240701/065f333c/attachment-0001.html>