Skip to content

Commit 6769cce

Browse files
author
Jaro Reinders
committed
begin work on infix constructors
1 parent fb4c6b3 commit 6769cce

30 files changed

+13806
-12224
lines changed

‎uuagc/trunk/src-ag/AbstractSyntaxDump.ag‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -42,6 +42,7 @@ SEM TypeSig
4242

4343
SEM Pattern
4444
| Constr lhs . pp = ppNestInfo ["Pattern","Constr"] [pp @name] [ppF "pats" $ ppVList @pats.ppL] []
45+
| InfixConstr lhs . pp = ppNestInfo ["Pattern","InfixConstr"] [pp @name] [ppF "patl" @patl.pp, ppF "patr" @patr.pp] []
4546
| Product lhs . pp = ppNestInfo ["Pattern","Product"] [ppShow @pos] [ppF "pats" $ ppVList @pats.ppL] []
4647
| Alias lhs . pp = ppNestInfo ["Pattern","Alias"] [pp @field, pp @attr] [ppF "pat" $ @pat.pp] []
4748
| Underscore lhs . pp = ppNestInfo ["Pattern","Underscore"] [ppShow @pos] [] []

‎uuagc/trunk/src-ag/DefaultRules.ag‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -508,12 +508,14 @@ addAugments (syn, exprs) rules
508508
modify r = r
509509

510510
containsSyn (Constr _ pats) = any containsSyn pats
511+
containsSyn (InfixConstr _ patl patr) = containsSyn patl || containsSyn patr
511512
containsSyn (Product _ pats) = any containsSyn pats
512513
containsSyn (Irrefutable pat) = containsSyn pat
513514
containsSyn (Alias field attr pat) = (field == _LHS && attr == syn) || containsSyn pat
514515
containsSyn _ = False
515516

516517
modifyPat (Constr name pats) = Constr name (map modifyPat pats)
518+
modifyPat (InfixConstr name patl patr) = InfixConstr name (modifyPat patl) (modifyPat patr)
517519
modifyPat (Product pos pats) = Product pos (map modifyPat pats)
518520
modifyPat (Irrefutable pat) = Irrefutable (modifyPat pat)
519521
modifyPat (Alias field attr pat)

‎uuagc/trunk/src-ag/ExecutionPlan2Hs.ag‎

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1137,13 +1137,15 @@ SEM Pattern
11371137
lhs.sem_lhs = @loc.addbang1 @loc.patExpr
11381138
| Product lhs.sem_lhs = @loc.addbang1 $ pp_block "(" ")" "," @pats.sem_lhs
11391139
| Constr lhs.sem_lhs = @loc.addbang1 $ pp_parens $ @name >#< hv_sp @pats.sem_lhs
1140+
| InfixConstr lhs.sem_lhs = @loc.addbang1 $ pp_parens $ @patl.sem_lhs >#< @name >#< @patr.sem_lhs
11401141
| Underscore lhs.sem_lhs = text "_"
11411142
| Irrefutable lhs.sem_lhs = text "~" >|< pp_parens @pat.sem_lhs
11421143

11431144
-- Check if a pattern is just an underscore
11441145
ATTR Pattern [ | | isUnderscore:{Bool}]
11451146
SEM Pattern
11461147
| Constr lhs.isUnderscore = False
1148+
| InfixConstr lhs.isUnderscore = False
11471149
| Product lhs.isUnderscore = False
11481150
| Alias lhs.isUnderscore = False
11491151
| Underscore lhs.isUnderscore = True
@@ -1553,12 +1555,12 @@ SEM EProduction | EProduction loc.addbang = \x -> if bangpats @lhs.options
15531555
SEM EChild | EChild loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x
15541556
SEM EChild | ETerm loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x
15551557
SEM VisitStep | ChildVisit loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x
1556-
SEM Pattern | Alias Constr Product loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x
1558+
SEM Pattern | Alias Constr InfixConstr Product loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x
15571559

15581560
SEM Visit | Visit loc.addbang1 = if isLazyKind @kind then id else @loc.addbang
15591561
SEM ENonterminal | ENonterminal loc.addbangWrap = id --if strictWrap @lhs.options then @loc.addbang else id
15601562
SEM ERule | ERule loc.addbang1 = if @loc.anyLazyKind then id else @loc.addbang
1561-
SEM Pattern | Alias Constr Product loc.addbang1 = if @lhs.anyLazyKind then id else @loc.addbang
1563+
SEM Pattern | Alias Constr InfixConstr Product loc.addbang1 = if @lhs.anyLazyKind then id else @loc.addbang
15621564

