[Git][ghc/ghc][wip/T22416] Fix a trivial typo in dataConNonlinearType

[Simon Peyton Jones (@simonpj)]

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


Commits:
294f9073 by Simon Peyton Jones at 2022-11-12T23:14:13+00:00
Fix a trivial typo in dataConNonlinearType

Fixes #22416

- - - - -


6 changed files:

- compiler/GHC/Core/DataCon.hs
- compiler/GHC/Core/Type.hs
- + testsuite/tests/hiefile/should_compile/T22416.hs
- + testsuite/tests/hiefile/should_compile/T22416.stderr
- testsuite/tests/hiefile/should_compile/all.T
- testsuite/tests/roles/should_compile/T8958.stderr


Changes:

=====================================
compiler/GHC/Core/DataCon.hs
=====================================
@@ -1542,14 +1542,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 OneTy -> ManyTy; _ -> w) t) arg_tys
-    in mkInvisForAllTys user_tvbs $
-       mkInvisFunTys theta $
-       mkScaledFunTys arg_tys' $
-       res_ty
+                               dcOrigResTy = res_ty,
+                               dcStupidTheta = stupid_theta })
+  = mkInvisForAllTys user_tvbs $
+    mkInvisFunTys (stupid_theta ++ theta) $
+    mkScaledFunTys arg_tys' $
+    res_ty
+  where
+    arg_tys' = map (\(Scaled w t) -> Scaled (case w of OneTy -> ManyTy; _ -> w) t) arg_tys
 
 dataConDisplayType :: Bool -> DataCon -> Type
 dataConDisplayType show_linear_types dc


=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -1383,7 +1383,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


=====================================
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


=====================================
testsuite/tests/hiefile/should_compile/T22416.stderr
=====================================
@@ -0,0 +1,2 @@
+Got valid scopes
+Got no roundtrip errors


=====================================
testsuite/tests/hiefile/should_compile/all.T
=====================================
@@ -22,3 +22,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'])


=====================================
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
@@ -92,3 +94,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’



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/294f907370fadd3313f8c5e6aa87a93c8b86f139

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/294f907370fadd3313f8c5e6aa87a93c8b86f139
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/20221112/21cda37e/attachment-0001.html>