Add regression test for #13142

Closes #13142

2 files changed, 161 insertions, 0 deletions

diff --git a/testsuite/tests/typecheck/should_compile/T13142.hs b/testsuite/tests/typecheck/should_compile/T13142.hs
new file mode 100644
index 0000000000..46943893bb
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T13142.hs
@@ -0,0 +1,160 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE EmptyCase #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module T13142 () where
+
+import Data.Foldable (foldl')
+import Data.Proxy
+import Data.Word
+import Foreign.Storable (Storable, sizeOf)
+import GHC.Generics
+import qualified Data.Kind as K
+import GHC.TypeLits
+
+newtype Type = VarT Name
+  deriving Generic
+
+data Name = Name OccName NameFlavour
+  deriving Generic
+
+data NameFlavour
+   = NameS
+   | NameQ ModName
+   | NameU !Int
+   | NameL !Int
+   | NameG PkgName ModName
+   deriving Generic
+
+newtype ModName = ModName String
+  deriving Generic
+
+newtype PkgName = PkgName String
+  deriving Generic
+
+newtype OccName = OccName String
+  deriving Generic
+
+instance Store Type
+instance Store Name
+instance Store NameFlavour
+instance Store ModName
+instance Store OccName
+instance Store PkgName
+
+instance Store Char where
+  {-# INLINE size #-}
+  size = sizeStorableTy "Foreign.Storable.Storable GHC.Types.Char"
+
+instance Store Int where
+  {-# INLINE size #-}
+  size = undefined
+
+instance Store a => Store [a] where
+    size = sizeSequence
+    {-# INLINE size #-}
+
+sizeSequence :: forall a. Store a => Size [a]
+sizeSequence = VarSize $ \t ->
+    case size :: Size a of
+        ConstSize n -> n * (length t) + sizeOf (undefined :: Int)
+        VarSize f -> foldl' (\acc x -> acc + f x) (sizeOf (undefined :: Int)) t
+{-# INLINE sizeSequence #-}
+
+class Store a where
+    size :: Size a
+
+    default size :: (Generic a, GStoreSize (Rep a)) => Size a
+    size = genericSize
+    {-# INLINE size #-}
+
+data Size a
+    = VarSize (a -> Int)
+    | ConstSize !Int
+
+getSizeWith :: Size a -> a -> Int
+getSizeWith (VarSize f) x = f x
+getSizeWith (ConstSize n) _ = n
+{-# INLINE getSizeWith #-}
+
+contramapSize :: (a -> b) -> Size b -> Size a
+contramapSize f (VarSize g) = VarSize (g . f)
+contramapSize _ (ConstSize n) = ConstSize n
+{-# INLINE contramapSize #-}
+
+combineSizeWith :: forall a b c. (c -> a) -> (c -> b) -> Size a -> Size b -> Size c
+combineSizeWith toA toB sizeA sizeB =
+    case (sizeA, sizeB) of
+        (VarSize f, VarSize g) -> VarSize (\x -> f (toA x) + g (toB x))
+        (VarSize f, ConstSize m) -> VarSize (\x -> f (toA x) + m)
+        (ConstSize n, VarSize g) -> VarSize (\x -> n + g (toB x))
+        (ConstSize n, ConstSize m) -> ConstSize (n + m)
+{-# INLINE combineSizeWith #-}
+
+sizeStorableTy :: forall a. Storable a => String -> Size a
+sizeStorableTy ty = ConstSize (sizeOf (error msg :: a))
+  where
+    msg = "In Data.Store.storableSize: " ++ ty ++ "'s sizeOf evaluated its argument."
+{-# INLINE sizeStorableTy #-}
+
+genericSize :: (Generic a, GStoreSize (Rep a)) => Size a
+genericSize = contramapSize from gsize
+{-# INLINE genericSize #-}
+
+type family SumArity (a :: K.Type -> K.Type) :: Nat where
+    SumArity (C1 c a) = 1
+    SumArity (x :+: y) = SumArity x + SumArity y
+
+class GStoreSize f where gsize :: Size (f a)
+
+instance GStoreSize f => GStoreSize (M1 i c f) where
+    gsize = contramapSize unM1 gsize
+    {-# INLINE gsize #-}
+
+instance Store a => GStoreSize (K1 i a) where
+    gsize = contramapSize unK1 size
+    {-# INLINE gsize #-}
+
+instance GStoreSize U1 where
+    gsize = ConstSize 0
+    {-# INLINE gsize #-}
+
+instance GStoreSize V1 where
+    gsize = ConstSize 0
+    {-# INLINE gsize #-}
+
+instance (GStoreSize a, GStoreSize b) => GStoreSize (a :*: b) where
+    gsize = combineSizeWith (\(x :*: _) -> x) (\(_ :*: y) -> y) gsize gsize
+    {-# INLINE gsize #-}
+
+instance (SumArity (a :+: b) <= 255, GStoreSizeSum 0 (a :+: b))
+         => GStoreSize (a :+: b) where
+    gsize = VarSize $ \x -> sizeOf (undefined :: Word8) + gsizeSum x (Proxy :: Proxy 0)
+    {-# INLINE gsize #-}
+
+class KnownNat n => GStoreSizeSum (n :: Nat) (f :: K.Type -> K.Type) where
+    gsizeSum :: f a -> Proxy n -> Int
+
+instance (GStoreSizeSum n a, GStoreSizeSum (n + SumArity a) b, KnownNat n)
+         => GStoreSizeSum n (a :+: b) where
+    gsizeSum (L1 l) _ = gsizeSum l (Proxy :: Proxy n)
+    gsizeSum (R1 r) _ = gsizeSum r (Proxy :: Proxy (n + SumArity a))
+    {-# INLINE gsizeSum #-}
+
+instance (GStoreSize a, KnownNat n) => GStoreSizeSum n (C1 c a) where
+    gsizeSum x _ = getSizeWith gsize x
+    {-# INLINE gsizeSum #-}
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index 215b57d87b..54a0c4f4c7 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -694,3 +694,4 @@ test('T15839b', normal, compile, [''])
 test('T17343', exit_code(1), compile_and_run, [''])
 test('T17566', [extra_files(['T17566a.hs'])], makefile_test, [])
 test('T12760', unless(compiler_debugged(), skip), compile, ['-O'])
+test('T13142', normal, compile, ['-O2'])