Optional arguments with default types

add a new predefined type: type ('a,'b) optional = | Default: ('default,'default) optional | Specific: 'a -> ('a, 'default) optional a new syntax: let f (type a) ?(x=0: a = int) () = x let f (type a): ?x:?(a=int) -> unit -> a = function | Default -> 0 | Specific x -> x and extend the optional argument machinery to this new gadt-ladened optional type.
ocaml · Jan 30, 2017 · a74ad3a · a74ad3a
1 parent b0a4467
commit a74ad3a
Show file tree

Hide file tree

Showing 24 changed files with 413 additions and 125 deletions.
diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml
@@ -50,7 +50,7 @@ module Typ = struct
 
   let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any
   let var ?loc ?attrs a = mk ?loc ?attrs (Ptyp_var a)
-  let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_arrow (a, b, c))
+  let arrow ?loc ?attrs a ?typopt b c = mk ?loc ?attrs (Ptyp_arrow (a, typopt, b, c))
   let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a)
   let constr ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_constr (a, b))
   let object_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_object (a, b))
@@ -78,8 +78,8 @@ module Typ = struct
         | Ptyp_var x ->
             check_variable var_names t.ptyp_loc x;
             Ptyp_var x
-        | Ptyp_arrow (label,core_type,core_type') ->
-            Ptyp_arrow(label, loop core_type, loop core_type')
+        | Ptyp_arrow (label,typopt, core_type,core_type') ->
+            Ptyp_arrow(label, loop_opt typopt, loop core_type, loop core_type')
         | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst)
         | Ptyp_constr( { txt = Longident.Lident s }, [])
           when List.mem s var_names ->
@@ -113,6 +113,9 @@ module Typ = struct
             Rtag(label,attrs,flag,List.map loop lst)
         | Rinherit t ->
             Rinherit (loop t)
+    and loop_opt = function
+      | None -> None
+      | Some x -> Some (loop x)
     in
     loop t
 
@@ -151,7 +154,8 @@ module Exp = struct
   let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a)
   let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a)
   let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c))
-  let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_fun (a, b, c, d))
+  let fun_ ?loc ?attrs a ?typopt b c d = mk ?loc ?attrs
+      (Pexp_fun (a,typopt, b, c, d))
   let function_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_function a)
   let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b))
   let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b))
@@ -281,7 +285,8 @@ module Cl = struct
 
   let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constr (a, b))
   let structure ?loc ?attrs a = mk ?loc ?attrs (Pcl_structure a)
-  let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pcl_fun (a, b, c, d))
+  let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs
+      (Pcl_fun (a, b, c, d))
   let apply ?loc ?attrs a b = mk ?loc ?attrs (Pcl_apply (a, b))
   let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcl_let (a, b, c))
   let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constraint (a, b))

diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli
@@ -56,7 +56,8 @@ 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 -> arg_label -> core_type -> core_type
+    val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> ?typopt:core_type -> 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
@@ -121,8 +122,9 @@ module Exp:
     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 -> arg_label -> expression option
-              -> pattern -> expression -> expression
+    val fun_: ?loc:loc -> ?attrs:attrs ->  arg_label ->
+      ?typopt:(core_type * core_type) -> expression option
+      -> pattern -> expression -> expression
     val function_: ?loc:loc -> ?attrs:attrs -> case list -> expression
     val apply: ?loc:loc -> ?attrs:attrs -> expression
                -> (arg_label * expression) list -> expression
@@ -350,8 +352,8 @@ 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 -> arg_label -> core_type ->
-      class_type -> class_type
+    val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> class_type
+      -> class_type
     val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type
   end
 
@@ -382,8 +384,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 -> arg_label -> expression option ->
-      pattern -> class_expr -> class_expr
+    val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option
+      -> pattern -> class_expr -> class_expr
     val apply: ?loc:loc -> ?attrs:attrs -> class_expr ->
       (arg_label * expression) list -> class_expr
     val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list ->

diff --git a/parsing/ast_iterator.ml b/parsing/ast_iterator.ml
@@ -93,8 +93,8 @@ module T = struct
     match desc with
     | Ptyp_any
     | Ptyp_var _ -> ()
