Testsuite error message changes
[ghc.git] / testsuite / tests / indexed-types / should_compile / IndTypesPerfMerge.hs
1 {-# LANGUAGE EmptyDataDecls, TypeFamilies, UndecidableInstances,
2 ScopedTypeVariables, TypeOperators,
3 FlexibleInstances, NoMonomorphismRestriction,
4 MultiParamTypeClasses, FlexibleContexts #-}
5 module IndTypesPerfMerge where
6
7 data a :* b = a :* b
8 infixr 6 :*
9
10 data TRUE
11 data FALSE
12 data Zero
13 data Succ a
14
15 type family Equals m n
16 type instance Equals Zero Zero = TRUE
17 type instance Equals (Succ a) Zero = FALSE
18 type instance Equals Zero (Succ a) = FALSE
19 type instance Equals (Succ a) (Succ b) = Equals a b
20
21 type family LessThan m n
22 type instance LessThan Zero Zero = FALSE
23 type instance LessThan (Succ n) Zero = FALSE
24 type instance LessThan Zero (Succ n) = TRUE
25 type instance LessThan (Succ m) (Succ n) = LessThan m n
26
27 newtype Tagged n a = Tagged a deriving (Show,Eq)
28
29 type family Cond p a b
30
31 type instance Cond TRUE a b = a
32 type instance Cond FALSE a b = b
33
34 class Merger a where
35 type Merged a
36 type UnmergedLeft a
37 type UnmergedRight a
38 mkMerge :: a -> UnmergedLeft a -> UnmergedRight a -> Merged a
39
40 class Mergeable a b where
41 type MergerType a b
42 merger :: a -> b -> MergerType a b
43
44 {-
45 merge ::
46 forall a b.
47 (Merger (MergerType a b), Mergeable a b,
48 UnmergedLeft (MergerType a b) ~ a,
49 UnmergedRight (MergerType a b) ~ b) =>
50 a -> b -> Merged (MergerType a b)
51 -}
52 merge x y = mkMerge (merger x y) x y
53
54 data TakeRight a
55 data TakeLeft a
56 data DiscardRightHead a b c d
57 data LeftHeadFirst a b c d
58 data RightHeadFirst a b c d
59 data EndMerge
60
61 instance Mergeable () () where
62 type MergerType () () = EndMerge
63 merger = undefined
64
65 instance Mergeable () (a :* b) where
66 type MergerType () (a :* b) = TakeRight (a :* b)
67 merger = undefined
68 instance Mergeable (a :* b) () where
69 type MergerType (a :* b) () = TakeLeft (a :* b)
70 merger = undefined
71
72 instance Mergeable (Tagged m a :* t1) (Tagged n b :* t2) where
73 type MergerType (Tagged m a :* t1) (Tagged n b :* t2) =
74 Cond (Equals m n) (DiscardRightHead (Tagged m a) t1 (Tagged n b) t2)
75 (Cond (LessThan m n) (LeftHeadFirst (Tagged m a) t1 (Tagged n b) t2)
76 (RightHeadFirst (Tagged m a ) t1 (Tagged n b) t2))
77 merger = undefined
78
79 instance Merger EndMerge where
80 type Merged EndMerge = ()
81 type UnmergedLeft EndMerge = ()
82 type UnmergedRight EndMerge = ()
83 mkMerge _ () () = ()
84
85 instance Merger (TakeRight a) where
86 type Merged (TakeRight a) = a
87 type UnmergedLeft (TakeRight a) = ()
88 type UnmergedRight (TakeRight a) = a
89 mkMerge _ () a = a
90
91 instance Merger (TakeLeft a) where
92 type Merged (TakeLeft a) = a
93 type UnmergedLeft (TakeLeft a) = a
94 type UnmergedRight (TakeLeft a) = ()
95 mkMerge _ a () = a
96
97 instance
98 (Mergeable t1 t2,
99 Merger (MergerType t1 t2),
100 t1 ~ UnmergedLeft (MergerType t1 t2),
101 t2 ~ UnmergedRight (MergerType t1 t2)) =>
102 Merger (DiscardRightHead h1 t1 h2 t2) where
103 type Merged (DiscardRightHead h1 t1 h2 t2) = h1 :* Merged (MergerType t1 t2)
104 type UnmergedLeft (DiscardRightHead h1 t1 h2 t2) = h1 :* t1
105 type UnmergedRight (DiscardRightHead h1 t1 h2 t2) = h2 :* t2
106 mkMerge _ (h1 :* t1) (h2 :* t2) = h1 :* mkMerge (merger t1 t2) t1 t2
107
108 instance
109 (Mergeable t1 (h2 :* t2),
110 Merger (MergerType t1 (h2 :* t2)),
111 t1 ~ UnmergedLeft (MergerType t1 (h2 :* t2)),
112 (h2 :* t2) ~ UnmergedRight (MergerType t1 (h2 :* t2))) =>
113 Merger (LeftHeadFirst h1 t1 h2 t2) where
114 type Merged (LeftHeadFirst h1 t1 h2 t2) = h1 :* Merged (MergerType t1 (h2 :* t2))
115 type UnmergedLeft (LeftHeadFirst h1 t1 h2 t2) = h1 :* t1
116 type UnmergedRight (LeftHeadFirst h1 t1 h2 t2) = h2 :* t2
117 mkMerge _ (h1 :* t1) (h2 :* t2) = h1 :* mkMerge (merger t1 (h2 :* t2)) t1 (h2 :* t2)
118
119 instance
120 (Mergeable (h1 :* t1) t2,
121 Merger (MergerType (h1 :* t1) t2),
122 (h1 :* t1) ~ UnmergedLeft (MergerType (h1 :* t1) t2),
123 t2 ~ UnmergedRight (MergerType (h1 :* t1) t2)) =>
124 Merger (RightHeadFirst h1 t1 h2 t2) where
125 type Merged (RightHeadFirst h1 t1 h2 t2) = h2 :* Merged (MergerType (h1 :* t1) t2)
126 type UnmergedLeft (RightHeadFirst h1 t1 h2 t2) = h1 :* t1
127 type UnmergedRight (RightHeadFirst h1 t1 h2 t2) = h2 :* t2
128 mkMerge _ (h1 :* t1) (h2 :* t2) = h2 :* mkMerge (merger (h1 :* t1) t2) (h1 :* t1) t2