Skip to content

Commit 28e53d1

Browse files
OctachronOctachron
committed
Add support for qualified indexing operators
aka `x.Module.Path.!(y)` and friends
1 parent 6a85360 commit 28e53d1

File tree

4 files changed

+96
-66
lines changed

4 files changed

+96
-66
lines changed

‎manual/manual/refman/exten.etex

+12-13
Original file line numberDiff line numberDiff line change
@@ -2352,7 +2352,7 @@ type t = T of string
23522352
[@@ocaml.doc " Attaches to t "]
23532353
\end{verbatim}
23542354

2355-
\section{Extendend indexing operators \label{s:index-operators} }
2355+
\section{Extended indexing operators \label{s:index-operators} }
23562356
(Introduced in 4.06)
23572357

23582358
\begin{syntax}
@@ -2362,7 +2362,7 @@ dot-ext:
23622362
;
23632363
expr:
23642364
...
2365-
| expr '.' dot-ext ( '(' expr ')' || '[' expr ']' || '{' expr '}' ) [ '<-' expr ]
2365+
| expr '.' [module-path '.'] dot-ext ( '(' expr ')' || '[' expr ']' || '{' expr '}' ) [ '<-' expr ]
23662366
;
23672367
operator-name:
23682368
...
@@ -2374,22 +2374,21 @@ operator-name:
23742374
This extension provides syntactic sugar for getting and setting elements
23752375
for user-defined indexed types. For instance, we can define python-like
23762376
dictionaries with
2377-
\begin{caml-example}
2377+
\begin{caml_example*}{verbatim}
23782378
module Dict = struct
2379-
23802379
include Hashtbl
23812380
let ( .%{} ) tabl index = find tabl index
23822381
let ( .%{}<- ) tabl index value = add tabl index value
2383-
end;;
2382+
end
23842383
let dict =
2385-
let open Dict in
2386-
let dict = create 10 in
2384+
let dict = Dict.create 10 in
23872385
let () =
2388-
dict.%{"one"} <- 1;
2386+
dict.Dict.%{"one"} <- 1;
2387+
let open Dict in
23892388
dict.%{"two"} <- 2 in
23902389
dict
2391-
;;
2392-
let () =
2393-
let open Dict in
2394-
assert( dict.%{"one"} = 1 );;
2395-
\end{caml-example}
2390+
\end{caml_example*}
2391+
\begin{caml_example}{toplevel}
2392+
dict.Dict.%{"one"};;
2393+
let open Dict in dict.%{"two"};;
2394+
\end{caml_example}

‎parsing/parser.mly

+24
Original file line numberDiff line numberDiff line change
@@ -1436,6 +1436,30 @@ expr:
14361436
mkexp @@ Pexp_apply(id, [Nolabel, $1; Nolabel, $4]) }
14371437
| simple_expr DOTOP LBRACE expr error
14381438
{ unclosed "{" 3 "}" 5 }
1439+
| simple_expr DOT mod_longident DOTOP LBRACKET expr RBRACKET LESSMINUS expr
1440+
{ let id = mkexp @@ Pexp_ident( ghloc @@ Ldot($3,"." ^ $4 ^ "[]<-")) in
1441+
mkexp @@ Pexp_apply(id , [Nolabel, $1; Nolabel, $6; Nolabel, $9]) }
1442+
| simple_expr DOT mod_longident DOTOP LBRACKET expr RBRACKET
1443+
{ let id = mkexp @@ Pexp_ident( ghloc @@ Ldot($3, "." ^ $4 ^ "[]")) in
1444+
mkexp @@ Pexp_apply(id, [Nolabel, $1; Nolabel, $6]) }
1445+
| simple_expr DOT mod_longident DOTOP LBRACKET expr error
1446+
{ unclosed "[" 5 "]" 7 }
1447+
| simple_expr DOT mod_longident DOTOP LPAREN expr RPAREN LESSMINUS expr
1448+
{ let id = mkexp @@ Pexp_ident( ghloc @@ Ldot($3, "." ^ $4 ^ "()<-")) in
1449+
mkexp @@ Pexp_apply(id , [Nolabel, $1; Nolabel, $6; Nolabel, $9]) }
1450+
| simple_expr DOT mod_longident DOTOP LPAREN expr RPAREN
1451+
{ let id = mkexp @@ Pexp_ident( ghloc @@ Ldot($3, "." ^ $4 ^ "()")) in
1452+
mkexp @@ Pexp_apply(id, [Nolabel, $1; Nolabel, $6]) }
1453+
| simple_expr DOT mod_longident DOTOP LPAREN expr error
1454+
{ unclosed "(" 5 ")" 7 }
1455+
| simple_expr DOT mod_longident DOTOP LBRACE expr RBRACE LESSMINUS expr
1456+
{ let id = mkexp @@ Pexp_ident( ghloc @@ Ldot($3, "." ^ $4 ^ "{}<-")) in
1457+
mkexp @@ Pexp_apply(id , [Nolabel, $1; Nolabel, $6; Nolabel, $9]) }
1458+
| simple_expr DOT mod_longident DOTOP LBRACE expr RBRACE
1459+
{ let id = mkexp @@ Pexp_ident( ghloc @@ Ldot($3, "." ^ $4 ^ "{}")) in
1460+
mkexp @@ Pexp_apply(id, [Nolabel, $1; Nolabel, $6]) }
1461+
| simple_expr DOT mod_longident DOTOP LBRACE expr error
1462+
{ unclosed "{" 5 "}" 7 }
14391463
| label LESSMINUS expr
14401464
{ mkexp(Pexp_setinstvar(mkrhs $1 1, $3)) }
14411465
| ASSERT ext_attributes simple_expr %prec below_HASH

