Start working on infix constructor patterns

Author: Jaro Reinders

uuagc/trunk/src-ag/AbstractSyntaxDump.ag

@@ -42,6 +42,7 @@ SEM TypeSig
 
 SEM Pattern
   | Constr          lhs     .   pp      =   ppNestInfo ["Pattern","Constr"] [pp @name] [ppF "pats" $ ppVList @pats.ppL] []
+  | InfixConstr     lhs     .   pp      =   ppNestInfo ["Pattern","InfixConstr"] [pp @name] [ppF "patl" @patl.pp, ppF "patr" @patr.pp] []
   | Product         lhs     .   pp      =   ppNestInfo ["Pattern","Product"] [ppShow @pos] [ppF "pats" $ ppVList @pats.ppL] []
   | Alias           lhs     .   pp      =   ppNestInfo ["Pattern","Alias"] [pp @field, pp @attr] [ppF "pat" $ @pat.pp] []
   | Underscore      lhs     .   pp      =   ppNestInfo ["Pattern","Underscore"] [ppShow @pos] [] []

uuagc/trunk/src-ag/DefaultRules.ag

@@ -508,12 +508,14 @@ addAugments (syn, exprs) rules
     modify r = r
 
     containsSyn (Constr _ pats)   = any containsSyn pats
+    containsSyn (InfixConstr _ patl patr) = containsSyn patl || containsSyn patr
     containsSyn (Product _ pats)  = any containsSyn pats
     containsSyn (Irrefutable pat) = containsSyn pat
     containsSyn (Alias field attr pat) = (field == _LHS && attr == syn) || containsSyn pat
     containsSyn _ = False
 
     modifyPat (Constr name pats) = Constr name (map modifyPat pats)
+    modifyPat (InfixConstr name patl patr) = InfixConstr name (modifyPat patl) (modifyPat patr)
     modifyPat (Product pos pats) = Product pos (map modifyPat pats)
     modifyPat (Irrefutable pat)  = Irrefutable (modifyPat pat)
     modifyPat (Alias field attr pat)

uuagc/trunk/src-ag/ExecutionPlan2Hs.ag

@@ -1137,13 +1137,15 @@ SEM Pattern
                 lhs.sem_lhs   = @loc.addbang1 @loc.patExpr
   | Product     lhs.sem_lhs   = @loc.addbang1 $ pp_block "(" ")" "," @pats.sem_lhs
   | Constr      lhs.sem_lhs   = @loc.addbang1 $ pp_parens $ @name >#< hv_sp @pats.sem_lhs
+  | InfixConstr lhs.sem_lhs   = @loc.addbang1 $ pp_parens $ @patl.sem_lhs >#< @name >#< @patr.sem_lhs
   | Underscore  lhs.sem_lhs   = text "_"
   | Irrefutable lhs.sem_lhs   = text "~" >|< pp_parens @pat.sem_lhs
 
 -- Check if a pattern is just an underscore
 ATTR Pattern [ | | isUnderscore:{Bool}]
 SEM Pattern
  | Constr      lhs.isUnderscore = False
+ | InfixConstr lhs.isUnderscore = False
  | Product     lhs.isUnderscore = False
  | Alias       lhs.isUnderscore = False
  | Underscore  lhs.isUnderscore = True
@@ -1553,12 +1555,12 @@ SEM EProduction | EProduction       loc.addbang = \x -> if bangpats @lhs.options
 SEM EChild | EChild                 loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x
 SEM EChild | ETerm                  loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x
 SEM VisitStep | ChildVisit          loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x
-SEM Pattern | Alias Constr Product  loc.addbang  = \x -> if bangpats @lhs.options then "!" >|< x else x
+SEM Pattern | Alias Constr InfixConstr Product  loc.addbang  = \x -> if bangpats @lhs.options then "!" >|< x else x
 
 SEM Visit | Visit                   loc.addbang1 = if isLazyKind @kind then id else @loc.addbang
 SEM ENonterminal | ENonterminal     loc.addbangWrap = id --if strictWrap @lhs.options then @loc.addbang else id
 SEM ERule | ERule                   loc.addbang1 = if @loc.anyLazyKind then id else @loc.addbang
-SEM Pattern | Alias Constr Product  loc.addbang1 = if @lhs.anyLazyKind then id else @loc.addbang
+SEM Pattern | Alias Constr InfixConstr Product  loc.addbang1 = if @lhs.anyLazyKind then id else @loc.addbang
 
 --
 -- Distribute single-visit-next map downward

uuagc/trunk/src-ag/Patterns.ag

@@ -9,6 +9,9 @@ TYPE Patterns   = [Pattern]
 
 DATA Pattern    | Constr      name  : {ConstructorIdent}
                               pats  : Patterns
+                | InfixConstr name  : {ConstructorIdent}
+                              patl  : Pattern
+                              patr  : Pattern
                 | Product     pos   : {Pos}
                               pats  : Patterns
                 | Alias       field : {Identifier}

uuagc/trunk/src-ag/PrintCode.ag

@@ -353,13 +353,14 @@ SEM Patterns [ | | pps : {[PP_Doc]} ]
   | Nil  lhs.pps = []
 
 SEM Pattern
