Extended indexing operators (ocaml#1064)

* Extended indexing operators

This commit adds extended indexing operators to the parser.
For instance,

```
let (.%()) p (x,y) = p.( x ).( y )
;; p.%(0,0)

```
Extended indexing operators name starts with a leading
dot "." followed by an operator symbol, except "." or "<"
and a sequence of any operators and must be closes with a
couple of enclosing parentheses ( i.e. "()", "[]", "{}" )
and then an optional assignment operator "<-":

  * '.' dotsymbolchar symbolchar* '(' ')' ['<-']
  * '.' dotsymbolchar symbolchar* '[' ']' ['<-']
  * '.' dotsymbolchar symbolchar* '{' '}' ['<-']

Similarly, expressions of the form

* expr_1 '.' dotsymbolchar symbolchar* '(' expr_2 ')'
* expr_1 '.' dotsymbolchar symbolchar* '[' expr_2 ']'
* expr_1 '.' dotsymbolchar symbolchar* '{' expr_2 '}'

and

* expr_1 '.' dotsymbolchar symbolchar* '(' expr_2 ')' '<-' expr_3
* expr_1 '.' dotsymbolchar symbolchar* '[' expr_2 ']' '<-' expr_3
* expr_1 '.' dotsymbolchar symbolchar* '{' expr_2 '}' '<-' expr_3

are desugared to

* ('.' dotsymbolchar symbolchar* '(' ')' ) expr_1 expr_2
* ('.' dotsymbolchar symbolchar* '[' ']' ) expr_1 expr_2
* ('.' dotsymbolchar symbolchar* '{' '}' ) expr_1 expr_2

and

* ('.' dotsymbolchar symbolchar* '(' ')' '<-' ) expr_1 expr_2 expr_3
* ('.' dotsymbolchar symbolchar* '[' ']' ) expr_1 expr_2 expr_3
* ('.' dotsymbolchar symbolchar* '{' '}' '<-' ) expr_1 expr_2 expr_3

Author: Octachron

Changes

@@ -4,6 +4,12 @@ Working version
 (Changes that can break existing programs are marked with a "*")
 
 ### Language features:
+
+- GPR#792: fix limitations of destructive substitutions, by
+  allowing "S with type t := type-expr",
+  "S with type M.t := type-expr", "S with module M.N := path"
+  (Valentin Gatien-Baron, review by Jacques Garrigue and Leo White)
+
 - GPR#1118: Support inherited field in object type expression
   (Runhang Li, reivew by Jeremy Yallop, Leo White, Jacques Garrigue,
    and Florian Angeletti)
@@ -12,10 +18,11 @@ Working version
   in class expressions and class type expressions.
   (Alain Frisch, reviews by Thomas Refis and Jacques Garrigue)
 
-- GPR#792: fix limitations of destructive substitutions, by
-  allowing "S with type t := type-expr",
-  "S with type M.t := type-expr", "S with module M.N := path"
-  (Valentin Gatien-Baron, review by Jacques Garrigue and Leo White)
+- GPR#1064: extended indexing operators, add a new class of
+  user-defined indexing operators, obtained by adding at least
+  one operator character after the dot symbol to the standard indexing
+  operators: e,g ".%()", ".?[]", ".@{}<-"
+  (Florian Angeletti, review by Damien Doligez and Gabriel Radanne)
 
 - GPR#1142: Mark assertions nonexpansive, so that 'assert false'
   can be used as a placeholder for a polymorphic function.

manual/manual/refman/expr.etex

@@ -118,8 +118,9 @@ See also the following language extensions:
 \hyperref[s:explicit-overriding-open]{overriding in open statements},
 \hyperref[s:bigarray-access]{syntax for Bigarray access},
 \hyperref[s:attributes]{attributes},
-\hyperref[s:extension-nodes]{extension nodes} and
-\hyperref[s:local-exceptions]{local exceptions}.
+\hyperref[s:extension-nodes]{extension nodes},
+\hyperref[s:local-exceptions]{local exceptions}
+\hyperref[s:index-operators]{extended indexing operators}.
 
 The table below shows the relative precedences and associativity of
 operators and non-closed constructions. The constructions with higher

manual/manual/refman/exten.etex

@@ -2351,3 +2351,45 @@ will be converted directly to
 type t =  T of string
 [@@ocaml.doc " Attaches to t "]
 \end{verbatim}
+
+\section{Extendend indexing operators \label{s:index-operators} }
+(Introduced in 4.06)
+
+\begin{syntax}
+
+dot-ext:
+   | ('!'||'$'||'%'||'&'||'*'||'+'||'-'||'/'||':'||'='||'>'||'?'||'@'||'^'||'|'||'~') { operator-char }
+;
+expr:
+          ...
+        | expr '.' dot-ext ( '(' expr ')' || '[' expr ']' || '{' expr '}' ) [ '<-' expr ]
+;
+operator-name:
+          ...
+        | '.' dot-ext ('()' || '[]' || '{}') ['<-']
+;
+\end{syntax}
+
+
+This extension provides syntactic sugar for getting and setting elements
+for user-defined indexed types. For instance, we can define python-like
+dictionaries with
+\begin{caml-example}
+module Dict = struct
+
+include Hashtbl
+let ( .%{} ) tabl index = find tabl index
+let ( .%{}<- ) tabl index value = add tabl index value
+end;;
+let dict =
+  let open Dict in
+  let dict = create 10 in
+  let () =
+    dict.%{"one"} <- 1;
+    dict.%{"two"} <- 2 in
+  dict
+;;
+let () =
+  let open Dict in
+  assert( dict.%{"one"} = 1 );;
+\end{caml-example}

manual/manual/refman/lex.etex

@@ -218,8 +218,9 @@ operator-char:
         '/' || ':' || '<' || '=' || '>' || '?' || '@' ||
         '^' || '|' || '~'
 \end{syntax}
-See also the following language extension:
-\hyperref[s:ext-ops]{extension operators}.
+See also the following language extensions:
+\hyperref[s:ext-ops]{extension operators} and
+\hyperref[s:index-operators]{extended indexing operators}.
 
 Sequences of ``operator characters'', such as "<=>" or "!!",
 are read as a single token from the @infix-symbol@ or @prefix-symbol@

manual/manual/refman/names.etex

@@ -73,6 +73,9 @@ inst-var-name:
 method-name:
     lowercase-ident
 \end{syntax}
+See also the following language extension:
+\hyperref[s:index-operators]{extended indexing operators}.
+
 As shown above, prefix and infix symbols as well as some keywords can
 be used as value names, provided they are written between parentheses.
 The capitalization rules  are summarized in the table below.

parsing/lexer.mll

@@ -292,6 +292,8 @@ let identchar_latin1 =
   ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9']
 let symbolchar =
   ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~']
+let dotsymbolchar =
+  ['!' '$' '%' '&' '*' '+' '-' '/' ':' '=' '>' '?' '@' '^' '|' '~']
 let decimal_literal =
   ['0'-'9'] ['0'-'9' '_']*
 let hex_digit =
@@ -467,6 +469,7 @@ rule token = parse
   | "->" { MINUSGREATER }
   | "."  { DOT }
   | ".." { DOTDOT }
+  | "." (dotsymbolchar symbolchar* as s) { DOTOP s }
   | ":"  { COLON }
   | "::" { COLONCOLON }
   | ":=" { COLONEQUAL }

parsing/parser.mly

@@ -465,6 +465,7 @@ let package_type_of_module_type pmty =
 %token <string> INFIXOP2
 %token <string> INFIXOP3
 %token <string> INFIXOP4
+%token <string> DOTOP
 %token INHERIT
 %token INITIALIZER
 %token <string * char option> INT
@@ -1411,6 +1412,30 @@ expr:
                          [Nolabel,$1; Nolabel,$4; Nolabel,$7])) }
   | simple_expr DOT LBRACE expr RBRACE LESSMINUS expr
       { bigarray_set $1 $4 $7 }
