| 1 | {-# LANGUAGE TypeOperators #-} |
|---|
| 2 | {-# LANGUAGE TypeFamilies #-} |
|---|
| 3 | {-# LANGUAGE FlexibleContexts #-} |
|---|
| 4 | {-# LANGUAGE DefaultSignatures #-} |
|---|
| 5 | |
|---|
| 6 | module Bug where |
|---|
| 7 | |
|---|
| 8 | import GHC.Generics |
|---|
| 9 | |
|---|
| 10 | |
|---|
| 11 | -------------------------------------------------------------------------------- |
|---|
| 12 | -- Inliner |
|---|
| 13 | -------------------------------------------------------------------------------- |
|---|
| 14 | |
|---|
| 15 | instance 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 | |
|---|
| 30 | instance Datatype D1Logic where |
|---|
| 31 | datatypeName _ = "Logic" |
|---|
| 32 | moduleName _ = "Bug" |
|---|
| 33 | |
|---|
| 34 | instance Constructor C1_0Logic where |
|---|
| 35 | conName _ = "T" |
|---|
| 36 | |
|---|
| 37 | instance Constructor C1_1Logic where |
|---|
| 38 | conName _ = "F" |
|---|
| 39 | |
|---|
| 40 | instance Constructor C1_2Logic where |
|---|
| 41 | conName _ = "Not" |
|---|
| 42 | |
|---|
| 43 | instance Constructor C1_3Logic where |
|---|
| 44 | conName _ = "And" |
|---|
| 45 | |
|---|
| 46 | |
|---|
| 47 | data D1Logic |
|---|
| 48 | data C1_0Logic |
|---|
| 49 | data C1_1Logic |
|---|
| 50 | data C1_2Logic |
|---|
| 51 | data C1_3Logic |
|---|
| 52 | data S1_2_0Logic |
|---|
| 53 | data S1_3_0Logic |
|---|
| 54 | data S1_3_1Logic |
|---|
| 55 | |
|---|
| 56 | |
|---|
| 57 | data Logic = T | F |
|---|
| 58 | | Not Logic |
|---|
| 59 | | And Logic Logic |
|---|
| 60 | deriving (Show) |
|---|
| 61 | |
|---|
| 62 | instance GEq Logic |
|---|
| 63 | |
|---|
| 64 | testEqLogic = geq (Not T) (Not F) |
|---|
| 65 | |
|---|
| 66 | |
|---|
| 67 | -------------------------------------------------------------------------------- |
|---|
| 68 | -- Generic show (library code, only here to simplify the test case) |
|---|
| 69 | -------------------------------------------------------------------------------- |
|---|
| 70 | |
|---|
| 71 | class GEq' f where |
|---|
| 72 | geq' :: f a -> f a -> Bool |
|---|
| 73 | |
|---|
| 74 | instance GEq' U1 where |
|---|
| 75 | {-# INLINE geq' #-} |
|---|
| 76 | geq' _ _ = True |
|---|
| 77 | |
|---|
| 78 | instance (GEq c) => GEq' (K1 i c) where |
|---|
| 79 | {-# INLINE geq' #-} |
|---|
| 80 | geq' (K1 a) (K1 b) = geq a b |
|---|
| 81 | |
|---|
| 82 | instance (GEq' a) => GEq' (M1 i c a) where |
|---|
| 83 | {-# INLINE geq' #-} |
|---|
| 84 | geq' (M1 a) (M1 b) = geq' a b |
|---|
| 85 | |
|---|
| 86 | instance (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 | |
|---|
| 92 | instance (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 | |
|---|
| 97 | class 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) |
|---|