-    | Ptyp_arrow (_lab, t1, t2) ->
-        sub.typ sub t1; sub.typ sub t2
+    | Ptyp_arrow (_lab, tyo,  t1, t2) ->
+        iter_opt (sub.typ sub) tyo; sub.typ sub t1; sub.typ sub t2
     | Ptyp_tuple tyl -> List.iter (sub.typ sub) tyl
     | Ptyp_constr (lid, tl) ->
         iter_loc sub lid; List.iter (sub.typ sub) tl
@@ -307,7 +307,8 @@ module E = struct
     | Pexp_let (_r, vbs, e) ->
         List.iter (sub.value_binding sub) vbs;
         sub.expr sub e
-    | Pexp_fun (_lab, def, p, e) ->
+    | Pexp_fun (_lab, tyo, def, p, e) ->
+        iter_opt (iter_tuple (sub.typ sub) (sub.typ sub)) tyo;
         iter_opt (sub.expr sub) def;
         sub.pat sub p;
         sub.expr sub e

diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml
@@ -95,8 +95,9 @@ module T = struct
     match desc with
     | Ptyp_any -> any ~loc ~attrs ()
     | Ptyp_var s -> var ~loc ~attrs s
-    | Ptyp_arrow (lab, t1, t2) ->
-        arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2)
+    | Ptyp_arrow (lab, tyo, t1, t2) ->
+        arrow ~loc ~attrs lab ?typopt:(map_opt (sub.typ sub) tyo)
+          (sub.typ sub t1) (sub.typ sub t2)
     | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl)
     | Ptyp_constr (lid, tl) ->
         constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
@@ -326,8 +327,10 @@ module E = struct
     | Pexp_let (r, vbs, e) ->
         let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs)
           (sub.expr sub e)
-    | Pexp_fun (lab, def, p, e) ->
-        fun_ ~loc ~attrs lab (map_opt (sub.expr sub) def) (sub.pat sub p)
+    | Pexp_fun (lab, tyo, def, p, e) ->
+        fun_ ~loc ~attrs lab
+          ?typopt:(map_opt (map_tuple (sub.typ sub) (sub.typ sub)) tyo)
+          (map_opt (sub.expr sub) def) (sub.pat sub p)
           (sub.expr sub e)
     | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel)
     | Pexp_apply (e, l) ->

diff --git a/parsing/asttypes.mli b/parsing/asttypes.mli
@@ -45,6 +45,7 @@ type arg_label =
     Nolabel
   | Labelled of string (*  label:T -> ... *)
   | Optional of string (* ?label:T -> ... *)
+  | Typed_optional of string (* ?label:T:?(a=b) *)
 
 type 'a loc = 'a Location.loc = {
   txt : 'a;

diff --git a/parsing/depend.ml b/parsing/depend.ml
@@ -95,11 +95,18 @@ let handle_extension ext =
   | _ ->
     ()
 
+
+let add_opt add_fn bv = function
+    None -> ()
+  | Some x -> add_fn bv x
+
 let rec add_type bv ty =
   match ty.ptyp_desc with
     Ptyp_any -> ()
   | Ptyp_var _ -> ()
-  | Ptyp_arrow(_, t1, t2) -> add_type bv t1; add_type bv t2
+  | Ptyp_arrow(_, tyo, t1, t2) ->
+      add_opt add_type bv tyo;
+      add_type bv t1; add_type bv t2
   | Ptyp_tuple tl -> List.iter (add_type bv) tl
   | Ptyp_constr(c, tl) -> add bv c; List.iter (add_type bv) tl
   | Ptyp_object (fl, _) -> List.iter (fun (_, _, t) -> add_type bv t) fl
@@ -118,10 +125,6 @@ and add_package_type bv (lid, l) =
   add bv lid;
   List.iter (add_type bv) (List.map (fun (_, e) -> e) l)
 
-let add_opt add_fn bv = function
-    None -> ()
-  | Some x -> add_fn bv x
-
 let add_constructor_arguments bv = function
   | Pcstr_tuple l -> List.iter (add_type bv) l
   | Pcstr_record l -> List.iter (fun l -> add_type bv l.pld_type) l
@@ -215,7 +218,8 @@ let rec add_expr bv exp =
   | Pexp_constant _ -> ()
   | Pexp_let(rf, pel, e) ->
       let bv = add_bindings rf bv pel in add_expr bv e
-  | Pexp_fun (_, opte, p, e) ->
+  | Pexp_fun (_, tyo, opte, p, e) ->
+      add_opt (fun bv (x,y) -> add_type bv x; add_type bv y) bv tyo;
       add_opt add_expr bv opte; add_expr (add_pattern bv p) e
   | Pexp_function pel ->
       add_cases bv pel

diff --git a/parsing/parser.mly b/parsing/parser.mly
@@ -412,6 +412,17 @@ let package_type_of_module_type pmty =
         "only module type identifier and 'with type' constraints are supported"
 
 
+let mk_opt (label,pat) (o,tyo) = match tyo with
+| None -> (Optional label, tyo, o, pat )
+| Some _ -> (Typed_optional label, tyo, o, pat)
+
+let class_typed_opt_error k tyo =
+    match tyo with
+    | Some _ -> raise Syntaxerr.( Error(Not_expecting (rhs_loc k,
+    "optional argument with default type"
+    )))
+    | None -> ()
+
 %}
 
 /* Tokens */
