From a74ad3a02276a733bca729b175983281a4eb6e50 Mon Sep 17 00:00:00 2001 From: octachron Date: Mon, 30 Jan 2017 22:19:22 +0100 Subject: [PATCH] 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. --- parsing/ast_helper.ml | 15 +- parsing/ast_helper.mli | 16 +- parsing/ast_iterator.ml | 7 +- parsing/ast_mapper.ml | 11 +- parsing/asttypes.mli | 1 + parsing/depend.ml | 16 +- parsing/parser.mly | 84 ++++++--- parsing/parsetree.mli | 34 ++-- parsing/pprintast.ml | 49 +++-- parsing/printast.ml | 13 +- testsuite/tests/parsetree/source.ml | 10 + testsuite/tests/typing-misc/typed_optional.ml | 36 ++++ tools/ocamlprof.ml | 2 +- typing/btype.ml | 8 +- typing/oprint.ml | 2 + typing/outcometree.mli | 1 + typing/predef.ml | 30 ++- typing/predef.mli | 2 + typing/printtyp.ml | 5 +- typing/printtyped.ml | 1 + typing/typecore.ml | 173 ++++++++++++++---- typing/typedecl.ml | 2 +- typing/typetexp.ml | 10 +- typing/untypeast.ml | 10 +- 24 files changed, 413 insertions(+), 125 deletions(-) create mode 100644 testsuite/tests/typing-misc/typed_optional.ml diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml index ac1fc40da5ce..d1e91086789b 100644 --- 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 index 0a216bdb56ea..a57dd7255121 100644 --- 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 index 8518438d829c..9d311877b038 100755 --- 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 index d58663ec26e0..813db52135f6 100644 --- 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 index 8cab1c6b8566..c9cc69972883 100644 --- 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 index 8703ffe0199f..46479af3c8bb 100644 --- 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 index f444810ede9d..65899fbf824b 100644 --- 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,7 +1023,9 @@ 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*/ { [] } @@ -1020,9 +1033,13 @@ class_type_parameters: ; 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,29 +1286,33 @@ 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 @@ -1299,6 +1320,7 @@ label_let_pattern: | 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: diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index 1155ddc9ec0f..1102e7a0e6da 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -78,10 +78,11 @@ and core_type_desc = (* _ *) | Ptyp_var of string (* 'a *) - | Ptyp_arrow of arg_label * core_type * core_type - (* T1 -> T2 Simple - ~l:T1 -> T2 Labelled - ?l:T1 -> T2 Otional + | Ptyp_arrow of arg_label * core_type option * core_type * core_type + (* T1 -> T2 Simple + ~l:T1 -> T2 Labelled + ?l:T1 -> T2 Optional + ?l:(T1 = T2) Typed_optional *) | Ptyp_tuple of core_type list (* T1 * ... * Tn @@ -245,11 +246,15 @@ and expression_desc = *) | Pexp_function of case list (* function P1 -> E1 | ... | Pn -> En *) - | Pexp_fun of arg_label * expression option * pattern * expression - (* fun P -> E1 (Simple, None) - fun ~l:P -> E1 (Labelled l, None) - fun ?l:P -> E1 (Optional l, None) - fun ?l:(P = E0) -> E1 (Optional l, Some E0) + | Pexp_fun of arg_label + * (core_type * core_type) option * expression option * pattern * expression + (* fun P -> E1 (Simple, None, None) + fun ~l:P -> E1 (Labelled l, None, None) + fun ?l:P -> E1 (Optional l, None, None) + fun ?l:(P = E0) -> E1 (Optional l, None, Some E0) + fun ?l:(P = E0: t1 = t2) -> E1 (Typed_optional l, Some(t1,t2), Some E0) + fun ?l:?(t1 = t2) -> E1 (Typed_optional l, Some(t1,t2), None) + Notes: - If E0 is provided, only Optional is allowed. @@ -570,11 +575,12 @@ and class_expr_desc = ['a1, ..., 'an] c *) | Pcl_structure of class_structure (* object ... end *) - | Pcl_fun of arg_label * expression option * pattern * class_expr - (* fun P -> CE (Simple, None) - fun ~l:P -> CE (Labelled l, None) - fun ?l:P -> CE (Optional l, None) - fun ?l:(P = E0) -> CE (Optional l, Some E0) + | Pcl_fun of arg_label * expression option * pattern * class_expr + (* fun P -> CE (Simple, None) + fun ~l:P -> CE (Labelled l, None) + fun ?l:P -> CE (Optional l, None) + (Optional argument with default type are not allowed in class context) + *) | Pcl_apply of class_expr * (arg_label * expression) list (* CE ~l1:E1 ... ~ln:En diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml index bf1fd14dd2aa..b6e2168de034 100644 --- a/parsing/pprintast.ml +++ b/parsing/pprintast.ml @@ -228,11 +228,16 @@ let rec class_params_def ctxt f = function pp f "[%a] " (* space *) (list (type_param ctxt) ~sep:",") l -and type_with_label ctxt f (label, c) = +and type_with_label ctxt f (label,tyo, c) = match label with | Nolabel -> core_type1 ctxt f c (* otherwise parenthesize *) | Labelled s -> pp f "%s:%a" s (core_type1 ctxt) c | Optional s -> pp f "?%s:%a" s (core_type1 ctxt) c + | Typed_optional s -> + match tyo with + | None -> assert false + | Some default -> + pp f "?%s:?(%a=%a)" s (core_type1 ctxt) c (core_type1 ctxt) default and core_type ctxt f x = if x.ptyp_attributes <> [] then begin @@ -240,9 +245,9 @@ and core_type ctxt f x = (attributes ctxt) x.ptyp_attributes end else match x.ptyp_desc with - | Ptyp_arrow (l, ct1, ct2) -> + | Ptyp_arrow (l, tyo, ct1, ct2) -> pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *) - (type_with_label ctxt) (l,ct1) (core_type ctxt) ct2 + (type_with_label ctxt) (l,tyo,ct1) (core_type ctxt) ct2 | Ptyp_alias (ct, s) -> pp f "@[<2>%a@;as@;'%s@]" (core_type1 ctxt) ct s | Ptyp_poly (sl, ct) -> @@ -421,23 +426,33 @@ and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit = (paren with_paren @@ pattern1 ctxt) p | _ -> paren true (pattern ctxt) f x -and label_exp ctxt f (l,opt,p) = +and pp_tyopt pre post ctxt f = function + | None -> () + | Some (a,b) -> + pp f "%s%a=%a%s" pre (core_type1 ctxt) a (core_type1 ctxt) b post + +and label_exp ctxt f (l, tyopt, opt,p) = match l with | Nolabel -> (* single case pattern parens needed here *) pp f "%a@ " (simple_pattern ctxt) p - | Optional rest -> + | Optional rest | Typed_optional rest -> begin match p.ppat_desc with | Ppat_var {txt;_} when txt = rest -> (match opt with - | Some o -> pp f "?(%s=@;%a)@;" rest (expression ctxt) o - | None -> pp f "?%s@ " rest) + | Some o -> pp f "?(%s=@;%a%a)@;" rest (expression ctxt) o + (pp_tyopt ":" "" ctxt) tyopt + | None -> pp f "?%s%a@ " rest (pp_tyopt ":?(" ")" ctxt) tyopt + ) | _ -> (match opt with | Some o -> - pp f "?%s:(%a=@;%a)@;" + pp f "?%s:(%a=@;%a@;%a)@;" rest (pattern1 ctxt) p (expression ctxt) o - | None -> pp f "?%s:%a@;" rest (simple_pattern ctxt) p) + (pp_tyopt ":" "" ctxt) tyopt + | None -> pp f "?%s:%a%a@;" rest (simple_pattern ctxt) p + (pp_tyopt ":(" ")" ctxt) tyopt + ) end | Labelled l -> match p.ppat_desc with | Ppat_var {txt;_} when txt = l -> @@ -500,9 +515,9 @@ and expression ctxt f x = | Pexp_let _ | Pexp_letmodule _ | Pexp_open _ | Pexp_letexception _ when ctxt.semi -> paren true (expression reset_ctxt) f x - | Pexp_fun (l, e0, p, e) -> + | Pexp_fun (l, tyo, e0, p, e) -> pp f "@[<2>fun@;%a@;->@;%a@]" - (label_exp ctxt) (l, e0, p) + (label_exp ctxt) (l, tyo, e0, p) (expression ctxt) e | Pexp_function l -> pp f "@[function%a@]" (case_list ctxt) l @@ -775,7 +790,7 @@ and class_type ctxt f x = (attributes ctxt) x.pcty_attributes | Pcty_arrow (l, co, cl) -> pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *) - (type_with_label ctxt) (l,co) + (type_with_label ctxt) (l,None,co) (class_type ctxt) cl | Pcty_extension e -> extension ctxt f e; @@ -874,7 +889,7 @@ and class_expr ctxt f x = | Pcl_structure (cs) -> class_structure ctxt f cs | Pcl_fun (l, eo, p, e) -> pp f "fun@ %a@ ->@ %a" - (label_exp ctxt) (l,eo,p) + (label_exp ctxt) (l, None, eo,p) (class_expr ctxt) e | Pcl_let (rf, l, ce) -> pp f "%a@ in@ %a" @@ -1072,12 +1087,12 @@ and binding ctxt f {pvb_pat=p; pvb_expr=x; _} = let rec pp_print_pexp_function f x = if x.pexp_attributes <> [] then pp f "=@;%a" (expression ctxt) x else match x.pexp_desc with - | Pexp_fun (label, eo, p, e) -> + | Pexp_fun (label, tyo, eo, p, e) -> if label=Nolabel then pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function e else pp f "%a@ %a" - (label_exp ctxt) (label,eo,p) pp_print_pexp_function e + (label_exp ctxt) (label, tyo, eo,p) pp_print_pexp_function e | Pexp_newtype (str,e) -> pp f "(type@ %s)@ %a" str.txt pp_print_pexp_function e | _ -> pp f "=@;%a" (expression ctxt) x @@ -1199,7 +1214,7 @@ and structure_item ctxt f x = let rec loop acc cl = match cl.pcl_desc with | Pcl_fun (l, eo, p, cl') when cl.pcl_attributes = [] -> - loop ((l,eo,p) :: acc) cl' + loop ((l,None,eo,p) :: acc) cl' | _ -> List.rev acc, cl in let args, cl = loop [] cl in @@ -1417,7 +1432,7 @@ and label_x_expression_param ctxt f (l,e) = | _ -> None in match l with | Nolabel -> expression2 ctxt f e (* level 2*) - | Optional str -> + | Optional str | Typed_optional str -> if Some str = simple_name then pp f "?%s" str else diff --git a/parsing/printast.ml b/parsing/printast.ml index 6e167b3e47be..ca3ba6b4093e 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -129,12 +129,19 @@ let option i f ppf x = f (i+1) ppf x; ;; +let pair f g i ppf (x,y) = + f (i+1) ppf x; + g (i+1) ppf y + + + let longident_loc i ppf li = line i ppf "%a\n" fmt_longident_loc li;; let string i ppf s = line i ppf "\"%s\"\n" s;; let string_loc i ppf s = line i ppf "%a\n" fmt_string_loc s;; let arg_label i ppf = function | Nolabel -> line i ppf "Nolabel\n" | Optional s -> line i ppf "Optional \"%s\"\n" s + | Typed_optional s -> line i ppf "Typed optional \"%s\"\n" s | Labelled s -> line i ppf "Labelled \"%s\"\n" s ;; @@ -145,9 +152,10 @@ let rec core_type i ppf x = match x.ptyp_desc with | Ptyp_any -> line i ppf "Ptyp_any\n"; | Ptyp_var (s) -> line i ppf "Ptyp_var %s\n" s; - | Ptyp_arrow (l, ct1, ct2) -> + | Ptyp_arrow (l, oty, ct1, ct2) -> line i ppf "Ptyp_arrow\n"; arg_label i ppf l; + option i core_type ppf oty; core_type i ppf ct1; core_type i ppf ct2; | Ptyp_tuple l -> @@ -259,9 +267,10 @@ and expression i ppf x = | Pexp_function l -> line i ppf "Pexp_function\n"; list i case ppf l; - | Pexp_fun (l, eo, p, e) -> + | Pexp_fun (l, tyo, eo, p, e) -> line i ppf "Pexp_fun\n"; arg_label i ppf l; + option i (pair core_type core_type) ppf tyo; option i expression ppf eo; pattern i ppf p; expression i ppf e; diff --git a/testsuite/tests/parsetree/source.ml b/testsuite/tests/parsetree/source.ml index cbb96405456d..19ab5cdd30cc 100644 --- a/testsuite/tests/parsetree/source.ml +++ b/testsuite/tests/parsetree/source.ml @@ -7263,3 +7263,13 @@ let foo : type a' b'. a' -> b' = fun a -> assert false let foo : type t' . t' = fun (type t') -> (assert false : t') let foo : 't . 't = fun (type t) -> (assert false : t) let foo : type a' b' c' t. a' -> b' -> c' -> t = fun a b c -> assert false + + +(* Typed optional argument *) +type 'a t = ?x:?('a = int) -> unit -> 'a +let f (type a) ?(x=0: a = int) : unit -> a = fun () -> x +let filter (type a b) ?map:?(a -> b = a -> a) (pred: b -> bool): a list -> a list = + match map with + | Default -> List.filter pred + | Specific map -> List.filter (fun x -> pred (map x)) + diff --git a/testsuite/tests/typing-misc/typed_optional.ml b/testsuite/tests/typing-misc/typed_optional.ml new file mode 100644 index 000000000000..27b6dda4276f --- /dev/null +++ b/testsuite/tests/typing-misc/typed_optional.ml @@ -0,0 +1,36 @@ +let explicit (type a) (x: (a,int) optional): unit -> a = + match x with + | Default -> let x = 0 in fun () -> x + | Specific x -> fun () -> x;; + +let f (type a) ?( x = 0 : a = int ): unit -> a = fun () -> x;; + +let k = 1 + f ();; +let h = f ~x:"Hello" () ^" world";; +let m = f ?x:Default () + 2;; + +let filter (type a b) ?map:?(a->b=a->a) (pred: b -> bool): a list -> a list = + match map with + | Default -> List.filter pred + | Specific f -> List.filter (fun x -> pred (f x)) + +let l = filter ~map:float ( fun x -> x > 0. ) [2;5;-5;9;-3] +let l' = filter (fun x -> x < 0 ) [-5;1;8;-3];; + +let error = f () ();; + +[%%expect{| +val explicit : ('a, int) optional -> unit -> 'a = +val f : ?x:?('a=int) -> unit -> 'a = +val k : int = 1 +val h : string = "Hello world" +val m : int = 2 +val filter : ?map:?('a -> 'b='a -> 'a) -> ('b -> bool) -> 'a list -> 'a list = + +val l : int list = [2; 5; 9] +val l' : int list = [-5; -3] +Line _: +Error: This expression has type ('a -> 'b, int) optional + but an expression was expected of type ('a -> 'b, 'a -> 'b) optional + Type int is not compatible with type 'a -> 'b +|}] diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml index fb08ffd5ea10..8a7248240c30 100644 --- a/tools/ocamlprof.ml +++ b/tools/ocamlprof.ml @@ -189,7 +189,7 @@ and rw_exp iflag sexp = else rewrite_cases iflag caselist - | Pexp_fun (_, _, p, e) -> + | Pexp_fun (_, _, _, p, e) -> let l = [{pc_lhs=p; pc_guard=None; pc_rhs=e}] in if !instr_fun then rewrite_function iflag l diff --git a/typing/btype.ml b/typing/btype.ml index 686bfc442dcd..c6a0a6ae03dd 100644 --- a/typing/btype.ml +++ b/typing/btype.ml @@ -605,17 +605,21 @@ let check_memorized_abbrevs () = (* Utilities for labels *) (**********************************) -let is_optional = function Optional _ -> true | _ -> false +let is_optional = function + Optional _ | Typed_optional _ -> true | _ -> false let label_name = function Nolabel -> "" | Labelled s - | Optional s -> s + | Optional s + | Typed_optional s -> s let prefixed_label_name = function Nolabel -> "" | Labelled s -> "~" ^ s | Optional s -> "?" ^ s + | Typed_optional s -> "?" ^ s + let rec extract_label_aux hd l = function [] -> raise Not_found diff --git a/typing/oprint.ml b/typing/oprint.ml index b0145ec63206..b18eae4b5d13 100644 --- a/typing/oprint.ml +++ b/typing/oprint.ml @@ -241,6 +241,8 @@ and print_simple_out_type ppf = fprintf ppf ")@]" | Otyp_attribute (t, attr) -> fprintf ppf "@[<1>(%a [@@%s])@]" print_out_type t attr.oattr_name + | Otyp_optional_eq (t, t2) -> + fprintf ppf "@[<1>?(%a=%a)@]" print_out_type t print_out_type t2 and print_record_decl ppf lbls = fprintf ppf "{%a@;<1 -2>}" (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls diff --git a/typing/outcometree.mli b/typing/outcometree.mli index 17c4862d63b6..6f3798c6bc1f 100644 --- a/typing/outcometree.mli +++ b/typing/outcometree.mli @@ -67,6 +67,7 @@ type out_type = | Otyp_poly of string list * out_type | Otyp_module of string * string list * out_type list | Otyp_attribute of out_type * out_attribute + | Otyp_optional_eq of out_type * out_type and out_variant = | Ovar_fields of (string * bool * out_type list) list diff --git a/typing/predef.ml b/typing/predef.ml index a16997f96e6b..71b78d02ea0b 100644 --- a/typing/predef.ml +++ b/typing/predef.ml @@ -39,6 +39,7 @@ and ident_exn = ident_create "exn" and ident_array = ident_create "array" and ident_list = ident_create "list" and ident_option = ident_create "option" +and ident_optional = ident_create "optional" and ident_nativeint = ident_create "nativeint" and ident_int32 = ident_create "int32" and ident_int64 = ident_create "int64" @@ -56,6 +57,7 @@ and path_exn = Pident ident_exn and path_array = Pident ident_array and path_list = Pident ident_list and path_option = Pident ident_option +and path_optional = Pident ident_optional and path_nativeint = Pident ident_nativeint and path_int32 = Pident ident_int32 and path_int64 = Pident ident_int64 @@ -73,6 +75,8 @@ and type_exn = newgenty (Tconstr(path_exn, [], ref Mnil)) and type_array t = newgenty (Tconstr(path_array, [t], ref Mnil)) and type_list t = newgenty (Tconstr(path_list, [t], ref Mnil)) and type_option t = newgenty (Tconstr(path_option, [t], ref Mnil)) +and type_optional gen default = + newgenty (Tconstr(path_optional, [gen;default], ref Mnil)) and type_nativeint = newgenty (Tconstr(path_nativeint, [], ref Mnil)) and type_int32 = newgenty (Tconstr(path_int32, [], ref Mnil)) and type_int64 = newgenty (Tconstr(path_int64, [], ref Mnil)) @@ -139,6 +143,16 @@ let cstr id args = cd_attributes = []; } +let gadt_cstr id args res = + { + cd_id = id; + cd_args = Cstr_tuple args; + cd_res = Some res; + cd_loc = Location.none; + cd_attributes = []; + } + + let ident_false = ident_create "false" and ident_true = ident_create "true" and ident_void = ident_create "()" @@ -146,6 +160,8 @@ and ident_nil = ident_create "[]" and ident_cons = ident_create "::" and ident_none = ident_create "None" and ident_some = ident_create "Some" +and ident_default = ident_create "Default" +and ident_custom = ident_create "Specific" let common_initial_env add_type add_extension empty_env = let decl_bool = {decl_abstr with @@ -179,6 +195,17 @@ let common_initial_env add_type add_extension empty_env = type_arity = 1; type_kind = Type_variant([cstr ident_none []; cstr ident_some [tvar]]); type_variance = [Variance.covariant]} + and decl_optional = + let tvar = newgenvar() and tvar2 = newgenvar () in + {decl_abstr with + type_params = [tvar;tvar2]; + type_arity = 2; + type_kind = Type_variant [ + gadt_cstr ident_default [] (type_optional tvar2 tvar2) ; + gadt_cstr ident_custom [tvar] (type_optional tvar tvar2) + ]; + type_variance = [Variance.full; Variance.full] + } and decl_lazy_t = let tvar = newgenvar() in {decl_abstr with @@ -219,6 +246,7 @@ let common_initial_env add_type add_extension empty_env = add_type ident_nativeint decl_abstr ( add_type ident_lazy_t decl_lazy_t ( add_type ident_option decl_option ( + add_type ident_optional decl_optional ( add_type ident_list decl_list ( add_type ident_array decl_array ( add_type ident_exn decl_exn ( @@ -229,7 +257,7 @@ let common_initial_env add_type add_extension empty_env = add_type ident_char decl_abstr_imm ( add_type ident_int decl_abstr_imm ( add_type ident_extension_constructor decl_abstr ( - empty_env))))))))))))))))))))))))))) + empty_env)))))))))))))))))))))))))))) let build_initial_env add_type add_exception empty_env = let common = common_initial_env add_type add_exception empty_env in diff --git a/typing/predef.mli b/typing/predef.mli index a7bf06342454..1ac2d2ec15d9 100644 --- a/typing/predef.mli +++ b/typing/predef.mli @@ -28,6 +28,7 @@ val type_exn: type_expr val type_array: type_expr -> type_expr val type_list: type_expr -> type_expr val type_option: type_expr -> type_expr +val type_optional : type_expr -> type_expr -> type_expr val type_nativeint: type_expr val type_int32: type_expr val type_int64: type_expr @@ -45,6 +46,7 @@ val path_exn: Path.t val path_array: Path.t val path_list: Path.t val path_option: Path.t +val path_optional: Path.t val path_nativeint: Path.t val path_int32: Path.t val path_int64: Path.t diff --git a/typing/printtyp.ml b/typing/printtyp.ml index f97a498858b7..872c275487b3 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -139,7 +139,7 @@ let print_name ppf = function let string_of_label = function Nolabel -> "" | Labelled s -> s - | Optional s -> "?"^s + | Optional s | Typed_optional s -> "?"^s let visited = ref [] let rec raw_type ppf ty = @@ -573,6 +573,9 @@ let rec tree_of_typexp sch ty = | Tconstr(path, [ty], _) when Path.same path Predef.path_option -> tree_of_typexp sch ty + | Tconstr (path,[ty1;ty2], _ ) + when Path.same path Predef.path_optional -> + Otyp_optional_eq(tree_of_typexp sch ty1, tree_of_typexp sch ty2) | _ -> Otyp_stuff "" else tree_of_typexp sch ty1 in Otyp_arrow (lab, t1, tree_of_typexp sch ty2) in diff --git a/typing/printtyped.ml b/typing/printtyped.ml index 78e1b60a5b6e..d5428824f8c7 100644 --- a/typing/printtyped.ml +++ b/typing/printtyped.ml @@ -144,6 +144,7 @@ let string i ppf s = line i ppf "\"%s\"\n" s;; let arg_label i ppf = function | Nolabel -> line i ppf "Nolabel\n" | Optional s -> line i ppf "Optional \"%s\"\n" s + | Typed_optional s -> line i ppf "Typed optional \"%s\"\n" s | Labelled s -> line i ppf "Labelled \"%s\"\n" s ;; diff --git a/typing/typecore.ml b/typing/typecore.ml index f80b81beaac9..d64d474bae55 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -142,7 +142,7 @@ let iter_expression f e = | Pexp_new _ | Pexp_constant _ -> () | Pexp_function pel -> List.iter case pel - | Pexp_fun (_, eo, _, e) -> may expr eo; expr e + | Pexp_fun (_, _, eo, _, e) -> may expr eo; expr e | Pexp_apply (e, lel) -> expr e; List.iter (fun (_, e) -> expr e) lel | Pexp_let (_, pel, e) -> expr e; List.iter binding pel | Pexp_match (e, pel) @@ -302,25 +302,41 @@ let constant_or_raise env loc cst = let type_option ty = newty (Tconstr(Predef.path_option,[ty], ref Mnil)) +let type_optional ty ty2= + newty (Tconstr(Predef.path_optional,[ty;ty2], ref Mnil)) + let mkexp exp_desc exp_type exp_loc exp_env = { exp_desc; exp_type; exp_loc; exp_env; exp_extra = []; exp_attributes = [] } + +let default_type () = + let tvar = newvar () in + type_optional tvar tvar + let option_none ty loc = - let lid = Longident.Lident "None" + let lid = Longident.Lident "None" and env = Env.initial_safe_string in let cnone = Env.lookup_constructor lid env in mkexp (Texp_construct(mknoloc lid, cnone, [])) ty loc env -let option_some texp = - let lid = Longident.Lident "Some" in +let option_some_t typed texp = + let lid = Longident.Lident (if typed then "Specific" else "Some") in let csome = Env.lookup_constructor lid Env.initial_safe_string in mkexp ( Texp_construct(mknoloc lid , csome, [texp]) ) (type_option texp.exp_type) texp.exp_loc texp.exp_env -let extract_option_type env ty = - match expand_head env ty with {desc = Tconstr(path, [ty], _)} - when Path.same path Predef.path_option -> ty +let option_some = option_some_t false + +let extract_option_type_t typed env ty = + match expand_head env ty with + | {desc = Tconstr(path, [ty], _)} + when not typed && Path.same path Predef.path_option -> ty + | {desc = Tconstr(path, [ty; _default], _)} + when typed && Path.same path Predef.path_optional -> ty | _ -> assert false +let extract_option_type = extract_option_type_t false + +let typed_optional = function Typed_optional _ -> true | _ -> false let extract_concrete_record env ty = match extract_concrete_typedecl env ty with @@ -364,6 +380,14 @@ let unify_exp_types loc env ty expected_ty = | Tags(l1,l2) -> raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2))) +(* Generated optional default *) +let optional_default env ty loc = + let () = unify_exp_types loc env ty (default_type ()) in + let lid = Longident.Lident "Default" + and env = Env.initial_safe_string in + let cnone = Env.lookup_constructor lid env in + mkexp (Texp_construct(mknoloc lid, cnone, [])) ty loc env + (* level at which to create the local type declarations *) let newtype_level = ref None let get_newtype_level () = @@ -1656,10 +1680,18 @@ and is_nonexpansive_opt = function (* Approximate the type of an expression, for better recursion *) +let opt_approx p tyo = + if is_optional p then + match tyo with + | Some _default -> type_optional (newvar()) (newvar ()) + | None -> type_option (newvar()) + else + newvar () + let rec approx_type env sty = match sty.ptyp_desc with - Ptyp_arrow (p, _, sty) -> - let ty1 = if is_optional p then type_option (newvar ()) else newvar () in + Ptyp_arrow (p, tyo, _, sty) -> + let ty1 = opt_approx p tyo in newty (Tarrow (p, ty1, approx_type env sty, Cok)) | Ptyp_tuple args -> newty (Ttuple (List.map (approx_type env) args)) @@ -1679,8 +1711,8 @@ let rec approx_type env sty = let rec type_approx env sexp = match sexp.pexp_desc with Pexp_let (_, _, e) -> type_approx env e - | Pexp_fun (p, _, _, e) -> - let ty = if is_optional p then type_option (newvar ()) else newvar () in + | Pexp_fun (p, tyo, _, _, e) -> + let ty = opt_approx p tyo in newty (Tarrow(p, ty, type_approx env e, Cok)) | Pexp_function ({pc_rhs=e}::_) -> newty (Tarrow(Nolabel, newvar (), type_approx env e, Cok)) @@ -2074,7 +2106,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected = exp_type = body.exp_type; exp_attributes = sexp.pexp_attributes; exp_env = env } - | Pexp_fun (l, Some default, spat, sbody) -> + | Pexp_fun (l, None, Some default, spat, sbody) -> assert(is_optional l); (* default allowed only with optional argument *) let open Ast_helper in let default_loc = default.pexp_loc in @@ -2109,7 +2141,66 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected = in type_function ?in_function loc sexp.pexp_attributes env ty_expected l [Exp.case pat body] - | Pexp_fun (l, None, spat, sbody) -> + | Pexp_fun (l, Some (ty1,ty2),default , spat, sbody) -> + assert(is_optional l); + (* default types are allowed only with typed optional argument *) + let open Ast_helper in + let constrain pat = + let typ = Typ.constr + (mknoloc @@ Longident.Lident "optional") [ty1;ty2] in + Pat.constraint_ ~loc:pat.ppat_loc pat typ in + let lident x = mknoloc @@ Longident.Lident x in + let f_name = "*opttyped_fn*" in + let f = Exp.ident ~loc (lident f_name) in + let let_f_in = + let body = Exp.fun_ ~loc Nolabel None spat sbody in + let name = Pat.var ~loc (mknoloc f_name) in + Exp.let_ ~loc Nonrecursive [Vb.mk name body] in + type_function ?in_function loc sexp.pexp_attributes env ty_expected l @@ + begin match default with + | None -> [Exp.case (constrain spat) sbody] + | Some default -> + let reconstraint body = match sbody.pexp_desc with + | Pexp_constraint (_, ct) -> + { body with pexp_desc = Pexp_constraint(body,ct) } + | _ -> body in + let default_loc = default.pexp_loc in + let sth = + Exp.ident ~loc:default_loc (mknoloc @@ Longident.Lident "*sth*") in + let (<*>) f x = + Exp.apply ~loc f [Nolabel, x] in + let scases = + [ + Exp.case + (Pat.construct ~loc:default_loc + (lident "Specific") + (Some (Pat.var ~loc:default_loc (mknoloc "*sth*"))) + ) + ( f <*> sth) + ; + + Exp.case + (Pat.construct ~loc:default_loc + (lident "Default") + None + ) + (f <*> default) + ] in + let sloc = + { Location.loc_start = spat.ppat_loc.Location.loc_start; + loc_end = default_loc.Location.loc_end; + loc_ghost = true } + in + let smatch = + let_f_in @@ + Exp.match_ ~loc:sloc + (Exp.ident ~loc (mknoloc (Longident.Lident "*opt*"))) + scases + in + let pat = constrain @@ Pat.var ~loc:sloc (mkloc "*opt*" sloc) in + [Exp.case pat @@ reconstraint smatch] + end + | Pexp_fun (l, None, None, spat, sbody) -> type_function ?in_function loc sexp.pexp_attributes env ty_expected l [Ast_helper.Exp.case spat sbody] | Pexp_function caselist -> @@ -3028,14 +3119,22 @@ and type_function ?in_function loc attrs env ty_expected l caselist = Too_many_arguments (in_function <> None, ty_fun))) in let ty_arg = - if is_optional l then - let tv = newvar() in - begin - try unify env ty_arg (type_option tv) - with Unify _ -> assert false - end; - type_option tv - else ty_arg + match l with + | Optional _ -> + let tv = newvar() in + begin + try unify env ty_arg (type_option tv) + with Unify _ -> assert false + end; + type_option tv + | Typed_optional _ -> + let tv1, tv2 = newvar(), newvar () in + begin + try unify env ty_arg (type_optional tv1 tv2) + with Unify _ -> assert false + end; + type_optional tv1 tv2 + | Labelled _ | Nolabel -> ty_arg in if separate then begin end_def (); @@ -3411,9 +3510,12 @@ and type_argument ?recarg env sarg ty_expected' ty_expected = end; let rec make_args args ty_fun = match (expand_head env ty_fun).desc with - | Tarrow (l,ty_arg,ty_fun,_) when is_optional l -> + | Tarrow (Optional _ as l,ty_arg,ty_fun,_) -> let ty = option_none (instance env ty_arg) sarg.pexp_loc in make_args ((l, Some ty) :: args) ty_fun + | Tarrow (Typed_optional _ as l ,ty_arg,ty_fun,_) -> + let ty = optional_default env (instance env ty_arg) sarg.pexp_loc in + make_args ((l, Some ty) :: args) ty_fun | Tarrow (l,_,ty_res',_) when l = Nolabel || !Clflags.classic -> List.rev args, ty_fun, no_labels ty_res' | Tvar _ -> List.rev args, ty_fun, false @@ -3534,11 +3636,13 @@ and type_application env funct sargs = raise(Error(funct.exp_loc, env, Apply_non_function (expand_head env funct.exp_type))) in - let optional = is_optional l1 in let arg1 () = let arg1 = type_expect env sarg1 ty1 in - if optional then - unify_exp env arg1 (type_option(newvar())); + (match l1 with + | Optional _ -> unify_exp env arg1 (type_option(newvar())) + | Typed_optional _ -> unify_exp env arg1 + (type_optional(newvar())(newvar())) + | Labelled _ | Nolabel -> () ) ; arg1 in type_unknown_args ((l1, Some arg1) :: args) omitted ty2 sargl @@ -3588,7 +3692,8 @@ and type_application env funct sargs = Apply_wrong_label(l', ty_fun'))) else ([], more_sargs, - Some (fun () -> type_argument env sarg0 ty ty0)) + Some (fun () -> + type_argument env sarg0 ty ty0)) | _ -> assert false end else try @@ -3616,9 +3721,12 @@ and type_application env funct sargs = else begin may_warn sarg0.pexp_loc (Warnings.Not_principal "using an optional argument here"); - Some (fun () -> option_some (type_argument env sarg0 - (extract_option_type env ty) - (extract_option_type env ty0))) + Some (fun () -> + let typed = typed_optional l in + option_some_t typed (type_argument env sarg0 + (extract_option_type_t typed env ty) + (extract_option_type_t typed env ty0)) + ) end with Not_found -> sargs, more_sargs, @@ -3629,7 +3737,10 @@ and type_application env funct sargs = may_warn funct.exp_loc (Warnings.Without_principality "eliminated optional argument"); ignored := (l,ty,lv) :: !ignored; - Some (fun () -> option_none (instance env ty) Location.none) + Some (fun () -> + (if typed_optional l then (optional_default env) + else option_none) + (instance env ty) funct.exp_loc) end else begin may_warn funct.exp_loc (Warnings.Without_principality "commuted an argument"); @@ -3788,7 +3899,7 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist = let contains_polyvars = List.exists contains_polymorphic_variant patterns in let erase_either = contains_polyvars && contains_variant_either ty_arg and has_gadts = List.exists (contains_gadt env) patterns in -(* prerr_endline ( if has_gadts then "contains gadt" else "no gadt"); *) + (* prerr_endline ( if has_gadts then "contains gadt" else "no gadt");*) let ty_arg = if (has_gadts || erase_either) && not !Clflags.principal then correct_levels ty_arg else ty_arg diff --git a/typing/typedecl.ml b/typing/typedecl.ml index fde3963ced6c..9c90257b08b7 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -1618,7 +1618,7 @@ let rec parse_native_repr_attributes env core_type ty ~global_repr = with | Ptyp_arrow _, Tarrow _, Native_repr_attr_present kind -> raise (Error (core_type.ptyp_loc, Cannot_unbox_or_untag_type kind)) - | Ptyp_arrow (_, ct1, ct2), Tarrow (_, t1, t2, _), _ -> + | Ptyp_arrow (_,_, ct1, ct2), Tarrow (_, t1, t2, _), _ -> let repr_arg = make_native_repr env ct1 t1 ~global_repr in let repr_args, repr_res = parse_native_repr_attributes env ct2 t2 ~global_repr diff --git a/typing/typetexp.ml b/typing/typetexp.ml index 81bad9dd4d59..90cb7cdea5b4 100644 --- a/typing/typetexp.ml +++ b/typing/typetexp.ml @@ -324,13 +324,19 @@ let rec transl_type env policy styp = end in ctyp (Ttyp_var name) ty - | Ptyp_arrow(l, st1, st2) -> + | Ptyp_arrow(l, tyo, st1, st2) -> let cty1 = transl_type env policy st1 in let cty2 = transl_type env policy st2 in let ty1 = cty1.ctyp_type in let ty1 = if Btype.is_optional l - then newty (Tconstr(Predef.path_option,[ty1], ref Mnil)) + then + match tyo with + | None -> newty (Tconstr(Predef.path_option,[ty1], ref Mnil)) + | Some st3 -> + let cty3 = transl_type env policy st3 in + let ty3 = cty3.ctyp_type in + newty (Tconstr(Predef.path_optional,[ty1;ty3], ref Mnil)) else ty1 in let ty = newty (Tarrow(l, ty1, cty2.ctyp_type, Cok)) in ctyp (Ttyp_arrow (l, cty1, cty2)) ty diff --git a/typing/untypeast.ml b/typing/untypeast.ml index 0cb58f484a68..7e079844cf33 100644 --- a/typing/untypeast.ml +++ b/typing/untypeast.ml @@ -367,15 +367,17 @@ let expression sub exp = (* One case, no guard: It's a fun. *) | Texp_function { arg_label; cases = [{c_lhs=p; c_guard=None; c_rhs=e}]; _ } -> - Pexp_fun (arg_label, None, sub.pat sub p, sub.expr sub e) + Pexp_fun (arg_label, None, None, sub.pat sub p, sub.expr sub e) (* No label: it's a function. *) | Texp_function { arg_label = Nolabel; cases; _; } -> Pexp_function (sub.cases sub cases) (* Mix of both, we generate `fun ~label:$name$ -> match $name$ with ...` *) - | Texp_function { arg_label = Labelled s | Optional s as label; cases; + | Texp_function { + arg_label = Labelled s | Optional s | Typed_optional s as label; + cases; _ } -> let name = fresh_name s exp.exp_env in - Pexp_fun (label, None, Pat.var ~loc {loc;txt = name }, + Pexp_fun (label, None, None, Pat.var ~loc {loc;txt = name }, Exp.match_ ~loc (Exp.ident ~loc {loc;txt= Lident name}) (sub.cases sub cases)) | Texp_apply (exp, list) -> @@ -679,7 +681,7 @@ let core_type sub ct = Ttyp_any -> Ptyp_any | Ttyp_var s -> Ptyp_var s | Ttyp_arrow (label, ct1, ct2) -> - Ptyp_arrow (label, sub.typ sub ct1, sub.typ sub ct2) + Ptyp_arrow (label, None, sub.typ sub ct1, sub.typ sub ct2) | Ttyp_tuple list -> Ptyp_tuple (List.map (sub.typ sub) list) | Ttyp_constr (_path, lid, list) -> Ptyp_constr (map_loc sub lid,