+  | simple_expr DOTOP LBRACKET expr RBRACKET LESSMINUS expr
+      { let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ $2 ^ "[]<-")) in
+        mkexp @@ Pexp_apply(id , [Nolabel, $1; Nolabel, $4; Nolabel, $7]) }
+  | simple_expr DOTOP LBRACKET expr RBRACKET
+      { let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ $2 ^ "[]")) in
+        mkexp @@ Pexp_apply(id, [Nolabel, $1; Nolabel, $4]) }
+  | simple_expr DOTOP LBRACKET expr error
+      { unclosed "[" 3 "]" 5 }
+  | simple_expr DOTOP LPAREN expr RPAREN LESSMINUS expr
+      { let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ $2 ^ "()<-")) in
+        mkexp @@ Pexp_apply(id , [Nolabel, $1; Nolabel, $4; Nolabel, $7]) }
+  | simple_expr DOTOP LPAREN expr RPAREN
+      { let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ $2 ^ "()")) in
+        mkexp @@ Pexp_apply(id, [Nolabel, $1; Nolabel, $4]) }
+  | simple_expr DOTOP LPAREN expr error
+      { unclosed "(" 3 ")" 5 }
+  | simple_expr DOTOP LBRACE expr RBRACE LESSMINUS expr
+      { let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ $2 ^ "{}<-")) in
+        mkexp @@ Pexp_apply(id , [Nolabel, $1; Nolabel, $4; Nolabel, $7]) }
+  | simple_expr DOTOP LBRACE expr RBRACE
+      { let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ $2 ^ "{}")) in
+        mkexp @@ Pexp_apply(id, [Nolabel, $1; Nolabel, $4]) }
+  | simple_expr DOTOP LBRACE expr error
+      { unclosed "{" 3 "}" 5 }
   | label LESSMINUS expr
       { mkexp(Pexp_setinstvar(mkrhs $1 1, $3)) }
   | ASSERT ext_attributes simple_expr %prec below_HASH