@@ -1012,17 +1023,23 @@ class_fun_binding:
   | COLON class_type EQUAL class_expr
       { mkclass(Pcl_constraint($4, $2)) }
   | labeled_simple_pattern class_fun_binding
-      { let (l,o,p) = $1 in mkclass(Pcl_fun(l, o, p, $2)) }
+      { let (l,tyo,o,p) = $1 in
+      class_typed_opt_error 1 tyo;
+      mkclass(Pcl_fun(l, o, p, $2)) }
 ;
 class_type_parameters:
     /*empty*/                                   { [] }
   | LBRACKET type_parameter_list RBRACKET       { List.rev $2 }
 ;
 class_fun_def:
     labeled_simple_pattern MINUSGREATER class_expr
-      { let (l,o,p) = $1 in mkclass(Pcl_fun(l, o, p, $3)) }
+      { let (l,tyo,o,p) = $1 in
+       class_typed_opt_error 1 tyo;
+       mkclass(Pcl_fun(l, o, p, $3)) }
   | labeled_simple_pattern class_fun_def
-      { let (l,o,p) = $1 in mkclass(Pcl_fun(l, o, p, $2)) }
+      { let (l,tyo,o,p) = $1 in
+       class_typed_opt_error 1 tyo;
+       mkclass(Pcl_fun(l, o, p, $2)) }
 ;
 class_expr:
     class_simple_expr
@@ -1269,36 +1286,41 @@ seq_expr:
 ;
 labeled_simple_pattern:
     QUESTION LPAREN label_let_pattern opt_default RPAREN
-      { (Optional (fst $3), $4, snd $3) }
+      { mk_opt $3 $4 }
   | QUESTION label_var
-      { (Optional (fst $2), None, snd $2) }
+      { mk_opt ($2) (None,None) }
   | OPTLABEL LPAREN let_pattern opt_default RPAREN
-      { (Optional $1, $4, $3) }
-  | OPTLABEL pattern_var
-      { (Optional $1, None, $2) }
+      { mk_opt ($1,$3) $4 }
+| OPTLABEL QUESTION LPAREN constrain RPAREN
+      { let t1,t2, _ = $4 in mk_opt ($1, mkpat(Ppat_var (mkrhs $1 1)))
+      (None,Some (t1,t2)) }
+| OPTLABEL pattern_var
+      { mk_opt ($1,$2) (None,None) }
   | TILDE LPAREN label_let_pattern RPAREN
-      { (Labelled (fst $3), None, snd $3) }
+      { (Labelled (fst $3), None, None, snd $3) }
   | TILDE label_var
-      { (Labelled (fst $2), None, snd $2) }
+      { (Labelled (fst $2), None, None, snd $2) }
   | LABEL simple_pattern
-      { (Labelled $1, None, $2) }
+      { (Labelled $1, None, None, $2) }
   | simple_pattern
-      { (Nolabel, None, $1) }
+      { (Nolabel, None, None, $1) }
 ;
 pattern_var:
     LIDENT            { mkpat(Ppat_var (mkrhs $1 1)) }
   | UNDERSCORE        { mkpat Ppat_any }
 ;
 opt_default:
