Commit 00dc0f7e authored by Ömer Sinan Ağacan's avatar Ömer Sinan Ağacan Committed by Marge Bot

Add regression test for #13142

Closes #13142
parent f0fd72ee
Pipeline #15593 failed with stages
in 471 minutes and 7 seconds
{-# 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 #-}
......@@ -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'])
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment