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
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
|
INCLUDE "ErrorMessages.ag"
imports
{
import UU.Scanner.Position(Pos(..), noPos)
import ErrorMessages
import Data.List(mapAccumL)
import GrammarInfo
}
{
isError :: Options -> Error -> Bool
isError _ (ParserError _ _ _ ) = True
isError _ (DupAlt _ _ _ ) = False
isError _ (DupSynonym _ _ ) = False
isError _ (DupSet _ _ ) = False
isError _ (DupInhAttr _ _ _ ) = True
isError _ (DupSynAttr _ _ _ ) = True
isError _ (DupChild _ _ _ _ ) = False
isError _ (DupRule _ _ _ _ _) = True
isError _ (DupSig _ _ _ ) = False
isError _ (UndefNont _ ) = True
isError _ (UndefAlt _ _ ) = True
isError _ (UndefChild _ _ _ ) = True
isError _ (MissingRule _ _ _ _ ) = False
isError _ (SuperfluousRule _ _ _ _ ) = False
isError _ (UndefLocal _ _ _ ) = True
isError _ (ChildAsLocal _ _ _ ) = False
isError _ (UndefAttr _ _ _ _ _) = True
isError _ (CyclicSet _ ) = True
isError _ (CustomError w _ _ ) = not w
isError opts (LocalCirc _ _ _ _ _) = cycleIsDangerous opts
isError opts (InstCirc _ _ _ _ _) = cycleIsDangerous opts
isError opts (DirectCirc _ _ _ ) = cycleIsDangerous opts
isError opts (InducedCirc _ _ _ ) = cycleIsDangerous opts
isError _ (MissingTypeSig _ _ _ ) = False
isError _ (MissingInstSig _ _ _ ) = True
isError _ (DupUnique _ _ _ ) = False
isError _ (MissingUnique _ _ ) = True
isError _ (MissingSyn _ _ ) = True
isError _ (MissingNamedRule _ _ _) = True
isError _ (DupRuleName _ _ _) = True
isError _ (HsParseError _ _) = True
isError _ (Cyclic _ _ _) = True
isError _ (IncompatibleVisitKind _ _ _ _) = True
isError _ (IncompatibleRuleKind _ _) = True
isError _ (IncompatibleAttachKind _ _) = True
cycleIsDangerous :: Options -> Bool
cycleIsDangerous opts
= any ($ opts) [ wignore, bangpats, cases, strictCases, stricterCases, strictSems, withCycle ]
}
ATTR Error [ options:{Options} verbose:{Bool} | | pp :{PP_Doc}
me :SELF
]
ATTR Errors [ options:{Options} dups : {[String]} | | pp USE {>-<} {text ""} : {PP_Doc}
]
SEM Errors
| * loc.verbose = verbose @lhs.options
| Cons loc.str = disp @hd.pp 5000 ""
lhs.pp = if @loc.str `elem` @lhs.dups
then @tl.pp
else @hd.pp >-< @tl.pp
tl.dups = @loc.str : @lhs.dups
| Nil lhs.pp = text ""
SEM Error
| ParserError lhs.pp = let mesg = text ("parser expecting " ++ @problem)
pat = text ""
help = text ""
act = text @action
in ppError (isError @lhs.options @me) @pos mesg pat help act @lhs.verbose
| HsParseError lhs.pp = ppError True @pos (text @msg) (text "") (text "") (text "Correct the syntax of the Haskell code.") @lhs.verbose
| DupAlt lhs.pp = let mesg = wfill ["Repeated definition for alternative", getName @con
,"of nonterminal", getName @nt, "."
] >-<
wfill ["First definition:", (showPos @occ1),"."] >-<
wfill ["Other definition:", (showPos @con),"."]
pat = "DATA" >#< getName @nt
>-< indent 2 ("|" >#< getName @con >#< "...")
>-< indent 2 ("|" >#< getName @con >#< "...")
help = wfill ["The nonterminal",getName @nt,"has more than one alternative that"
,"is labelled with the constructor name",getName @con,"."
,"You should either rename or remove enough of them to make all"
,"constructors of",getName @nt,"uniquely named."
]
act = wfill [ "The first alternative of name",getName @con
,"you have given for nonterminal",getName @nt
,"is considered valid. All other alternatives have been discarded."
]
in ppError (isError @lhs.options @me) (getPos @con) mesg pat help act @lhs.verbose
| DupSynonym lhs.pp = let mesg = wfill ["Definition of type synonym", getName @nt, "clashes with another"
,"type synonym."
] >-<
wfill ["First definition:", (showPos @occ1),"."] >-<
wfill ["Type synonym :" , (showPos @nt),"."]
pat = "DATA" >#< getName @nt
>-< indent 2 ("|" >#< "...")
>-< "TYPE" >#< getName @nt >#< "=" >#< "..."
help = wfill ["A type synonym with name", getName @nt
,"has been given while there already is TYPE"
,"definition with the same name."
,"You should either rename or remove the type synonym."
]
act = wfill [ "The clashing type synonym will be ignored."
]
in ppError (isError @lhs.options @me) (getPos @nt) mesg pat help act @lhs.verbose
| DupSet lhs.pp = let mesg = wfill ["Definition of nonterminal set", getName @name, "clashes with another"
,"set, a type synonym or a data definition."
] >-<
wfill ["First definition:", (showPos @occ1),"."] >-<
wfill ["Set definition:" , (showPos @name),"."]
pat = "SET" >#< getName @name >#< "=" >#< "..."
>-< "SET" >#< getName @name >#< "=" >#< "..."
help = wfill ["A nonterminal set with name", getName @name
,"has been given while there already is a SET, DATA, or TYPE"
,"definition with the same name."
,"You should either rename or remove the nonterminal set."
]
act = wfill [ "The clashing nonterminal set will be ignored."
]
in ppError (isError @lhs.options @me) (getPos @name) mesg pat help act @lhs.verbose
| DupInhAttr lhs.pp = let mesg = wfill ["Repeated declaration of inherited attribute", getName @attr
, "of nonterminal", getName @nt, "."
] >-<
wfill ["First definition:", (showPos @occ1),"."] >-<
wfill ["Other definition:", (showPos @attr),"."]
pat = "ATTR" >#< getName @nt >#< "[" >#< getName @attr >|< ":...,"
>#< getName @attr >|< ":... | | ]"
help = wfill ["The identifier" , getName @attr ,"has been declared"
,"as an inherited (or chained) attribute for nonterminal"
,getName @nt , "more than once, with possibly different types."
,"Delete all but one or rename them to make them unique."
]
act = wfill ["One declaration with its corresponding type is considered valid."
,"All others have been discarded. The generated program will probably not run."
]
in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose
| DupSynAttr lhs.pp = let mesg = wfill ["Repeated declaration of synthesized attribute", getName @attr
, "of nonterminal", getName @nt, "."
] >-<
wfill ["First definition:", (showPos @occ1),"."] >-<
wfill ["Other definition:", (showPos @attr),"."]
pat = "ATTR" >#< getName @nt >#< "[ | |" >#< getName @attr >|< ":...,"
>#< getName @attr >|< ":... ]"
help = wfill ["The identifier" , getName @attr ,"has been declared"
,"as a synthesized (or chained) attribute for nonterminal"
,getName @nt , "more than once, with possibly different types."
,"Delete all but one or rename them to make them unique."
]
act = wfill ["One declaration with its corresponding type is considered valid."
,"All others have been discarded. The generated program will probably not run."
]
in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose
| DupChild lhs.pp = let mesg = wfill ["Repeated declaration for field", getName @name, "of alternative"
,getName @con, "of nonterminal", getName @nt, "."
] >-<
wfill ["First definition:", (showPos @occ1),"."] >-<
wfill ["Other definition:", (showPos @name),"."]
pat = "DATA" >#< getName @nt
>-< indent 2 ("|" >#< getName @con >#< (getName @name >|< ":..." >-< getName @name >|< ":..."))
help = wfill ["The alternative" ,getName @con , "of nonterminal" ,getName @nt
,"has more than one field that is named"
, getName @name ++ ". Possibly they have different types."
,"You should either rename or remove enough of them to make all fields of"
,getName @con , "for nonterminal " , getName @nt , "uniquely named."
]
act = wfill ["The last declaration with its corresponding type is considered valid."
,"All others have been discarded."
]
in ppError (isError @lhs.options @me) (getPos @name) mesg pat help act @lhs.verbose
| DupRule lhs.pp = let mesg = wfill ["At constructor",getName @con, "of nonterminal", getName @nt, "there are two or more rules for"
,showAttrDef @field @attr,"."
] >-<
wfill ["First rule:", (showPos @occ1),"."] >-<
wfill ["Other rule:", (showPos @attr),"."]
pat = "SEM" >#< getName @nt
>-< indent 2 ("|" >#< getName @con >#< ppAttr @field @attr >#< "= ...")
>-< indent 2 ("|" >#< getName @con >#< ppAttr @field @attr >#< "= ...")
help = wfill ["In the rules for alternative" , getName @con , "of nonterminal" , getName @nt
,", there is more than one rule for the" , showAttrDef @field @attr
,". You should either rename or remove enough of them to make all rules for alternative"
,getName @con , "of nonterminal " ,getName @nt , "uniquely named."
]
act = wfill ["The last rule given is considered valid. All others have been discarded."]
in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose
| DupRuleName lhs.pp = let mesg = wfill ["At constructor",getName @con, "of nonterminal", getName @nt, "there are two or more rule names for"
,show @nm,"."
]
pat = "SEM" >#< getName @nt
>-< indent 2 ("|" >#< getName @con >#< show @nm >#< ": ... = ...")
>-< indent 2 ("|" >#< getName @con >#< show @nm >#< ": ... = ...")
help = wfill ["In the rules for alternative" , getName @con , "of nonterminal" , getName @nt
,", there is more than one rule name " , show @nm
,". You should either rename or remove enough of them."
]
act = wfill ["Compilation cannot continue."]
in ppError (isError @lhs.options @me) (getPos @nm) mesg pat help act @lhs.verbose
| DupSig lhs.pp = let mesg = wfill ["At constructor",getName @con, "of nonterminal", getName @nt, "there are two or more typesignatures for"
,showAttrDef _LOC @attr,"."
] >-<
wfill ["First signature:", (showPos @attr),"."]
pat = "SEM" >#< getName @nt
>-< indent 2 ("|" >#< getName @con >#< ppAttr _LOC @attr >#< "= ...")
>-< indent 2 ("|" >#< getName @con >#< ppAttr _LOC @attr >#< "= ...")
help = wfill ["In the rules for alternative" , getName @con , "of nonterminal" , getName @nt
,", there is more than one rule for the" , showAttrDef _LOC @attr
,". You should remove enough of them to make all typesignatures for alternative"
,getName @con , "of nonterminal " ,getName @nt , "unique."
]
act = wfill ["The last typesignature given is considered valid. All others have been discarded."]
in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose
| UndefNont lhs.pp = let mesg = wfill ["Nonterminal", getName @nt, "is not defined."
]
pat = "DATA" >#< getName @nt >#< "..."
help = wfill ["There are attributes and/or rules for nonterminal" , getName @nt ,", but there is no definition"
, "for" ,getName @nt, ". Maybe you misspelled it? Otherwise insert a definition."
]
act = wfill ["Everything regarding the unknown nonterminal has been ignored."]
in ppError (isError @lhs.options @me) (getPos @nt) mesg pat help act @lhs.verbose
| UndefAlt lhs.pp = let mesg = wfill ["Constructor", getName @con, "of nonterminal" ,getName @nt, "is not defined."
]
pat = "DATA" >#< getName @nt
>-< indent 2 ("|" >#< getName @con >#< "...")
help = wfill ["There are rules for alternative", getName @con , "of nonterminal" ,getName @nt
,", but there is no definition for this alternative in the definitions of the"
,"nonterminal" , getName @nt, ". Maybe you misspelled it? Otherwise insert a definition."
]
act = wfill ["All rules for the unknown alternative have been ignored."]
in ppError (isError @lhs.options @me) (getPos @con) mesg pat help act @lhs.verbose
| UndefChild lhs.pp = let mesg = wfill ["Constructor", getName @con, "of nonterminal" ,getName @nt
, "does not have a nontrivial field named", getName @name , "."
]
pat = "SEM" >#< @nt
>-< indent 2 ("|" >#< getName @con >#< ppAttr @name (identifier "<attr>") >#< "= ...")
help = wfill ["There are rules that define or use attributes of field" , getName @name
,"in alternative" , getName @con , "of nonterminal" , getName @nt
,", but there is no field with AG-type in the definition of the alternative."
,"Maybe you misspelled it? Otherwise insert the field into the definition,"
,"or change its type from an HS-type to an AG-type."
]
act = wfill ["All rules for the unknown field have been ignored."]
in ppError (isError @lhs.options @me) (getPos @name) mesg pat help act @lhs.verbose
| MissingRule lhs.pp = let mesg = wfill ["Missing rule for", showAttrDef @field @attr , "in alternative"
, getName @con , "of nonterminal",getName @nt ,"."
]
pat = "SEM" >#< @nt
>-< indent 2 ("|" >#< getName @con >#< ppAttr @field @attr >#< "= ...")
help = wfill ["The", showAttrDef @field @attr, "in alternative", getName @con
, "of nonterminal", getName @nt, "is missing and cannot be inferred"
,"by a copy rule, so you should add an appropriate rule."
]
act = wfill ["The value of the attribute has been set to undefined."]
in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose
| MissingNamedRule lhs.pp = let mesg = wfill ["Missing rule name ", show @name , "in alternative"
, getName @con , "of nonterminal",getName @nt ,"."
]
pat = "SEM" >#< @nt
>-< indent 2 ("|" >#< getName @con >#< show @name >#< ": ... = ...")
help = wfill ["There is a dependency on a rule with name ", show @name , "in alternative"
, getName @con , "of nonterminal",getName @nt ,", but no rule has been defined with this name. Maybe you misspelled it?"
]
act = wfill ["Compilation cannot continue."]
in ppError (isError @lhs.options @me) (getPos @name) mesg pat help act @lhs.verbose
| SuperfluousRule lhs.pp = let mesg = wfill ["Rule for non-existing", showAttrDef @field @attr , "at alternative"
, getName @con , "of nonterminal",getName @nt, "."
]
pat = "SEM" >#< getName @nt
>-< indent 2 ("|" >#< getName @con >#< ppAttr @field @attr >#< "= ...")
help = wfill ["There is a rule for" , showAttrDef @field @attr , "in the definitions for alternative" , getName @con
,"of nonterminal" , getName @nt, ", but this attribute does not exist. Maybe you misspelled it?"
,"Otherwise either remove the rule or add an appropriate attribute definition."
]
act = wfill ["The rule has been ignored."]
in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose
| UndefLocal lhs.pp = let mesg = wfill ["Undefined local variable or field",getName @var, "at constructor"
, getName @con , "of nonterminal",getName @nt, "."
]
pat = "SEM" >#< getName @nt
>-< indent 2 ("|" >#< getName @con >#< "<field>.<attr> = "
>#< "..." >#< "@" >|< getName @var >#< "..." )
help = wfill ["A rule in the definitions for alternative" , getName @con ,"of nonterminal"
, getName @nt , "contains a local variable or field name that is not defined. "
,"Maybe you misspelled it?"
,"Otherwise either remove the rule or add an appropriate definition."
]
act = wfill ["The generated program will not run."]
in ppError (isError @lhs.options @me) (getPos @var) mesg pat help act @lhs.verbose
| ChildAsLocal lhs.pp = let mesg = wfill ["Nontrivial field ",getName @var, "is used as local at constructor"
, getName @con , "of nonterminal",getName @nt, "."
]
pat = "SEM" >#< getName @nt
>-< indent 2 ("|" >#< getName @con >#< "... = "
>#< "..." >#< "@" >|< getName @var >#< "..." )
help = wfill ["A rule in the definitions for alternative" , getName @con ,"of nonterminal"
, getName @nt , "contains a nontrivial field name", getName @var, "."
,"You should use @", getName @var, ".self instead, where self is a SELF-attribute."
]
act = wfill ["The generated program probably contains a type error or has undefined variables."]
in ppError (isError @lhs.options @me) (getPos @var) mesg pat help act @lhs.verbose
| UndefAttr lhs.pp = let mesg = wfill ["Undefined"
, if @isOut
then showAttrDef @field @attr
else showAttrUse @field @attr
, "at constructor"
, getName @con , "of nonterminal",getName @nt, "."
]
pat = "SEM" >#< getName @nt
>-< indent 2 ("|" >#< getName @con >#< "<field>.<attr> = "
>#< "..." >#< ppAttrUse @field @attr >#< "...")
help = wfill ["A rule in the definitions for alternative" , getName @con ,"of nonterminal"
,getName @nt , "contains an attribute that is not defined"
,"Maybe you misspelled it?"
,"Otherwise either remove the rule or add an appropriate attribute definition."
]
act = wfill ["The generated program will not run."]
in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose
| CyclicSet lhs.pp = let mesg = wfill ["Cyclic definition for nonterminal set", getName @name]
pat = "SET" >#< getName @name >#< "=" >#< "..." >#< getName @name >#< "..."
help = wfill ["The defintion for a nonterminal set named" , getName @name
,"directly or indirectly refers to itself."
,"Adapt the definition of the nonterminal set, to remove the cyclic dependency."
]
act = wfill ["The nonterminal set", getName @name, "is considered to be empty."]
in ppError (isError @lhs.options @me) (getPos @name) mesg pat help act @lhs.verbose
| Cyclic lhs.pp = let pos = getPos @nt
mesg = text "Circular dependency for nonterminal" >#< getName @nt
>#< ( case @mbCon of
Nothing -> empty
Just con -> text "and constructor" >#< con
)
>#< ( case @verts of
v : _ -> text "including vertex" >#< text v
_ -> empty
)
pat = text "cyclic rule definition"
help = hlist (text "The following attributes are all cyclic: " : map text @verts)
act = wfill ["code cannot be generated until the cycle is removed."]
in ppError (isError @lhs.options @me) pos mesg pat help act False
| CustomError lhs.pp = let pat = text "unknown"
help = wfill ["not available."]
act = wfill ["unknown"]
in ppError (isError @lhs.options @me) @pos @mesg pat help act False
| LocalCirc lhs.pp = let mesg = wfill ["Circular dependency for local attribute", getName @attr
, "of alternative", getName @con, "of nonterminal", getName @nt]
pat = "SEM" >#< getName @nt
>-< indent 2 ("|" >#< getName @con >#< "loc." >|< getName @attr >#< "="
>#< "..." >#< "@loc." >|< getName @attr >#< "...")
help = if null @path
then text "the definition is directly circular"
else hlist ("The following attributes are involved in the cycle:": @path)
act | @o_visit = text "An unoptimized version was generated. It might hang when run."
| otherwise = text "The generated program might hang when run."
in ppError (isError @lhs.options @me) (getPos (@attr)) mesg pat help act @lhs.verbose
| InstCirc lhs.pp = let mesg = wfill ["Circular dependency for inst attribute", getName @attr
, "of alternative", getName @con, "of nonterminal", getName @nt]
pat = "SEM" >#< getName @nt
>-< indent 2 ("|" >#< getName @con >#< "inst." >|< getName @attr >#< "="
>#< "..." >#< "@s.<some attribte>" >#< "...")
help = if null @path
then text "the definition is directly circular"
else hlist ("The following attributes are involved in the cycle:": @path)
act | @o_visit = text "An unoptimized version was generated. It might hang when run."
| otherwise = text "The generated program might hang when run."
in ppError (isError @lhs.options @me) (getPos (@attr)) mesg pat help act @lhs.verbose
| DirectCirc lhs.pp = let mesg = wfill ["In nonterminal", getName @nt, "synthesized and inherited attributes are mutually dependent" ]
>-< vlist (map showEdge @cyclic)
pat = text ""
help = vlist (map showEdgeLong @cyclic)
act | @o_visit = text "An unoptimized version was generated. It might hang when run."
| otherwise = text "The generated program might hang when run."
in ppError (isError @lhs.options @me) noPos mesg pat help act @lhs.verbose
| InducedCirc lhs.pp = let mesg = wfill ["After scheduling, in nonterminal", getName @nt, "synthesized and inherited attributes have an INDUCED mutual dependency" ]
>-< vlist (map showEdge @cyclic)
pat = text ""
showInter (CInterface segs) = concat (snd (mapAccumL (\i c -> (succ i :: Integer,("visit " ++ show i) : map ind (showsSegment c))) 0 segs))
help = vlist (("Interface for nonterminal " ++ getName @nt ++ ":") : map ind (showInter @cinter))
>-< vlist (map showEdgeLong @cyclic)
act = text "An unoptimized version was generated. It might hang when run."
in ppError (isError @lhs.options @me) noPos mesg pat help act @lhs.verbose
| MissingTypeSig lhs.pp = let mesg = wfill ["Type signature needed, but not found for", showAttrDef _LOC @attr , "in alternative"
, getName @con , "of nonterminal",getName @nt ,"."
]>-<
wfill ["Location:", (showPos @attr),"."]
pat = "SEM" >#< @nt
>-< indent 2 ("|" >#< getName @con >#< ppAttr _LOC @attr >#< ": ...")
help = wfill ["The", showAttrDef _LOC @attr, "in alternative", getName @con
,"of nonterminal", getName @nt, "is needed in two separate visits to", getName @nt
,"so its type is needed to generate type signatures."
,"Please supply its type."
]
act = wfill ["The type signatures of semantic functions are not generated."]
in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose
| MissingInstSig lhs.pp = let mesg = wfill ["Type signature needed, but not found for", showAttrDef _INST @attr , "in alternative"
, getName @con , "of nonterminal",getName @nt ,"."
]>-<
wfill ["Location:", (showPos @attr),"."]
pat = "SEM" >#< @nt
>-< indent 2 ("|" >#< getName @con >#< ppAttr _INST @attr >#< ": ...")
help = wfill ["The", showAttrDef _INST @attr, "in alternative", getName @con
,"of nonterminal", getName @nt, "is a non-terminal attribute, so "
,"its type is needed to attribute its value."
,"Please supply its type."
]
act = wfill ["It is not possible to proceed without this signature."]
in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose
| MissingUnique lhs.pp = let mesg = wfill ["Missing unique counter (chained attribute)"
, getName @attr
, "at nonterminal"
, getName @nt, "."
]
pat = "ATTR" >#< getName @nt >#< "[ |" >#< getName @attr >#< " : ... | ]"
help = wfill ["A unique attribute signature in a constructor for nonterminal" , getName @nt
, "refers to an unique counter (chained attribute) named "
, getName @attr
,"Maybe you misspelled it?"
,"Otherwise either remove the signature or add an appropriate attribute definition."
]
act = wfill ["It is not possible to proceed without this declaration."]
in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose
| DupUnique lhs.pp = let mesg = wfill ["At constructor",getName @con, "of nonterminal", getName @nt, "there are two or more unique-attribute signatures for"
,showAttrDef _LOC @attr,"."
] >-<
wfill ["First signature:", (showPos @attr),"."]
pat = "SEM" >#< getName @nt
>-< indent 2 ("|" >#< getName @con >#< ppAttr _LOC @attr >#< " : UNIQUEREF ...")
>-< indent 2 ("|" >#< getName @con >#< ppAttr _LOC @attr >#< " : UNIQUEREF ...")
help = wfill ["In the rules for alternative" , getName @con , "of nonterminal" , getName @nt
,", there is more than one unique-attribute signature for the" , showAttrDef _LOC @attr
,". You should remove enough of them to make all unique-signatures for alternative"
,getName @con , "of nonterminal " ,getName @nt , "unique."
]
act = wfill ["Unpredicatable sharing of unique numbers may occur."]
in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose
| MissingSyn lhs.pp = let mesg = wfill ["Missing synthesized attribute"
, getName @attr
, "at nonterminal"
, getName @nt, "."
]
pat = "ATTR" >#< getName @nt >#< "[ | | " >#< getName @attr >#< " : ... ]"
help = wfill ["An augment rule for a constructor for nonterminal" , getName @nt
, "refers to a synthesized attribute named "
, getName @attr
,"Maybe you misspelled it?"
,"Otherwise add an appropriate attribute definition."
]
act = wfill ["It is not possible to proceed without this declaration."]
in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose
| IncompatibleVisitKind
lhs.pp = let mesg = "visit" >#< @vis >#< "of child" >#< @child >#< " with kind" >#< show @to >#< " cannot be called from a visit with kind " >#< show @from
pat = empty
help = empty
act = text "It is not possible to proceed without fixing this kind error."
in ppError (isError @lhs.options @me) (getPos @child) mesg pat help act @lhs.verbose
| IncompatibleRuleKind
lhs.pp = let mesg = "rule" >#< @rule >#< "cannot be called from a visit with kind " >#< show @kind
pat = empty
help = empty
act = text "It is not possible to proceed without fixing this kind error."
in ppError (isError @lhs.options @me) (getPos @rule) mesg pat help act @lhs.verbose
| IncompatibleAttachKind
lhs.pp = let mesg = "child" >#< @child >#< "cannot be called from a visit with kind " >#< show @kind
pat = empty
help = empty
act = text "It is not possible to proceed without fixing this kind error."
in ppError (isError @lhs.options @me) (getPos @child) mesg pat help act @lhs.verbose
{
toWidth :: Int -> String -> String
toWidth n xs | k<n = xs ++ replicate (n-k) ' '
| otherwise = xs
where k = length xs
showEdge :: ((Identifier,Identifier),[String],[String]) -> PP_Doc
showEdge ((inh,syn),_,_)
= text ("inherited attribute " ++ toWidth 20 (getName inh) ++ " with synthesized attribute " ++ getName syn)
showEdgeLong :: ((Identifier,Identifier),[String],[String]) -> PP_Doc
showEdgeLong ((inh,syn),path1,path2)
= text ("inherited attribute " ++ getName inh ++ " is needed for " ++ "synthesized attribute " ++ getName syn)
>-< indent 4 (vlist (map text path2))
>-< text "and back: "
>-< indent 4 (vlist (map text path1))
attrText :: Identifier -> Identifier -> String
attrText inh syn
= if inh == syn
then "threaded attribute " ++ getName inh
else "inherited attribute " ++ getName inh ++ " and synthesized attribute " ++getName syn
showLineNr :: Int -> String
showLineNr i | i==(-1) = "CR"
| otherwise = show i
showAttrDef :: Identifier -> Identifier -> String
showAttrDef f a | f == _LHS = "synthesized attribute " ++ getName a
| f == _LOC = "local attribute " ++ getName a
| f == _INST = "inst attribute " ++ getName a
| otherwise = "inherited attribute " ++ getName a ++ " of field " ++ getName f
showAttrUse :: Identifier -> Identifier -> String
showAttrUse f a | f == _LHS = "inherited attribute " ++ getName a
| f == _LOC = "local attribute " ++ getName a
| f == _INST = "inst attribute " ++ getName a
| otherwise = "synthesized attribute " ++ getName a ++ " of field " ++ getName f
ppAttr :: Identifier -> Identifier -> PP_Doc
ppAttr f a = text (getName f++"."++getName a)
ppAttrUse :: Identifier -> Identifier -> PP_Doc
ppAttrUse f a = "@" >|< ppAttr f a
}
-- Printing of error messages
{
infixr 5 +#+
(+#+) :: String -> String -> String
(+#+) s t = s ++ " " ++ t
infixr 5 +.+
(+.+) :: Identifier -> Identifier -> String
(+.+) s t = getName s ++ "." ++ getName t
wfill :: [String] -> PP_Doc
wfill = fill . addSpaces. concat . map words
where addSpaces (x:xs) = x:map addSpace xs
addSpaces [] = []
addSpace [x] | x `elem` ".,;:!?" = [x]
addSpace xs = ' ':xs
ppError :: Bool -- class of the error, True:error False:warning
-> Pos -- source position
-> PP_Doc -- error message
-> PP_Doc -- pattern
-> PP_Doc -- help, more info
-> PP_Doc -- action taken by AG
-> Bool -- verbose? show help and action?
-> PP_Doc
ppError isErr pos mesg pat hlp act verb
= let position = case pos of
Pos l c f | l >= 0 -> f >|< ":" >|< show l >|< ":" >|< show c
| otherwise -> pp "uuagc"
tp = if isErr then "error" else "warning"
header = position >|< ":" >#< tp >|< ":" >#< mesg
pattern = "pattern :" >#< pat
help = "help :" >#< hlp
action = "action :" >#< act
in if verb
then vlist [text "",header,pattern,help,action]
else header
{-
-- old error reporting code
= let
cl = if isError then "ERROR" else "Warning"
position = case pos of
(Pos l c f) | l >= 0 -> f >|< ": line " >|< show l >|< ", column " >|< show c
| otherwise -> empty
header = "*** UU.AG" >#< cl >#< position >#< "***"
message = "problem :" >#< mesg
pattern = "pattern :" >#< pat
help = "help :" >#< hlp
action = "action :" >#< act
in
if verbose
then vlist [text "",header,message,pattern,help,action]
else vlist [text "",header,message]
-}
showPos :: Identifier -> String
showPos = show . getPos
ppInterface :: Show a => a -> PP_Doc
ppInterface inter = wfill ["interface:", show inter]
}
|
