[feature] xml_parser: added case default

compiler/opalang/classic_syntax/xml_parser.trx

@@ -36,7 +36,8 @@ xml_parser <- (=Opa_lexer.exact_ident("xml_parser")) spacing xml_parser_no_keywo
 ;deco_xml_parser_no_keyword = deco xml_parser_no_keyword;
 xml_parser_no_keyword <-
                 Opa_lexer.BAR? xml_rule:v (Opa_lexer.BAR xml_rule:v {{v}})*:l
-                Opa_parser.match_end {{ (xml_parser (v::l : _ xml_parser) : (_,_) expr_node) }}
+                (Opa_lexer.BAR? Opa_parser.match_code_arrow:h Opa_parser.expr:e {{ clear_1hint h; e }})?:d
+                Opa_parser.match_end {{ (xml_parser ((v::l, d) : _ xml_parser) : (_,_) expr_node) }}
 
 trx_parser <- Opa_lexer.PARSER? Trx.Item+:l (*Trx.ParserSeq:e*) {{ l }}
 

compiler/opalang/js_syntax/xml_parser.trx

@@ -40,7 +40,8 @@ xml_parser <-
 ;deco_xml_parser_no_keyword = deco xml_parser_no_keyword;
 xml_parser_no_keyword <-
   / (Opa_parser.match_case xml_rule:v {{v}})+:l
-    {{ (xml_parser (l : _ xml_parser) : (_,_) expr_node) }}
+    (Opa_parser.match_default_case Opa_parser.match_prod:e {{e}})?:d
+    {{ (xml_parser ((l, d) : _ xml_parser) : (_,_) expr_node) }}
 
 trx_parser <- Opa_lexer.PARSER? Trx.Item+:l (*Trx.ParserSeq:e*) {{ l }}
 

compiler/opalang/opaPrint.ml

@@ -1782,8 +1782,10 @@ let makeFamilly syntax =
             pp f "@[<h>%a@]" self#under_colon#expr e
         | d -> super#directive f d
 
-      method xml_parser f l =
-        pp f "@[<v>xml_parser{@ | %a@ end@]" (list "@ | " self#xml_rule) l
+      method xml_parser f (l, d) =
+        match d with
+        | None -> pp f "@[<v>xml_parser{@ | %a@ end@]" (list "@ | " self#xml_rule) l
+        | Some def -> pp f "@[<v>xml_parser{@ | %a@ | -> %a@ end@]" (list "@ | " self#xml_rule) l self#expr def
       method xml_rule f (pl,e) =
         pp f "@[<2>%a -> @ %a@]" (list "@ " self#xml_named_pattern) pl self#expr e
       method xml_named_pattern f (nameo,p,s) =

compiler/opalang/surfaceAst.ml

@@ -278,7 +278,7 @@ type 'expr xml_pattern =
 and 'expr xml_named_pattern = string option * 'expr xml_pattern * 'expr xml_suffix label option
 and 'expr xml_rule = 'expr xml_named_pattern list * 'expr (* one line of parser *)
 type 'expr xml_parser =
-  'expr xml_rule list (* the alternatives *)
+  'expr xml_rule list * 'expr option (* the alternatives *)
 
 
 (**

compiler/passes/surfaceAstXmlPattern.ml

@@ -269,18 +269,22 @@ let process_rule xml env (patterns,e) : (_,_) expr =
   let res = C.E.some (C.E.tuple_2 e (C.E.ident last_name)) in
   process_named_patterns xml env patterns last_name res
 
-let process_rules xml env l =
+let process_rules xml env rules =
+  let l, def = rules in
   let last_none = C.E.none () in
+  let def = match def with
+  | None -> last_none
+  | Some e -> C.E.some (C.E.tuple_2 e !xml) in
   List.fold_right_i
     (fun rule_ i acc ->
-       let n = fresh_name ~name:(Printf.sprintf "case_%d" i) () in
        if acc == last_none then
          process_rule xml env rule_ (* avoid a stupid match *)
        else
-       C.E.letin n (process_rule xml env rule_)
-         (C.E.match_opt !n
-            (C.P.none (), acc)
-            (C.P.ident "res", !"res"))) l last_none
+         let n = fresh_name ~name:(Printf.sprintf "case_%d" i) () in
+         C.E.letin n (process_rule xml env rule_)
+           (C.E.match_opt !n
+              (C.P.none (), acc)
+              (C.P.ident "res", !"res"))) l def
 
 let process_parser _e rules =
   #<If:SA_XML_PATTERN>