blob: e3dd74257e2882525951faf294573bdf982764ab (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
|
{-# OPTIONS_GHC -fglasgow-exts #-}
module Transfer.Core.Abs where
import Control.Monad (ap,MonadPlus,msum,mplus,mzero)
import Data.Monoid
-- Haskell module generated by the BNF converter
data Module_
type Module = Tree Module_
data Decl_
type Decl = Tree Decl_
data ConsDecl_
type ConsDecl = Tree ConsDecl_
data Pattern_
type Pattern = Tree Pattern_
data FieldPattern_
type FieldPattern = Tree FieldPattern_
data PatternVariable_
type PatternVariable = Tree PatternVariable_
data Exp_
type Exp = Tree Exp_
data LetDef_
type LetDef = Tree LetDef_
data FieldType_
type FieldType = Tree FieldType_
data FieldValue_
type FieldValue = Tree FieldValue_
data Case_
type Case = Tree Case_
data TMeta_
type TMeta = Tree TMeta_
data CIdent_
type CIdent = Tree CIdent_
data Tree :: * -> * where
Module :: [Decl] -> Tree Module_
DataDecl :: CIdent -> Exp -> [ConsDecl] -> Tree Decl_
TypeDecl :: CIdent -> Exp -> Tree Decl_
ValueDecl :: CIdent -> Exp -> Tree Decl_
ConsDecl :: CIdent -> Exp -> Tree ConsDecl_
PCons :: CIdent -> [Pattern] -> Tree Pattern_
PVar :: PatternVariable -> Tree Pattern_
PRec :: [FieldPattern] -> Tree Pattern_
PType :: Tree Pattern_
PStr :: String -> Tree Pattern_
PInt :: Integer -> Tree Pattern_
FieldPattern :: CIdent -> Pattern -> Tree FieldPattern_
PVVar :: CIdent -> Tree PatternVariable_
PVWild :: Tree PatternVariable_
ELet :: [LetDef] -> Exp -> Tree Exp_
ECase :: Exp -> [Case] -> Tree Exp_
EAbs :: PatternVariable -> Exp -> Tree Exp_
EPi :: PatternVariable -> Exp -> Exp -> Tree Exp_
EApp :: Exp -> Exp -> Tree Exp_
EProj :: Exp -> CIdent -> Tree Exp_
ERecType :: [FieldType] -> Tree Exp_
ERec :: [FieldValue] -> Tree Exp_
EVar :: CIdent -> Tree Exp_
EType :: Tree Exp_
EStr :: String -> Tree Exp_
EInt :: Integer -> Tree Exp_
EMeta :: TMeta -> Tree Exp_
LetDef :: CIdent -> Exp -> Exp -> Tree LetDef_
FieldType :: CIdent -> Exp -> Tree FieldType_
FieldValue :: CIdent -> Exp -> Tree FieldValue_
Case :: Pattern -> Exp -> Tree Case_
TMeta :: String -> Tree TMeta_
CIdent :: String -> Tree CIdent_
composOp :: (forall a. Tree a -> Tree a) -> Tree c -> Tree c
composOp f = head . composOpM (\x -> [f x])
composOpM_ :: Monad m => (forall a. Tree a -> m ()) -> Tree c -> m ()
composOpM_ = composOpFold (return ()) (>>)
composOpMPlus :: MonadPlus m => (forall a. Tree a -> m b) -> Tree c -> m b
composOpMPlus = composOpFold mzero mplus
composOpMonoid :: Monoid m => (forall a. Tree a -> m) -> Tree c -> m
composOpMonoid = composOpFold mempty mappend
composOpM :: Monad m => (forall a. Tree a -> m (Tree a)) -> Tree c -> m (Tree c)
composOpM f t = case t of
Module decls -> return Module `ap` mapM f decls
DataDecl cident exp consdecls -> return DataDecl `ap` f cident `ap` f exp `ap` mapM f consdecls
TypeDecl cident exp -> return TypeDecl `ap` f cident `ap` f exp
ValueDecl cident exp -> return ValueDecl `ap` f cident `ap` f exp
ConsDecl cident exp -> return ConsDecl `ap` f cident `ap` f exp
PCons cident patterns -> return PCons `ap` f cident `ap` mapM f patterns
PVar patternvariable -> return PVar `ap` f patternvariable
PRec fieldpatterns -> return PRec `ap` mapM f fieldpatterns
FieldPattern cident pattern -> return FieldPattern `ap` f cident `ap` f pattern
PVVar cident -> return PVVar `ap` f cident
ELet letdefs exp -> return ELet `ap` mapM f letdefs `ap` f exp
ECase exp cases -> return ECase `ap` f exp `ap` mapM f cases
EAbs patternvariable exp -> return EAbs `ap` f patternvariable `ap` f exp
EPi patternvariable exp0 exp1 -> return EPi `ap` f patternvariable `ap` f exp0 `ap` f exp1
EApp exp0 exp1 -> return EApp `ap` f exp0 `ap` f exp1
EProj exp cident -> return EProj `ap` f exp `ap` f cident
ERecType fieldtypes -> return ERecType `ap` mapM f fieldtypes
ERec fieldvalues -> return ERec `ap` mapM f fieldvalues
EVar cident -> return EVar `ap` f cident
EMeta tmeta -> return EMeta `ap` f tmeta
LetDef cident exp0 exp1 -> return LetDef `ap` f cident `ap` f exp0 `ap` f exp1
FieldType cident exp -> return FieldType `ap` f cident `ap` f exp
FieldValue cident exp -> return FieldValue `ap` f cident `ap` f exp
Case pattern exp -> return Case `ap` f pattern `ap` f exp
_ -> return t
composOpFold :: b -> (b -> b -> b) -> (forall a. Tree a -> b) -> Tree c -> b
composOpFold zero combine f t = case t of
Module decls -> foldr combine zero (map f decls)
DataDecl cident exp consdecls -> f cident `combine` f exp `combine` foldr combine zero (map f consdecls)
TypeDecl cident exp -> f cident `combine` f exp
ValueDecl cident exp -> f cident `combine` f exp
ConsDecl cident exp -> f cident `combine` f exp
PCons cident patterns -> f cident `combine` foldr combine zero (map f patterns)
PVar patternvariable -> f patternvariable
PRec fieldpatterns -> foldr combine zero (map f fieldpatterns)
FieldPattern cident pattern -> f cident `combine` f pattern
PVVar cident -> f cident
ELet letdefs exp -> foldr combine zero (map f letdefs) `combine` f exp
ECase exp cases -> f exp `combine` foldr combine zero (map f cases)
EAbs patternvariable exp -> f patternvariable `combine` f exp
EPi patternvariable exp0 exp1 -> f patternvariable `combine` f exp0 `combine` f exp1
EApp exp0 exp1 -> f exp0 `combine` f exp1
EProj exp cident -> f exp `combine` f cident
ERecType fieldtypes -> foldr combine zero (map f fieldtypes)
ERec fieldvalues -> foldr combine zero (map f fieldvalues)
EVar cident -> f cident
EMeta tmeta -> f tmeta
LetDef cident exp0 exp1 -> f cident `combine` f exp0 `combine` f exp1
FieldType cident exp -> f cident `combine` f exp
FieldValue cident exp -> f cident `combine` f exp
Case pattern exp -> f pattern `combine` f exp
_ -> zero
instance Show (Tree c) where
showsPrec n t = case t of
Module decls -> opar n . showString "Module" . showChar ' ' . showsPrec 1 decls . cpar n
DataDecl cident exp consdecls -> opar n . showString "DataDecl" . showChar ' ' . showsPrec 1 cident . showChar ' ' . showsPrec 1 exp . showChar ' ' . showsPrec 1 consdecls . cpar n
TypeDecl cident exp -> opar n . showString "TypeDecl" . showChar ' ' . showsPrec 1 cident . showChar ' ' . showsPrec 1 exp . cpar n
ValueDecl cident exp -> opar n . showString "ValueDecl" . showChar ' ' . showsPrec 1 cident . showChar ' ' . showsPrec 1 exp . cpar n
ConsDecl cident exp -> opar n . showString "ConsDecl" . showChar ' ' . showsPrec 1 cident . showChar ' ' . showsPrec 1 exp . cpar n
PCons cident patterns -> opar n . showString "PCons" . showChar ' ' . showsPrec 1 cident . showChar ' ' . showsPrec 1 patterns . cpar n
PVar patternvariable -> opar n . showString "PVar" . showChar ' ' . showsPrec 1 patternvariable . cpar n
PRec fieldpatterns -> opar n . showString "PRec" . showChar ' ' . showsPrec 1 fieldpatterns . cpar n
PType -> showString "PType"
PStr str -> opar n . showString "PStr" . showChar ' ' . showsPrec 1 str . cpar n
PInt n -> opar n . showString "PInt" . showChar ' ' . showsPrec 1 n . cpar n
FieldPattern cident pattern -> opar n . showString "FieldPattern" . showChar ' ' . showsPrec 1 cident . showChar ' ' . showsPrec 1 pattern . cpar n
PVVar cident -> opar n . showString "PVVar" . showChar ' ' . showsPrec 1 cident . cpar n
PVWild -> showString "PVWild"
ELet letdefs exp -> opar n . showString "ELet" . showChar ' ' . showsPrec 1 letdefs . showChar ' ' . showsPrec 1 exp . cpar n
ECase exp cases -> opar n . showString "ECase" . showChar ' ' . showsPrec 1 exp . showChar ' ' . showsPrec 1 cases . cpar n
EAbs patternvariable exp -> opar n . showString "EAbs" . showChar ' ' . showsPrec 1 patternvariable . showChar ' ' . showsPrec 1 exp . cpar n
EPi patternvariable exp0 exp1 -> opar n . showString "EPi" . showChar ' ' . showsPrec 1 patternvariable . showChar ' ' . showsPrec 1 exp0 . showChar ' ' . showsPrec 1 exp1 . cpar n
EApp exp0 exp1 -> opar n . showString "EApp" . showChar ' ' . showsPrec 1 exp0 . showChar ' ' . showsPrec 1 exp1 . cpar n
EProj exp cident -> opar n . showString "EProj" . showChar ' ' . showsPrec 1 exp . showChar ' ' . showsPrec 1 cident . cpar n
ERecType fieldtypes -> opar n . showString "ERecType" . showChar ' ' . showsPrec 1 fieldtypes . cpar n
ERec fieldvalues -> opar n . showString "ERec" . showChar ' ' . showsPrec 1 fieldvalues . cpar n
EVar cident -> opar n . showString "EVar" . showChar ' ' . showsPrec 1 cident . cpar n
EType -> showString "EType"
EStr str -> opar n . showString "EStr" . showChar ' ' . showsPrec 1 str . cpar n
EInt n -> opar n . showString "EInt" . showChar ' ' . showsPrec 1 n . cpar n
EMeta tmeta -> opar n . showString "EMeta" . showChar ' ' . showsPrec 1 tmeta . cpar n
LetDef cident exp0 exp1 -> opar n . showString "LetDef" . showChar ' ' . showsPrec 1 cident . showChar ' ' . showsPrec 1 exp0 . showChar ' ' . showsPrec 1 exp1 . cpar n
FieldType cident exp -> opar n . showString "FieldType" . showChar ' ' . showsPrec 1 cident . showChar ' ' . showsPrec 1 exp . cpar n
FieldValue cident exp -> opar n . showString "FieldValue" . showChar ' ' . showsPrec 1 cident . showChar ' ' . showsPrec 1 exp . cpar n
Case pattern exp -> opar n . showString "Case" . showChar ' ' . showsPrec 1 pattern . showChar ' ' . showsPrec 1 exp . cpar n
TMeta str -> opar n . showString "TMeta" . showChar ' ' . showsPrec 1 str . cpar n
CIdent str -> opar n . showString "CIdent" . showChar ' ' . showsPrec 1 str . cpar n
where opar n = if n > 0 then showChar '(' else id
cpar n = if n > 0 then showChar ')' else id
instance Eq (Tree c) where (==) = johnMajorEq
johnMajorEq :: Tree a -> Tree b -> Bool
johnMajorEq (Module decls) (Module decls_) = decls == decls_
johnMajorEq (DataDecl cident exp consdecls) (DataDecl cident_ exp_ consdecls_) = cident == cident_ && exp == exp_ && consdecls == consdecls_
johnMajorEq (TypeDecl cident exp) (TypeDecl cident_ exp_) = cident == cident_ && exp == exp_
johnMajorEq (ValueDecl cident exp) (ValueDecl cident_ exp_) = cident == cident_ && exp == exp_
johnMajorEq (ConsDecl cident exp) (ConsDecl cident_ exp_) = cident == cident_ && exp == exp_
johnMajorEq (PCons cident patterns) (PCons cident_ patterns_) = cident == cident_ && patterns == patterns_
johnMajorEq (PVar patternvariable) (PVar patternvariable_) = patternvariable == patternvariable_
johnMajorEq (PRec fieldpatterns) (PRec fieldpatterns_) = fieldpatterns == fieldpatterns_
johnMajorEq PType PType = True
johnMajorEq (PStr str) (PStr str_) = str == str_
johnMajorEq (PInt n) (PInt n_) = n == n_
johnMajorEq (FieldPattern cident pattern) (FieldPattern cident_ pattern_) = cident == cident_ && pattern == pattern_
johnMajorEq (PVVar cident) (PVVar cident_) = cident == cident_
johnMajorEq PVWild PVWild = True
johnMajorEq (ELet letdefs exp) (ELet letdefs_ exp_) = letdefs == letdefs_ && exp == exp_
johnMajorEq (ECase exp cases) (ECase exp_ cases_) = exp == exp_ && cases == cases_
johnMajorEq (EAbs patternvariable exp) (EAbs patternvariable_ exp_) = patternvariable == patternvariable_ && exp == exp_
johnMajorEq (EPi patternvariable exp0 exp1) (EPi patternvariable_ exp0_ exp1_) = patternvariable == patternvariable_ && exp0 == exp0_ && exp1 == exp1_
johnMajorEq (EApp exp0 exp1) (EApp exp0_ exp1_) = exp0 == exp0_ && exp1 == exp1_
johnMajorEq (EProj exp cident) (EProj exp_ cident_) = exp == exp_ && cident == cident_
johnMajorEq (ERecType fieldtypes) (ERecType fieldtypes_) = fieldtypes == fieldtypes_
johnMajorEq (ERec fieldvalues) (ERec fieldvalues_) = fieldvalues == fieldvalues_
johnMajorEq (EVar cident) (EVar cident_) = cident == cident_
johnMajorEq EType EType = True
johnMajorEq (EStr str) (EStr str_) = str == str_
johnMajorEq (EInt n) (EInt n_) = n == n_
johnMajorEq (EMeta tmeta) (EMeta tmeta_) = tmeta == tmeta_
johnMajorEq (LetDef cident exp0 exp1) (LetDef cident_ exp0_ exp1_) = cident == cident_ && exp0 == exp0_ && exp1 == exp1_
johnMajorEq (FieldType cident exp) (FieldType cident_ exp_) = cident == cident_ && exp == exp_
johnMajorEq (FieldValue cident exp) (FieldValue cident_ exp_) = cident == cident_ && exp == exp_
johnMajorEq (Case pattern exp) (Case pattern_ exp_) = pattern == pattern_ && exp == exp_
johnMajorEq (TMeta str) (TMeta str_) = str == str_
johnMajorEq (CIdent str) (CIdent str_) = str == str_
johnMajorEq _ _ = False
instance Ord (Tree c) where
compare x y = compare (index x) (index y) `mappend` compareSame x y
where
index (Module _) = 0
index (DataDecl _ _ _) = 1
index (TypeDecl _ _) = 2
index (ValueDecl _ _) = 3
index (ConsDecl _ _) = 4
index (PCons _ _) = 5
index (PVar _) = 6
index (PRec _) = 7
index (PType ) = 8
index (PStr _) = 9
index (PInt _) = 10
index (FieldPattern _ _) = 11
index (PVVar _) = 12
index (PVWild ) = 13
index (ELet _ _) = 14
index (ECase _ _) = 15
index (EAbs _ _) = 16
index (EPi _ _ _) = 17
index (EApp _ _) = 18
index (EProj _ _) = 19
index (ERecType _) = 20
index (ERec _) = 21
index (EVar _) = 22
index (EType ) = 23
index (EStr _) = 24
index (EInt _) = 25
index (EMeta _) = 26
index (LetDef _ _ _) = 27
index (FieldType _ _) = 28
index (FieldValue _ _) = 29
index (Case _ _) = 30
index (TMeta _) = 31
index (CIdent _) = 32
compareSame (Module decls) (Module decls_) = compare decls decls_
compareSame (DataDecl cident exp consdecls) (DataDecl cident_ exp_ consdecls_) = mappend (compare cident cident_) (mappend (compare exp exp_) (compare consdecls consdecls_))
compareSame (TypeDecl cident exp) (TypeDecl cident_ exp_) = mappend (compare cident cident_) (compare exp exp_)
compareSame (ValueDecl cident exp) (ValueDecl cident_ exp_) = mappend (compare cident cident_) (compare exp exp_)
compareSame (ConsDecl cident exp) (ConsDecl cident_ exp_) = mappend (compare cident cident_) (compare exp exp_)
compareSame (PCons cident patterns) (PCons cident_ patterns_) = mappend (compare cident cident_) (compare patterns patterns_)
compareSame (PVar patternvariable) (PVar patternvariable_) = compare patternvariable patternvariable_
compareSame (PRec fieldpatterns) (PRec fieldpatterns_) = compare fieldpatterns fieldpatterns_
compareSame PType PType = EQ
compareSame (PStr str) (PStr str_) = compare str str_
compareSame (PInt n) (PInt n_) = compare n n_
compareSame (FieldPattern cident pattern) (FieldPattern cident_ pattern_) = mappend (compare cident cident_) (compare pattern pattern_)
compareSame (PVVar cident) (PVVar cident_) = compare cident cident_
compareSame PVWild PVWild = EQ
compareSame (ELet letdefs exp) (ELet letdefs_ exp_) = mappend (compare letdefs letdefs_) (compare exp exp_)
compareSame (ECase exp cases) (ECase exp_ cases_) = mappend (compare exp exp_) (compare cases cases_)
compareSame (EAbs patternvariable exp) (EAbs patternvariable_ exp_) = mappend (compare patternvariable patternvariable_) (compare exp exp_)
compareSame (EPi patternvariable exp0 exp1) (EPi patternvariable_ exp0_ exp1_) = mappend (compare patternvariable patternvariable_) (mappend (compare exp0 exp0_) (compare exp1 exp1_))
compareSame (EApp exp0 exp1) (EApp exp0_ exp1_) = mappend (compare exp0 exp0_) (compare exp1 exp1_)
compareSame (EProj exp cident) (EProj exp_ cident_) = mappend (compare exp exp_) (compare cident cident_)
compareSame (ERecType fieldtypes) (ERecType fieldtypes_) = compare fieldtypes fieldtypes_
compareSame (ERec fieldvalues) (ERec fieldvalues_) = compare fieldvalues fieldvalues_
compareSame (EVar cident) (EVar cident_) = compare cident cident_
compareSame EType EType = EQ
compareSame (EStr str) (EStr str_) = compare str str_
compareSame (EInt n) (EInt n_) = compare n n_
compareSame (EMeta tmeta) (EMeta tmeta_) = compare tmeta tmeta_
compareSame (LetDef cident exp0 exp1) (LetDef cident_ exp0_ exp1_) = mappend (compare cident cident_) (mappend (compare exp0 exp0_) (compare exp1 exp1_))
compareSame (FieldType cident exp) (FieldType cident_ exp_) = mappend (compare cident cident_) (compare exp exp_)
compareSame (FieldValue cident exp) (FieldValue cident_ exp_) = mappend (compare cident cident_) (compare exp exp_)
compareSame (Case pattern exp) (Case pattern_ exp_) = mappend (compare pattern pattern_) (compare exp exp_)
compareSame (TMeta str) (TMeta str_) = compare str str_
compareSame (CIdent str) (CIdent str_) = compare str str_
compareSame x y = error "BNFC error:" compareSame
|
