Bump a few more performance regressions from Type-indexed Typeable
[ghc.git] / testsuite / tests / perf / compiler / T9872a.hs
1 {-
2 - Instant Insanity using Type Families.
3 -
4 - See: The Monad Read, Issue #8 - http://www.haskell.org/wikiupload/d/dd/TMR-Issue8.pdf
5 -}
6
7 {-# OPTIONS_GHC -freduction-depth=400 #-}
8
9 {-# LANGUAGE MultiParamTypeClasses #-}
10 {-# LANGUAGE TypeFamilies #-}
11 {-# LANGUAGE UndecidableInstances #-}
12
13 import Prelude hiding (all, flip, map, filter )
14
15 data Proxy a = Proxy
16 main = print (Proxy :: Proxy (Solutions Cubes))
17
18 data R -- Red
19 data G -- Green
20 data B -- Blue
21 data W -- White
22
23 data Cube u f r b l d
24
25 data True
26 data False
27
28 type family And b1 b2 :: *
29 type instance And True True = True
30 type instance And True False = False
31 type instance And False False = False
32 type instance And False True = False
33
34 type family NE x y :: *
35 type instance NE R R = False
36 type instance NE R G = True
37 type instance NE R B = True
38 type instance NE R W = True
39 type instance NE G R = True
40 type instance NE G G = False
41 type instance NE G B = True
42 type instance NE G W = True
43 type instance NE B R = True
44 type instance NE B G = True
45 type instance NE B B = False
46 type instance NE B W = True
47 type instance NE W R = True
48 type instance NE W G = True
49 type instance NE W B = True
50 type instance NE W W = False
51
52 type family EQ x y :: *
53
54 type instance EQ R R = True
55 type instance EQ R G = False
56 type instance EQ R B = False
57 type instance EQ R W = False
58 type instance EQ G R = False
59 type instance EQ G G = True
60 type instance EQ G B = False
61 type instance EQ G W = False
62 type instance EQ B R = False
63 type instance EQ B G = False
64 type instance EQ B B = True
65 type instance EQ B W = False
66 type instance EQ W R = False
67 type instance EQ W G = False
68 type instance EQ W B = False
69 type instance EQ W W = True
70
71 data Nil = Nil
72 data Cons x xs = Cons x xs
73
74 type family All l :: *
75 type instance All Nil = True
76 type instance All (Cons False xs) = False
77 type instance All (Cons True xs) = All xs
78
79 type family ListConcat xs ys :: *
80 type instance ListConcat Nil ys = ys
81 type instance ListConcat (Cons x xs) ys = Cons x (ListConcat xs ys)
82
83 type family AppendIf b a as :: *
84 type instance AppendIf False a as = as
85 type instance AppendIf True a as = Cons a as
86
87 data Rotate
88 data Twist
89 data Flip
90
91 type family Apply f a :: *
92 type instance Apply Rotate (Cube u f r b l d) = (Cube u r b l f d)
93 type instance Apply Twist (Cube u f r b l d) = (Cube f r u l d b)
94 type instance Apply Flip (Cube u f r b l d) = (Cube d l b r f u)
95
96 -- orientations c = [ z | x <- [ c, flip c ], y <- [ x, twist x, twist (twist x) ], z <- [y, rot y, rot(rot y), rot(rot(rot(y))) ] ]
97
98 type family Map f as :: *
99 type instance Map f Nil = Nil
100 type instance Map f (Cons a as) = Cons (Apply f a) (Map f as)
101
102 type family MapAppend f as :: *
103 type instance MapAppend f xs = ListConcat xs (Map f xs)
104
105 type family MapAppend2 f as :: *
106 type instance MapAppend2 f xs = ListConcat xs (MapAppend f (Map f xs))
107
108 type family MapAppend3 f as :: *
109 type instance MapAppend3 f xs = ListConcat xs (MapAppend2 f (Map f xs))
110
111 type family Iterate2 f as :: *
112 type instance Iterate2 f Nil = Nil
113 type instance Iterate2 f (Cons a as) = ListConcat (Cons (Apply f a) (Cons a Nil)) (Iterate2 f as)
114
115 type family Iterate3 f as :: *
116 type instance Iterate3 f (Cons a as) =
117 ListConcat (Cons a
118 (Cons (Apply f a)
119 (Cons (Apply f (Apply f a))
120 Nil)))
121 (Iterate3 f as)
122
123 type family Iterate4 f as :: *
124 type instance Iterate4 f Nil = Nil
125 type instance Iterate4 f (Cons a as) =
126 ListConcat (Cons a
127 (Cons (Apply f a)
128 (Cons (Apply f (Apply f a))
129 (Cons (Apply f (Apply f (Apply f a)))
130 Nil))))
131 (Iterate4 f as)
132
133 type family Orientations c :: *
134 -- type instance Orientations c = Iterate4 Rotate (Iterate3 Twist (Iterate2 Flip (Cons c Nil)))
135 type instance Orientations c = MapAppend3 Rotate (MapAppend2 Twist (MapAppend Flip (Cons c Nil)))
136
137 type Cube1 = Cube B G W G B R
138 type Cube2 = Cube W G B W R R
139 type Cube3 = Cube G W R B R R
140 type Cube4 = Cube B R G G W W
141
142 type Cubes = Cons Cube1 (Cons Cube2 (Cons Cube3 (Cons Cube4 Nil)))
143
144 type family Compatible c d :: *
145 type instance Compatible (Cube u1 f1 r1 b1 l1 d1) (Cube u2 f2 r2 b2 l2 d2) =
146 All (Cons (NE f1 f2) (Cons (NE r1 r2) (Cons (NE b1 b2) (Cons (NE l1 l2) Nil))))
147
148 type family Allowed c cs :: *
149 type instance Allowed c Nil = True
150 type instance Allowed c (Cons s ss) = And (Compatible c s) (Allowed c ss)
151
152 type family MatchingOrientations as sol :: *
153 type instance MatchingOrientations Nil sol = Nil
154 type instance MatchingOrientations (Cons o os) sol = AppendIf (Allowed o sol) (Cons o sol) (MatchingOrientations os sol)
155
156 type family AllowedCombinations os sols :: *
157 type instance AllowedCombinations os Nil = Nil
158 type instance AllowedCombinations os (Cons sol sols) = ListConcat (MatchingOrientations os sol) (AllowedCombinations os sols)
159
160 type family Solutions c :: *
161 type instance Solutions Nil = Cons Nil Nil
162 type instance Solutions (Cons c cs) = AllowedCombinations (Orientations c) (Solutions cs)
163
164 {-
165 - solutions [] = [ [] ]
166 - solutions (c:cs) = [ (o:sol) | sol <- solutions cs, o <- orientations c, allowed o
167 -}