Embrace -XTypeInType, add -XStarIsType
[ghc.git] / testsuite / tests / perf / compiler / T12227.hs
1 {-# LANGUAGE ConstraintKinds #-}
2 {-# LANGUAGE DataKinds #-}
3 {-# LANGUAGE DeriveGeneric #-}
4 {-# LANGUAGE FlexibleInstances #-}
5 {-# LANGUAGE FunctionalDependencies #-}
6 {-# LANGUAGE ScopedTypeVariables #-}
7 {-# LANGUAGE TypeFamilies #-}
8 {-# LANGUAGE TypeOperators #-}
9 {-# LANGUAGE UndecidableInstances #-}
10 {-# LANGUAGE GADTs #-}
11
12 module Crash where
13
14 import Data.Proxy (Proxy(..))
15 import Data.Type.Equality (type (==))
16 import Data.Kind
17 import GHC.Exts
18 import GHC.Generics
19
20 data Dict :: Constraint -> Type where
21 Dict :: a => Dict a
22
23 infixr 0 -->
24
25 type family (args :: [Type]) --> (ret :: Type) :: Type
26 where
27 '[] --> ret = ret
28 (arg ': args) --> ret = arg -> (args --> ret)
29
30 type family AllArguments (func :: Type) :: [Type]
31 where
32 AllArguments (arg -> func) = arg ': AllArguments func
33 AllArguments ret = '[]
34
35 type family FinalReturn (func :: Type) :: Type
36 where
37 FinalReturn (arg -> func) = FinalReturn func
38 FinalReturn ret = ret
39
40 type IsFullFunction f
41 = (AllArguments f --> FinalReturn f) ~ f
42
43 type family SConstructor (struct :: Type) :: Type
44 where
45 SConstructor struct = GPrependFields (Rep struct ()) '[] --> struct
46
47 type family GPrependFields (gstruct :: Type) (tail :: [Type]) :: [Type]
48 where
49 GPrependFields (M1 i t f p) tail = GPrependFields (f p) tail
50 GPrependFields (K1 i c p) tail = c ': tail
51 GPrependFields ((:*:) f g p) tail =
52 GPrependFields (f p) (GPrependFields (g p) tail)
53
54 class (fields1 --> (fields2 --> r)) ~ (fields --> r)
55 => AppendFields fields1 fields2 fields r
56 | fields1 fields2 -> fields
57
58 instance AppendFields '[] fields fields r
59
60 instance AppendFields fields1 fields2 fields r
61 => AppendFields (f ': fields1) fields2 (f ': fields) r
62
63 class Generic struct
64 => GoodConstructor (struct :: Type)
65 where
66 goodConstructor :: Proxy struct
67 -> Dict ( IsFullFunction (SConstructor struct)
68 , FinalReturn (SConstructor struct) ~ struct
69 )
70
71 instance ( Generic struct
72 , GoodConstructorEq (SConstructor struct == struct)
73 (SConstructor struct)
74 struct
75 ) => GoodConstructor struct
76 where
77 goodConstructor _ =
78 goodConstructorEq (Proxy :: Proxy (SConstructor struct == struct))
79 (Proxy :: Proxy (SConstructor struct))
80 (Proxy :: Proxy struct)
81 {-# INLINE goodConstructor #-}
82
83 class GoodConstructorEq (isEqual :: Bool) (ctor :: Type) (struct :: Type)
84 where
85 goodConstructorEq :: Proxy isEqual
86 -> Proxy ctor
87 -> Proxy struct
88 -> Dict ( IsFullFunction ctor
89 , FinalReturn ctor ~ struct
90 )
91
92 instance ( FinalReturn struct ~ struct
93 , AllArguments struct ~ '[]
94 ) => GoodConstructorEq True struct struct
95 where
96 goodConstructorEq _ _ _ = Dict
97 {-# INLINE goodConstructorEq #-}
98
99 instance GoodConstructorEq (ctor == struct) ctor struct
100 => GoodConstructorEq False (arg -> ctor) struct
101 where
102 goodConstructorEq _ _ _ =
103 case goodConstructorEq (Proxy :: Proxy (ctor == struct))
104 (Proxy :: Proxy ctor)
105 (Proxy :: Proxy struct)
106 of
107 Dict -> Dict
108 {-# INLINE goodConstructorEq #-}
109
110 data Foo = Foo
111 { _01 :: Int
112 , _02 :: Int
113 , _03 :: Int
114 , _04 :: Int
115 , _05 :: Int
116 , _06 :: Int
117 , _07 :: Int
118 , _08 :: Int
119 , _09 :: Int
120 , _10 :: Int
121 , _11 :: Int
122 , _12 :: Int
123 , _13 :: Int
124 , _14 :: Int
125 , _15 :: Int
126 , _16 :: Int
127 }
128 deriving (Generic)
129
130 crash :: () -> Int
131 crash p1 = x + y
132 where
133 p2 = p1 -- This indirection is required to trigger the problem.
134 x = fst $ case goodConstructor (Proxy :: Proxy Foo) of
135 Dict -> (0, p2)
136 y = fst $ case goodConstructor (Proxy :: Proxy Foo) of
137 Dict -> (0, p2)
138 {-# INLINE crash #-} -- Even 'INLINABLE' is not enough to trigger the problem.