diff options
author | Ömer Sinan Ağacan <omeragacan@gmail.com> | 2020-02-06 16:24:28 +0300 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-02-09 17:23:17 -0500 |
commit | 00dc0f7e66a18ab50931325cb6333a2bfd2a6650 (patch) | |
tree | df1cccc1caf0af76f0a140881cd8133b58d0aa59 | |
parent | f0fd72ee042aa011af7d870febcfead01a424370 (diff) | |
download | haskell-00dc0f7e66a18ab50931325cb6333a2bfd2a6650.tar.gz |
Add regression test for #13142
Closes #13142
-rw-r--r-- | testsuite/tests/typecheck/should_compile/T13142.hs | 160 | ||||
-rw-r--r-- | testsuite/tests/typecheck/should_compile/all.T | 1 |
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']) |