Tests for Trac #9872

5 files changed, 392 insertions, 0 deletions

diff --git a/testsuite/tests/perf/compiler/T9872a.hs b/testsuite/tests/perf/compiler/T9872a.hs
new file mode 100644
index 0000000000..16a0adcb44
--- /dev/null
+++ b/testsuite/tests/perf/compiler/T9872a.hs
@@ -0,0 +1,167 @@
+{-
+ - Instant Insanity using Type Families.
+ -
+ - See:  The Monad Read, Issue #8 - http://www.haskell.org/wikiupload/d/dd/TMR-Issue8.pdf
+ -}
+
+{-# OPTIONS_GHC -ftype-function-depth=400 #-}
+
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+import Prelude hiding (all, flip, map, filter )
+
+data Proxy a = Proxy
+main = print (Proxy :: Proxy (Solutions Cubes))
+
+data R -- Red
+data G -- Green
+data B -- Blue
+data W -- White
+
+data Cube u f r b l d
+
+data True
+data False
+
+type family And b1 b2 :: *
+type instance And True True   = True
+type instance And True False  = False
+type instance And False False = False
+type instance And False True  = False
+
+type family NE x y :: *
+type instance NE R R = False
+type instance NE R G = True
+type instance NE R B = True
+type instance NE R W = True
+type instance NE G R = True
+type instance NE G G = False
+type instance NE G B = True
+type instance NE G W = True
+type instance NE B R = True
+type instance NE B G = True
+type instance NE B B = False
+type instance NE B W = True
+type instance NE W R = True
+type instance NE W G = True
+type instance NE W B = True
+type instance NE W W = False
+
+type family EQ x y :: *
+
+type instance EQ R R = True
+type instance EQ R G = False
+type instance EQ R B = False
+type instance EQ R W = False
+type instance EQ G R = False
+type instance EQ G G = True
+type instance EQ G B = False
+type instance EQ G W = False
+type instance EQ B R = False
+type instance EQ B G = False
+type instance EQ B B = True
+type instance EQ B W = False
+type instance EQ W R = False
+type instance EQ W G = False
+type instance EQ W B = False
+type instance EQ W W = True
+
+data Nil = Nil
+data Cons x xs = Cons x xs
+
+type family All l :: *
+type instance All Nil = True
+type instance All (Cons False xs) = False
+type instance All (Cons True xs) = All xs
+
+type family ListConcat xs ys :: *
+type instance ListConcat Nil ys = ys
+type instance ListConcat (Cons x xs) ys = Cons x (ListConcat xs ys)
+
+type family AppendIf b a as :: *
+type instance AppendIf False a as = as
+type instance AppendIf True a as = Cons a as
+
+data Rotate
+data Twist
+data Flip
+
+type family Apply f a :: *
+type instance Apply Rotate (Cube u f r b l d) = (Cube u r b l f d)
+type instance Apply Twist  (Cube u f r b l d) = (Cube f r u l d b)
+type instance Apply Flip   (Cube u f r b l d) = (Cube d l b r f u)
+
+-- 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))) ] ]
+
+type family Map f as :: *
+type instance Map f Nil = Nil
+type instance Map f (Cons a as) = Cons (Apply f a) (Map f as)
+
+type family MapAppend f as :: *
+type instance MapAppend f xs = ListConcat xs (Map f xs)
+
+type family MapAppend2 f as :: *
+type instance MapAppend2 f xs = ListConcat xs (MapAppend f (Map f xs))
+
+type family MapAppend3 f as :: *
+type instance MapAppend3 f xs = ListConcat xs (MapAppend2 f (Map f xs))
+
+type family Iterate2 f as :: *
+type instance Iterate2 f Nil = Nil
+type instance Iterate2 f (Cons a as) = ListConcat (Cons (Apply f a) (Cons a Nil)) (Iterate2 f as)
+
+type family Iterate3 f as :: *
+type instance Iterate3 f (Cons a as) =
+  ListConcat (Cons a
+             (Cons (Apply f a)
+             (Cons (Apply f (Apply f a))
+              Nil)))
+             (Iterate3 f as)
+
+type family Iterate4 f as :: *
+type instance Iterate4 f Nil = Nil
+type instance Iterate4 f (Cons a as) =
+   ListConcat (Cons a
+              (Cons (Apply f a)
+              (Cons (Apply f (Apply f a))
+              (Cons (Apply f (Apply f (Apply f a)))
+               Nil))))
+              (Iterate4 f as)
+
+type family Orientations c :: *
+-- type instance Orientations c = Iterate4 Rotate (Iterate3 Twist (Iterate2 Flip (Cons c Nil)))
+type instance Orientations c = MapAppend3 Rotate (MapAppend2 Twist (MapAppend Flip (Cons c Nil)))
+
+type Cube1 = Cube B G W G B R
+type Cube2 = Cube W G B W R R
+type Cube3 = Cube G W R B R R
+type Cube4 = Cube B R G G W W
+
+type Cubes = Cons Cube1 (Cons Cube2 (Cons Cube3 (Cons Cube4 Nil)))
+
+type family Compatible c d :: *
+type instance Compatible (Cube u1 f1 r1 b1 l1 d1) (Cube u2 f2 r2 b2 l2 d2) =
+  All (Cons (NE f1 f2) (Cons (NE r1 r2) (Cons (NE b1 b2) (Cons (NE l1 l2) Nil))))
+
+type family Allowed c cs :: *
+type instance Allowed c Nil = True
+type instance Allowed c (Cons s ss) = And (Compatible c s) (Allowed c ss)
+
+type family MatchingOrientations as sol :: *
+type instance MatchingOrientations Nil sol = Nil
+type instance MatchingOrientations (Cons o os) sol = AppendIf (Allowed o sol) (Cons o sol) (MatchingOrientations os sol)
+
+type family AllowedCombinations os sols :: *
+type instance AllowedCombinations os Nil = Nil
+type instance AllowedCombinations os (Cons sol sols) = ListConcat (MatchingOrientations os sol) (AllowedCombinations os sols)
+
+type family Solutions c :: *
+type instance Solutions Nil = Cons Nil Nil
+type instance Solutions (Cons c cs) = AllowedCombinations (Orientations c) (Solutions cs)
+
+{-
+ - solutions [] = [ [] ]
+ - solutions (c:cs) = [ (o:sol) | sol <- solutions cs, o <- orientations c, allowed o 
+-}
\ No newline at end of file
diff --git a/testsuite/tests/perf/compiler/T9872a.stderr b/testsuite/tests/perf/compiler/T9872a.stderr
new file mode 100644
index 0000000000..b38fcaeeb1
--- /dev/null
+++ b/testsuite/tests/perf/compiler/T9872a.stderr
@@ -0,0 +1,66 @@
+
+T9872a.hs:16:8:
+    No instance for (Show
+                       (Proxy
+                          (Cons
+                             (Cons
+                                (Cube G B W R B G)
+                                (Cons
+                                   (Cube W G B W R R)
+                                   (Cons (Cube R W R B G R) (Cons (Cube B R G G W W) Nil))))
+                             (Cons
+                                (Cons
+                                   (Cube G B R W B G)
+                                   (Cons
+                                      (Cube R R W B G W)
+                                      (Cons (Cube R G B R W R) (Cons (Cube W W G G R B) Nil))))
+                                (Cons
+                                   (Cons
+                                      (Cube G W R B B G)
+                                      (Cons
+                                         (Cube W B W R G R)
+                                         (Cons (Cube R R B G W R) (Cons (Cube B G G W R W) Nil))))
+                                   (Cons
+                                      (Cons
+                                         (Cube G R W B B G)
+                                         (Cons
+                                            (Cube R W B G R W)
+                                            (Cons
+                                               (Cube R B R W G R) (Cons (Cube W G G R W B) Nil))))
+                                      (Cons
+                                         (Cons
+                                            (Cube G R B B W G)
+                                            (Cons
+                                               (Cube W W R G B R)
+                                               (Cons
+                                                  (Cube R B G W R R)
+                                                  (Cons (Cube B G W R G W) Nil))))
+                                         (Cons
+                                            (Cons
+                                               (Cube G W B B R G)
+                                               (Cons
+                                                  (Cube R B G R W W)
+                                                  (Cons
+                                                     (Cube R R W G B R)
+                                                     (Cons (Cube W G R W G B) Nil))))
+                                            (Cons
+                                               (Cons
+                                                  (Cube G B B W R G)
+                                                  (Cons
+                                                     (Cube W R G B W R)
+                                                     (Cons
+                                                        (Cube R G W R B R)
+                                                        (Cons (Cube B W R G G W) Nil))))
+                                               (Cons
+                                                  (Cons
+                                                     (Cube G B B R W G)
+                                                     (Cons
+                                                        (Cube R G R W B W)
+                                                        (Cons
+                                                           (Cube R W G B R R)
+                                                           (Cons (Cube W R W G G B) Nil))))
+                                                  Nil))))))))))
+      arising from a use of ‘print’
+    In the expression: print (Proxy :: Proxy (Solutions Cubes))
+    In an equation for ‘main’:
+        main = print (Proxy :: Proxy (Solutions Cubes))
diff --git a/testsuite/tests/perf/compiler/T9872b.hs b/testsuite/tests/perf/compiler/T9872b.hs
new file mode 100644
index 0000000000..77c204e097
--- /dev/null
+++ b/testsuite/tests/perf/compiler/T9872b.hs
@@ -0,0 +1,115 @@
+{-
+ - Instant Insanity using Closed Type Families and DataKinds.
+ -
+ - See:  http://stackoverflow.com/questions/26538595
+ -}
+
+{-# OPTIONS_GHC -ftype-function-depth=400 #-}
+
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE DataKinds, KindSignatures, PolyKinds #-}
+{-# LANGUAGE TypeOperators #-}
+
+import Prelude hiding (all, flip, map, filter )
+
+data Proxy (a :: k) = Proxy
+
+main = print (Proxy :: Proxy (Solutions Cubes))
+
+data Color = R | G | B | W
+
+data Cube = Cube Color Color Color Color Color Color
+
+type family And (b1 :: Bool) (b2 :: Bool) :: Bool where
+    And True True = True
+    And b1 b2 = False
+
+type family NE (x :: Color) (y :: Color) :: Bool where
+    NE x x = False
+    NE x y = True
+
+type family EQ (x :: Color) (y :: Color) :: Bool where
+    EQ a a = True
+    EQ a b = False
+
+type family All (l :: [Bool]) :: Bool where
+    All '[] = True
+    All (False ': xs) = False
+    All (True ': xs) = All xs
+
+type family ListConcat (xs :: [k]) (ys :: [k]) :: [k] where
+    ListConcat '[] ys = ys
+    ListConcat (x ': xs) ys = x ': ListConcat xs ys
+
+type family AppendIf (b :: Bool) (a :: [Cube]) (as :: [[Cube]]) :: [[Cube]] where
+    AppendIf False a as = as
+    AppendIf True a as = a ': as
+
+data Transform = Rotate | Twist | Flip
+
+type family Apply (f :: Transform) (a :: Cube) :: Cube where
+    Apply Rotate ('Cube u f r b l d) = ('Cube u r b l f d)
+    Apply Twist  ('Cube u f r b l d) = ('Cube f r u l d b)
+    Apply Flip   ('Cube u f r b l d) = ('Cube d l b r f u)
+
+type family Map (f :: Transform) (as :: [Cube]) :: [Cube] where
+    Map f '[] = '[]
+    Map f (a ': as) = (Apply f a) ': (Map f as)
+
+type family MapAppend (f :: Transform) (as :: [Cube]) :: [Cube] where
+    MapAppend f xs = ListConcat xs (Map f xs)
+
+type family MapAppend2 (f :: Transform) (as :: [Cube]) :: [Cube] where
+    MapAppend2 f xs = ListConcat xs (MapAppend f (Map f xs))
+
+type family MapAppend3 (f :: Transform) (as :: [Cube]) :: [Cube] where
+    MapAppend3 f xs = ListConcat xs (MapAppend2 f (Map f xs))
+
+type family Iterate2 (f :: Transform) (as :: [Cube]) :: [Cube] where
+    Iterate2 f '[] = '[]
+    Iterate2 f (a ': as) = ListConcat [Apply f a, a] (Iterate2 f as)
+
+type family Iterate3 (f :: Transform) (as :: [Cube]) :: [Cube] where
+    Iterate3 f '[] = '[]
+    Iterate3 f (a ': as) =
+        ListConcat [a, Apply f a, Apply f (Apply f a)] (Iterate3 f as)
+
+type family Iterate4 (f :: Transform) (as :: [Cube]) :: [Cube] where
+    Iterate4 f '[] = '[]
+    Iterate4 f (a ': as) =
+        ListConcat [a, Apply f a, Apply f (Apply f a), Apply f (Apply f (Apply f a))]
+                   (Iterate4 f as)
+
+type family Orientations (c :: Cube) :: [Cube] where
+    Orientations c = MapAppend3 Rotate (MapAppend2 Twist (MapAppend Flip '[c]))
+
+type Cube1 = 'Cube B G W G B R
+type Cube2 = 'Cube W G B W R R
+type Cube3 = 'Cube G W R B R R
+type Cube4 = 'Cube B R G G W W
+
+type Cubes = [Cube1, Cube2, Cube3, Cube4]
+
+type family Compatible (c :: Cube) (d :: Cube) :: Bool where
+    Compatible ('Cube u1 f1 r1 b1 l1 d1) ('Cube u2 f2 r2 b2 l2 d2) =
+        All [NE f1 f2, NE r1 r2, NE b1 b2, NE l1 l2]
+
+type family Allowed (c :: Cube) (cs :: [Cube]) :: Bool where
+    Allowed c '[] = True
+    Allowed c (s ': ss) = And (Compatible c s) (Allowed c ss)
+
+type family MatchingOrientations (as :: [Cube]) (sol :: [Cube]) :: [[Cube]] where
+    MatchingOrientations '[] sol = '[]
+    MatchingOrientations (o ': os) sol =
+        AppendIf (Allowed o sol) (o ': sol) (MatchingOrientations os sol)
+
+type family AllowedCombinations (os :: [Cube]) (sols :: [[Cube]]) where
+    AllowedCombinations os '[] = '[]
+    AllowedCombinations os (sol ': sols) =
+        ListConcat (MatchingOrientations os sol) (AllowedCombinations os sols)
+
+type family Solutions (cs :: [Cube]) :: [[Cube]] where
+    Solutions '[] = '[ '[] ]
+    Solutions (c ': cs) = AllowedCombinations (Orientations c) (Solutions cs)
diff --git a/testsuite/tests/perf/compiler/T9872b.stderr b/testsuite/tests/perf/compiler/T9872b.stderr
new file mode 100644
index 0000000000..d2d8ad8441
--- /dev/null
+++ b/testsuite/tests/perf/compiler/T9872b.stderr
@@ -0,0 +1,24 @@
+
+T9872b.hs:19:8:
+    No instance for (Show
+                       (Proxy
+                          '['['Cube 'G 'B 'W 'R 'B 'G, 'Cube 'W 'G 'B 'W 'R 'R,
+                              'Cube 'R 'W 'R 'B 'G 'R, 'Cube 'B 'R 'G 'G 'W 'W],
+                            '['Cube 'G 'B 'R 'W 'B 'G, 'Cube 'R 'R 'W 'B 'G 'W,
+                              'Cube 'R 'G 'B 'R 'W 'R, 'Cube 'W 'W 'G 'G 'R 'B],
+                            '['Cube 'G 'W 'R 'B 'B 'G, 'Cube 'W 'B 'W 'R 'G 'R,
+                              'Cube 'R 'R 'B 'G 'W 'R, 'Cube 'B 'G 'G 'W 'R 'W],
+                            '['Cube 'G 'R 'W 'B 'B 'G, 'Cube 'R 'W 'B 'G 'R 'W,
+                              'Cube 'R 'B 'R 'W 'G 'R, 'Cube 'W 'G 'G 'R 'W 'B],
+                            '['Cube 'G 'R 'B 'B 'W 'G, 'Cube 'W 'W 'R 'G 'B 'R,
+                              'Cube 'R 'B 'G 'W 'R 'R, 'Cube 'B 'G 'W 'R 'G 'W],
+                            '['Cube 'G 'W 'B 'B 'R 'G, 'Cube 'R 'B 'G 'R 'W 'W,
+                              'Cube 'R 'R 'W 'G 'B 'R, 'Cube 'W 'G 'R 'W 'G 'B],
+                            '['Cube 'G 'B 'B 'W 'R 'G, 'Cube 'W 'R 'G 'B 'W 'R,
+                              'Cube 'R 'G 'W 'R 'B 'R, 'Cube 'B 'W 'R 'G 'G 'W],
+                            '['Cube 'G 'B 'B 'R 'W 'G, 'Cube 'R 'G 'R 'W 'B 'W,
+                              'Cube 'R 'W 'G 'B 'R 'R, 'Cube 'W 'R 'W 'G 'G 'B]]))
+      arising from a use of ‘print’
+    In the expression: print (Proxy :: Proxy (Solutions Cubes))
+    In an equation for ‘main’:
+        main = print (Proxy :: Proxy (Solutions Cubes))
diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T
index 03ff0c3825..104741a659 100644
--- a/testsuite/tests/perf/compiler/all.T
+++ b/testsuite/tests/perf/compiler/all.T
@@ -545,3 +545,23 @@ test('T9675',
       ],
      compile,
      [''])
+
+test('T9872a',
+     [ only_ways(['normal']),
+       compiler_stats_num_field('bytes allocated',
+          [(wordsize(64), 5521332656, 5)
+          # 2014-12-10    5521332656    Initally created
+          ]),
+      ],
+     compile_fail,
+     [''])
+
+test('T9872b',
+     [ only_ways(['normal']),
+       compiler_stats_num_field('bytes allocated',
+          [(wordsize(64), 6483306280, 5)
+          # 2014-12-10    6483306280    Initally created
+          ]),
+      ],
+     compile_fail,
+     [''])