Ticket #2456: DerivingError.hs

File DerivingError.hs, 2.4 KB (added by ronwalf, 7 years ago)
Line 
1{-# OPTIONS
2 -fglasgow-exts
3 -fallow-overlapping-instances
4  #-}
5module DerivingError where
6
7--import Data.Generics hiding ((:+:), Inl, Inr)
8import Data.Generics (Data, Typeable, Typeable1, Typeable2, mkTyCon, mkTyConApp, typeOf, typeOf1)
9
10--------------------------------
11-- Expressions
12--------------------------------
13
14infixr 6 :+:
15data (f :+: g) e = Inl (f e) | Inr (g e) deriving (Data, Eq)
16
17instance (Functor f, Functor g) => Functor (f :+: g) where
18    fmap f (Inl e1) = Inl (fmap f e1)
19    fmap f (Inr e2) = Inr (fmap f e2)
20
21instance (Typeable1 f, Typeable1 g) => Typeable1 (f :+: g) where
22    typeOf1 l = mkTyConApp (mkTyCon "Planning.Wouter.:+:") [typeOf1 x, typeOf1 y] where
23        Inl x = (Inl undefined) `asTypeOf` l
24        Inr y = (Inr undefined) `asTypeOf` l
25
26
27class (Functor sub, Functor sup) => sub :<: sup where
28    inj :: sub a -> sup a
29
30instance Functor f => (:<:) f f where
31    inj = id
32
33instance (Functor f, Functor g) => (:<:) f (f :+: g) where
34    inj = Inl
35
36instance (Functor f, Functor g, Functor h, (:<:) f g) => (:<:) f (h :+: g) where
37    inj = Inr . inj
38
39newtype Expr f = In (f (Expr f))
40instance Typeable1 f => Typeable (Expr f) where
41    typeOf e = mkTyConApp (mkTyCon "Planning.Wouter.Expr") [typeOf1 x]
42        where In x = (In undefined) `asTypeOf` e
43
44inject :: (g :<: f) => g (Expr f) -> Expr f
45inject = In . inj
46
47--------------------------------
48-- Utilities
49--------------------------------
50foldExpr :: Functor f => (f a -> a) -> Expr f -> a
51foldExpr f (In t) = f (fmap (foldExpr f) t)
52
53class Functor f => FuncEq f where
54    funcEq :: FuncEq g => f (Expr g) -> f (Expr g) -> Bool
55
56instance (FuncEq f, FuncEq g) => FuncEq (f :+: g) where
57    funcEq (Inl x) (Inl y) = funcEq x y
58    funcEq (Inr x) (Inr y) = funcEq x y
59    funcEq _ _ = False
60
61instance (FuncEq f) => Eq (Expr f) where
62    (In x) == (In y) = funcEq x y
63
64data Const e = Const String deriving (Data, Eq)
65deriving instance Typeable1 Const
66instance Functor Const where
67    fmap f (Const x) = Const x
68instance FuncEq Const where
69    funcEq (Const x) (Const y) = x == y
70eConst x = inject (Const x)
71
72data Var e = Var String deriving (Data, Eq)
73deriving instance Typeable1 Var
74instance Functor Var where
75    fmap f (Var x) = Var x
76instance FuncEq Var where
77    funcEq (Var x) (Var y) = x == y
78eVar x = inject (Var x)
79
80----------------------------------
81-- Data instance derivations
82----------------------------------
83deriving instance Data (Expr Const)
84deriving instance Data (Expr Var)