Merge pull request #392 from diml/ast-invariants

Ast invariants

.depend

@@ -45,6 +45,7 @@ utils/warnings.cmo : utils/warnings.cmi
 utils/warnings.cmx : utils/warnings.cmi
 parsing/ast_helper.cmi : parsing/parsetree.cmi parsing/longident.cmi \
     parsing/location.cmi parsing/docstrings.cmi parsing/asttypes.cmi
+parsing/ast_invariants.cmi : parsing/parsetree.cmi
 parsing/ast_mapper.cmi : parsing/parsetree.cmi parsing/location.cmi
 parsing/asttypes.cmi : parsing/location.cmi
 parsing/attr_helper.cmi : parsing/parsetree.cmi parsing/location.cmi \
@@ -70,6 +71,10 @@ parsing/ast_helper.cmo : parsing/parsetree.cmi parsing/longident.cmi \
 parsing/ast_helper.cmx : parsing/parsetree.cmi parsing/longident.cmx \
     parsing/location.cmx parsing/docstrings.cmx parsing/asttypes.cmi \
     parsing/ast_helper.cmi
+parsing/ast_invariants.cmo : parsing/syntaxerr.cmi parsing/parsetree.cmi \
+    parsing/ast_mapper.cmi parsing/ast_invariants.cmi
+parsing/ast_invariants.cmx : parsing/syntaxerr.cmx parsing/parsetree.cmi \
+    parsing/ast_mapper.cmx parsing/ast_invariants.cmi
 parsing/ast_mapper.cmo : parsing/parsetree.cmi utils/misc.cmi \
     parsing/longident.cmi parsing/location.cmi utils/config.cmi \
     utils/clflags.cmi parsing/asttypes.cmi parsing/ast_helper.cmi \
@@ -1895,10 +1900,10 @@ driver/optmain.cmx : utils/warnings.cmx utils/timings.cmx \
     asmcomp/arch.cmx driver/optmain.cmi
 driver/pparse.cmo : utils/timings.cmi parsing/parse.cmi utils/misc.cmi \
     parsing/location.cmi utils/config.cmi utils/clflags.cmi utils/ccomp.cmi \
-    parsing/ast_mapper.cmi driver/pparse.cmi
+    parsing/ast_mapper.cmi parsing/ast_invariants.cmi driver/pparse.cmi
 driver/pparse.cmx : utils/timings.cmx parsing/parse.cmx utils/misc.cmx \
     parsing/location.cmx utils/config.cmx utils/clflags.cmx utils/ccomp.cmx \
-    parsing/ast_mapper.cmx driver/pparse.cmi
+    parsing/ast_mapper.cmx parsing/ast_invariants.cmx driver/pparse.cmi
 toplevel/genprintval.cmi : typing/types.cmi typing/path.cmi \
     typing/outcometree.cmi typing/env.cmi
 toplevel/opttopdirs.cmi : parsing/longident.cmi

Changes

@@ -147,6 +147,8 @@ Compilers:
   (David Allsopp)
 - GPR#431: permit constant float arrays to be eligible for pattern match
   branch merging (Pierre Chambart)
+- GPR#392: put all parsetree invariants in a new module Ast_invariants
+  (Jérémie Dimino)
 
 Runtime system:
 - PR#3612: allow allocating custom block with finalizers in the minor heap
@@ -473,6 +475,8 @@ Bug fixes:
   (David Allsopp)
 - GPR#441: better type error location in presence of type constraints
   (Thomas Refis, report by Arseniy Alekseyev)
+- PR#7111: reject empty let bindings instead of printing incorrect syntax
+  (Jérémie Dimino)
 
 Features wishes:
 - PR#4518, GPR#29: change location format for reporting errors in ocamldoc

Makefile.shared

@@ -49,7 +49,7 @@ PARSING=parsing/location.cmo parsing/longident.cmo \
   parsing/lexer.cmo parsing/parse.cmo parsing/printast.cmo \
   parsing/pprintast.cmo \
   parsing/ast_mapper.cmo parsing/attr_helper.cmo \
-  parsing/builtin_attributes.cmo
+  parsing/builtin_attributes.cmo parsing/ast_invariants.cmo
 
 TYPING=typing/ident.cmo typing/path.cmo \
   typing/primitive.cmo typing/types.cmo \

