M.(::) syntax and printing exotic lists in the toplevel. (#1247)

7 files changed, 52 insertions, 10 deletions

diff --git a/Changes b/Changes
index fc61b9226e..e6f45ab4b5 100644
--- a/Changes
+++ b/Changes
@@ -22,6 +22,10 @@ Working version
   (Daniel Bünzli, review by Damien Doligez, Alain Frisch, Xavier
   Leroy and Leo White)
 
+- GPR#1247: M.(::) construction for expressions
+  and patterns (plus fix printing of (::) in the toplevel)
+  (Florian Angeletti, review by Alain Frisch, Gabriel Scherer)
+
 ### Code generation and optimizations:
 
 - MPR#5324, GPR#375: An alternative Linear Scan register allocator for
diff --git a/parsing/parser.mly b/parsing/parser.mly
index aef35c3de8..2758eec662 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -1357,8 +1357,6 @@ expr:
       { mkexp_attrs(Pexp_for($3, $5, $7, $6, $9)) $2 }
   | expr COLONCOLON expr
       { mkexp_cons (rhs_loc 2) (ghexp(Pexp_tuple[$1;$3])) (symbol_rloc()) }
-  | LPAREN COLONCOLON RPAREN LPAREN expr COMMA expr RPAREN
-      { mkexp_cons (rhs_loc 2) (ghexp(Pexp_tuple[$5;$7])) (symbol_rloc()) }
   | expr INFIXOP0 expr
       { mkinfix $1 $2 $3 }
   | expr INFIXOP1 expr
@@ -1749,10 +1747,6 @@ pattern_gen:
       { mkpat(Ppat_construct(mkrhs $1 1, Some $2)) }
   | name_tag pattern %prec prec_constr_appl
       { mkpat(Ppat_variant($1, Some $2)) }
-  | LPAREN COLONCOLON RPAREN LPAREN pattern COMMA pattern RPAREN
-      { mkpat_cons (rhs_loc 2) (ghpat(Ppat_tuple[$5;$7])) (symbol_rloc()) }
-  | LPAREN COLONCOLON RPAREN LPAREN pattern COMMA pattern error
-      { unclosed "(" 4 ")" 8 }
   | LAZY ext_attributes simple_pattern
       { mkpat_attrs (Ppat_lazy $3) $2}
 ;
@@ -2389,7 +2383,6 @@ constr_ident:
     UIDENT                                      { $1 }
   | LBRACKET RBRACKET                           { "[]" }
   | LPAREN RPAREN                               { "()" }
-  /* | COLONCOLON                               { "::" } */
   | LPAREN COLONCOLON RPAREN                    { "::" }
   | FALSE                                       { "false" }
   | TRUE                                        { "true" }
@@ -2401,8 +2394,10 @@ val_longident:
 ;
 constr_longident:
     mod_longident       %prec below_DOT         { $1 }
+  | mod_longident DOT LPAREN COLONCOLON RPAREN  { Ldot($1,"::") }
   | LBRACKET RBRACKET                           { Lident "[]" }
   | LPAREN RPAREN                               { Lident "()" }
+  | LPAREN COLONCOLON RPAREN                    { Lident "::" }
   | FALSE                                       { Lident "false" }
   | TRUE                                        { Lident "true" }
 ;
diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml
index 4b35d89888..e60f9c5791 100644
--- a/parsing/pprintast.ml
+++ b/parsing/pprintast.ml
@@ -33,7 +33,7 @@ let infix_symbols = [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/';
                       '$'; '%'; '#' ]
 (* type fixity = Infix| Prefix  *)
 let special_infix_strings =
-  ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!=" ]
+  ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!="; "::" ]
 
 (* determines if the string is an infix string.
    checks backwards, first allowing a renaming postfix ("_102") which
diff --git a/testsuite/tests/parsetree/source.ml b/testsuite/tests/parsetree/source.ml
index ef67a9746a..31a4e8cef4 100644
--- a/testsuite/tests/parsetree/source.ml
+++ b/testsuite/tests/parsetree/source.ml
@@ -7313,3 +7313,12 @@ class type ct =
     method f : t
   end
 ;;
+
+(* M.(::) notation *)
+module Exotic_list = struct
+  module Inner = struct
+    type ('a,'b) t = [] | (::) of 'a * 'b *  ('a,'b) t
+  end
+
+  let Inner.(::)(x,y, Inner.[]) = Inner.(::)(1,"one",Inner.[])
+end
diff --git a/testsuite/tests/tool-toplevel/exotic_lists.ml b/testsuite/tests/tool-toplevel/exotic_lists.ml
new file mode 100644
index 0000000000..ae42ec8f19
--- /dev/null
+++ b/testsuite/tests/tool-toplevel/exotic_lists.ml
@@ -0,0 +1,15 @@
+module L = struct
+        type ('a,'b) t = [] | (::) of 'a * ('b,'a) t
+end;;
+L.[([1;2]:int list);"2";[3;4];"4";[5]];;
+open L;;
+[1;"2";3;"4";5];;
+
+module L = struct
+        type 'a t = 'a list = [] | (::) of 'a * 'a t
+end;;
+L.[[1];[2];[3];[4];[5]];;
+open L;;
+[1;2;3;4;5];;
+
+
diff --git a/testsuite/tests/tool-toplevel/exotic_lists.ml.reference b/testsuite/tests/tool-toplevel/exotic_lists.ml.reference
new file mode 100644
index 0000000000..e064340d76
--- /dev/null
+++ b/testsuite/tests/tool-toplevel/exotic_lists.ml.reference
@@ -0,0 +1,15 @@
+
+#     module L : sig type ('a, 'b) t = [] | (::) of 'a * ('b, 'a) t end
+# - : (int list, string) L.t =
+L.(::) ([1; 2],
+ L.(::) ("2", L.(::) ([3; 4], L.(::) ("4", L.(::) ([5], L.[])))))
+# # - : (int, string) L.t =
+(::) (1, (::) ("2", (::) (3, (::) ("4", (::) (5, [])))))
+#       module L : sig type 'a t = 'a list = [] | (::) of 'a * 'a t end
+# - : int L.t L.t =
+L.(::) (L.(::) (1, L.[]),
+ L.(::) (L.(::) (2, L.[]),
+  L.(::) (L.(::) (3, L.[]),
+   L.(::) (L.(::) (4, L.[]), L.(::) (L.(::) (5, L.[]), L.[])))))
+# # - : int L.t = (::) (1, (::) (2, (::) (3, (::) (4, (::) (5, [])))))
+#     
diff --git a/typing/oprint.ml b/typing/oprint.ml
index 7135fe26a1..e4230603c0 100644
--- a/typing/oprint.ml
+++ b/typing/oprint.ml
@@ -22,11 +22,15 @@ let cautious f ppf arg =
   try f ppf arg with
     Ellipsis -> fprintf ppf "..."
 
+let print_lident ppf = function
+  | "::" -> pp_print_string ppf "(::)"
+  | s -> pp_print_string ppf s
+
 let rec print_ident ppf =
   function
-    Oide_ident s -> pp_print_string ppf s
+    Oide_ident s -> print_lident ppf s
   | Oide_dot (id, s) ->
-      print_ident ppf id; pp_print_char ppf '.'; pp_print_string ppf s
+      print_ident ppf id; pp_print_char ppf '.'; print_lident ppf s
   | Oide_apply (id1, id2) ->
       fprintf ppf "%a(%a)" print_ident id1 print_ident id2