Implement the 'let new type t in e' construct.

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/newtypein@9362 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

9 files changed, 80 insertions, 1 deletions

diff --git a/parsing/parser.mly b/parsing/parser.mly
index 77309e4e49..867db06c0c 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -825,6 +825,8 @@ expr:
       { mkexp(Pexp_let($2, List.rev $3, $5)) }
   | LET MODULE UIDENT module_binding IN seq_expr
       { mkexp(Pexp_letmodule($3, $4, $6)) }
+  | LET NEW TYPE LIDENT IN seq_expr
+      { mkexp(Pexp_newtype($4, $6)) }
   | FUNCTION opt_bar match_cases
       { mkexp(Pexp_function("", None, List.rev $3)) }
   | FUN labeled_simple_pattern fun_def
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index 8fbf190cbd..0be71b4e7c 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -112,6 +112,7 @@ and expression_desc =
   | Pexp_lazy of expression
   | Pexp_poly of expression * core_type option
   | Pexp_object of class_structure
+  | Pexp_newtype of string * expression
 
 (* Value descriptions *)
 
diff --git a/parsing/printast.ml b/parsing/printast.ml
index 50a422cc1b..a81c9e6753 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -305,6 +305,9 @@ and expression i ppf x =
   | Pexp_object s ->
       line i ppf "Pexp_object";
       class_structure i ppf s
+  | Pexp_newtype (s, e) ->
+      line i ppf "Pexp_newtype \"%s\"\n" s;
+      expression i ppf e
 
 and value_description i ppf x =
   line i ppf "value_description\n";
diff --git a/test/Makefile b/test/Makefile
index cf1f3e1524..b2e7da5b25 100644
--- a/test/Makefile
+++ b/test/Makefile
@@ -28,7 +28,8 @@ CODERUNPARAMS=OCAMLRUNPARAM='o=100'
 BYTE_EXE=fib.byt takc.byt taku.byt sieve.byt quicksort.byt quicksort.fast.byt \
   fft.byt fft.fast.byt soli.byt soli.fast.byt boyer.byt kb.byt \
   nucleic.byt bdd.byt hamming.byt sorts.byt \
-  almabench.byt almabench.fast.byt weaktest.byt
+  almabench.byt almabench.fast.byt weaktest.byt \
+  newtype.byt
 
 CODE_EXE=$(BYTE_EXE:.byt=.out)
 
diff --git a/test/newtype.ml b/test/newtype.ml
new file mode 100644
index 0000000000..451e0fa3e8
--- /dev/null
+++ b/test/newtype.ml
@@ -0,0 +1,31 @@
+let property =
+  let new type t in
+  fun () ->
+    let module M = struct exception E of t end in
+    (fun x -> M.E x), (function M.E x -> Some x | _ -> None)
+
+let () =
+  let (int_inj, int_proj) = property () in
+  let (string_inj, string_proj) = property () in
+
+  let i = int_inj 3 in
+  let s = string_inj "abc" in
+
+  Printf.printf "%b\n%!" (int_proj i = None);
+  Printf.printf "%b\n%!" (int_proj s = None);
+  Printf.printf "%b\n%!" (string_proj i = None);
+  Printf.printf "%b\n%!" (string_proj s = None)
+
+
+
+
+let sort_uniq =
+  let new type s in
+  fun cmp l ->
+    let module S = Set.Make(struct type t = s let compare = cmp end) in
+    S.elements (List.fold_right S.add l S.empty)
+
+let () =
+  print_endline (String.concat "," (sort_uniq compare [ "abc"; "xyz"; "abc" ]))
+
+
diff --git a/tools/depend.ml b/tools/depend.ml
index 3be1c3a06e..f4bebad294 100644
--- a/tools/depend.ml
+++ b/tools/depend.ml
@@ -157,6 +157,7 @@ let rec add_expr bv exp =
   | Pexp_poly (e, t) -> add_expr bv e; add_opt add_type bv t
   | Pexp_object (pat, fieldl) ->
       add_pattern bv pat; List.iter (add_class_field bv) fieldl
+  | Pexp_newtype (_, e) -> add_expr bv e
 and add_pat_expr_list bv pel =
   List.iter (fun (p, e) -> add_pattern bv p; add_expr bv e) pel
 
diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml
index c66e6722f2..2425a9adcd 100644
--- a/tools/ocamlprof.ml
+++ b/tools/ocamlprof.ml
@@ -285,6 +285,9 @@ and rw_exp iflag sexp =
   | Pexp_object (_, fieldl) ->
       List.iter (rewrite_class_field iflag) fieldl
 
+  | Pexp_newtype (_, sexp) ->
+      rewrite_exp iflag sexp
+
 and rewrite_ifbody iflag ghost sifbody =
   if !instr_if && not ghost then
     insert_profile rw_exp sifbody
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 7e81fa9f11..7083887e9c 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -1596,6 +1596,42 @@ let rec type_exp env sexp =
       }
   | Pexp_poly _ ->
       assert false
+  | Pexp_newtype(name, sbody) ->
+      (* Create a fake abstract type declaration for name. *)
+      let decl = {
+        type_params = [];
+        type_arity = 0;
+        type_kind = Type_abstract;
+        type_private = Public;
+        type_manifest = None;
+        type_variance = [];
+      }
+      in
+
+      let ty = newvar () in
+      Ident.set_current_time ty.level;
+      let (id, new_env) = Env.enter_type name decl env in
+      Ctype.init_def(Ident.current_time());
+
+      let body = type_exp new_env sbody in
+      (* Replace every instance of this type constructor in the resulting type. *)
+      let seen = Hashtbl.create 8 in
+      let rec replace t =
+        if Hashtbl.mem seen t.id then ()
+        else begin
+          Hashtbl.add seen t.id ();
+          match t.desc with
+          | Tconstr (Path.Pident id', _, _) when id == id' -> link_type t ty
+          | _ -> Btype.iter_type_expr replace t
+        end
+      in
+      let ety = Subst.type_expr Subst.identity body.exp_type in
+      replace ety;
+
+      (* non-expansive if the body is non-expansive, so we don't introduce
+         any new extra node in the typed AST. *)
+      re { body with exp_loc = sexp.pexp_loc; exp_type = ety }
+
 
 and type_argument env sarg ty_expected' =
   (* ty_expected' may be generic *)
diff --git a/typing/unused_var.ml b/typing/unused_var.ml
index 25f65464d7..633de59643 100644
--- a/typing/unused_var.ml
+++ b/typing/unused_var.ml
@@ -173,6 +173,7 @@ and expression ppf tbl e =
   | Pexp_lazy e -> expression ppf tbl e;
   | Pexp_poly (e, _) -> expression ppf tbl e;
   | Pexp_object cs -> class_structure ppf tbl cs;
+  | Pexp_newtype (_, e) -> expression ppf tbl e
 
 and expression_option ppf tbl eo =
   match eo with