@@ -2364,7 +2389,13 @@ operator:
   | INFIXOP2                                    { $1 }
   | INFIXOP3                                    { $1 }
   | INFIXOP4                                    { $1 }
-  | HASHOP                                     { $1 }
+  | DOTOP LPAREN RPAREN                         { "."^ $1 ^"()" }
+  | DOTOP LPAREN RPAREN LESSMINUS               { "."^ $1 ^ "()<-" }
+  | DOTOP LBRACKET RBRACKET                     { "."^ $1 ^"[]" }
+  | DOTOP LBRACKET RBRACKET LESSMINUS           { "."^ $1 ^ "[]<-" }
+  | DOTOP LBRACE RBRACE                         { "."^ $1 ^"{}" }
+  | DOTOP LBRACE RBRACE LESSMINUS               { "."^ $1 ^ "{}<-" }
+  | HASHOP                                      { $1 }
   | BANG                                        { "!" }
   | PLUS                                        { "+" }
   | PLUSDOT                                     { "+." }

parsing/pprintast.ml

@@ -31,6 +31,7 @@ open Ast_helper
 let prefix_symbols  = [ '!'; '?'; '~' ] ;;
 let infix_symbols = [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/';
                       '$'; '%'; '#' ]
+
 (* type fixity = Infix| Prefix  *)
 let special_infix_strings =
   ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!="; "::" ]
@@ -44,6 +45,7 @@ let fixity_of_string  = function
   | s when List.mem s special_infix_strings -> `Infix s
   | s when List.mem s.[0] infix_symbols -> `Infix s
   | s when List.mem s.[0] prefix_symbols -> `Prefix s
+  | s when s.[0] = '.' -> `Mixfix s
   | _ -> `Normal
 
 let view_fixity_of_exp = function
@@ -52,10 +54,13 @@ let view_fixity_of_exp = function
   | _ -> `Normal
 
 let is_infix  = function  | `Infix _ -> true | _  -> false
+let is_mixfix = function `Mixfix _ -> true | _ -> false
 
 (* which identifiers are in fact operators needing parentheses *)
 let needs_parens txt =