driver/pparse.ml

@@ -145,7 +145,7 @@ let open_and_check_magic inputfile ast_magic =
   in
   (ic, is_ast_file)
 
-let file ppf ~tool_name inputfile parse_fun ast_magic =
+let file_aux ppf ~tool_name inputfile parse_fun invariant_fun ast_magic =
   let (ic, is_ast_file) = open_and_check_magic inputfile ast_magic in
   let ast =
     try
@@ -166,7 +166,12 @@ let file ppf ~tool_name inputfile parse_fun ast_magic =
     with x -> close_in ic; raise x
   in
   close_in ic;
-  apply_rewriters ~restore:false ~tool_name ast_magic ast
+  let ast = apply_rewriters ~restore:false ~tool_name ast_magic ast in
+  if is_ast_file || !Clflags.all_ppx <> [] then invariant_fun ast;
+  ast
+
+let file ppf ~tool_name inputfile parse_fun ast_magic =
+  file_aux ppf ~tool_name inputfile parse_fun ignore ast_magic
 
 let report_error ppf = function
   | CannotRun cmd ->
@@ -183,11 +188,11 @@ let () =
       | _ -> None
     )
 
-let parse_all ~tool_name parse_fun magic ppf sourcefile =
+let parse_all ~tool_name parse_fun invariant_fun magic ppf sourcefile =
   Location.input_name := sourcefile;
   let inputfile = preprocess sourcefile in
   let ast =
-    try file ppf ~tool_name inputfile parse_fun magic
+    try file_aux ppf ~tool_name inputfile parse_fun invariant_fun magic
     with exn ->
       remove_preprocessed inputfile;
       raise exn
@@ -198,8 +203,10 @@ let parse_all ~tool_name parse_fun magic ppf sourcefile =
 let parse_implementation ppf ~tool_name sourcefile =
   parse_all ~tool_name
     (Timings.(time (Parsing sourcefile)) Parse.implementation)
+    Ast_invariants.structure
     Config.ast_impl_magic_number ppf sourcefile
 let parse_interface ppf ~tool_name sourcefile =
   parse_all ~tool_name
     (Timings.(time (Parsing sourcefile)) Parse.interface)
+    Ast_invariants.signature
     Config.ast_intf_magic_number ppf sourcefile

parsing/ast_invariants.ml