15631565
--
15641566
-- Distribute single-visit-next map downward

‎uuagc/trunk/src-ag/Patterns.ag‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,9 @@ TYPE Patterns = [Pattern]
99

1010
DATA Pattern | Constr name : {ConstructorIdent}
1111
pats : Patterns
12+
| InfixConstr name : {ConstructorIdent}
13+
patl : Pattern
14+
patr : Pattern
1215
| Product pos : {Pos}
1316
pats : Patterns
1417
| Alias field : {Identifier}

‎uuagc/trunk/src-ag/PrintCode.ag‎

Lines changed: 5 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -353,13 +353,14 @@ SEM Patterns [ | | pps : {[PP_Doc]} ]
353353
| Nil lhs.pps = []
354354

355355
SEM Pattern
356-
| Constr Product Alias
356+
| Constr InfixConstr Product Alias
357357
loc.addBang = if bangpats @lhs.options && not @lhs.isDeclOfLet && not @lhs.belowIrrefutable
358358
then \p -> "!" >|< p
359359
else id
360360

361361
SEM Pattern [ | | pp:PP_Doc ]
362-
| Constr lhs.pp = @loc.addBang $ pp_parens $ @name >#< hv_sp @pats.pps
362+
| Constr lhs.pp = @loc.addBang $ pp_parens $ @pats.pps >#< @name >#< @pats.pps
363+
| InfixConstr lhs.pp = @loc.addBang $ pp_parens $ @patl.pp >#< @name >#< @patr.pp
363364
| Product lhs.pp = @loc.addBang $ pp_block "(" ")" "," @pats.pps
364365
| Alias loc.ppVar = pp (attrname @lhs.options False @field @attr)
365366
loc.ppVarBang = @loc.addBang $ @loc.ppVar
@@ -371,6 +372,7 @@ SEM Pattern [ | | pp:PP_Doc ]
371372

372373
SEM Pattern [ | | isUnderscore:{Bool}]
373374
| Constr lhs.isUnderscore = False
375+
| InfixConstr lhs.isUnderscore = False
374376
| Product lhs.isUnderscore = False
375377
| Alias lhs.isUnderscore = False
376378
| Underscore lhs.isUnderscore = True
@@ -394,6 +396,7 @@ SEM Patterns [ | | pps' : {[PP_Doc]} ]
394396

395397
SEM Pattern [ | | pp':PP_Doc ]
396398
| Constr lhs.pp' = pp_parens $ @name >#< hv_sp (map pp_parens @pats.pps')
399+
| InfixConstr lhs.pp' = pp_parens $ pp_parens @patl.pp' >#< @name >#< pp_parens @patr.pp'
397400
| Product lhs.pp' = pp_block "(" ")" "," @pats.pps'
398401
| Alias lhs.pp' = let attribute | @field == _LOC || @field == nullIdent = locname' @attr
399402
| otherwise = attrname @lhs.options False @field @attr

‎uuagc/trunk/src-ag/Transform.ag‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1188,6 +1188,7 @@ SEM Pattern
11881188
lhs.definedInsts = (if @field == _INST then [@attr] else []) ++ @pat.definedInsts
11891189
| Underscore lhs.patunder = \_ -> @copy
11901190
| Constr lhs.patunder = \us -> Constr @name (@pats.patunder us)
1191+
| InfixConstr lhs.patunder = \us -> InfixConstr @name (@patl.patunder us) (@patr.patunder us)
11911192
| Product lhs.patunder = \us -> Product @pos (@pats.patunder us)
11921193
| Irrefutable lhs.patunder = \us -> Irrefutable (@pat.patunder us)
11931194

@@ -1199,6 +1200,7 @@ ATTR Pattern [ | | stpos : Pos ]
11991200

12001201
SEM Pattern
12011202
| Constr lhs.stpos = getPos @name
1203+
| InfixConstr lhs.stpos = @patl.stpos
12021204
| Product lhs.stpos = @pos
12031205
| Alias lhs.stpos = getPos @field
12041206
| Underscore lhs.stpos = @pos

0 commit comments

Comments
 (0)