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