‎parsing/pprintast.ml

+44-41
Original file line numberDiff line numberDiff line change
@@ -472,63 +472,66 @@ and sugar_expr ctxt f e =
472472
| Pexp_apply ({ pexp_desc = Pexp_ident {txt = id; _};
473473
pexp_attributes=[]; _}, args)
474474
when List.for_all (fun (lab, _) -> lab = Nolabel) args -> begin
475-
let print a assign left right print_index indexes rem_args =
476-
match assign, rem_args with
477-
| true, [] ->
478-
pp f "@[%a.%s%a%s@]"
479-
(simple_expr ctxt) a
480-
left (list ~sep:"," print_index) indexes right; true
481-
| false, [v] ->
482-
pp f "@[%a.%s%a%s@ <-@;<1 2>%a@]"
483-
(simple_expr ctxt) a
484-
left (list ~sep:"," print_index) indexes right
475+
let print_indexop a path_prefix assign left right print_index indices
476+
rem_args =
477+
let print_path ppf = function
478+
| None -> ()
479+
| Some m -> pp ppf ".%a" longident m in
480+
match assign, rem_args with
481+
| false, [] ->
482+
pp f "@[%a%a%s%a%s@]"
483+
(simple_expr ctxt) a print_path path_prefix
484+
left (list ~sep:"," print_index) indices right; true
485+
| true, [v] ->
486+
pp f "@[%a%a%s%a%s@ <-@;<1 2>%a@]"
487+
(simple_expr ctxt) a print_path path_prefix
488+
left (list ~sep:"," print_index) indices right
485489
(simple_expr ctxt) v; true
486490
| _ -> false in
487491
match id, List.map snd args with
488492
| Lident "!", [e] ->
489493
pp f "@[<hov>!%a@]" (simple_expr ctxt) e; true
490494
| Ldot (path, ("get"|"set" as func)), a :: other_args -> begin
491-
let assign = func = "get" in
492-
let print = print a assign in
495+
let assign = func = "set" in
496+
let print = print_indexop a None assign in
493497
match path, other_args with
494498
| Lident "Array", i :: rest ->
495-
print "(" ")" (expression ctxt) [i] rest
499+
print ".(" ")" (expression ctxt) [i] rest
496500
| Lident "String", i :: rest ->
497-
print "[" "]" (expression ctxt) [i] rest
501+
print ".[" "]" (expression ctxt) [i] rest
498502
| Ldot (Lident "Bigarray", "Array1"), i1 :: rest ->
499-
print "{" "}" (simple_expr ctxt) [i1] rest
503+
print ".{" "}" (simple_expr ctxt) [i1] rest
500504
| Ldot (Lident "Bigarray", "Array2"), i1 :: i2 :: rest ->
501-
print "{" "}" (simple_expr ctxt) [i1; i2] rest
505+
print ".{" "}" (simple_expr ctxt) [i1; i2] rest
502506
| Ldot (Lident "Bigarray", "Array3"), i1 :: i2 :: i3 :: rest ->
503-
print "{" "}" (simple_expr ctxt) [i1; i2; i3] rest
507+
print ".{" "}" (simple_expr ctxt) [i1; i2; i3] rest
504508
| Ldot (Lident "Bigarray", "Genarray"),
505509
{pexp_desc = Pexp_array indexes; pexp_attributes = []} :: rest ->
506-
print "{" "}" (simple_expr ctxt) indexes rest
510+
print ".{" "}" (simple_expr ctxt) indexes rest
507511
| _ -> false
508512
end
509-
| Lident s, a :: other_args when s.[0] = '.' ->
510-
begin match other_args with
511-
| i :: rest ->
512-
let n = String.length s in
513-
(* extract operator:
514-
assignment operators end with [right_bracket ^ "<-"],
515-
access operators end with [right_bracket] directly
516-
*)
517-
let assign =
518-
s.[n - 1] = '-' in
519-
let kind =
520-
(* extract the right end bracket *)
521-
if assign then s.[n - 3] else s.[n - 1] in
522-
let left, right = match kind with
523-
| ')' -> '(', ")"
524-
| ']' -> '[', "]"
525-
| '}' -> '{', "}"
526-
| _ -> assert false in
527-
let prefix = String.sub s 0 (1+String.index s left) in
528-
print a assign prefix right
529-
(simple_expr ctxt) [i] rest
530-
| _ -> false
531-
end
513+
| (Lident s | Ldot(_,s)) , a :: i :: rest
514+
when s.[0] = '.' ->
515+
let n = String.length s in
516+
(* extract operator:
517+
assignment operators end with [right_bracket ^ "<-"],
518+
access operators end with [right_bracket] directly
519+
*)
520+
let assign = s.[n - 1] = '-' in
521+
let kind =
522+
(* extract the right end bracket *)
523+
if assign then s.[n - 3] else s.[n - 1] in
524+
let left, right = match kind with
525+
| ')' -> '(', ")"
526+
| ']' -> '[', "]"
527+
| '}' -> '{', "}"
528+
| _ -> assert false in
529+
let path_prefix = match id with
530+
| Ldot(m,_) -> Some m
531+
| _ -> None in
532+
let left = String.sub s 0 (1+String.index s left) in
533+
print_indexop a path_prefix assign left right
534+
(expression ctxt) [i] rest
532535
| _ -> false
533536
end
534537
| _ -> false