-  | Constr Product Alias
+  | Constr InfixConstr Product Alias
       loc.addBang = if bangpats @lhs.options && not @lhs.isDeclOfLet && not @lhs.belowIrrefutable
                     then \p -> "!" >|< p
                     else id
 
 SEM Pattern [ | | pp:PP_Doc ]
-  | Constr  lhs.pp     = @loc.addBang $ pp_parens $ @name >#< hv_sp @pats.pps
+  | Constr  lhs.pp     = @loc.addBang $ pp_parens $ @pats.pps >#< @name >#< @pats.pps
+  | InfixConstr lhs.pp = @loc.addBang $ pp_parens $ @patl.pp >#< @name >#< @patr.pp
   | Product lhs.pp     = @loc.addBang $ pp_block "(" ")" "," @pats.pps
   | Alias   loc.ppVar  = pp (attrname @lhs.options False @field @attr)
             loc.ppVarBang = @loc.addBang $ @loc.ppVar
@@ -371,6 +372,7 @@ SEM Pattern [ | | pp:PP_Doc ]
 
 SEM Pattern [ | | isUnderscore:{Bool}]
  | Constr      lhs.isUnderscore = False
+ | InfixConstr lhs.isUnderscore = False
  | Product     lhs.isUnderscore = False
  | Alias       lhs.isUnderscore = False
  | Underscore  lhs.isUnderscore = True
@@ -394,6 +396,7 @@ SEM Patterns [ | | pps' : {[PP_Doc]} ]
 
 SEM Pattern [ | | pp':PP_Doc ]
   | Constr  lhs.pp'     = pp_parens $ @name >#< hv_sp (map pp_parens @pats.pps')
+  | InfixConstr lhs.pp' = pp_parens $ pp_parens @patl.pp' >#< @name >#< pp_parens @patr.pp'
   | Product lhs.pp'     = pp_block "(" ")" "," @pats.pps'
   | Alias   lhs.pp'     = let attribute | @field == _LOC || @field == nullIdent = locname' @attr
                                         | otherwise                             = attrname @lhs.options False @field @attr

uuagc/trunk/src-ag/Transform.ag

@@ -1188,6 +1188,7 @@ SEM Pattern
           lhs.definedInsts = (if @field == _INST then [@attr] else []) ++ @pat.definedInsts
   | Underscore lhs.patunder = \_ -> @copy
   | Constr lhs.patunder    = \us -> Constr @name (@pats.patunder us)
+  | InfixConstr lhs.patunder = \us -> InfixConstr @name (@patl.patunder us) (@patr.patunder us)
   | Product lhs.patunder    = \us -> Product @pos (@pats.patunder us)
   | Irrefutable lhs.patunder = \us -> Irrefutable (@pat.patunder us)
 
@@ -1199,6 +1200,7 @@ ATTR Pattern [ | | stpos : Pos ]
 
 SEM Pattern
   | Constr     lhs.stpos = getPos @name
+  | InfixConstr lhs.stpos = @patl.stpos
   | Product    lhs.stpos = @pos
   | Alias      lhs.stpos = getPos @field
   | Underscore lhs.stpos = @pos

uuagc/trunk/src/PPUtil.hs

@@ -43,6 +43,9 @@ ppNestInfo {- opts -} nms attrs ps infos
         )
     >-< indent 2 (vlist ps)
 
+-- >>> ppNestInfo ["foo"] [text "bar"] [] []
+-- Data constructor not in scope: Str :: String -> PP_Doc
+
 ppNm :: String -> PP_Doc
 ppNm = text . show
 

uuagc/trunk/src/Parser.hs

@@ -530,7 +530,8 @@ pPattern :: AGParser (a -> (Identifier,Identifier)) -> AGParser (a -> Pattern)
 pPattern pvar = pPattern2 where
   pPattern0 =  (\i pats a -> Constr i (map ($ a) pats))
                <$> pIdentifierU <*> pList  pPattern1
-               <|> pPattern1 <?> "a pattern"
+           <|> (pPattern1 <?> "a pattern")
+           <|> pChainr ((\(x,p) l r a -> InfixConstr (Ident x p) (l a) (r a)) <$> (pConsymPos <|> ((\x -> (":",x)) <$> pReserved ":"))) pPattern1
   pPattern1 =  pvariable
            <|> pPattern2
   pvariable = (\ir var pat a -> case var a of (fld,att) -> ir $ Alias fld att (pat a))

uuagc/trunk/src/Scanner.hs

@@ -118,6 +118,9 @@ scan opts p0
                                            tok | str `elem` keywords' = reserved (mkKeyword str)
                                                | otherwise            = valueToken TkConid str
                                        in (tok p, advc (length var+1) p,rest)
+                         -- FIXME: this does not work because : is reserved...
+                         | x == ':' = let (var,rest) = span (`elem` "!#$%&⋆+./<=>?@\\^|-~:") rs
+                                       in (valueToken TkConOp (':' : var) p, advc (length var+1) p,rest)
                          | otherwise = (errToken ("unexpected character " ++ show x) p, advc 1 p, rs)
 
     scanBeginOfLine :: Lexer Token