summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSimon Peyton Jones <simonpj@microsoft.com>2022-11-10 17:31:54 +0000
committerSimon Peyton Jones <simon.peytonjones@gmail.com>2022-11-12 23:14:13 +0000
commit294f907370fadd3313f8c5e6aa87a93c8b86f139 (patch)
tree4071c1470efea858998a63225f95ef5c76e645bc
parente160cf4776f21a39adebfa8f5d4dcbe9ec6b0ffe (diff)
downloadhaskell-294f907370fadd3313f8c5e6aa87a93c8b86f139.tar.gz
Fix a trivial typo in dataConNonlinearTypewip/T22416
Fixes #22416
-rw-r--r--compiler/GHC/Core/DataCon.hs16
-rw-r--r--compiler/GHC/Core/Type.hs2
-rw-r--r--testsuite/tests/hiefile/should_compile/T22416.hs20
-rw-r--r--testsuite/tests/hiefile/should_compile/T22416.stderr2
-rw-r--r--testsuite/tests/hiefile/should_compile/all.T1
-rw-r--r--testsuite/tests/roles/should_compile/T8958.stderr20
6 files changed, 53 insertions, 8 deletions
diff --git a/compiler/GHC/Core/DataCon.hs b/compiler/GHC/Core/DataCon.hs
index 2846fa7b33..043cb82574 100644
--- a/compiler/GHC/Core/DataCon.hs
+++ b/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
diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs
index a36a398773..7e0444cbfe 100644
--- a/compiler/GHC/Core/Type.hs
+++ b/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
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 73b98a1f94..8b90f91376 100644
--- a/testsuite/tests/hiefile/should_compile/all.T
+++ b/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'])
diff --git a/testsuite/tests/roles/should_compile/T8958.stderr b/testsuite/tests/roles/should_compile/T8958.stderr
index 028f92c498..a5538a8723 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
@@ -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’