@@ -0,0 +1,158 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                 Jeremie Dimino, Jane Street Europe                  *)
+(*                                                                     *)
+(*  Copyright 2015 Jane Street Group LLC                               *)
+(*                                                                     *)
+(*  All rights reserved.  This file is distributed under the terms of  *)
+(*  the GNU Lesser General Public License version 2.1, with the        *)
+(*  special exception on linking described in the file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+open Asttypes
+open Parsetree
+open Ast_mapper
+
+let err = Syntaxerr.ill_formed_ast
+
+let empty_record loc = err loc "Records cannot be empty."
+let empty_variant loc = err loc "Variant types cannot be empty."
+let invalid_tuple loc = err loc "Tuples must have at least 2 components."
+let no_args loc = err loc "Function application with no argument."
+let empty_let loc = err loc "Let with no bindings."
+let empty_type loc = err loc "Type declarations cannot be empty."
+let complex_id loc = err loc "Functor application not allowed here."
+
+let simple_longident id =
+  let rec is_simple = function
+    | Longident.Lident _ -> true
+    | Longident.Ldot (id, _) -> is_simple id
+    | Longident.Lapply _ -> false
+  in
+  if not (is_simple id.txt) then complex_id id.loc
+
+let mapper =
+  let super = Ast_mapper.default_mapper in
+  let type_declaration self td =
+    let td = super.type_declaration self td in
+    let loc = td.ptype_loc in
+    match td.ptype_kind with
+    | Ptype_record [] -> empty_record loc
+    | Ptype_variant [] -> empty_variant loc
+    | _ -> td
+  in
+  let typ self ty =
+    let ty = super.typ self ty in
+    let loc = ty.ptyp_loc in
+    match ty.ptyp_desc with
+    | Ptyp_tuple ([] | [_]) -> invalid_tuple loc
+    | Ptyp_class (id, _) -> simple_longident id; ty
+    | Ptyp_package (_, cstrs) ->
+      List.iter (fun (id, _) -> simple_longident id) cstrs;
+      ty
+    | _ -> ty
+  in
+  let pat self pat =
+    let pat = super.pat self pat in
+    let loc = pat.ppat_loc in
+    match pat.ppat_desc with
+    | Ppat_tuple ([] | [_]) -> invalid_tuple loc
+    | Ppat_record ([], _) -> empty_record loc
+    | Ppat_construct (id, _) -> simple_longident id; pat
+    | Ppat_record (fields, _) ->
+      List.iter (fun (id, _) -> simple_longident id) fields;
+      pat
+    | _ -> pat
+  in
+  let expr self exp =
+    let exp = super.expr self exp in
+    let loc = exp.pexp_loc in
+    match exp.pexp_desc with
+    | Pexp_tuple ([] | [_]) -> invalid_tuple loc
+    | Pexp_record ([], _) -> empty_record loc
+    | Pexp_apply (_, []) -> no_args loc
+    | Pexp_let (_, [], _) -> empty_let loc
+    | Pexp_ident id
+    | Pexp_construct (id, _)
+    | Pexp_field (_, id)
+    | Pexp_setfield (_, id, _)
+    | Pexp_new id
+    | Pexp_open (_, id, _) -> simple_longident id; exp
+    | Pexp_record (fields, _) ->
+      List.iter (fun (id, _) -> simple_longident id) fields;
+      exp
+    | _ -> exp
+  in
+  let extension_constructor self ec =
+    let ec = super.extension_constructor self ec in
+    match ec.pext_kind with
+    | Pext_rebind id -> simple_longident id; ec
+    | _ -> ec
+  in
+  let class_expr self ce =
+    let ce = super.class_expr self ce in
+    let loc = ce.pcl_loc in
+    match ce.pcl_desc with
+    | Pcl_apply (_, []) -> no_args loc
+    | Pcl_constr (id, _) -> simple_longident id; ce
+    | _ -> ce
+  in
+  let module_type self mty =
+    let mty = super.module_type self mty in
+    match mty.pmty_desc with
+    | Pmty_alias id -> simple_longident id; mty
+    | _ -> mty
+  in
+  let open_description self opn =
+    let opn = super.open_description self opn in
+    simple_longident opn.popen_lid;
+    opn
+  in
+  let with_constraint self wc =
+    let wc = super.with_constraint self wc in
+    match wc with
+    | Pwith_type (id, _)
+    | Pwith_module (id, _) -> simple_longident id; wc
+    | _ -> wc
+  in
+  let module_expr self me =
+    let me = super.module_expr self me in
+    match me.pmod_desc with
+    | Pmod_ident id -> simple_longident id; me
+    | _ -> me
+  in
+  let structure_item self st =
+    let st = super.structure_item self st in
+    let loc = st.pstr_loc in
+    match st.pstr_desc with
+    | Pstr_type (_, []) -> empty_type loc
+    | Pstr_value (_, []) -> empty_let loc
+    | _ -> st
+  in
+  let signature_item self sg =
+    let sg = super.signature_item self sg in
+    let loc = sg.psig_loc in
+    match sg.psig_desc with
+    | Psig_type (_, []) -> empty_type loc
+    | _ -> sg
+  in
+  { super with
+    type_declaration
+  ; typ
+  ; pat
+  ; expr
+  ; extension_constructor
+  ; class_expr
+  ; module_expr
+  ; module_type
+  ; open_description
+  ; with_constraint
+  ; structure_item
+  ; signature_item
+  }
+
+let structure st = ignore (mapper.structure mapper st : structure)
+let signature sg = ignore (mapper.signature mapper sg : signature)

parsing/ast_invariants.mli

@@ -0,0 +1,18 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                 Jeremie Dimino, Jane Street Europe                  *)
+(*                                                                     *)
+(*  Copyright 2015 Jane Street Group LLC                               *)
+(*                                                                     *)
+(*  All rights reserved.  This file is distributed under the terms of  *)
+(*  the GNU Lesser General Public License version 2.1, with the        *)
+(*  special exception on linking described in the file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(** Check AST invariants *)
+
+val structure : Parsetree.structure -> unit
+val signature : Parsetree.signature -> unit

testsuite/tests/ast-invariants/Makefile

@@ -0,0 +1,26 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#                  Jeremie Dimino, Jane Street Europe                   #
+#                                                                       #
+#   Copyright 2015 Jane Street Group LLC                                #
+#                                                                       #
+#   All rights reserved.  This file is distributed under the terms of   #
+#   the GNU Lesser General Public License version 2.1, with the         #
+#   special exception on linking described in the file ../LICENSE.      #
+#                                                                       #
+#########################################################################
+
+BASEDIR=../..
+COMPFLAGS=-I $(TOPDIR)/parsing -I $(TOPDIR)/utils
+LIBRARIES=$(TOPDIR)/compilerlibs/ocamlcommon
+MODULES=
+MAIN_MODULE=test
+
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
+
+# This test is a bit slow and there is little value in testing both
+# versions so we run only the native code one:
+NATIVECODE_ONLY=true

testsuite/tests/ast-invariants/test.ml

@@ -0,0 +1,67 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*                 Jeremie Dimino, Jane Street Europe                  *)
+(*                                                                     *)
+(*  Copyright 2015 Jane Street Group LLC                               *)
+(*                                                                     *)
+(*  All rights reserved.  This file is distributed under the terms of  *)
+(*  the GNU Lesser General Public License version 2.1, with the        *)
+(*  special exception on linking described in the file ../LICENSE.     *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* This test checks all ml files in the ocaml repository that are accepted
+   by the parser satisfy [Ast_invariants].
+
+   We don't check the invariants on the output of the parser, so this test
+   is to ensure that we the parser doesn't accept more than [Ast_invariants].
+*)
+
+let root = "../../.."
+let () = assert (Sys.file_exists (Filename.concat root "VERSION"))
+
+type _ kind =
+  | Implem : Parsetree.structure kind
+  | Interf : Parsetree.signature kind
+
+let parse : type a. a kind -> Lexing.lexbuf -> a = function
+  | Implem -> Parse.implementation
+  | Interf -> Parse.interface
+
+let invariants : type a. a kind -> a -> unit = function
+  | Implem -> Ast_invariants.structure
+  | Interf -> Ast_invariants.signature
+
+let check_file kind fn =
+  Warnings.parse_options false "-a";
+  let ic = open_in fn in
+  Location.input_name := fn;
+  let lexbuf = Lexing.from_channel ic in
+  Location.init lexbuf fn;
+  match parse kind lexbuf with
+  | exception _ ->
+    (* A few files don't parse as they are meant for the toplevel;
+       ignore them *)
+    close_in ic
+  | ast ->
+    close_in ic;
+    try
+      invariants kind ast
+    with exn ->
+      Location.report_exception Format.std_formatter exn
+
+let rec walk dir =
+  Array.iter
+    (fun fn ->
+       let fn = Filename.concat dir fn in
+       if Sys.is_directory fn then
+         walk fn
+       else if Filename.check_suffix fn ".mli" then
+         check_file Interf fn
+       else if Filename.check_suffix fn ".ml" then
+         check_file Implem fn)
+    (Sys.readdir dir)
+
+let () = walk root