-  is_infix (fixity_of_string txt)
+  let fix = fixity_of_string txt in
+  is_infix fix
+  || is_mixfix fix
   || List.mem txt.[0] prefix_symbols
 
 (* some infixes need spaces around parens to avoid clashes with comment
@@ -467,23 +472,24 @@ and sugar_expr ctxt f e =
   | Pexp_apply ({ pexp_desc = Pexp_ident {txt = id; _};
                   pexp_attributes=[]; _}, args)
     when List.for_all (fun (lab, _) -> lab = Nolabel) args -> begin
-      match id, List.map snd args with
-      | Lident "!", [e] ->
-        pp f "@[<hov>!%a@]" (simple_expr ctxt) e; true
-      | Ldot (path, ("get"|"set" as func)), a :: other_args -> begin
-          let print left right print_index indexes rem_args =
-            match func, rem_args with
-            | "get", [] ->
+      let print a assign left right print_index indexes rem_args =
+            match assign, rem_args with
+            | true, [] ->
               pp f "@[%a.%s%a%s@]"
                 (simple_expr ctxt) a
                 left (list ~sep:"," print_index) indexes right; true
-            | "set", [v] ->
+            | false, [v] ->
               pp f "@[%a.%s%a%s@ <-@;<1 2>%a@]"
                 (simple_expr ctxt) a
                 left (list ~sep:"," print_index) indexes right
                 (simple_expr ctxt) v; true
-            | _ -> false
-          in
+            | _ -> false in
+      match id, List.map snd args with
+      | Lident "!", [e] ->
+        pp f "@[<hov>!%a@]" (simple_expr ctxt) e; true
+      | Ldot (path, ("get"|"set" as func)), a :: other_args -> begin
+          let assign = func = "get" in
+          let print = print a assign in
           match path, other_args with
           | Lident "Array", i :: rest ->
             print "(" ")" (expression ctxt) [i] rest
@@ -500,6 +506,29 @@ and sugar_expr ctxt f e =
             print "{" "}" (simple_expr ctxt) indexes rest
           | _ -> false
         end
+      | Lident s, a :: other_args when s.[0] = '.' ->
+          begin match other_args with
+          | i :: rest ->
+              let n = String.length s in
+              (* extract operator:
+                 assignment operators end with [right_bracket ^ "<-"],
+                 access operators end with [right_bracket] directly
+              *)
+              let assign =
+                s.[n - 1] = '-'  in
+              let kind =
+                (* extract the right end bracket *)
+                if assign then s.[n - 3] else s.[n - 1] in
+              let left, right = match kind with
+                | ')' -> '(', ")"
+                | ']' -> '[', "]"
+                | '}' -> '{', "}"
+                | _ -> assert false in
+              let prefix = String.sub s 0 (1+String.index s left) in
+              print a assign prefix right
+                (simple_expr ctxt) [i] rest
+          | _ -> false
+          end
       | _ -> false
     end
   | _ -> false

testsuite/tests/parsetree/source.ml

@@ -7322,3 +7322,17 @@ module Exotic_list = struct
 
   let Inner.(::)(x,y, Inner.[]) = Inner.(::)(1,"one",Inner.[])
 end
+
+(** Extended index operators *)
+let ( .%[] ) = Hashtbl.find
+let ( .%[] <- ) = Hashtbl.add
+let ( .%() ) = Hashtbl.find
+let ( .%() <- ) = Hashtbl.add
+let ( .%{} ) = Hashtbl.find
+let ( .%{} <- ) = Hashtbl.add
+
+;;
+let h = Hashtbl.create 17 in
+h.%["one"] <- 1;
+h.%("two") <- 2;
+h.%{"three"} <- 3;

testsuite/tests/parsing/extended_indexoperators.ml

@@ -0,0 +1,14 @@
+let (.?[]) = Hashtbl.find_opt
+let (.@[]) = Hashtbl.find
+let ( .@[]<- ) = Hashtbl.add
+let (.@{}) = Hashtbl.find
+let ( .@{}<- ) = Hashtbl.add
+let (.@()) = Hashtbl.find
+let ( .@()<- ) = Hashtbl.add
+
+let h = Hashtbl.create 17
+
+;;
+  h.@("One") <- 1
+; assert (h.@{"One"} = 1)
+; assert (h.?["Two"] = None)