diff options
-rw-r--r-- | libraries/base/Data/Typeable/Internal.hs | 2 | ||||
-rw-r--r-- | libraries/base/tests/T19288.hs | 31 | ||||
-rw-r--r-- | libraries/base/tests/T19288.stderr | 3 | ||||
-rw-r--r-- | libraries/base/tests/all.T | 1 |
4 files changed, 36 insertions, 1 deletions
diff --git a/libraries/base/Data/Typeable/Internal.hs b/libraries/base/Data/Typeable/Internal.hs index 85abebf331..547fd13d62 100644 --- a/libraries/base/Data/Typeable/Internal.hs +++ b/libraries/base/Data/Typeable/Internal.hs @@ -990,7 +990,7 @@ mkTypeLitFromString :: TypeLitSort -> String -> SomeTypeRep mkTypeLitFromString TypeLitSymbol s = SomeTypeRep $ (typeLitTypeRep s tcSymbol :: TypeRep Symbol) mkTypeLitFromString TypeLitNat s = - SomeTypeRep $ (typeLitTypeRep s tcSymbol :: TypeRep Nat) + SomeTypeRep $ (typeLitTypeRep s tcNat :: TypeRep Nat) tcSymbol :: TyCon tcSymbol = typeRepTyCon (typeRep @Symbol) diff --git a/libraries/base/tests/T19288.hs b/libraries/base/tests/T19288.hs new file mode 100644 index 0000000000..7bb5fd2616 --- /dev/null +++ b/libraries/base/tests/T19288.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, Safe, TypeFamilies #-} + +module Main where + +import Data.Maybe +import Data.Proxy +import Type.Reflection +import GHC.TypeLits + +data Dat (x :: Proxy 1) = MkD1 + +evil :: Maybe (Nat :~~: Symbol) +evil = eqTypeRep (case (typeRepKind (typeRep :: TypeRep Dat)) of + (Fun (App _ x) _) -> typeRepKind x) + (typeRep :: TypeRep Symbol) + + +data family Cast k l r +newtype instance Cast Nat l r = CastNat { runCastNat :: l } +newtype instance Cast Symbol l r = CastSymbol { runCastSymbol :: r } + +{-# NOINLINE castHelper #-} +castHelper :: Maybe (a :~~: b) -> Cast a l r -> Cast b l r +castHelper (Just HRefl) = id +castHelper Nothing = error "No more bug!" + +cast :: a -> b +cast = runCastSymbol . castHelper evil . CastNat + +main :: IO () +main = print (cast 'a' :: Int) diff --git a/libraries/base/tests/T19288.stderr b/libraries/base/tests/T19288.stderr new file mode 100644 index 0000000000..68f83bff83 --- /dev/null +++ b/libraries/base/tests/T19288.stderr @@ -0,0 +1,3 @@ +T19288: No more bug! +CallStack (from HasCallStack): + error, called at T19288.hs:25:27 in main:Main diff --git a/libraries/base/tests/all.T b/libraries/base/tests/all.T index ac65224ef0..da828cb2c2 100644 --- a/libraries/base/tests/all.T +++ b/libraries/base/tests/all.T @@ -261,3 +261,4 @@ test('T17499', [collect_stats('bytes allocated',5)], compile_and_run, ['-O -w']) test('T16643', normal, compile_and_run, ['']) test('clamp', normal, compile_and_run, ['']) test('T18642', extra_run_opts('+RTS -T -RTS'), compile_and_run, ['-O2']) +test('T19288', exit_code(1), compile_and_run, ['']) |