Bump a few more performance regressions from Type-indexed Typeable
[ghc.git] / testsuite / tests / perf / compiler / T9872b.hs
1 {-
2 - Instant Insanity using Closed Type Families and DataKinds.
3 -
4 - See: http://stackoverflow.com/questions/26538595
5 -}
6
7 {-# OPTIONS_GHC -freduction-depth=400 #-}
8
9 {-# LANGUAGE MultiParamTypeClasses #-}
10 {-# LANGUAGE TypeFamilies #-}
11 {-# LANGUAGE UndecidableInstances #-}
12 {-# LANGUAGE DataKinds, KindSignatures, PolyKinds #-}
13 {-# LANGUAGE TypeOperators #-}
14
15 import Prelude hiding (all, flip, map, filter )
16
17 data Proxy (a :: k) = Proxy
18
19 main = print (Proxy :: Proxy (Solutions Cubes))
20
21 data Color = R | G | B | W
22
23 data Cube = Cube Color Color Color Color Color Color
24
25 type family And (b1 :: Bool) (b2 :: Bool) :: Bool where
26 And True True = True
27 And b1 b2 = False
28
29 type family NE (x :: Color) (y :: Color) :: Bool where
30 NE x x = False
31 NE x y = True
32
33 type family EQ (x :: Color) (y :: Color) :: Bool where
34 EQ a a = True
35 EQ a b = False
36
37 type family All (l :: [Bool]) :: Bool where
38 All '[] = True
39 All (False ': xs) = False
40 All (True ': xs) = All xs
41
42 type family ListConcat (xs :: [k]) (ys :: [k]) :: [k] where
43 ListConcat '[] ys = ys
44 ListConcat (x ': xs) ys = x ': ListConcat xs ys
45
46 type family AppendIf (b :: Bool) (a :: [Cube]) (as :: [[Cube]]) :: [[Cube]] where
47 AppendIf False a as = as
48 AppendIf True a as = a ': as
49
50 data Transform = Rotate | Twist | Flip
51
52 type family Apply (f :: Transform) (a :: Cube) :: Cube where
53 Apply Rotate ('Cube u f r b l d) = ('Cube u r b l f d)
54 Apply Twist ('Cube u f r b l d) = ('Cube f r u l d b)
55 Apply Flip ('Cube u f r b l d) = ('Cube d l b r f u)
56
57 type family Map (f :: Transform) (as :: [Cube]) :: [Cube] where
58 Map f '[] = '[]
59 Map f (a ': as) = (Apply f a) ': (Map f as)
60
61 type family MapAppend (f :: Transform) (as :: [Cube]) :: [Cube] where
62 MapAppend f xs = ListConcat xs (Map f xs)
63
64 type family MapAppend2 (f :: Transform) (as :: [Cube]) :: [Cube] where
65 MapAppend2 f xs = ListConcat xs (MapAppend f (Map f xs))
66
67 type family MapAppend3 (f :: Transform) (as :: [Cube]) :: [Cube] where
68 MapAppend3 f xs = ListConcat xs (MapAppend2 f (Map f xs))
69
70 type family Iterate2 (f :: Transform) (as :: [Cube]) :: [Cube] where
71 Iterate2 f '[] = '[]
72 Iterate2 f (a ': as) = ListConcat [Apply f a, a] (Iterate2 f as)
73
74 type family Iterate3 (f :: Transform) (as :: [Cube]) :: [Cube] where
75 Iterate3 f '[] = '[]
76 Iterate3 f (a ': as) =
77 ListConcat [a, Apply f a, Apply f (Apply f a)] (Iterate3 f as)
78
79 type family Iterate4 (f :: Transform) (as :: [Cube]) :: [Cube] where
80 Iterate4 f '[] = '[]
81 Iterate4 f (a ': as) =
82 ListConcat [a, Apply f a, Apply f (Apply f a), Apply f (Apply f (Apply f a))]
83 (Iterate4 f as)
84
85 type family Orientations (c :: Cube) :: [Cube] where
86 Orientations c = MapAppend3 Rotate (MapAppend2 Twist (MapAppend Flip '[c]))
87
88 type Cube1 = 'Cube B G W G B R
89 type Cube2 = 'Cube W G B W R R
90 type Cube3 = 'Cube G W R B R R
91 type Cube4 = 'Cube B R G G W W
92
93 type Cubes = [Cube1, Cube2, Cube3, Cube4]
94
95 type family Compatible (c :: Cube) (d :: Cube) :: Bool where
96 Compatible ('Cube u1 f1 r1 b1 l1 d1) ('Cube u2 f2 r2 b2 l2 d2) =
97 All [NE f1 f2, NE r1 r2, NE b1 b2, NE l1 l2]
98
99 type family Allowed (c :: Cube) (cs :: [Cube]) :: Bool where
100 Allowed c '[] = True
101 Allowed c (s ': ss) = And (Compatible c s) (Allowed c ss)
102
103 type family MatchingOrientations (as :: [Cube]) (sol :: [Cube]) :: [[Cube]] where
104 MatchingOrientations '[] sol = '[]
105 MatchingOrientations (o ': os) sol =
106 AppendIf (Allowed o sol) (o ': sol) (MatchingOrientations os sol)
107
108 type family AllowedCombinations (os :: [Cube]) (sols :: [[Cube]]) where
109 AllowedCombinations os '[] = '[]
110 AllowedCombinations os (sol ': sols) =
111 ListConcat (MatchingOrientations os sol) (AllowedCombinations os sols)
112
113 type family Solutions (cs :: [Cube]) :: [[Cube]] where
114 Solutions '[] = '[ '[] ]
115 Solutions (c ': cs) = AllowedCombinations (Orientations c) (Solutions cs)