ocaml · let-def · Mar 28, 2014 · Apr 10, 2014 · Apr 10, 2014
diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli
@@ -18,7 +18,7 @@ open Typedtree
 open Lambda
 
 val transl_exp: expression -> lambda
-val transl_apply: lambda -> (label * expression option * optional) list
+val transl_apply: lambda -> (arrow_flag * expression option * optional) list
                   -> Location.t -> lambda
 val transl_let: rec_flag -> value_binding list -> lambda -> lambda
 val transl_primitive: Location.t -> Primitive.description -> lambda

diff --git a/ocamldoc/odoc_info.mli b/ocamldoc/odoc_info.mli
@@ -709,11 +709,11 @@ val create_index_lists : 'a list -> ('a -> string) -> 'a list list
 val remove_option : Types.type_expr -> Types.type_expr
 
 (** Return [true] if the given label is optional.*)
-val is_optional : string -> bool
+val is_optional : Asttypes.arrow_flag -> bool
 
 (** Return the label name for the given label,
    i.e. removes the beginning '?' if present.*)
-val label_name : string -> string
+val label_name : Asttypes.arrow_flag -> string option
 
 (** Return the given name where the module name or
    part of it was removed, according to the list of modules

diff --git a/ocamldoc/odoc_misc.ml b/ocamldoc/odoc_misc.ml
@@ -472,6 +472,15 @@ let create_index_lists elements string_of_ele =
 let is_optional = Btype.is_optional
 let label_name = Btype.label_name
 
+let label_name' label = match label_name label with
+  | None -> ""
+  | Some s -> s
+
+let label_prefix = function
+  | Asttypes.Simple -> ""
+  | Asttypes.Optional s -> "?" ^ s ^ ":"
+  | Asttypes.Labelled s -> s ^ ":"
+
 let remove_option typ =
   let rec iter t =
     match t with

diff --git a/ocamldoc/odoc_misc.mli b/ocamldoc/odoc_misc.mli
@@ -107,8 +107,13 @@ val search_string_backward : pat: string -> s: string -> int
 val remove_option : Types.type_expr -> Types.type_expr
 
 (** Return [true] if the given label is optional.*)
-val is_optional : string -> bool
+val is_optional : Asttypes.arrow_flag -> bool
 
 (** Return the label name for the given label,
    i.e. removes the beginning '?' if present.*)
-val label_name : string -> string
+val label_name : Asttypes.arrow_flag -> string option
+val label_name' : Asttypes.arrow_flag -> string
+
+(** Return the string to print when label is prefixing a type
+   i.e. appends ':' if label is non-empty .*)
+val label_prefix : Asttypes.arrow_flag -> string
diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml
@@ -222,7 +222,7 @@ module Analyser =
           let f {Types.cd_id=constructor_name;cd_args=type_expr_list;cd_res=ret_type} =
             let constructor_name = Ident.name constructor_name in
             let comment_opt =
-              try List.assoc constructor_name name_comment_list 
+              try List.assoc constructor_name name_comment_list
               with Not_found -> None
             in
             {
@@ -1262,7 +1262,7 @@ module Analyser =
             (
              let new_param = Simple_name
                  {
-                   sn_name = Btype.label_name label ;
+                   sn_name = Odoc_misc.label_name' label ;
                    sn_type = Odoc_env.subst_type env type_expr ;
                    sn_text = None ; (* will be updated when the class will be created *)
                  }

diff --git a/ocamldoc/odoc_str.ml b/ocamldoc/odoc_str.ml
@@ -128,11 +128,7 @@ let string_of_class_params c =
       Types.Cty_arrow (label, t, ctype) ->
         let parent = is_arrow_type t in
         Printf.bprintf b "%s%s%s%s -> "
-          (
-           match label with
-             "" -> ""
-           | s -> s^":"
-          )
+          (Odoc_misc.label_prefix label)
           (if parent then "(" else "")
           (Odoc_print.string_of_type_expr
              (if Odoc_misc.is_optional label then

diff --git a/ocamldoc/odoc_value.ml b/ocamldoc/odoc_value.ml
@@ -95,36 +95,29 @@ let parameter_list_from_arrows typ =
    so there is nothing to merge. With this dummy list we can merge the
    parameter names from the .ml and the type from the .mli file. *)
 let dummy_parameter_list typ =
-  let normal_name s =
-    match s with
-      "" -> s
-    | _ ->
-        match s.[0] with
-          '?' -> String.sub s 1 ((String.length s) - 1)
-        | _ -> s
-  in
   Printtyp.mark_loops typ;
   let liste_param = parameter_list_from_arrows typ in
   let rec iter (label, t) =
     match t.Types.desc with
     | Types.Ttuple l ->
-        if label = "" then
-          Odoc_parameter.Tuple
-            (List.map (fun t2 -> iter ("", t2)) l, t)
-        else
-          (* if there is a label, then we don't want to decompose the tuple *)
-          Odoc_parameter.Simple_name
-            { Odoc_parameter.sn_name = normal_name label ;
-              Odoc_parameter.sn_type = t ;
-              Odoc_parameter.sn_text = None }
+        begin match Odoc_misc.label_name label with
+        | None -> Odoc_parameter.Tuple
+                    (List.map (fun t2 -> iter (Asttypes.Simple, t2)) l, t)
+        | Some name ->
+            (* if there is a label, then we don't want to decompose the tuple *)
+            Odoc_parameter.Simple_name
+              { Odoc_parameter.sn_name = name;
+                Odoc_parameter.sn_type = t;
+                Odoc_parameter.sn_text = None }
+        end
     | Types.Tlink t2
     | Types.Tsubst t2 ->
         (iter (label, t2))
 
     | _ ->
         Odoc_parameter.Simple_name
-          { Odoc_parameter.sn_name = normal_name label ;
-             Odoc_parameter.sn_type = t ;
+          { Odoc_parameter.sn_name = Odoc_misc.label_name' label;
+            Odoc_parameter.sn_type = t ;
             Odoc_parameter.sn_text = None }
   in
   List.map iter liste_param

diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml
@@ -390,8 +390,8 @@ module Convenience = struct
   let record ?over l =
     Exp.record (List.map (fun (s, e) -> (lid s, e)) l) over
   let func l = Exp.function_ (List.map (fun (p, e) -> Exp.case p e) l)
-  let lam ?(label = "") ?default pat exp = Exp.fun_ label default pat exp
-  let app f l = Exp.apply f (List.map (fun a -> "", a) l)
+  let lam ?(label = Simple) ?default pat exp = Exp.fun_ label default pat exp
+  let app f l = Exp.apply f (List.map (fun a -> Simple, a) l)
   let evar s = Exp.ident (lid s)
   let let_in ?(recursive = false) b body =
     Exp.let_ (if recursive then Recursive else Nonrecursive) b body

diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli
@@ -38,7 +38,7 @@ module Typ :
 
     val any: ?loc:loc -> ?attrs:attrs -> unit -> core_type
     val var: ?loc:loc -> ?attrs:attrs -> string -> core_type
-    val arrow: ?loc:loc -> ?attrs:attrs -> label -> core_type -> core_type -> core_type
+    val arrow: ?loc:loc -> ?attrs:attrs -> arrow_flag -> core_type -> core_type -> core_type
     val tuple: ?loc:loc -> ?attrs:attrs -> core_type list -> core_type
     val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type
     val object_: ?loc:loc -> ?attrs:attrs -> (string * core_type) list -> closed_flag -> core_type
@@ -85,9 +85,9 @@ module Exp:
     val ident: ?loc:loc -> ?attrs:attrs -> lid -> expression
     val constant: ?loc:loc -> ?attrs:attrs -> constant -> expression
     val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list -> expression -> expression
-    val fun_: ?loc:loc -> ?attrs:attrs -> label -> expression option -> pattern -> expression -> expression
+    val fun_: ?loc:loc -> ?attrs:attrs -> arrow_flag -> expression option -> pattern -> expression -> expression
     val function_: ?loc:loc -> ?attrs:attrs -> case list -> expression
-    val apply: ?loc:loc -> ?attrs:attrs -> expression -> (label * expression) list -> expression
+    val apply: ?loc:loc -> ?attrs:attrs -> expression -> (arrow_flag * expression) list -> expression
     val match_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression
     val try_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression
     val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression
@@ -246,7 +246,7 @@ module Cty:
 
     val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_type
     val signature: ?loc:loc -> ?attrs:attrs -> class_signature -> class_type
-    val arrow: ?loc:loc -> ?attrs:attrs -> label -> core_type -> class_type -> class_type
+    val arrow: ?loc:loc -> ?attrs:attrs -> arrow_flag -> core_type -> class_type -> class_type
     val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type
   end
 
@@ -271,8 +271,8 @@ module Cl:
 
     val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_expr
     val structure: ?loc:loc -> ?attrs:attrs -> class_structure -> class_expr
-    val fun_: ?loc:loc -> ?attrs:attrs -> label -> expression option -> pattern -> class_expr -> class_expr
-    val apply: ?loc:loc -> ?attrs:attrs -> class_expr -> (label * expression) list -> class_expr
+    val fun_: ?loc:loc -> ?attrs:attrs -> arrow_flag -> expression option -> pattern -> class_expr -> class_expr
+    val apply: ?loc:loc -> ?attrs:attrs -> class_expr -> (arrow_flag * expression) list -> class_expr
     val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list -> class_expr -> class_expr
     val constraint_: ?loc:loc -> ?attrs:attrs -> class_expr -> class_type -> class_expr
     val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_expr
@@ -340,7 +340,7 @@ module Convenience :
     val unit: unit -> expression
 
     val func: (pattern * expression) list -> expression
-    val lam: ?label:string -> ?default:expression -> pattern -> expression -> expression
+    val lam: ?label:arrow_flag -> ?default:expression -> pattern -> expression -> expression
     val app: expression -> expression list -> expression
 
     val str: string -> expression

diff --git a/parsing/asttypes.mli b/parsing/asttypes.mli
@@ -42,8 +42,12 @@ type 'a loc = 'a Location.loc = {
   loc : Location.t;
 }
 
-
 type variance =
   | Covariant
   | Contravariant
   | Invariant
+
+type arrow_flag =
+  | Simple             (*        T -> ... *)
+  | Labelled of string (*  label:T -> ... *)
+  | Optional of string (* ?label:T -> ... *)