GhcApiAstTraversals: CoreSynTraverse.hs

File CoreSynTraverse.hs, 2.7 KB (added by batterseapower, 6 years ago)

Slightly eccentric CoreSyn? instances

Line 
1instance Typeable a => Data (Expr a) where
2    gfoldl _ z (Var v) = z (Var v)
3    gfoldl _ z (Lit l) = z (Lit l)
4    gfoldl k z (App e1 e2) = z App `k` e1 `k` e2
5    gfoldl k z (Lam b e) = z (Lam b) `k` e
6    gfoldl k z (Let bs e) = z Let `k` bs `k` e
7    gfoldl k z (Case e b t alts) = z (\e' alts' -> Case e' b t (map unwrapAlt alts')) `k` e `k` (map WrappedAlt alts)
8    gfoldl k z (Cast e o) = z (\e' -> Cast e' o) `k` e
9    gfoldl k z (Note n e) = z (Note n) `k` e
10    gfoldl _ z (Type t) = z (Type t)
11
12    gunfold _ _ _ = error "gunfold not defined for Expr"
13
14    toConstr (Var _) = con_Var
15    toConstr (Lit _) = con_Lit
16    toConstr (App _ _) = con_App
17    toConstr (Lam _ _) = con_Lam
18    toConstr (Let _ _) = con_Let
19    toConstr (Case _ _ _ _) = con_Case
20    toConstr (Cast _ _) = con_Cast
21    toConstr (Note _ _) = con_Note
22    toConstr (Type _) = con_Type
23   
24    dataTypeOf _ = ty_Expr
25
26con_Var, con_Lit, con_App, con_Lam, con_Let, con_Case, con_Cast, con_Note, con_Type :: Constr
27con_Var  = mkConstr ty_Expr "Var"  [] Prefix
28con_Lit  = mkConstr ty_Expr "Lit"  [] Prefix
29con_App  = mkConstr ty_Expr "App"  [] Prefix
30con_Lam  = mkConstr ty_Expr "Lam"  [] Prefix
31con_Let  = mkConstr ty_Expr "Let"  [] Prefix
32con_Case = mkConstr ty_Expr "Case" [] Prefix
33con_Cast = mkConstr ty_Expr "Cast" [] Prefix
34con_Note = mkConstr ty_Expr "Note" [] Prefix
35con_Type = mkConstr ty_Expr "Type" [] Prefix
36
37ty_Expr :: DataType
38ty_Expr = mkDataType "CoreSyn.Expr" [con_Var, con_Lit, con_App, con_Lam, con_Let, con_Case, con_Cast, con_Note, con_Type]
39
40
41instance Typeable a => Data (Bind a) where
42    gfoldl k z (NonRec b e) = z (NonRec b) `k` e
43    gfoldl k z (Rec bed_es) = let (bs, es) = unzip bed_es
44                              in z (\es' -> Rec (zip bs es')) `k` es
45
46    gunfold _ _ _ = error "gunfold not defined for Bind"
47
48    toConstr (NonRec _ _) = con_NonRec
49    toConstr (Rec _)      = con_Rec
50
51    dataTypeOf _ = ty_Bind
52
53con_NonRec, con_Rec :: Constr
54con_NonRec = mkConstr ty_Bind "NonRec" [] Prefix
55con_Rec    = mkConstr ty_Bind "Rec" [] Prefix
56
57ty_Bind :: DataType
58ty_Bind    = mkDataType "CoreSyn.Bind" [con_NonRec, con_Rec]
59
60
61newtype WrappedAlt a = WrappedAlt (Alt a)
62
63unwrapAlt :: WrappedAlt a -> Alt a
64unwrapAlt (WrappedAlt x) = x
65
66instance Typeable a => Typeable (WrappedAlt a) where
67    -- Hack or not? I'm not sure!
68    typeOf = typeOf . unwrapAlt
69
70instance Typeable a => Data (WrappedAlt a) where
71    gfoldl k z (WrappedAlt (con, bs, e)) = z (\e' -> WrappedAlt (con, bs, e')) `k` e
72
73    gunfold _ _ _ = error "gunfold not defined for Alt"
74
75    toConstr _ = con_Alt
76
77    dataTypeOf _ = ty_Alt
78
79con_Alt :: Constr
80con_Alt = mkConstr ty_Alt "Alt" [] Prefix
81
82ty_Alt :: DataType
83ty_Alt = mkDataType "CoreSyn.Alt" [con_Alt]