From a5451438bcf3a912910e7c2a5d40dfedfa7d1a4a Mon Sep 17 00:00:00 2001
From: sheaf <sam.derbyshire@gmail.com>
Date: Sat, 13 May 2023 15:59:10 +0200
Subject: Fix bad multiplicity role in tyConAppFunCo_maybe

The function tyConAppFunCo_maybe produces a multiplicity coercion
for the multiplicity argument of the function arrow, except that
it could be at the wrong role if asked to produce a representational
coercion. We fix this by using the 'funRole' function, which computes
the right roles for arguments to the function arrow TyCon.

Fixes #23386
---
 compiler/GHC/Core/Coercion.hs-boot |  2 ++
 compiler/GHC/Core/TyCo/Rep.hs-boot |  1 +
 compiler/GHC/Core/Type.hs          | 11 +++++++----
 3 files changed, 10 insertions(+), 4 deletions(-)

diff --git a/compiler/GHC/Core/Coercion.hs-boot b/compiler/GHC/Core/Coercion.hs-boot
index 3143414feb..276a48cf81 100644
--- a/compiler/GHC/Core/Coercion.hs-boot
+++ b/compiler/GHC/Core/Coercion.hs-boot
@@ -36,6 +36,8 @@ mkSubCo :: HasDebugCallStack => Coercion -> Coercion
 mkProofIrrelCo :: Role -> Coercion -> Coercion -> Coercion -> Coercion
 mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion
 
+funRole :: Role -> FunSel -> Role
+
 isGReflCo :: Coercion -> Bool
 isReflCo :: Coercion -> Bool
 isReflexiveCo :: Coercion -> Bool
diff --git a/compiler/GHC/Core/TyCo/Rep.hs-boot b/compiler/GHC/Core/TyCo/Rep.hs-boot
index a560e0d608..9b82d3cfa5 100644
--- a/compiler/GHC/Core/TyCo/Rep.hs-boot
+++ b/compiler/GHC/Core/TyCo/Rep.hs-boot
@@ -8,6 +8,7 @@ import {-# SOURCE #-} GHC.Core.TyCon ( TyCon )
 
 data Type
 data Coercion
+data FunSel
 data CoSel
 data UnivCoProvenance
 data TyLit
diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs
index 5e4be72a34..a5dc5a6865 100644
--- a/compiler/GHC/Core/Type.hs
+++ b/compiler/GHC/Core/Type.hs
@@ -274,7 +274,7 @@ import {-# SOURCE #-} GHC.Core.Coercion
    , mkTyConAppCo, mkAppCo
    , mkForAllCo, mkFunCo2, mkAxiomInstCo, mkUnivCo
    , mkSymCo, mkTransCo, mkSelCo, mkLRCo, mkInstCo
-   , mkKindCo, mkSubCo, mkFunCo
+   , mkKindCo, mkSubCo, mkFunCo, funRole
    , decomposePiCos, coercionKind
    , coercionRKind, coercionType
    , isReflexiveCo, seqCo
@@ -1331,9 +1331,12 @@ tyConAppFunCo_maybe :: HasDebugCallStack => Role -> TyCon -> [Coercion]
                     -> Maybe Coercion
 -- ^ Return Just if this TyConAppCo should be represented as a FunCo
 tyConAppFunCo_maybe r tc cos
-  | Just (af, mult, arg, res) <- ty_con_app_fun_maybe (mkReflCo r manyDataConTy) tc cos
-            = Just (mkFunCo r af mult arg res)
-  | otherwise = Nothing
+  | Just (af, mult, arg, res) <- ty_con_app_fun_maybe mult_refl tc cos
+  = Just (mkFunCo r af mult arg res)
+  | otherwise
+  = Nothing
+  where
+    mult_refl = mkReflCo (funRole r SelMult) manyDataConTy
 
 ty_con_app_fun_maybe :: (HasDebugCallStack, Outputable a) => a -> TyCon -> [a]
                      -> Maybe (FunTyFlag, a, a, a)
-- 
cgit v1.2.1