tools/Makefile.shared

@@ -39,7 +39,8 @@ CAMLDEP_IMPORTS=timings.cmo misc.cmo config.cmo identifiable.cmo numbers.cmo \
   arg_helper.cmo clflags.cmo terminfo.cmo \
   warnings.cmo location.cmo longident.cmo docstrings.cmo \
   syntaxerr.cmo ast_helper.cmo parser.cmo lexer.cmo parse.cmo \
-  ccomp.cmo ast_mapper.cmo pparse.cmo compenv.cmo builtin_attributes.cmo
+  ccomp.cmo ast_mapper.cmo ast_invariants.cmo pparse.cmo compenv.cmo \
+  builtin_attributes.cmo
 
 ocamldep: depend.cmi $(CAMLDEP_OBJ)
 	$(CAMLC) $(LINKFLAGS) -compat-32 -o ocamldep $(CAMLDEP_IMPORTS) $(CAMLDEP_OBJ)

typing/typeclass.ml

@@ -980,9 +980,7 @@ and class_expr cl_num val_env met_env scl =
           cl_attributes = scl.pcl_attributes;
          }
   | Pcl_apply (scl', sargs) ->
-      if sargs = [] then
+      assert (sargs <> []);
-        Syntaxerr.ill_formed_ast scl.pcl_loc
-          "Function application with no argument.";
       if !Clflags.principal then Ctype.begin_def ();
       let cl = class_expr cl_num val_env met_env scl' in
       if !Clflags.principal then begin

typing/typecore.ml

@@ -1087,8 +1087,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env
   | Ppat_interval _ ->
       raise (Error (loc, !env, Invalid_interval))
   | Ppat_tuple spl ->
-      if List.length spl < 2 then
+      assert (List.length spl >= 2);
-        Syntaxerr.ill_formed_ast loc "Tuples must have at least 2 components.";
       let spl_ann = List.map (fun p -> (p,newvar ())) spl in
       let ty = newty (Ttuple(List.map snd spl_ann)) in
       unify_pat_types loc !env ty expected_ty;
@@ -1210,8 +1209,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env
         | _            -> k None
       end
   | Ppat_record(lid_sp_list, closed) ->
-      if lid_sp_list = [] then
+      assert (lid_sp_list <> []);
-        Syntaxerr.ill_formed_ast loc "Records cannot be empty.";
       let opath, record_ty =
         try
           let (p0, p,_) = extract_concrete_record !env expected_ty in
@@ -2065,8 +2063,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
       type_function ?in_function
         loc sexp.pexp_attributes env ty_expected Nolabel caselist
   | Pexp_apply(sfunct, sargs) ->
-      if sargs = [] then
+      assert (sargs <> []);
-        Syntaxerr.ill_formed_ast loc "Function application with no argument.";
       begin_def (); (* one more level for non-returning functions *)
       if !Clflags.principal then begin_def ();
       let funct = type_exp env sfunct in
@@ -2136,8 +2133,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
         exp_attributes = sexp.pexp_attributes;
         exp_env = env }
   | Pexp_tuple sexpl ->
