Ticket #7109: Bug2.hs

File Bug2.hs, 2.3 KB (added by dreixel, 2 years 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  type Rep Logic = D1 D1Logic
17                     (C1 C1_0Logic U1 :+:
18                     (C1 C1_1Logic U1 :+:
19                      C1 C1_2Logic (S1 NoSelector (Rec0 Logic))))
20  {-# INLINE from #-}
21  from T = M1 (L1 (M1 U1))
22  from F = M1 (R1 (L1 (M1 U1)))
23  from (Not g1_aBc) = M1 (R1 (R1 (M1 (M1 (K1 g1_aBc)))))
24  {-# INLINE to #-}
25  to (M1 (L1 (M1 U1))) = T
26  to (M1 (R1 (L1 (M1 U1)))) = F
27  to (M1 (R1 (R1 (M1 (M1 (K1 g1_aBd)))))) = Not g1_aBd
28
29instance Datatype D1Logic where
30  datatypeName _ = "Logic"
31  moduleName _ = "Bug"
32
33instance Constructor C1_0Logic where
34  conName _ = "T"
35
36instance Constructor C1_1Logic where
37  conName _ = "F"
38
39instance Constructor C1_2Logic where
40  conName _ = "Not"
41
42data D1Logic
43data C1_0Logic
44data C1_1Logic
45data C1_2Logic
46data S1_2_0Logic
47
48
49data Logic = T | F
50           | Not Logic
51--         | And Logic Logic
52  deriving (Show)
53
54instance GEq Logic
55
56testEqLogic = geq (Not T) (Not F)
57
58
59--------------------------------------------------------------------------------
60-- Generic show (library code, only here to simplify the test case)
61--------------------------------------------------------------------------------
62
63class GEq' f where
64  geq' :: f a -> f a -> Bool
65
66instance GEq' U1 where
67  {-# INLINE geq' #-}
68  geq' _ _ = True
69
70instance (GEq c) => GEq' (K1 i c) where
71  {-# INLINE geq' #-}
72  geq' (K1 a) (K1 b) = geq a b
73
74instance (GEq' a) => GEq' (M1 i c a) where
75  {-# INLINE geq' #-}
76  geq' (M1 a) (M1 b) = geq' a b
77
78instance (GEq' a, GEq' b) => GEq' (a :+: b) where
79  {-# INLINE geq' #-}
80  geq' (L1 a) (L1 b) = geq' a b
81  geq' (R1 a) (R1 b) = geq' a b
82  geq' _      _      = False
83
84instance (GEq' a, GEq' b) => GEq' (a :*: b) where
85  {-# INLINE geq' #-}
86  geq' (a1 :*: b1) (a2 :*: b2) = geq' a1 a2 && geq' b1 b2
87
88
89class GEq a where
90  geq :: a -> a -> Bool
91
92  {-# INLINE geq #-}
93  default geq :: (Generic a, GEq' (Rep a)) => a -> a -> Bool
94  geq x y = geq' (from x) (from y)