Ticket #7109: Bug3.hs

File Bug3.hs, 2.7 KB (added by dreixel, 21 months ago)
Line 
1{-# LANGUAGE TypeOperators #-}
2{-# LANGUAGE TypeFamilies #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE DefaultSignatures #-}
5
6module Bug where
7   
8import GHC.Generics
9
10
11--------------------------------------------------------------------------------
12-- Inliner
13--------------------------------------------------------------------------------
14
15instance Generic Logic where
16
17  type Rep Logic = D1 D1Logic ((C1 C1_0Logic U1 :+: C1 C1_1Logic U1) :+: (C1 C1_2Logic (S1 NoSelector (Rec0 Logic)) :+: C1 C1_3Logic (S1 NoSelector (Rec0 Logic) :*: S1 NoSelector (Rec0 Logic))))
18
19  {-# INLINE from #-}
20  from T = M1 (L1 (L1 (M1 U1)))
21  from F = M1 (L1 (R1 (M1 U1)))
22  from (Not g1_aBh) = M1 (R1 (L1 (M1 (M1 (K1 g1_aBh)))))
23  from (And g1_aBi g2_aBj) = M1 (R1 (R1 (M1 ((:*:) (M1 (K1 g1_aBi)) (M1 (K1 g2_aBj))))))
24  {-# INLINE to #-}
25  to (M1 (L1 (L1 (M1 U1)))) = T
26  to (M1 (L1 (R1 (M1 U1)))) = F
27  to (M1 (R1 (L1 (M1 (M1 (K1 g1_aBk)))))) = Not g1_aBk
28  to (M1 (R1 (R1 (M1 ((:*:) (M1 (K1 g1_aBl)) (M1 (K1 g2_aBm))))))) = And g1_aBl g2_aBm
29
30instance Datatype D1Logic where
31  datatypeName _ = "Logic"
32  moduleName _ = "Bug"
33
34instance Constructor C1_0Logic where
35  conName _ = "T"
36
37instance Constructor C1_1Logic where
38  conName _ = "F"
39
40instance Constructor C1_2Logic where
41  conName _ = "Not"
42
43instance Constructor C1_3Logic where
44  conName _ = "And"
45 
46
47data D1Logic
48data C1_0Logic
49data C1_1Logic
50data C1_2Logic
51data C1_3Logic
52data S1_2_0Logic
53data S1_3_0Logic
54data S1_3_1Logic
55
56
57data Logic = T | F
58           | Not Logic 
59           | And Logic Logic
60  deriving (Show)
61
62instance GEq Logic
63
64testEqLogic = geq (Not T) (Not F)
65
66
67--------------------------------------------------------------------------------
68-- Generic show (library code, only here to simplify the test case)
69--------------------------------------------------------------------------------
70
71class GEq' f where
72  geq' :: f a -> f a -> Bool
73
74instance GEq' U1 where
75  {-# INLINE geq' #-}
76  geq' _ _ = True
77
78instance (GEq c) => GEq' (K1 i c) where
79  {-# INLINE geq' #-}
80  geq' (K1 a) (K1 b) = geq a b
81
82instance (GEq' a) => GEq' (M1 i c a) where
83  {-# INLINE geq' #-}
84  geq' (M1 a) (M1 b) = geq' a b
85
86instance (GEq' a, GEq' b) => GEq' (a :+: b) where
87  {-# INLINE geq' #-}
88  geq' (L1 a) (L1 b) = geq' a b
89  geq' (R1 a) (R1 b) = geq' a b
90  geq' _      _      = False
91
92instance (GEq' a, GEq' b) => GEq' (a :*: b) where
93  {-# INLINE geq' #-}
94  geq' (a1 :*: b1) (a2 :*: b2) = geq' a1 a2 && geq' b1 b2
95
96
97class GEq a where
98  geq :: a -> a -> Bool
99
100  {-# INLINE geq #-}
101  default geq :: (Generic a, GEq' (Rep a)) => a -> a -> Bool
102  geq x y = geq' (from x) (from y)