-    /* empty */                         { None }
-  | EQUAL seq_expr                      { Some $2 }
+    /* empty */                         { None, None }
+  | EQUAL seq_expr                      { Some $2, None }
+  | EQUAL seq_expr COLON constrain     { let t1, t2, _ = $4 in Some $2, Some(t1,t2) }
 ;
 label_let_pattern:
     label_var
       { $1 }
   | label_var COLON core_type
       { let (lab, pat) = $1 in (lab, mkpat(Ppat_constraint(pat, $3))) }
 ;
+;
 label_var:
     LIDENT    { ($1, mkpat(Ppat_var (mkrhs $1 1))) }
 ;
@@ -1324,8 +1346,8 @@ expr:
   | FUNCTION ext_attributes opt_bar match_cases
       { mkexp_attrs (Pexp_function(List.rev $4)) $2 }
   | FUN ext_attributes labeled_simple_pattern fun_def
-      { let (l,o,p) = $3 in
-        mkexp_attrs (Pexp_fun(l, o, p, $4)) $2 }
+      { let (l,tyo,o,p) = $3 in
+        mkexp_attrs (Pexp_fun(l,tyo, o, p, $4)) $2 }
   | FUN ext_attributes LPAREN TYPE lident_list RPAREN fun_def
       { mkexp_attrs (mk_newtypes $5 $7).pexp_desc $2 }
   | MATCH ext_attributes seq_expr WITH opt_bar match_cases
@@ -1609,7 +1631,7 @@ strict_binding:
     EQUAL seq_expr
       { $2 }
   | labeled_simple_pattern fun_binding
-      { let (l, o, p) = $1 in ghexp(Pexp_fun(l, o, p, $2)) }
+      { let (l, tyo, o, p) = $1 in ghexp(Pexp_fun(l, tyo, o, p, $2)) }
   | LPAREN TYPE lident_list RPAREN fun_binding
       { mk_newtypes $3 $5 }
 ;
@@ -1633,8 +1655,8 @@ fun_def:
 /* Cf #5939: we used to accept (fun p when e0 -> e) */
   | labeled_simple_pattern fun_def
       {
-       let (l,o,p) = $1 in
-       ghexp(Pexp_fun(l, o, p, $2))
+       let (l,tyo,o,p) = $1 in
+       ghexp(Pexp_fun(l, tyo, o, p, $2))
       }
   | LPAREN TYPE lident_list RPAREN fun_def
       { mk_newtypes $3 $5 }
@@ -2177,17 +2199,31 @@ core_type2:
       { $1 }
   | QUESTION LIDENT COLON core_type2 MINUSGREATER core_type2
       { let param = extra_rhs_core_type $4 ~pos:4 in
-        mktyp (Ptyp_arrow(Optional $2 , param, $6)) }
+        mktyp (Ptyp_arrow(Optional $2 , None, param, $6)) }
+  | QUESTION LIDENT COLON QUESTION LPAREN constrain RPAREN MINUSGREATER core_type2
+      {
+        let gen, default, _ = $6 in
+        let param = extra_rhs_core_type gen ~pos:6 in
+        mktyp (Ptyp_arrow(Typed_optional $2 , Some default, param, $9))
+      }
+
+  | OPTLABEL QUESTION LPAREN constrain RPAREN MINUSGREATER core_type2
+      {
+        let gen, default, _ = $4 in
+        let param = extra_rhs_core_type gen ~pos:4 in
+        mktyp(Ptyp_arrow(Typed_optional $1 , Some default, param, $7))
+      }
   | OPTLABEL core_type2 MINUSGREATER core_type2
-      { let param = extra_rhs_core_type $2 ~pos:2 in
-        mktyp(Ptyp_arrow(Optional $1 , param, $4))
+      {
+        let param = extra_rhs_core_type $2 ~pos:2 in
+        mktyp(Ptyp_arrow(Optional $1 , None, param, $4))
       }
   | LIDENT COLON core_type2 MINUSGREATER core_type2
       { let param = extra_rhs_core_type $3 ~pos:3 in
-        mktyp(Ptyp_arrow(Labelled $1, param, $5)) }
+        mktyp(Ptyp_arrow(Labelled $1, None, param, $5)) }
   | core_type2 MINUSGREATER core_type2
       { let param = extra_rhs_core_type $1 ~pos:1 in
-        mktyp(Ptyp_arrow(Nolabel, param, $3)) }
+        mktyp(Ptyp_arrow(Nolabel, None, param, $3)) }
 ;
 
 simple_core_type: