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