From 294f907370fadd3313f8c5e6aa87a93c8b86f139 Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Thu, 10 Nov 2022 17:31:54 +0000 Subject: Fix a trivial typo in dataConNonlinearType Fixes #22416 --- compiler/GHC/Core/DataCon.hs | 16 ++++++++++------ compiler/GHC/Core/Type.hs | 2 +- testsuite/tests/hiefile/should_compile/T22416.hs | 20 ++++++++++++++++++++ testsuite/tests/hiefile/should_compile/T22416.stderr | 2 ++ testsuite/tests/hiefile/should_compile/all.T | 1 + testsuite/tests/roles/should_compile/T8958.stderr | 20 +++++++++++++++++++- 6 files changed, 53 insertions(+), 8 deletions(-) create mode 100644 testsuite/tests/hiefile/should_compile/T22416.hs create mode 100644 testsuite/tests/hiefile/should_compile/T22416.stderr 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’ -- cgit v1.2.1