-      if List.length sexpl < 2 then
+      assert (List.length sexpl >= 2);
-        Syntaxerr.ill_formed_ast loc "Tuples must have at least 2 components.";
       let subtypes = List.map (fun _ -> newgenvar ()) sexpl in
       let to_unify = newgenty (Ttuple subtypes) in
       unify_exp_types loc env to_unify ty_expected;
@@ -2188,8 +2184,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
           exp_env = env }
       end
   | Pexp_record(lid_sexp_list, opt_sexp) ->
-      if lid_sexp_list = [] then
+      assert (lid_sexp_list <> []);
-        Syntaxerr.ill_formed_ast loc "Records cannot be empty.";
       let opt_exp =
         match opt_sexp with
           None -> None

typing/typedecl.ml

@@ -153,8 +153,7 @@ let make_params env params =
     List.map make_param params
 
 let transl_labels loc env closed lbls =
-  if lbls = [] then
+  assert (lbls <> []);
-    Syntaxerr.ill_formed_ast loc "Records cannot be empty.";
   let all_labels = ref StringSet.empty in
   List.iter
     (fun {pld_name = {txt=name; loc}} ->
@@ -238,9 +237,7 @@ let transl_declaration env sdecl id =
     match sdecl.ptype_kind with
         Ptype_abstract -> Ttype_abstract, Type_abstract
       | Ptype_variant scstrs ->
-        if scstrs = [] then
+        assert (scstrs <> []);
-          Syntaxerr.ill_formed_ast sdecl.ptype_loc
-            "Variant types cannot be empty.";
         let all_constrs = ref StringSet.empty in
         List.iter
           (fun {pcd_name = {txt = name}} ->

typing/typetexp.ml

@@ -331,8 +331,7 @@ let rec transl_type env policy styp =
     let ty = newty (Tarrow(l, ty1, cty2.ctyp_type, Cok)) in
     ctyp (Ttyp_arrow (l, cty1, cty2)) ty
   | Ptyp_tuple stl ->
-    if List.length stl < 2 then
+    assert (List.length stl >= 2);
-      Syntaxerr.ill_formed_ast loc "Tuples must have at least 2 components.";
     let ctys = List.map (transl_type env policy) stl in
     let ty = newty (Ttuple (List.map (fun ctyp -> ctyp.ctyp_type) ctys)) in
     ctyp (Ttyp_tuple ctys) ty