‎testsuite/tests/parsetree/source.ml

+16-12
Original file line numberDiff line numberDiff line change
@@ -7324,15 +7324,19 @@ module Exotic_list = struct
73247324
end
73257325

73267326
(** Extended index operators *)
7327-
let ( .%[] ) = Hashtbl.find
7328-
let ( .%[] <- ) = Hashtbl.add
7329-
let ( .%() ) = Hashtbl.find
7330-
let ( .%() <- ) = Hashtbl.add
7331-
let ( .%{} ) = Hashtbl.find
7332-
let ( .%{} <- ) = Hashtbl.add
7333-
7334-
;;
7335-
let h = Hashtbl.create 17 in
7336-
h.%["one"] <- 1;
7337-
h.%("two") <- 2;
7338-
h.%{"three"} <- 3;
7327+
module Indexop = struct
7328+
module Def = struct
7329+
let ( .%[] ) = Hashtbl.find
7330+
let ( .%[] <- ) = Hashtbl.add
7331+
let ( .%() ) = Hashtbl.find
7332+
let ( .%() <- ) = Hashtbl.add
7333+
let ( .%{} ) = Hashtbl.find
7334+
let ( .%{} <- ) = Hashtbl.add
7335+
end
7336+
;;
7337+
let h = Hashtbl.create 17 in
7338+
h.Def.%["one"] <- 1;
7339+
h.Def.%("two") <- 2;
7340+
h.Def.%{"three"} <- 3
7341+
let x,y,z = Def.(h.%["one"], h.%("two"), h.%{"three"})
7342+
end

0 commit comments

Comments
 (0)