Ticket #12506: test.hs

File test.hs, 4.1 KB (added by tdammers, 22 months ago)

Test case to reproduce

Line 
1{-# LANGUAGE TypeSynonymInstances, TypeFamilies, FlexibleContexts, EmptyDataDecls #-}
2{-# LANGUAGE KindSignatures, TypeFamilies, UndecidableInstances, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, ScopedTypeVariables #-}
3{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, TypeFamilies #-}
4module Main where
5
6import System.IO.Unsafe
7
8data Same
9data Different
10
11data Match a
12data NoFunction a b
13
14type family Contains as a where
15  Contains () (x ()) = Different
16  Contains (a as) (a ()) = Same
17  Contains (a as) (b ()) = Contains as (b ())
18
19type family FindOpHelper orig hierarchy  (needle :: *) (found :: *) :: * where
20  FindOpHelper orig hierarchy needle Same = Match hierarchy
21  FindOpHelper orig (child ancestors) needle Different = FindOp orig ancestors needle
22
23
24type family FindOp orig hierarchy (needle :: *) :: * where
25  FindOp orig () n = NoFunction n orig
26  FindOp orig hierarchy needle = FindOpHelper orig hierarchy needle (Contains (Functions hierarchy) needle)
27
28data InHierarchy
29data NotInHierarchy a b
30
31type family FindInHierarchy (needle :: * ) (curr :: *) (haystack :: *) :: * where
32  FindInHierarchy needle () (a as) = NotInHierarchy needle (a as)
33  FindInHierarchy needle (a as) (a as) = InHierarchy
34  FindInHierarchy needle (a as) (b bs) = FindInHierarchy needle as (b bs)
35
36class Parent a b
37instance (InHierarchy ~ FindInHierarchy a a b) => Parent a b
38
39type family Functions (x :: *) :: *
40
41class Op op obj origObj impl where
42  runOp :: op -> origObj -> (Ref obj) -> impl
43
44data Ref a = Ref ()
45
46castTo :: Ref a -> Ref r
47castTo (Ref x) = (Ref x)
48
49dispatch :: forall op obj origObj impl.
50            (
51              Match obj ~ FindOp origObj origObj op,
52              Op op obj origObj impl
53            ) =>
54            op -> Ref origObj -> impl
55dispatch op refOrig = runOp op (undefined :: origObj) ((castTo refOrig) :: Ref obj)
56
57a30 :: (Match r ~ FindOp a a (A30 ()), Op (A30 ()) r a impl) => Ref a -> impl
58a30 aRef = dispatch (undefined :: A30 ()) aRef
59
60data CBase parent
61type Base = CBase ()
62
63data CA parent
64type A = CA Base
65type AMembers =
66 (A0
67 (A1
68 (A2
69 (A3
70 (A4
71 (A5
72 (A6
73 (A7
74 (A8
75 (A9
76 (A10
77 (A11
78 (A12
79 (A13
80 (A14
81 (A15
82 (A16
83 (A17
84 (A18
85 (A19
86 (A20
87 (A21
88 (A22
89 (A23
90 (A24
91 (A25
92 (A26
93 (A27
94 (A28
95 (A29
96 (A30
97 ())))))))))))))))))))))))))))))))
98type instance Functions A = AMembers
99
100data CB parent
101type B = CB A
102type BMembers =
103 (B0
104 (B1
105 (B2
106 (B3
107 (B4
108 (B5
109 (B6
110 (B7
111 (B8
112 (B9
113 (B10
114 (B11
115 (B12
116 (B13
117 (B14
118 (B15
119 (B16
120 (B17
121 (B18
122 (B19
123 (B20
124 (B21
125 (B22
126 (B23
127 (B24
128 (B25
129 (B26
130 (B27
131 (B28
132 (B29
133 (B30
134 ())))))))))))))))))))))))))))))))
135
136type instance Functions B = BMembers
137
138
139data CC parent
140type C = CC A
141type CMembers =
142 (C0
143 (C1
144 (C2
145 (C3
146 (C4
147 (C5
148 (C6
149 (C7
150 (C8
151 (C9
152 (C10
153 (C11
154 (C12
155 (C13
156 (C14
157 (C15
158 (C16
159 (C17
160 (C18
161 (C19
162 (C20
163 (C21
164 (C22
165 (C23
166 (C24
167 (C25
168 (C26
169 (C27
170 (C28
171 (C29
172 (C30
173 ())))))))))))))))))))))))))))))))
174
175type instance Functions C = CMembers
176
177data CD parent
178type D = CD C
179type instance Functions D = ()
180
181data A0 a
182data A1 a
183data A2 a
184data A3 a
185data A4 a
186data A5 a
187data A6 a
188data A7 a
189data A8 a
190data A9 a
191data A10 a
192data A11 a
193data A12 a
194data A13 a
195data A14 a
196data A15 a
197data A16 a
198data A17 a
199data A18 a
200data A19 a
201data A20 a
202data A21 a
203data A22 a
204data A23 a
205data A24 a
206data A25 a
207data A26 a
208data A27 a
209data A28 a
210data A29 a
211data A30 a
212data B0 a
213data B1 a
214data B2 a
215data B3 a
216data B4 a
217data B5 a
218data B6 a
219data B7 a
220data B8 a
221data B9 a
222data B10 a
223data B11 a
224data B12 a
225data B13 a
226data B14 a
227data B15 a
228data B16 a
229data B17 a
230data B18 a
231data B19 a
232data B20 a
233data B21 a
234data B22 a
235data B23 a
236data B24 a
237data B25 a
238data B26 a
239data B27 a
240data B28 a
241data B29 a
242data B30 a
243data C0 a
244data C1 a
245data C2 a
246data C3 a
247data C4 a
248data C5 a
249data C6 a
250data C7 a
251data C8 a
252data C9 a
253data C10 a
254data C11 a
255data C12 a
256data C13 a
257data C14 a
258data C15 a
259data C16 a
260data C17 a
261data C18 a
262data C19 a
263data C20 a
264data C21 a
265data C22 a
266data C23 a
267data C24 a
268data C25 a
269data C26 a
270data C27 a
271data C28 a
272data C29 a
273data C30 a
274
275instance (impl ~ IO ()) => Op (A30 ()) A orig impl where
276  runOp _ _ _ = putStrLn "A30"
277
278newD :: IO (Ref D)
279newD = undefined
280
281main :: IO ()
282main = do
283  d <- newD
284  a30 d