Stabilise benchmarks wrt. GC
[nofib.git] / real / parser / parser.slowstdin
1
2 --==========================================================--
3 --=== The parser.                                        ===--
4 --===                                          Parser.hs ===--
5 --==========================================================--
6
7 module Parser where
8
9 {- FIX THESE UP -}
10 --utLookupDef env k def
11 --   = head ( [ vv | (kk,vv) <- env, kk == k] ++ [def] )
12 panic = error
13 {- END FIXUPS -}
14
15 --paLiteral :: Parser Literal
16 paLiteral
17    = pgAlts
18      [
19         pgApply (LiteralInt.leStringToInt) (pgItem Lintlit),
20         pgApply (LiteralChar.head)         (pgItem Lcharlit),
21         pgApply LiteralString              (pgItem Lstringlit)
22      ]
23
24 paExpr
25    = pgAlts
26      [
27         paCaseExpr,
28         paLetExpr,
29         paLamExpr,
30         paIfExpr,
31         paUnaryMinusExpr,
32         hsDoExpr []
33      ]
34
35 paUnaryMinusExpr
36    = pgThen2
37         (\minus (_, aexpr, _) ->
38              ExprApp (ExprApp (ExprVar "-") (ExprLiteral (LiteralInt 0))) aexpr)
39         paMinus
40         paAExpr
41
42 paCaseExpr
43    = pgThen4
44         (\casee expr off alts -> ExprCase expr alts)
45         (pgItem Lcase)
46         paExpr
47         (pgItem Lof)
48         (pgDeclList paAlt)
49
50 paAlt
51    = pgAlts
52      [
53         pgThen4
54            (\pat arrow expr wheres
55                 -> MkExprCaseAlt pat (pa_MakeWhereExpr expr wheres))
56            paPat
57            (pgItem Larrow)
58            paExpr
59            (pgOptional paWhereClause),
60         pgThen3
61            (\pat agrdrhss wheres
62                 -> MkExprCaseAlt pat
63                       (pa_MakeWhereExpr (ExprGuards agrdrhss) wheres))
64            paPat
65            (pgOneOrMore paGalt)
66            (pgOptional paWhereClause)
67      ]
68
69 paGalt
70    = pgThen4
71         (\bar guard arrow expr -> (guard, expr))
72         (pgItem Lbar)
73         paExpr
74         (pgItem Larrow)
75         paExpr
76
77 paLamExpr
78    = pgThen4
79         (\lam patterns arrow rhs -> ExprLam patterns rhs)
80         (pgItem Lslash)
81         (pgZeroOrMore paAPat)
82         (pgItem Larrow)
83         paExpr
84
85 paLetExpr
86    = pgThen4
87         (\lett decls inn rhs -> ExprLetrec decls rhs)
88         (pgItem Llet)
89         paValdefs
90         (pgItem Lin)
91         paExpr
92
93 paValdefs
94    = pgApply pa_MergeValdefs (pgDeclList paValdef)
95
96 pa_MergeValdefs
97    = id
98
99 paLhs
100    = pgAlts
101      [
102         pgThen2 (\v ps -> LhsVar v ps) paVar (pgOneOrMore paPat),
103         pgApply LhsPat paPat
104      ]
105
106 paValdef
107    = pgAlts
108      [
109         pgThen4
110            (\(line, lhs) eq rhs wheres
111                 -> MkValBind line lhs (pa_MakeWhereExpr rhs wheres))
112            (pgGetLineNumber paLhs)
113            (pgItem Lequals)
114            paExpr
115            (pgOptional paWhereClause),
116         pgThen3
117            (\(line, lhs) grdrhss wheres
118                 -> MkValBind line lhs
119                       (pa_MakeWhereExpr (ExprGuards grdrhss) wheres))
120            (pgGetLineNumber paLhs)
121            (pgOneOrMore paGrhs)
122            (pgOptional paWhereClause)
123      ]
124
125 pa_MakeWhereExpr expr Nothing
126    = expr
127 pa_MakeWhereExpr expr (Just whereClauses)
128    = ExprWhere expr whereClauses
129
130 paWhereClause
131    = pgThen2 (\x y -> y) (pgItem Lwhere) paValdefs
132 paGrhs
133    = pgThen4
134         (\bar guard equals expr -> (guard, expr))
135         (pgItem Lbar)
136         paExpr
137         (pgItem Lequals)
138         paExpr
139
140
141 paAPat
142    = pgAlts
143      [
144         pgApply PatVar paVar,
145         pgApply (\id -> PatCon id []) paCon,
146         pgApply (const PatWild) (pgItem Lunder),
147         pgApply PatTuple
148                 (pgThen3 (\l es r -> es)
149                          (pgItem Llparen)
150                          (pgTwoOrMoreWithSep paPat (pgItem Lcomma))
151                          (pgItem Lrparen)),
152         pgApply PatList
153                 (pgThen3 (\l es r -> es)
154                          (pgItem Llbrack)
155                          (pgZeroOrMoreWithSep paPat (pgItem Lcomma))
156                          (pgItem Lrbrack)),
157         pgThen3 (\l p r -> p)
158                 (pgItem Llparen)
159                 paPat
160                 (pgItem Lrparen)
161      ]
162
163 paPat
164    = pgAlts
165      [
166         pgThen2 (\c ps -> PatCon c ps)
167                 paCon
168                 (pgOneOrMore paAPat),
169         pgThen3 (\ap c pa -> PatCon c [ap,pa])
170                 paAPat
171                 paConop
172                 paPat,
173         paAPat
174      ]
175
176
177 paIfExpr
178  = pgThen4
179       (\iff c thenn (t,f) -> ExprIf c t f)
180       (pgItem Lif)
181       paExpr
182       (pgItem Lthen)
183       (pgThen3
184          (\t elsee f -> (t,f))
185          paExpr
186          (pgItem Lelse)
187          paExpr
188       )
189
190 paAExpr
191  = pgApply (\x -> (False, x, []))
192    (pgAlts
193     [
194        pgApply ExprVar paVar,
195        pgApply ExprCon paCon,
196        pgApply ExprLiteral paLiteral,
197        pgApply ExprList paListExpr,
198        pgApply ExprTuple paTupleExpr,
199        pgThen3 (\l e r -> e) (pgItem Llparen) paExpr (pgItem Lrparen)
200     ]
201    )
202
203 paListExpr
204    = pgThen3 (\l es r -> es)
205              (pgItem Llbrack)
206              (pgZeroOrMoreWithSep paExpr (pgItem Lcomma))
207              (pgItem Lrbrack)
208
209 paTupleExpr
210    = pgThen3 (\l es r -> es)
211              (pgItem Llparen)
212              (pgTwoOrMoreWithSep paExpr (pgItem Lcomma))
213              (pgItem Lrparen)
214
215 paVar = pgItem Lvar
216 paCon = pgItem Lcon
217 paVarop = pgItem Lvarop
218 paConop = pgItem Lconop
219 paMinus = pgItem Lminus
220
221 paOp
222  = pgAlts [
223             pgApply (\x -> (True, ExprVar x, x)) paVarop,
224             pgApply (\x -> (True, ExprCon x, x)) paConop,
225             pgApply (\x -> (True, ExprVar x, x)) paMinus
226           ]
227
228 paDataDecl
229    = pgThen2
230         (\dataa useful -> useful)
231         (pgItem Ldata)
232         paDataDecl_main
233
234 paDataDecl_main
235    = pgThen4
236         (\name params eq drhs -> MkDataDecl name (params, drhs))
237         paCon
238         (pgZeroOrMore paVar)
239         (pgItem Lequals)
240         (pgOneOrMoreWithSep paConstrs (pgItem Lbar))
241
242 paConstrs
243    = pgThen2
244         (\con texprs -> (con, texprs))
245         paCon
246         (pgZeroOrMore paAType)
247
248 paType
249    = pgAlts
250      [
251         pgThen3
252            (\atype arrow typee -> TypeArr atype typee)
253            paAType
254            (pgItem Larrow)
255            paType,
256         pgThen2
257            TypeCon
258            paCon
259            (pgOneOrMore paAType),
260         paAType
261      ]
262
263 paAType
264    = pgAlts
265      [
266         pgApply TypeVar paVar,
267         pgApply (\tycon -> TypeCon tycon []) paCon,
268         pgThen3
269            (\l t r -> t)
270            (pgItem Llparen)
271            paType
272            (pgItem Lrparen),
273         pgThen3
274            (\l t r -> TypeList t)
275            (pgItem Llbrack)
276            paType
277            (pgItem Lrbrack),
278         pgThen3
279            (\l t r -> TypeTuple t)
280            (pgItem Llparen)
281            (pgTwoOrMoreWithSep paType (pgItem Lcomma))
282            (pgItem Lrparen)
283      ]
284
285 paInfixDecl env toks
286   = let dump (ExprVar v) = v
287         dump (ExprCon c) = c
288     in
289     pa_UpdateFixityEnv
290        (pgThen3
291           (\assoc prio name -> MkFixDecl name (assoc, prio))
292           paInfixWord
293           (pgApply leStringToInt (pgItem Lintlit))
294           (pgApply (\(_, op, _) -> dump op) paOp)
295           env
296           toks
297        )
298
299 paInfixWord
300   = pgAlts
301     [
302        pgApply (const InfixL) (pgItem Linfixl),
303        pgApply (const InfixR) (pgItem Linfixr),
304        pgApply (const InfixN) (pgItem Linfix)
305     ]
306
307 pa_UpdateFixityEnv (PFail tok)
308    = PFail tok
309
310 pa_UpdateFixityEnv (POk env toks (MkFixDecl name assoc_prio))
311    = let
312          new_env = (name, assoc_prio) : env
313      in
314          POk new_env toks (MkFixDecl name assoc_prio)
315
316 paTopDecl
317    = pgAlts
318      [
319         pgApply MkTopF paInfixDecl,
320         pgApply MkTopD paDataDecl,
321         pgApply MkTopV paValdef
322      ]
323
324 paModule
325    = pgThen4
326         (\modyule name wheree topdecls -> MkModule name topdecls)
327         (pgItem Lmodule)
328         paCon
329         (pgItem Lwhere)
330         (pgDeclList paTopDecl)
331
332 parser_test toks
333    = let parser_to_test
334             = --paPat
335               --paExpr
336               --paValdef
337               --pgZeroOrMore paInfixDecl
338               --paDataDecl
339               --paType
340               paModule
341               --pgTwoOrMoreWithSep (pgItem Lsemi) (pgItem Lcomma)
342
343      in
344          parser_to_test hsPrecTable toks
345
346 --==============================================--
347 --=== The Operator-Precedence parser (yuck!) ===--
348 --==============================================--
349
350 --
351 --==========================================================--
352 --
353 hsAExprOrOp
354  = pgAlts [paAExpr, paOp]
355
356 --hsDoExpr :: [PEntry] -> Parser Expr
357 -- [PaEntry] is a stack of operators and atomic expressions
358 -- hsDoExpr uses a parser (hsAexpOrOp :: Parsr PaEntry) for atomic
359 -- expressions or operators
360
361 hsDoExpr stack env toks =
362   let
363      (validIn, restIn, parseIn, err)
364         = case hsAExprOrOp env toks of
365              POk env1 toks1 item1
366                 -> (True, toks1, item1, panic "hsDoExpr(1)")
367              PFail err
368                 -> (False, panic "hsDoExpr(2)", panic "hsDoExpr(3)", err)
369      (opIn, valueIn, nameIn)
370         = parseIn
371      (assocIn, priorIn)
372         = utLookupDef env nameIn (InfixL, 9)
373      shift
374         = hsDoExpr (parseIn:stack) env restIn
375   in
376      case stack of
377         s1:s2:s3:ss
378            | validIn && opS2 && opIn && priorS2 > priorIn
379               -> reduce
380            | validIn && opS2 && opIn && priorS2 == priorIn
381               -> if assocS2 == InfixL &&
382                     assocIn == InfixL
383                  then reduce
384                  else
385                  if assocS2 == InfixR &&
386                     assocIn == InfixR
387                  then shift
388                  else PFail (head toks) -- Because of ambiguousness
389            | not validIn && opS2
390               -> reduce
391              where
392                (opS1, valueS1, nameS1) = s1
393                (opS2, valueS2, nameS2) = s2
394                (opS3, valueS3, nameS3) = s3
395                (assocS2, priorS2) = utLookupDef env nameS2 (InfixL, 9)
396                reduce = hsDoExpr ((False, ExprApp (ExprApp valueS2 valueS3)
397                                                   valueS1, [])
398                                   : ss) env toks
399         s1:s2:ss
400            | validIn && (opS1 || opS2) -> shift
401            | otherwise -> reduce
402              where
403                 (opS1, valueS1, nameS1) = s1
404                 (opS2, valueS2, nameS2) = s2
405                 reduce = hsDoExpr ((False, ExprApp valueS2 valueS1, []) : ss)
406                                   env toks
407         (s1:[])
408            | validIn -> shift
409            | otherwise -> POk env toks valueS1
410              where
411                 (opS1, valueS1, nameS1) = s1
412         []
413            | validIn -> shift
414            | otherwise -> PFail err
415
416 --==========================================================--
417 --=== end                                      Parser.hs ===--
418 --==========================================================--
419
420
421 hsPrecTable = [
422   ("-",         (InfixL, 6)),
423   ("+",         (InfixL, 6)),
424   ("*",         (InfixL, 7)),
425   ("div",       (InfixN, 7)),
426   ("mod",       (InfixN, 7)),
427
428   ("<",         (InfixN, 4)),
429   ("<=",        (InfixN, 4)),
430   ("==",        (InfixN, 4)),
431   ("/=",        (InfixN, 4)),
432   (">=",        (InfixN, 4)),
433   (">",         (InfixN, 4)),
434
435   ("C:",        (InfixR, 5)),
436   ("++",        (InfixR, 5)),
437   ("\\",        (InfixN, 5)),
438   ("!!",        (InfixL, 9)),
439   (".",         (InfixR, 9)),
440   ("^",         (InfixR, 8)),
441   ("elem",      (InfixN, 4)),
442   ("notElem",   (InfixN, 4)),
443
444   ("||",        (InfixR, 2)),
445   ("&&",        (InfixR, 3))]
446
447 {- FIX THESE UP -}
448 --utLookupDef env k def
449 --   = head ( [ vv | (kk,vv) <- env, kk == k] ++ [def] )
450 panic = error
451 {- END FIXUPS -}
452
453 --paLiteral :: Parser Literal
454 paLiteral
455    = pgAlts
456      [
457         pgApply (LiteralInt.leStringToInt) (pgItem Lintlit),
458         pgApply (LiteralChar.head)         (pgItem Lcharlit),
459         pgApply LiteralString              (pgItem Lstringlit)
460      ]
461
462 paExpr
463    = pgAlts
464      [
465         paCaseExpr,
466         paLetExpr,
467         paLamExpr,
468         paIfExpr,
469         paUnaryMinusExpr,
470         hsDoExpr []
471      ]
472
473 paUnaryMinusExpr
474    = pgThen2
475         (\minus (_, aexpr, _) ->
476              ExprApp (ExprApp (ExprVar "-") (ExprLiteral (LiteralInt 0))) aexpr)
477         paMinus
478         paAExpr
479
480 paCaseExpr
481    = pgThen4
482         (\casee expr off alts -> ExprCase expr alts)
483         (pgItem Lcase)
484         paExpr
485         (pgItem Lof)
486         (pgDeclList paAlt)
487
488 paAlt
489    = pgAlts
490      [
491         pgThen4
492            (\pat arrow expr wheres
493                 -> MkExprCaseAlt pat (pa_MakeWhereExpr expr wheres))
494            paPat
495            (pgItem Larrow)
496            paExpr
497            (pgOptional paWhereClause),
498         pgThen3
499            (\pat agrdrhss wheres
500                 -> MkExprCaseAlt pat
501                       (pa_MakeWhereExpr (ExprGuards agrdrhss) wheres))
502            paPat
503            (pgOneOrMore paGalt)
504            (pgOptional paWhereClause)
505      ]
506
507 paGalt
508    = pgThen4
509         (\bar guard arrow expr -> (guard, expr))
510         (pgItem Lbar)
511         paExpr
512         (pgItem Larrow)
513         paExpr
514
515 paLamExpr
516    = pgThen4
517         (\lam patterns arrow rhs -> ExprLam patterns rhs)
518         (pgItem Lslash)
519         (pgZeroOrMore paAPat)
520         (pgItem Larrow)
521         paExpr
522
523 paLetExpr
524    = pgThen4
525         (\lett decls inn rhs -> ExprLetrec decls rhs)
526         (pgItem Llet)
527         paValdefs
528         (pgItem Lin)
529         paExpr
530
531 paValdefs
532    = pgApply pa_MergeValdefs (pgDeclList paValdef)
533
534 pa_MergeValdefs
535    = id
536
537 paLhs
538    = pgAlts
539      [
540         pgThen2 (\v ps -> LhsVar v ps) paVar (pgOneOrMore paPat),
541         pgApply LhsPat paPat
542      ]
543
544 paValdef
545    = pgAlts
546      [
547         pgThen4
548            (\(line, lhs) eq rhs wheres
549                 -> MkValBind line lhs (pa_MakeWhereExpr rhs wheres))
550            (pgGetLineNumber paLhs)
551            (pgItem Lequals)
552            paExpr
553            (pgOptional paWhereClause),
554         pgThen3
555            (\(line, lhs) grdrhss wheres
556                 -> MkValBind line lhs
557                       (pa_MakeWhereExpr (ExprGuards grdrhss) wheres))
558            (pgGetLineNumber paLhs)
559            (pgOneOrMore paGrhs)
560            (pgOptional paWhereClause)
561      ]
562
563 pa_MakeWhereExpr expr Nothing
564    = expr
565 pa_MakeWhereExpr expr (Just whereClauses)
566    = ExprWhere expr whereClauses
567
568 paWhereClause
569    = pgThen2 (\x y -> y) (pgItem Lwhere) paValdefs
570 paGrhs
571    = pgThen4
572         (\bar guard equals expr -> (guard, expr))
573         (pgItem Lbar)
574         paExpr
575         (pgItem Lequals)
576         paExpr
577
578
579 paAPat
580    = pgAlts
581      [
582         pgApply PatVar paVar,
583         pgApply (\id -> PatCon id []) paCon,
584         pgApply (const PatWild) (pgItem Lunder),
585         pgApply PatTuple
586                 (pgThen3 (\l es r -> es)
587                          (pgItem Llparen)
588                          (pgTwoOrMoreWithSep paPat (pgItem Lcomma))
589                          (pgItem Lrparen)),
590         pgApply PatList
591                 (pgThen3 (\l es r -> es)
592                          (pgItem Llbrack)
593                          (pgZeroOrMoreWithSep paPat (pgItem Lcomma))
594                          (pgItem Lrbrack)),
595         pgThen3 (\l p r -> p)
596                 (pgItem Llparen)
597                 paPat
598                 (pgItem Lrparen)
599      ]
600
601 paPat
602    = pgAlts
603      [
604         pgThen2 (\c ps -> PatCon c ps)
605                 paCon
606                 (pgOneOrMore paAPat),
607         pgThen3 (\ap c pa -> PatCon c [ap,pa])
608                 paAPat
609                 paConop
610                 paPat,
611         paAPat
612      ]
613
614
615 paIfExpr
616  = pgThen4
617       (\iff c thenn (t,f) -> ExprIf c t f)
618       (pgItem Lif)
619       paExpr
620       (pgItem Lthen)
621       (pgThen3
622          (\t elsee f -> (t,f))
623          paExpr
624          (pgItem Lelse)
625          paExpr
626       )
627
628 paAExpr
629  = pgApply (\x -> (False, x, []))
630    (pgAlts
631     [
632        pgApply ExprVar paVar,
633        pgApply ExprCon paCon,
634        pgApply ExprLiteral paLiteral,
635        pgApply ExprList paListExpr,
636        pgApply ExprTuple paTupleExpr,
637        pgThen3 (\l e r -> e) (pgItem Llparen) paExpr (pgItem Lrparen)
638     ]
639    )
640
641 paListExpr
642    = pgThen3 (\l es r -> es)
643              (pgItem Llbrack)
644              (pgZeroOrMoreWithSep paExpr (pgItem Lcomma))
645              (pgItem Lrbrack)
646
647 paTupleExpr
648    = pgThen3 (\l es r -> es)
649              (pgItem Llparen)
650              (pgTwoOrMoreWithSep paExpr (pgItem Lcomma))
651              (pgItem Lrparen)
652
653 paVar = pgItem Lvar
654 paCon = pgItem Lcon
655 paVarop = pgItem Lvarop
656 paConop = pgItem Lconop
657 paMinus = pgItem Lminus
658
659 paOp
660  = pgAlts [
661             pgApply (\x -> (True, ExprVar x, x)) paVarop,
662             pgApply (\x -> (True, ExprCon x, x)) paConop,
663             pgApply (\x -> (True, ExprVar x, x)) paMinus
664           ]
665
666 paDataDecl
667    = pgThen2
668         (\dataa useful -> useful)
669         (pgItem Ldata)
670         paDataDecl_main
671
672 paDataDecl_main
673    = pgThen4
674         (\name params eq drhs -> MkDataDecl name (params, drhs))
675         paCon
676         (pgZeroOrMore paVar)
677         (pgItem Lequals)
678         (pgOneOrMoreWithSep paConstrs (pgItem Lbar))
679
680 paConstrs
681    = pgThen2
682         (\con texprs -> (con, texprs))
683         paCon
684         (pgZeroOrMore paAType)
685
686 paType
687    = pgAlts
688      [
689         pgThen3
690            (\atype arrow typee -> TypeArr atype typee)
691            paAType
692            (pgItem Larrow)
693            paType,
694         pgThen2
695            TypeCon
696            paCon
697            (pgOneOrMore paAType),
698         paAType
699      ]
700
701 paAType
702    = pgAlts
703      [
704         pgApply TypeVar paVar,
705         pgApply (\tycon -> TypeCon tycon []) paCon,
706         pgThen3
707            (\l t r -> t)
708            (pgItem Llparen)
709            paType
710            (pgItem Lrparen),
711         pgThen3
712            (\l t r -> TypeList t)
713            (pgItem Llbrack)
714            paType
715            (pgItem Lrbrack),
716         pgThen3
717            (\l t r -> TypeTuple t)
718            (pgItem Llparen)
719            (pgTwoOrMoreWithSep paType (pgItem Lcomma))
720            (pgItem Lrparen)
721      ]
722
723 paInfixDecl env toks
724   = let dump (ExprVar v) = v
725         dump (ExprCon c) = c
726     in
727     pa_UpdateFixityEnv
728        (pgThen3
729           (\assoc prio name -> MkFixDecl name (assoc, prio))
730           paInfixWord
731           (pgApply leStringToInt (pgItem Lintlit))
732           (pgApply (\(_, op, _) -> dump op) paOp)
733           env
734           toks
735        )
736
737 paInfixWord
738   = pgAlts
739     [
740        pgApply (const InfixL) (pgItem Linfixl),
741        pgApply (const InfixR) (pgItem Linfixr),
742        pgApply (const InfixN) (pgItem Linfix)
743     ]
744
745 pa_UpdateFixityEnv (PFail tok)
746    = PFail tok
747
748 pa_UpdateFixityEnv (POk env toks (MkFixDecl name assoc_prio))
749    = let
750          new_env = (name, assoc_prio) : env
751      in
752          POk new_env toks (MkFixDecl name assoc_prio)
753
754 paTopDecl
755    = pgAlts
756      [
757         pgApply MkTopF paInfixDecl,
758         pgApply MkTopD paDataDecl,
759         pgApply MkTopV paValdef
760      ]
761
762 paModule
763    = pgThen4
764         (\modyule name wheree topdecls -> MkModule name topdecls)
765         (pgItem Lmodule)
766         paCon
767         (pgItem Lwhere)
768         (pgDeclList paTopDecl)
769
770 parser_test toks
771    = let parser_to_test
772             = --paPat
773               --paExpr
774               --paValdef
775               --pgZeroOrMore paInfixDecl
776               --paDataDecl
777               --paType
778               paModule
779               --pgTwoOrMoreWithSep (pgItem Lsemi) (pgItem Lcomma)
780
781      in
782          parser_to_test hsPrecTable toks
783
784 --==============================================--
785 --=== The Operator-Precedence parser (yuck!) ===--
786 --==============================================--
787
788 --
789 --==========================================================--
790 --
791 hsAExprOrOp
792  = pgAlts [paAExpr, paOp]
793
794 --hsDoExpr :: [PEntry] -> Parser Expr
795 -- [PaEntry] is a stack of operators and atomic expressions
796 -- hsDoExpr uses a parser (hsAexpOrOp :: Parsr PaEntry) for atomic
797 -- expressions or operators
798
799 hsDoExpr stack env toks =
800   let
801      (validIn, restIn, parseIn, err)
802         = case hsAExprOrOp env toks of
803              POk env1 toks1 item1
804                 -> (True, toks1, item1, panic "hsDoExpr(1)")
805              PFail err
806                 -> (False, panic "hsDoExpr(2)", panic "hsDoExpr(3)", err)
807      (opIn, valueIn, nameIn)
808         = parseIn
809      (assocIn, priorIn)
810         = utLookupDef env nameIn (InfixL, 9)
811      shift
812         = hsDoExpr (parseIn:stack) env restIn
813   in
814      case stack of
815         s1:s2:s3:ss
816            | validIn && opS2 && opIn && priorS2 > priorIn
817               -> reduce
818            | validIn && opS2 && opIn && priorS2 == priorIn
819               -> if assocS2 == InfixL &&
820                     assocIn == InfixL
821                  then reduce
822                  else
823                  if assocS2 == InfixR &&
824                     assocIn == InfixR
825                  then shift
826                  else PFail (head toks) -- Because of ambiguousness
827            | not validIn && opS2
828               -> reduce
829              where
830                (opS1, valueS1, nameS1) = s1
831                (opS2, valueS2, nameS2) = s2
832                (opS3, valueS3, nameS3) = s3
833                (assocS2, priorS2) = utLookupDef env nameS2 (InfixL, 9)
834                reduce = hsDoExpr ((False, ExprApp (ExprApp valueS2 valueS3)
835                                                   valueS1, [])
836                                   : ss) env toks
837         s1:s2:ss
838            | validIn && (opS1 || opS2) -> shift
839            | otherwise -> reduce
840              where
841                 (opS1, valueS1, nameS1) = s1
842                 (opS2, valueS2, nameS2) = s2
843                 reduce = hsDoExpr ((False, ExprApp valueS2 valueS1, []) : ss)
844                                   env toks
845         (s1:[])
846            | validIn -> shift
847            | otherwise -> POk env toks valueS1
848              where
849                 (opS1, valueS1, nameS1) = s1
850         []
851            | validIn -> shift
852            | otherwise -> PFail err
853
854 --==========================================================--
855 --=== end                                      Parser.hs ===--
856 --==========================================================--
857
858
859 hsPrecTable = [
860   ("-",         (InfixL, 6)),
861   ("+",         (InfixL, 6)),
862   ("*",         (InfixL, 7)),
863   ("div",       (InfixN, 7)),
864   ("mod",       (InfixN, 7)),
865
866   ("<",         (InfixN, 4)),
867   ("<=",        (InfixN, 4)),
868   ("==",        (InfixN, 4)),
869   ("/=",        (InfixN, 4)),
870   (">=",        (InfixN, 4)),
871   (">",         (InfixN, 4)),
872
873   ("C:",        (InfixR, 5)),
874   ("++",        (InfixR, 5)),
875   ("\\",        (InfixN, 5)),
876   ("!!",        (InfixL, 9)),
877   (".",         (InfixR, 9)),
878   ("^",         (InfixR, 8)),
879   ("elem",      (InfixN, 4)),
880   ("notElem",   (InfixN, 4)),
881
882   ("||",        (InfixR, 2)),
883   ("&&",        (InfixR, 3))]
884
885 {- FIX THESE UP -}
886 --utLookupDef env k def
887 --   = head ( [ vv | (kk,vv) <- env, kk == k] ++ [def] )
888 panic = error
889 {- END FIXUPS -}
890
891 --paLiteral :: Parser Literal
892 paLiteral
893    = pgAlts
894      [
895         pgApply (LiteralInt.leStringToInt) (pgItem Lintlit),
896         pgApply (LiteralChar.head)         (pgItem Lcharlit),
897         pgApply LiteralString              (pgItem Lstringlit)
898      ]
899
900 paExpr
901    = pgAlts
902      [
903         paCaseExpr,
904         paLetExpr,
905         paLamExpr,
906         paIfExpr,
907         paUnaryMinusExpr,
908         hsDoExpr []
909      ]
910
911 paUnaryMinusExpr
912    = pgThen2
913         (\minus (_, aexpr, _) ->
914              ExprApp (ExprApp (ExprVar "-") (ExprLiteral (LiteralInt 0))) aexpr)
915         paMinus
916         paAExpr
917
918 paCaseExpr
919    = pgThen4
920         (\casee expr off alts -> ExprCase expr alts)
921         (pgItem Lcase)
922         paExpr
923         (pgItem Lof)
924         (pgDeclList paAlt)
925
926 paAlt
927    = pgAlts
928      [
929         pgThen4
930            (\pat arrow expr wheres
931                 -> MkExprCaseAlt pat (pa_MakeWhereExpr expr wheres))
932            paPat
933            (pgItem Larrow)
934            paExpr
935            (pgOptional paWhereClause),
936         pgThen3
937            (\pat agrdrhss wheres
938                 -> MkExprCaseAlt pat
939                       (pa_MakeWhereExpr (ExprGuards agrdrhss) wheres))
940            paPat
941            (pgOneOrMore paGalt)
942            (pgOptional paWhereClause)
943      ]
944
945 paGalt
946    = pgThen4
947         (\bar guard arrow expr -> (guard, expr))
948         (pgItem Lbar)
949         paExpr
950         (pgItem Larrow)
951         paExpr
952
953 paLamExpr
954    = pgThen4
955         (\lam patterns arrow rhs -> ExprLam patterns rhs)
956         (pgItem Lslash)
957         (pgZeroOrMore paAPat)
958         (pgItem Larrow)
959         paExpr
960
961 paLetExpr
962    = pgThen4
963         (\lett decls inn rhs -> ExprLetrec decls rhs)
964         (pgItem Llet)
965         paValdefs
966         (pgItem Lin)
967         paExpr
968
969 paValdefs
970    = pgApply pa_MergeValdefs (pgDeclList paValdef)
971
972 pa_MergeValdefs
973    = id
974
975 paLhs
976    = pgAlts
977      [
978         pgThen2 (\v ps -> LhsVar v ps) paVar (pgOneOrMore paPat),
979         pgApply LhsPat paPat
980      ]
981
982 paValdef
983    = pgAlts
984      [
985         pgThen4
986            (\(line, lhs) eq rhs wheres
987                 -> MkValBind line lhs (pa_MakeWhereExpr rhs wheres))
988            (pgGetLineNumber paLhs)
989            (pgItem Lequals)
990            paExpr
991            (pgOptional paWhereClause),
992         pgThen3
993            (\(line, lhs) grdrhss wheres
994                 -> MkValBind line lhs
995                       (pa_MakeWhereExpr (ExprGuards grdrhss) wheres))
996            (pgGetLineNumber paLhs)
997            (pgOneOrMore paGrhs)
998            (pgOptional paWhereClause)
999      ]
1000
1001 pa_MakeWhereExpr expr Nothing
1002    = expr
1003 pa_MakeWhereExpr expr (Just whereClauses)
1004    = ExprWhere expr whereClauses
1005
1006 paWhereClause
1007    = pgThen2 (\x y -> y) (pgItem Lwhere) paValdefs
1008 paGrhs
1009    = pgThen4
1010         (\bar guard equals expr -> (guard, expr))
1011         (pgItem Lbar)
1012         paExpr
1013         (pgItem Lequals)
1014         paExpr
1015
1016
1017 paAPat
1018    = pgAlts
1019      [
1020         pgApply PatVar paVar,
1021         pgApply (\id -> PatCon id []) paCon,
1022         pgApply (const PatWild) (pgItem Lunder),
1023         pgApply PatTuple
1024                 (pgThen3 (\l es r -> es)
1025                          (pgItem Llparen)
1026                          (pgTwoOrMoreWithSep paPat (pgItem Lcomma))
1027                          (pgItem Lrparen)),
1028         pgApply PatList
1029                 (pgThen3 (\l es r -> es)
1030                          (pgItem Llbrack)
1031                          (pgZeroOrMoreWithSep paPat (pgItem Lcomma))
1032                          (pgItem Lrbrack)),
1033         pgThen3 (\l p r -> p)
1034                 (pgItem Llparen)
1035                 paPat
1036                 (pgItem Lrparen)
1037      ]
1038
1039 paPat
1040    = pgAlts
1041      [
1042         pgThen2 (\c ps -> PatCon c ps)
1043                 paCon
1044                 (pgOneOrMore paAPat),
1045         pgThen3 (\ap c pa -> PatCon c [ap,pa])
1046                 paAPat
1047                 paConop
1048                 paPat,
1049         paAPat
1050      ]
1051
1052
1053 paIfExpr
1054  = pgThen4
1055       (\iff c thenn (t,f) -> ExprIf c t f)
1056       (pgItem Lif)
1057       paExpr
1058       (pgItem Lthen)
1059       (pgThen3
1060          (\t elsee f -> (t,f))
1061          paExpr
1062          (pgItem Lelse)
1063          paExpr
1064       )
1065
1066 paAExpr
1067  = pgApply (\x -> (False, x, []))
1068    (pgAlts
1069     [
1070        pgApply ExprVar paVar,
1071        pgApply ExprCon paCon,
1072        pgApply ExprLiteral paLiteral,
1073        pgApply ExprList paListExpr,
1074        pgApply ExprTuple paTupleExpr,
1075        pgThen3 (\l e r -> e) (pgItem Llparen) paExpr (pgItem Lrparen)
1076     ]
1077    )
1078
1079 paListExpr
1080    = pgThen3 (\l es r -> es)
1081              (pgItem Llbrack)
1082              (pgZeroOrMoreWithSep paExpr (pgItem Lcomma))
1083              (pgItem Lrbrack)
1084
1085 paTupleExpr
1086    = pgThen3 (\l es r -> es)
1087              (pgItem Llparen)
1088              (pgTwoOrMoreWithSep paExpr (pgItem Lcomma))
1089              (pgItem Lrparen)
1090
1091 paVar = pgItem Lvar
1092 paCon = pgItem Lcon
1093 paVarop = pgItem Lvarop
1094 paConop = pgItem Lconop
1095 paMinus = pgItem Lminus
1096
1097 paOp
1098  = pgAlts [
1099             pgApply (\x -> (True, ExprVar x, x)) paVarop,
1100             pgApply (\x -> (True, ExprCon x, x)) paConop,
1101             pgApply (\x -> (True, ExprVar x, x)) paMinus
1102           ]
1103
1104 paDataDecl
1105    = pgThen2
1106         (\dataa useful -> useful)
1107         (pgItem Ldata)
1108         paDataDecl_main
1109
1110 paDataDecl_main
1111    = pgThen4
1112         (\name params eq drhs -> MkDataDecl name (params, drhs))
1113         paCon
1114         (pgZeroOrMore paVar)
1115         (pgItem Lequals)
1116         (pgOneOrMoreWithSep paConstrs (pgItem Lbar))
1117
1118 paConstrs
1119    = pgThen2
1120         (\con texprs -> (con, texprs))
1121         paCon
1122         (pgZeroOrMore paAType)
1123
1124 paType
1125    = pgAlts
1126      [
1127         pgThen3
1128            (\atype arrow typee -> TypeArr atype typee)
1129            paAType
1130            (pgItem Larrow)
1131            paType,
1132         pgThen2
1133            TypeCon
1134            paCon
1135            (pgOneOrMore paAType),
1136         paAType
1137      ]
1138
1139 paAType
1140    = pgAlts
1141      [
1142         pgApply TypeVar paVar,
1143         pgApply (\tycon -> TypeCon tycon []) paCon,
1144         pgThen3
1145            (\l t r -> t)
1146            (pgItem Llparen)
1147            paType
1148            (pgItem Lrparen),
1149         pgThen3
1150            (\l t r -> TypeList t)
1151            (pgItem Llbrack)
1152            paType
1153            (pgItem Lrbrack),
1154         pgThen3
1155            (\l t r -> TypeTuple t)
1156            (pgItem Llparen)
1157            (pgTwoOrMoreWithSep paType (pgItem Lcomma))
1158            (pgItem Lrparen)
1159      ]
1160
1161 paInfixDecl env toks
1162   = let dump (ExprVar v) = v
1163         dump (ExprCon c) = c
1164     in
1165     pa_UpdateFixityEnv
1166        (pgThen3
1167           (\assoc prio name -> MkFixDecl name (assoc, prio))
1168           paInfixWord
1169           (pgApply leStringToInt (pgItem Lintlit))
1170           (pgApply (\(_, op, _) -> dump op) paOp)
1171           env
1172           toks
1173        )
1174
1175 paInfixWord
1176   = pgAlts
1177     [
1178        pgApply (const InfixL) (pgItem Linfixl),
1179        pgApply (const InfixR) (pgItem Linfixr),
1180        pgApply (const InfixN) (pgItem Linfix)
1181     ]
1182
1183 pa_UpdateFixityEnv (PFail tok)
1184    = PFail tok
1185
1186 pa_UpdateFixityEnv (POk env toks (MkFixDecl name assoc_prio))
1187    = let
1188          new_env = (name, assoc_prio) : env
1189      in
1190          POk new_env toks (MkFixDecl name assoc_prio)
1191
1192 paTopDecl
1193    = pgAlts
1194      [
1195         pgApply MkTopF paInfixDecl,
1196         pgApply MkTopD paDataDecl,
1197         pgApply MkTopV paValdef
1198      ]
1199
1200 paModule
1201    = pgThen4
1202         (\modyule name wheree topdecls -> MkModule name topdecls)
1203         (pgItem Lmodule)
1204         paCon
1205         (pgItem Lwhere)
1206         (pgDeclList paTopDecl)
1207
1208 parser_test toks
1209    = let parser_to_test
1210             = --paPat
1211               --paExpr
1212               --paValdef
1213               --pgZeroOrMore paInfixDecl
1214               --paDataDecl
1215               --paType
1216               paModule
1217               --pgTwoOrMoreWithSep (pgItem Lsemi) (pgItem Lcomma)
1218
1219      in
1220          parser_to_test hsPrecTable toks
1221
1222 --==============================================--
1223 --=== The Operator-Precedence parser (yuck!) ===--
1224 --==============================================--
1225
1226 --
1227 --==========================================================--
1228 --
1229 hsAExprOrOp
1230  = pgAlts [paAExpr, paOp]
1231
1232 --hsDoExpr :: [PEntry] -> Parser Expr
1233 -- [PaEntry] is a stack of operators and atomic expressions
1234 -- hsDoExpr uses a parser (hsAexpOrOp :: Parsr PaEntry) for atomic
1235 -- expressions or operators
1236
1237 hsDoExpr stack env toks =
1238   let
1239      (validIn, restIn, parseIn, err)
1240         = case hsAExprOrOp env toks of
1241              POk env1 toks1 item1
1242                 -> (True, toks1, item1, panic "hsDoExpr(1)")
1243              PFail err
1244                 -> (False, panic "hsDoExpr(2)", panic "hsDoExpr(3)", err)
1245      (opIn, valueIn, nameIn)
1246         = parseIn
1247      (assocIn, priorIn)
1248         = utLookupDef env nameIn (InfixL, 9)
1249      shift
1250         = hsDoExpr (parseIn:stack) env restIn
1251   in
1252      case stack of
1253         s1:s2:s3:ss
1254            | validIn && opS2 && opIn && priorS2 > priorIn
1255               -> reduce
1256            | validIn && opS2 && opIn && priorS2 == priorIn
1257               -> if assocS2 == InfixL &&
1258                     assocIn == InfixL
1259                  then reduce
1260                  else
1261                  if assocS2 == InfixR &&
1262                     assocIn == InfixR
1263                  then shift
1264                  else PFail (head toks) -- Because of ambiguousness
1265            | not validIn && opS2
1266               -> reduce
1267              where
1268                (opS1, valueS1, nameS1) = s1
1269                (opS2, valueS2, nameS2) = s2
1270                (opS3, valueS3, nameS3) = s3
1271                (assocS2, priorS2) = utLookupDef env nameS2 (InfixL, 9)
1272                reduce = hsDoExpr ((False, ExprApp (ExprApp valueS2 valueS3)
1273                                                   valueS1, [])
1274                                   : ss) env toks
1275         s1:s2:ss
1276            | validIn && (opS1 || opS2) -> shift
1277            | otherwise -> reduce
1278              where
1279                 (opS1, valueS1, nameS1) = s1
1280                 (opS2, valueS2, nameS2) = s2
1281                 reduce = hsDoExpr ((False, ExprApp valueS2 valueS1, []) : ss)
1282                                   env toks
1283         (s1:[])
1284            | validIn -> shift
1285            | otherwise -> POk env toks valueS1
1286              where
1287                 (opS1, valueS1, nameS1) = s1
1288         []
1289            | validIn -> shift
1290            | otherwise -> PFail err
1291
1292 --==========================================================--
1293 --=== end                                      Parser.hs ===--
1294 --==========================================================--
1295
1296
1297 hsPrecTable = [
1298   ("-",         (InfixL, 6)),
1299   ("+",         (InfixL, 6)),
1300   ("*",         (InfixL, 7)),
1301   ("div",       (InfixN, 7)),
1302   ("mod",       (InfixN, 7)),
1303
1304   ("<",         (InfixN, 4)),
1305   ("<=",        (InfixN, 4)),
1306   ("==",        (InfixN, 4)),
1307   ("/=",        (InfixN, 4)),
1308   (">=",        (InfixN, 4)),
1309   (">",         (InfixN, 4)),
1310
1311   ("C:",        (InfixR, 5)),
1312   ("++",        (InfixR, 5)),
1313   ("\\",        (InfixN, 5)),
1314   ("!!",        (InfixL, 9)),
1315   (".",         (InfixR, 9)),
1316   ("^",         (InfixR, 8)),
1317   ("elem",      (InfixN, 4)),
1318   ("notElem",   (InfixN, 4)),
1319
1320   ("||",        (InfixR, 2)),
1321   ("&&",        (InfixR, 3))]
1322
1323 {- FIX THESE UP -}
1324 --utLookupDef env k def
1325 --   = head ( [ vv | (kk,vv) <- env, kk == k] ++ [def] )
1326 panic = error
1327 {- END FIXUPS -}
1328
1329 --paLiteral :: Parser Literal
1330 paLiteral
1331    = pgAlts
1332      [
1333         pgApply (LiteralInt.leStringToInt) (pgItem Lintlit),
1334         pgApply (LiteralChar.head)         (pgItem Lcharlit),
1335         pgApply LiteralString              (pgItem Lstringlit)
1336      ]
1337
1338 paExpr
1339    = pgAlts
1340      [
1341         paCaseExpr,
1342         paLetExpr,
1343         paLamExpr,
1344         paIfExpr,
1345         paUnaryMinusExpr,
1346         hsDoExpr []
1347      ]
1348
1349 paUnaryMinusExpr
1350    = pgThen2
1351         (\minus (_, aexpr, _) ->
1352              ExprApp (ExprApp (ExprVar "-") (ExprLiteral (LiteralInt 0))) aexpr)
1353         paMinus
1354         paAExpr
1355
1356 paCaseExpr
1357    = pgThen4
1358         (\casee expr off alts -> ExprCase expr alts)
1359         (pgItem Lcase)
1360         paExpr
1361         (pgItem Lof)
1362         (pgDeclList paAlt)
1363
1364 paAlt
1365    = pgAlts
1366      [
1367         pgThen4
1368            (\pat arrow expr wheres
1369                 -> MkExprCaseAlt pat (pa_MakeWhereExpr expr wheres))
1370            paPat
1371            (pgItem Larrow)
1372            paExpr
1373            (pgOptional paWhereClause),
1374         pgThen3
1375            (\pat agrdrhss wheres
1376                 -> MkExprCaseAlt pat
1377                       (pa_MakeWhereExpr (ExprGuards agrdrhss) wheres))
1378            paPat
1379            (pgOneOrMore paGalt)
1380            (pgOptional paWhereClause)
1381      ]
1382
1383 paGalt
1384    = pgThen4
1385         (\bar guard arrow expr -> (guard, expr))
1386         (pgItem Lbar)
1387         paExpr
1388         (pgItem Larrow)
1389         paExpr
1390
1391 paLamExpr
1392    = pgThen4
1393         (\lam patterns arrow rhs -> ExprLam patterns rhs)
1394         (pgItem Lslash)
1395         (pgZeroOrMore paAPat)
1396         (pgItem Larrow)
1397         paExpr
1398
1399 paLetExpr
1400    = pgThen4
1401         (\lett decls inn rhs -> ExprLetrec decls rhs)
1402         (pgItem Llet)
1403         paValdefs
1404         (pgItem Lin)
1405         paExpr
1406
1407 paValdefs
1408    = pgApply pa_MergeValdefs (pgDeclList paValdef)
1409
1410 pa_MergeValdefs
1411    = id
1412
1413 paLhs
1414    = pgAlts
1415      [
1416         pgThen2 (\v ps -> LhsVar v ps) paVar (pgOneOrMore paPat),
1417         pgApply LhsPat paPat
1418      ]
1419
1420 paValdef
1421    = pgAlts
1422      [
1423         pgThen4
1424            (\(line, lhs) eq rhs wheres
1425                 -> MkValBind line lhs (pa_MakeWhereExpr rhs wheres))
1426            (pgGetLineNumber paLhs)
1427            (pgItem Lequals)
1428            paExpr
1429            (pgOptional paWhereClause),
1430         pgThen3
1431            (\(line, lhs) grdrhss wheres
1432                 -> MkValBind line lhs
1433                       (pa_MakeWhereExpr (ExprGuards grdrhss) wheres))
1434            (pgGetLineNumber paLhs)
1435            (pgOneOrMore paGrhs)
1436            (pgOptional paWhereClause)
1437      ]
1438
1439 pa_MakeWhereExpr expr Nothing
1440    = expr
1441 pa_MakeWhereExpr expr (Just whereClauses)
1442    = ExprWhere expr whereClauses
1443
1444 paWhereClause
1445    = pgThen2 (\x y -> y) (pgItem Lwhere) paValdefs
1446 paGrhs
1447    = pgThen4
1448         (\bar guard equals expr -> (guard, expr))
1449         (pgItem Lbar)
1450         paExpr
1451         (pgItem Lequals)
1452         paExpr
1453
1454
1455 paAPat
1456    = pgAlts
1457      [
1458         pgApply PatVar paVar,
1459         pgApply (\id -> PatCon id []) paCon,
1460         pgApply (const PatWild) (pgItem Lunder),
1461         pgApply PatTuple
1462                 (pgThen3 (\l es r -> es)
1463                          (pgItem Llparen)
1464                          (pgTwoOrMoreWithSep paPat (pgItem Lcomma))
1465                          (pgItem Lrparen)),
1466         pgApply PatList
1467                 (pgThen3 (\l es r -> es)
1468                          (pgItem Llbrack)
1469                          (pgZeroOrMoreWithSep paPat (pgItem Lcomma))
1470                          (pgItem Lrbrack)),
1471         pgThen3 (\l p r -> p)
1472                 (pgItem Llparen)
1473                 paPat
1474                 (pgItem Lrparen)
1475      ]
1476
1477 paPat
1478    = pgAlts
1479      [
1480         pgThen2 (\c ps -> PatCon c ps)
1481                 paCon
1482                 (pgOneOrMore paAPat),
1483         pgThen3 (\ap c pa -> PatCon c [ap,pa])
1484                 paAPat
1485                 paConop
1486                 paPat,
1487         paAPat
1488      ]
1489
1490
1491 paIfExpr
1492  = pgThen4
1493       (\iff c thenn (t,f) -> ExprIf c t f)
1494       (pgItem Lif)
1495       paExpr
1496       (pgItem Lthen)
1497       (pgThen3
1498          (\t elsee f -> (t,f))
1499          paExpr
1500          (pgItem Lelse)
1501          paExpr
1502       )
1503
1504 paAExpr
1505  = pgApply (\x -> (False, x, []))
1506    (pgAlts
1507     [
1508        pgApply ExprVar paVar,
1509        pgApply ExprCon paCon,
1510        pgApply ExprLiteral paLiteral,
1511        pgApply ExprList paListExpr,
1512        pgApply ExprTuple paTupleExpr,
1513        pgThen3 (\l e r -> e) (pgItem Llparen) paExpr (pgItem Lrparen)
1514     ]
1515    )
1516
1517 paListExpr
1518    = pgThen3 (\l es r -> es)
1519              (pgItem Llbrack)
1520              (pgZeroOrMoreWithSep paExpr (pgItem Lcomma))
1521              (pgItem Lrbrack)
1522
1523 paTupleExpr
1524    = pgThen3 (\l es r -> es)
1525              (pgItem Llparen)
1526              (pgTwoOrMoreWithSep paExpr (pgItem Lcomma))
1527              (pgItem Lrparen)
1528
1529 paVar = pgItem Lvar
1530 paCon = pgItem Lcon
1531 paVarop = pgItem Lvarop
1532 paConop = pgItem Lconop
1533 paMinus = pgItem Lminus
1534
1535 paOp
1536  = pgAlts [
1537             pgApply (\x -> (True, ExprVar x, x)) paVarop,
1538             pgApply (\x -> (True, ExprCon x, x)) paConop,
1539             pgApply (\x -> (True, ExprVar x, x)) paMinus
1540           ]
1541
1542 paDataDecl
1543    = pgThen2
1544         (\dataa useful -> useful)
1545         (pgItem Ldata)
1546         paDataDecl_main
1547
1548 paDataDecl_main
1549    = pgThen4
1550         (\name params eq drhs -> MkDataDecl name (params, drhs))
1551         paCon
1552         (pgZeroOrMore paVar)
1553         (pgItem Lequals)
1554         (pgOneOrMoreWithSep paConstrs (pgItem Lbar))
1555
1556 paConstrs
1557    = pgThen2
1558         (\con texprs -> (con, texprs))
1559         paCon
1560         (pgZeroOrMore paAType)
1561
1562 paType
1563    = pgAlts
1564      [
1565         pgThen3
1566            (\atype arrow typee -> TypeArr atype typee)
1567            paAType
1568            (pgItem Larrow)
1569            paType,
1570         pgThen2
1571            TypeCon
1572            paCon
1573            (pgOneOrMore paAType),
1574         paAType
1575      ]
1576
1577 paAType
1578    = pgAlts
1579      [
1580         pgApply TypeVar paVar,
1581         pgApply (\tycon -> TypeCon tycon []) paCon,
1582         pgThen3
1583            (\l t r -> t)
1584            (pgItem Llparen)
1585            paType
1586            (pgItem Lrparen),
1587         pgThen3
1588            (\l t r -> TypeList t)
1589            (pgItem Llbrack)
1590            paType
1591            (pgItem Lrbrack),
1592         pgThen3
1593            (\l t r -> TypeTuple t)
1594            (pgItem Llparen)
1595            (pgTwoOrMoreWithSep paType (pgItem Lcomma))
1596            (pgItem Lrparen)
1597      ]
1598
1599 paInfixDecl env toks
1600   = let dump (ExprVar v) = v
1601         dump (ExprCon c) = c
1602     in
1603     pa_UpdateFixityEnv
1604        (pgThen3
1605           (\assoc prio name -> MkFixDecl name (assoc, prio))
1606           paInfixWord
1607           (pgApply leStringToInt (pgItem Lintlit))
1608           (pgApply (\(_, op, _) -> dump op) paOp)
1609           env
1610           toks
1611        )
1612
1613 paInfixWord
1614   = pgAlts
1615     [
1616        pgApply (const InfixL) (pgItem Linfixl),
1617        pgApply (const InfixR) (pgItem Linfixr),
1618        pgApply (const InfixN) (pgItem Linfix)
1619     ]
1620
1621 pa_UpdateFixityEnv (PFail tok)
1622    = PFail tok
1623
1624 pa_UpdateFixityEnv (POk env toks (MkFixDecl name assoc_prio))
1625    = let
1626          new_env = (name, assoc_prio) : env
1627      in
1628          POk new_env toks (MkFixDecl name assoc_prio)
1629
1630 paTopDecl
1631    = pgAlts
1632      [
1633         pgApply MkTopF paInfixDecl,
1634         pgApply MkTopD paDataDecl,
1635         pgApply MkTopV paValdef
1636      ]
1637
1638 paModule
1639    = pgThen4
1640         (\modyule name wheree topdecls -> MkModule name topdecls)
1641         (pgItem Lmodule)
1642         paCon
1643         (pgItem Lwhere)
1644         (pgDeclList paTopDecl)
1645
1646 parser_test toks
1647    = let parser_to_test
1648             = --paPat
1649               --paExpr
1650               --paValdef
1651               --pgZeroOrMore paInfixDecl
1652               --paDataDecl
1653               --paType
1654               paModule
1655               --pgTwoOrMoreWithSep (pgItem Lsemi) (pgItem Lcomma)
1656
1657      in
1658          parser_to_test hsPrecTable toks
1659
1660 --==============================================--
1661 --=== The Operator-Precedence parser (yuck!) ===--
1662 --==============================================--
1663
1664 --
1665 --==========================================================--
1666 --
1667 hsAExprOrOp
1668  = pgAlts [paAExpr, paOp]
1669
1670 --hsDoExpr :: [PEntry] -> Parser Expr
1671 -- [PaEntry] is a stack of operators and atomic expressions
1672 -- hsDoExpr uses a parser (hsAexpOrOp :: Parsr PaEntry) for atomic
1673 -- expressions or operators
1674
1675 hsDoExpr stack env toks =
1676   let
1677      (validIn, restIn, parseIn, err)
1678         = case hsAExprOrOp env toks of
1679              POk env1 toks1 item1
1680                 -> (True, toks1, item1, panic "hsDoExpr(1)")
1681              PFail err
1682                 -> (False, panic "hsDoExpr(2)", panic "hsDoExpr(3)", err)
1683      (opIn, valueIn, nameIn)
1684         = parseIn
1685      (assocIn, priorIn)
1686         = utLookupDef env nameIn (InfixL, 9)
1687      shift
1688         = hsDoExpr (parseIn:stack) env restIn
1689   in
1690      case stack of
1691         s1:s2:s3:ss
1692            | validIn && opS2 && opIn && priorS2 > priorIn
1693               -> reduce
1694            | validIn && opS2 && opIn && priorS2 == priorIn
1695               -> if assocS2 == InfixL &&
1696                     assocIn == InfixL
1697                  then reduce
1698                  else
1699                  if assocS2 == InfixR &&
1700                     assocIn == InfixR
1701                  then shift
1702                  else PFail (head toks) -- Because of ambiguousness
1703            | not validIn && opS2
1704               -> reduce
1705              where
1706                (opS1, valueS1, nameS1) = s1
1707                (opS2, valueS2, nameS2) = s2
1708                (opS3, valueS3, nameS3) = s3
1709                (assocS2, priorS2) = utLookupDef env nameS2 (InfixL, 9)
1710                reduce = hsDoExpr ((False, ExprApp (ExprApp valueS2 valueS3)
1711                                                   valueS1, [])
1712                                   : ss) env toks
1713         s1:s2:ss
1714            | validIn && (opS1 || opS2) -> shift
1715            | otherwise -> reduce
1716              where
1717                 (opS1, valueS1, nameS1) = s1
1718                 (opS2, valueS2, nameS2) = s2
1719                 reduce = hsDoExpr ((False, ExprApp valueS2 valueS1, []) : ss)
1720                                   env toks
1721         (s1:[])
1722            | validIn -> shift
1723            | otherwise -> POk env toks valueS1
1724              where
1725                 (opS1, valueS1, nameS1) = s1
1726         []
1727            | validIn -> shift
1728            | otherwise -> PFail err
1729
1730 --==========================================================--
1731 --=== end                                      Parser.hs ===--
1732 --==========================================================--
1733
1734
1735 hsPrecTable = [
1736   ("-",         (InfixL, 6)),
1737   ("+",         (InfixL, 6)),
1738   ("*",         (InfixL, 7)),
1739   ("div",       (InfixN, 7)),
1740   ("mod",       (InfixN, 7)),
1741
1742   ("<",         (InfixN, 4)),
1743   ("<=",        (InfixN, 4)),
1744   ("==",        (InfixN, 4)),
1745   ("/=",        (InfixN, 4)),
1746   (">=",        (InfixN, 4)),
1747   (">",         (InfixN, 4)),
1748
1749   ("C:",        (InfixR, 5)),
1750   ("++",        (InfixR, 5)),
1751   ("\\",        (InfixN, 5)),
1752   ("!!",        (InfixL, 9)),
1753   (".",         (InfixR, 9)),
1754   ("^",         (InfixR, 8)),
1755   ("elem",      (InfixN, 4)),
1756   ("notElem",   (InfixN, 4)),
1757
1758   ("||",        (InfixR, 2)),
1759   ("&&",        (InfixR, 3))]
1760