e37bfe323e875b48e8063743fa8ab3d97884cd38
[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 merge x y = mkMerge (merger x y) x y
45
46 data TakeRight a
47 data TakeLeft a
48 data DiscardRightHead a b c d
49 data LeftHeadFirst a b c d
50 data RightHeadFirst a b c d
51 data EndMerge
52
53 instance Mergeable () () where
54 type MergerType () () = EndMerge
55 merger = undefined
56
57 instance Mergeable () (a :* b) where
58 type MergerType () (a :* b) = TakeRight (a :* b)
59 merger = undefined
60 instance Mergeable (a :* b) () where
61 type MergerType (a :* b) () = TakeLeft (a :* b)
62 merger = undefined
63
64 instance Mergeable (Tagged m a :* t1) (Tagged n b :* t2) where
65 type MergerType (Tagged m a :* t1) (Tagged n b :* t2) =
66 Cond (Equals m n) (DiscardRightHead (Tagged m a) t1 (Tagged n b) t2)
67 (Cond (LessThan m n) (LeftHeadFirst (Tagged m a) t1 (Tagged n b) t2)
68 (RightHeadFirst (Tagged m a ) t1 (Tagged n b) t2))
69 merger = undefined
70
71 instance Merger EndMerge where
72 type Merged EndMerge = ()
73 type UnmergedLeft EndMerge = ()
74 type UnmergedRight EndMerge = ()
75 mkMerge _ () () = ()
76
77 instance Merger (TakeRight a) where
78 type Merged (TakeRight a) = a
79 type UnmergedLeft (TakeRight a) = ()
80 type UnmergedRight (TakeRight a) = a
81 mkMerge _ () a = a
82
83 instance Merger (TakeLeft a) where
84 type Merged (TakeLeft a) = a
85 type UnmergedLeft (TakeLeft a) = a
86 type UnmergedRight (TakeLeft a) = ()
87 mkMerge _ a () = a
88
89 instance
90 (Mergeable t1 t2,
91 Merger (MergerType t1 t2),
92 t1 ~ UnmergedLeft (MergerType t1 t2),
93 t2 ~ UnmergedRight (MergerType t1 t2)) =>
94 Merger (DiscardRightHead h1 t1 h2 t2) where
95 type Merged (DiscardRightHead h1 t1 h2 t2) = h1 :* Merged (MergerType t1 t2)
96 type UnmergedLeft (DiscardRightHead h1 t1 h2 t2) = h1 :* t1
97 type UnmergedRight (DiscardRightHead h1 t1 h2 t2) = h2 :* t2
98 mkMerge _ (h1 :* t1) (h2 :* t2) = h1 :* mkMerge (merger t1 t2) t1 t2
99
100 instance
101 (Mergeable t1 (h2 :* t2),
102 Merger (MergerType t1 (h2 :* t2)),
103 t1 ~ UnmergedLeft (MergerType t1 (h2 :* t2)),
104 (h2 :* t2) ~ UnmergedRight (MergerType t1 (h2 :* t2))) =>
105 Merger (LeftHeadFirst h1 t1 h2 t2) where
106 type Merged (LeftHeadFirst h1 t1 h2 t2) = h1 :* Merged (MergerType t1 (h2 :* t2))
107 type UnmergedLeft (LeftHeadFirst h1 t1 h2 t2) = h1 :* t1
108 type UnmergedRight (LeftHeadFirst h1 t1 h2 t2) = h2 :* t2
109 mkMerge _ (h1 :* t1) (h2 :* t2) = h1 :* mkMerge (merger t1 (h2 :* t2)) t1 (h2 :* t2)
110
111 instance
112 (Mergeable (h1 :* t1) t2,
113 Merger (MergerType (h1 :* t1) t2),
114 (h1 :* t1) ~ UnmergedLeft (MergerType (h1 :* t1) t2),
115 t2 ~ UnmergedRight (MergerType (h1 :* t1) t2)) =>
116 Merger (RightHeadFirst h1 t1 h2 t2) where
117 type Merged (RightHeadFirst h1 t1 h2 t2) = h2 :* Merged (MergerType (h1 :* t1) t2)
118 type UnmergedLeft (RightHeadFirst h1 t1 h2 t2) = h1 :* t1
119 type UnmergedRight (RightHeadFirst h1 t1 h2 t2) = h2 :* t2
120 mkMerge _ (h1 :* t1) (h2 :* t2) = h2 :* mkMerge (merger (h1 :* t1) t2) (h1 :* t1) t2