Fix a trivial typo in dataConNonlinearType

Fixes #22416

(cherry picked from commit 294f907370fadd3313f8c5e6aa87a93c8b86f139)

6 files changed, 53 insertions, 8 deletions

diff --git a/compiler/GHC/Core/DataCon.hs b/compiler/GHC/Core/DataCon.hs
index 07419b9c5c..9ce4dbd7e4 100644
--- a/compiler/GHC/Core/DataCon.hs
+++ b/compiler/GHC/Core/DataCon.hs
@@ -1456,14 +1456,18 @@ dataConWrapperType (MkData { dcUserTyVarBinders = user_tvbs,
     res_ty
 
 dataConNonlinearType :: DataCon -> Type
+-- Just like dataConWrapperType, but with the
+-- linearity on the arguments all zapped to Many
 dataConNonlinearType (MkData { dcUserTyVarBinders = user_tvbs,
                                dcOtherTheta = theta, dcOrigArgTys = arg_tys,
-                               dcOrigResTy = res_ty })
-  = let arg_tys' = map (\(Scaled w t) -> Scaled (case w of One -> Many; _ -> w) t) arg_tys
-    in mkInvisForAllTys user_tvbs $
-       mkInvisFunTysMany theta $
-       mkVisFunTys arg_tys' $
-       res_ty
+                               dcOrigResTy = res_ty,
+                               dcStupidTheta = stupid_theta })
+  = mkInvisForAllTys user_tvbs $
+    mkInvisFunTysMany (stupid_theta ++ theta) $
+    mkVisFunTys arg_tys' $
+    res_ty
+  where
+    arg_tys' = map (\(Scaled w t) -> Scaled (case w of One -> Many; _ -> w) t) arg_tys
 
 dataConDisplayType :: Bool -> DataCon -> Type
 dataConDisplayType show_linear_types dc
diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs
index 6eb247db16..988abce61b 100644
--- a/compiler/GHC/Core/Type.hs
+++ b/compiler/GHC/Core/Type.hs
@@ -1327,7 +1327,7 @@ splitFunTys ty = split [] ty ty
     split args orig_ty ty | Just ty' <- coreView ty = split args orig_ty ty'
     split args orig_ty _                   = (reverse args, orig_ty)
 
-funResultTy :: Type -> Type
+funResultTy :: HasDebugCallStack => Type -> Type
 -- ^ Extract the function result type and panic if that is not possible
 funResultTy ty
   | FunTy { ft_res = res } <- coreFullView ty = res
diff --git a/testsuite/tests/hiefile/should_compile/T22416.hs b/testsuite/tests/hiefile/should_compile/T22416.hs
new file mode 100644
index 0000000000..97a09d6b62
--- /dev/null
+++ b/testsuite/tests/hiefile/should_compile/T22416.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE Haskell2010 #-}
+module Swish.GraphMatch where
+
+import qualified Data.Map as M
+import Data.Word (Word32)
+
+class Label lb
+
+type LabelIndex = (Word32, Word32)
+
+data (Label lb, Eq lv, Show lv) => GenLabelMap lb lv =
+    MkLabelMap Word32 (M.Map lb lv)
+
+type LabelMap lb = GenLabelMap lb LabelIndex
+
+emptyMap :: Label lb => LabelMap lb
+emptyMap = MkLabelMap 1 M.empty
+
+-- MkLabelMap :: forall lb lv. (Label lb, Eq lv, Show lv)
+--            => Word32 -> M.Map lb lv -> GenLabelMap lb lv
\ No newline at end of file
diff --git a/testsuite/tests/hiefile/should_compile/T22416.stderr b/testsuite/tests/hiefile/should_compile/T22416.stderr
new file mode 100644
index 0000000000..f31d37d99f
--- /dev/null
+++ b/testsuite/tests/hiefile/should_compile/T22416.stderr
@@ -0,0 +1,2 @@
+Got valid scopes
+Got no roundtrip errors
diff --git a/testsuite/tests/hiefile/should_compile/all.T b/testsuite/tests/hiefile/should_compile/all.T
index 018585a0f4..436928dbe7 100644
--- a/testsuite/tests/hiefile/should_compile/all.T
+++ b/testsuite/tests/hiefile/should_compile/all.T
@@ -23,3 +23,4 @@ test('Scopes',       normal,                   compile, ['-fno-code -fwrite-ide-
 # See https://gitlab.haskell.org/ghc/ghc/-/issues/18425 and https://gitlab.haskell.org/ghc/ghc/-/merge_requests/2464#note_301989
 test('ScopesBug',    expect_broken(18425),     compile, ['-fno-code -fwrite-ide-info -fvalidate-ide-info'])
 test('T18425',       normal,     compile, ['-fno-code -fwrite-ide-info -fvalidate-ide-info'])
+test('T22416',       normal,     compile, ['-fno-code -fwrite-ide-info -fvalidate-ide-info'])
diff --git a/testsuite/tests/roles/should_compile/T8958.stderr b/testsuite/tests/roles/should_compile/T8958.stderr
index 6a6e3dc627..7e6df4bd7c 100644
--- a/testsuite/tests/roles/should_compile/T8958.stderr
+++ b/testsuite/tests/roles/should_compile/T8958.stderr
@@ -10,7 +10,9 @@ TYPE CONSTRUCTORS
 COERCION AXIOMS
   axiom T8958.N:Map :: Map k v = [(k, v)]
 DATA CONSTRUCTORS
-  MkMap :: forall k v. [(k, v)] -> Map k v
+  MkMap :: forall k v.
+           (Nominal k, Representational v) =>
+           [(k, v)] -> Map k v
 CLASS INSTANCES
   instance [incoherent] Representational a
     -- Defined at T8958.hs:11:10
@@ -94,3 +96,19 @@ AbsBinds [a] []
    Evidence: [EvBinds{}]}
 
 
+
+T8958.hs:14:54: warning: [-Wsimplifiable-class-constraints (in -Wdefault)]
+    • The constraint ‘Representational v’ matches
+        instance Representational a -- Defined at T8958.hs:11:10
+      This makes type inference for inner bindings fragile;
+        either use MonoLocalBinds, or simplify it using the instance
+    • In the definition of data constructor ‘MkMap’
+      In the newtype declaration for ‘Map’
+
+T8958.hs:14:54: warning: [-Wsimplifiable-class-constraints (in -Wdefault)]
+    • The constraint ‘Nominal k’ matches
+        instance Nominal a -- Defined at T8958.hs:8:10
+      This makes type inference for inner bindings fragile;
+        either use MonoLocalBinds, or simplify it using the instance
+    • In the definition of data constructor ‘MkMap’
+      In the newtype declaration for ‘Map’