diff --git a/src/reason-parser/reason_parser.mly b/src/reason-parser/reason_parser.mly index 224f30aaf..e9d04d25f 100644 --- a/src/reason-parser/reason_parser.mly +++ b/src/reason-parser/reason_parser.mly @@ -1664,15 +1664,16 @@ structure: ; opt_LET_MODULE_ident: - | opt_LET_MODULE as_loc(mod_ident) { $2 } - | opt_LET_MODULE as_loc(LIDENT) - { syntax_error $2.loc lowercase_module_msg; { $2 with txt = Some $2.txt } } + | opt_LET_MODULE item_extension_sugar as_loc(mod_ident) { Some $2, $3 } + | opt_LET_MODULE as_loc(mod_ident) { None, $2 } + | opt_LET_MODULE item_extension_sugar? as_loc(LIDENT) + { syntax_error $3.loc lowercase_module_msg; $2, { $3 with txt = Some $3.txt } } ; opt_LET_MODULE_REC_ident: - | opt_LET_MODULE REC as_loc(mod_ident) { $3 } - | opt_LET_MODULE REC as_loc(LIDENT) - { syntax_error $3.loc lowercase_module_msg; { $3 with txt = Some $3.txt } } + | opt_LET_MODULE item_extension_sugar? REC as_loc(mod_ident) { $2, $4 } + | opt_LET_MODULE item_extension_sugar? REC as_loc(LIDENT) + { syntax_error $4.loc lowercase_module_msg; $2, { $4 with txt = Some $4.txt } } ; structure_item: @@ -1708,11 +1709,20 @@ structure_item: { mkstr(Pstr_exception (Ast_helper.Te.mk_exception ~loc:$1.pext_loc $1)) } | item_attributes opt_LET_MODULE_ident module_binding_body { let loc = mklocation $symbolstartpos $endpos in - mkstr(Pstr_module (Ast_helper.Mb.mk $2 $3 ~attrs:$1 ~loc)) } + let ext, letmod = $2 in + wrap_str_ext + ~loc + (mkstr(Pstr_module (Ast_helper.Mb.mk letmod $3 ~attrs:$1 ~loc))) + ext + } | item_attributes opt_LET_MODULE_REC_ident module_binding_body and_module_bindings* { let loc = mklocation $symbolstartpos $endpos($2) in - mkstr (Pstr_recmodule ((Ast_helper.Mb.mk $2 $3 ~attrs:$1 ~loc) :: $4)) + let ext, letmodule = $2 in + wrap_str_ext + ~loc + (mkstr (Pstr_recmodule ((Ast_helper.Mb.mk letmodule $3 ~attrs:$1 ~loc) :: $4))) + ext } | item_attributes MODULE TYPE OF? as_loc(ident) { let loc = mklocation $symbolstartpos $endpos in @@ -1931,25 +1941,37 @@ signature_item: { Psig_exception $1 } | item_attributes opt_LET_MODULE_ident module_declaration { let loc = mklocation $symbolstartpos $endpos in - Psig_module (Ast_helper.Md.mk $2 $3 ~attrs:$1 ~loc) + let ext, letmod = $2 in + wrap_sig_ext + ~loc + (Psig_module (Ast_helper.Md.mk letmod $3 ~attrs:$1 ~loc)) + ext } | item_attributes opt_LET_MODULE_ident EQUAL as_loc(mod_longident) { let loc = mklocation $symbolstartpos $endpos in let loc_mod = mklocation $startpos($4) $endpos($4) in - Psig_module ( - Ast_helper.Md.mk - $2 + let ext, letmod = $2 in + wrap_sig_ext + ~loc + (Psig_module + (Ast_helper.Md.mk + letmod (Ast_helper.Mty.alias ~loc:loc_mod $4) ~attrs:$1 - ~loc - ) + ~loc)) + ext } | item_attributes opt_LET_MODULE as_loc(UIDENT) COLONEQUAL as_loc(mod_ext_longident) { Psig_modsubst (Ast_helper.Ms.mk $3 $5 ~attrs:$1 ~loc:(mklocation $symbolstartpos $endpos))} | item_attributes opt_LET_MODULE_REC_ident module_type_body(COLON) and_module_rec_declaration* { let loc = mklocation $symbolstartpos $endpos($3) in - Psig_recmodule (Ast_helper.Md.mk $2 $3 ~attrs:$1 ~loc :: $4) } + let ext, letmodule = $2 in + wrap_sig_ext + ~loc + (Psig_recmodule (Ast_helper.Md.mk letmodule $3 ~attrs:$1 ~loc :: $4)) + ext + } | item_attributes MODULE TYPE as_loc(ident) { let loc = mklocation $symbolstartpos $endpos in Psig_modtype (Ast_helper.Mtd.mk $4 ~attrs:$1 ~loc) @@ -2536,7 +2558,14 @@ mark_position_exp seq_expr_no_seq [@recover.expr default_expr ()] (semi): | expr semi { $1 } | opt_LET_MODULE_ident module_binding_body SEMI seq_expr(SEMI?) - { mkexp (Pexp_letmodule($1, $2, $4)) } + { let loc = mklocation $symbolstartpos $endpos in + let ext, letmod = $1 in + let exp = mkexp (Pexp_letmodule(letmod, $2, $4)) in + match ext with + | None -> exp + | Some (ext_attrs, ext_id) -> + mkexp ~loc (Pexp_extension (ext_id, PStr [mkstrexp exp ext_attrs])) + } | item_attributes LET? OPEN override_flag as_loc(mod_longident) SEMI seq_expr(SEMI?) { let loc = (mklocation $startpos($1) $endpos($4)) in let me = Ast_helper.Mod.ident ~loc $5 in diff --git a/src/reason-parser/reason_pprint_ast.ml b/src/reason-parser/reason_pprint_ast.ml index a7875fcf0..31144c30b 100644 --- a/src/reason-parser/reason_pprint_ast.ml +++ b/src/reason-parser/reason_pprint_ast.ml @@ -162,7 +162,7 @@ let expression_immediate_extension_sugar x = | Some (name, expr) -> match expr.pexp_desc with | Pexp_for _ | Pexp_while _ | Pexp_ifthenelse _ | Pexp_function _ - | Pexp_newtype _ | Pexp_try _ | Pexp_match _ -> + | Pexp_newtype _ | Pexp_try _ | Pexp_match _ (* | Pexp_letmodule _ *) -> (Some name, expr) | _ -> (None, x) @@ -5516,6 +5516,28 @@ let printer = object(self:'self) itemsLayout method letList expr = + let letModuleBinding ?extension s me = + let prefixText = add_extension_sugar "module" extension in + let bindingName = atom ~loc:s.loc (moduleIdent s) in + let moduleExpr = me in + let letModuleLayout = + (self#let_module_binding prefixText bindingName moduleExpr) in + let letModuleLoc = { + loc_start = s.loc.loc_start; + loc_end = me.pmod_loc.loc_end; + loc_ghost = false + } in + (* Just like the bindings, have to synthesize a location since the + * Pexp location is parsed (potentially) beginning with the open + * brace {} in the let sequence. *) + let layout = source_map ~loc:letModuleLoc letModuleLayout in + let (_, return) = self#curriedFunctorPatternsAndReturnStruct moduleExpr in + let loc = { + letModuleLoc with + loc_end = return.pmod_loc.loc_end + } in + (loc, layout) + in (* Recursively transform a nested ast of "let-items", into a flat * list containing the location indicating start/end of the "let-item" and * its layout. *) @@ -5576,26 +5598,8 @@ let printer = object(self:'self) processLetList ((loc, layout)::acc) e ) | ([], Pexp_letmodule (s, me, e)) -> - let prefixText = "module" in - let bindingName = atom ~loc:s.loc (moduleIdent s) in - let moduleExpr = me in - let letModuleLayout = - (self#let_module_binding prefixText bindingName moduleExpr) in - let letModuleLoc = { - loc_start = s.loc.loc_start; - loc_end = me.pmod_loc.loc_end; - loc_ghost = false - } in - (* Just like the bindings, have to synthesize a location since the - * Pexp location is parsed (potentially) beginning with the open - * brace {} in the let sequence. *) - let layout = source_map ~loc:letModuleLoc letModuleLayout in - let (_, return) = self#curriedFunctorPatternsAndReturnStruct moduleExpr in - let loc = { - letModuleLoc with - loc_end = return.pmod_loc.loc_end - } in - processLetList ((loc, layout)::acc) e + let loc, layout = letModuleBinding s me in + processLetList ((loc, layout)::acc) e | ([], Pexp_letexception (extensionConstructor, expr)) -> let exc = self#exception_declaration extensionConstructor in let layout = source_map ~loc:extensionConstructor.pext_loc exc in @@ -5623,6 +5627,9 @@ let printer = object(self:'self) let bindingsLoc = self#bindingsLocationRange ~extension:expr l in let layout = source_map ~loc:bindingsLoc bindingsLayout in processLetList ((extractLocationFromValBindList expr l, layout)::acc) e + | Some (extension, {pexp_attributes = []; pexp_desc = Pexp_letmodule (s, me, e)}) -> + let loc, layout = letModuleBinding ~extension s me in + processLetList ((loc, layout)::acc) e | Some (extension, e) -> let layout = self#attach_std_item_attrs ~extension [] (self#unparseExpr e) in (expr.pexp_loc, layout)::acc @@ -6458,7 +6465,7 @@ let printer = object(self:'self) | None -> Some (self#extension e) | Some (_, x') -> match x'.pexp_desc with - | Pexp_let _ -> + | Pexp_let _ | Pexp_letmodule _ -> Some (makeLetSequence (self#letList x)) | _ -> Some (self#extension e) end @@ -7204,6 +7211,8 @@ let printer = object(self:'self) `let%private a = 1` *) | Psig_value ({ pval_prim = [_]; _ } as vd) -> self#primitive_declaration ~extension vd | Psig_value vd -> self#val_binding ~extension vd + | Psig_module pmd -> self#psig_module ~extension pmd + | Psig_recmodule pmd -> self#psig_recmodule ~extension pmd | _ -> self#payload "%%" extension (PSig [item]) end | _ -> self#signature_item' item @@ -7225,6 +7234,75 @@ let printer = object(self:'self) ~layout () + method psig_module ?extension pmd = + let layout = + let prefix = add_extension_sugar "module" extension in + match pmd.pmd_type.pmty_desc with + | Pmty_alias alias -> + label ~space:true + (makeList ~postSpace:true [ + atom prefix; + atom (moduleIdent pmd.pmd_name); + atom "=" + ]) + (self#longident_loc alias) + | _ -> + let letPattern = + makeList + [makeList ~postSpace:true [atom prefix; (atom (moduleIdent pmd.pmd_name))]; + atom ":"] + in + (self#module_type letPattern pmd.pmd_type) + in + let {stdAttrs; docAttrs} = + partitionAttributes ~partDoc:true pmd.pmd_attributes + in + self#attachDocAttrsToLayout + ~stdAttrs + ~docAttrs + ~loc:pmd.pmd_name.loc + ~layout:(self#attach_std_item_attrs stdAttrs @@ layout) + () + + method psig_recmodule ?extension decls = + let items = List.mapi (fun i xx -> + let {stdAttrs; docAttrs} = + partitionAttributes ~partDoc:true xx.pmd_attributes + in + let letPattern = + makeList [ + makeList ~postSpace:true [ + atom (if i == 0 + then + add_extension_sugar "module" extension ^ " rec" + else "and"); + atom (moduleIdent xx.pmd_name) + ]; + atom ":" + ] + in + let layout = + self#attach_std_item_attrs stdAttrs + (self#module_type ~space:true letPattern xx.pmd_type) + in + let layoutWithDocAttrs = + self#attachDocAttrsToLayout + ~stdAttrs + ~docAttrs + ~loc:xx.pmd_name.loc + ~layout + () + in + (extractLocModDecl xx, layoutWithDocAttrs) + ) decls + in + makeNonIndentedBreakingList + (groupAndPrint + ~xf:(fun (_, layout) -> layout) + ~getLoc:(fun (loc, _) -> loc) + ~comments:self#comments + items) + method signature_item' x : Layout.t = let item: Layout.t = match x.psig_desc with @@ -7272,45 +7350,7 @@ let printer = object(self:'self) (class_description ~class_keyword:true x):: (List.map class_description xs) ) - | Psig_module {pmd_name; pmd_type={pmty_desc=Pmty_alias alias}; pmd_attributes} -> - let {stdAttrs; docAttrs} = - partitionAttributes ~partDoc:true pmd_attributes - in - let layout = - self#attach_std_item_attrs stdAttrs @@ - label ~space:true - (makeList ~postSpace:true [ - atom "module"; - atom (moduleIdent pmd_name); - atom "=" - ]) - (self#longident_loc alias) - in - self#attachDocAttrsToLayout - ~stdAttrs - ~docAttrs - ~loc:pmd_name.loc - ~layout - () - | Psig_module pmd -> - let {stdAttrs; docAttrs} = - partitionAttributes ~partDoc:true pmd.pmd_attributes - in - let letPattern = - makeList - [makeList ~postSpace:true [atom "module"; (atom (moduleIdent pmd.pmd_name))]; - atom ":"] - in - let layout = - self#attach_std_item_attrs stdAttrs @@ - (self#module_type letPattern pmd.pmd_type) - in - self#attachDocAttrsToLayout - ~stdAttrs - ~docAttrs - ~loc:pmd.pmd_name.loc - ~layout - () + | Psig_module pmd -> self#psig_module pmd | Psig_open od -> let {stdAttrs; docAttrs} = partitionAttributes ~partDoc:true od.popen_attributes @@ -7361,42 +7401,7 @@ let printer = object(self:'self) ~layout () | Psig_class_type l -> self#class_type_declaration_list l - | Psig_recmodule decls -> - let items = List.mapi (fun i xx -> - let {stdAttrs; docAttrs} = - partitionAttributes ~partDoc:true xx.pmd_attributes - in - let letPattern = - makeList [ - makeList ~postSpace:true [ - atom (if i == 0 then "module rec" else "and"); - atom (moduleIdent xx.pmd_name) - ]; - atom ":" - ] - in - let layout = - self#attach_std_item_attrs stdAttrs - (self#module_type ~space:true letPattern xx.pmd_type) - in - let layoutWithDocAttrs = - self#attachDocAttrsToLayout - ~stdAttrs - ~docAttrs - ~loc:xx.pmd_name.loc - ~layout - () - in - (extractLocModDecl xx, layoutWithDocAttrs) - ) decls - in - makeNonIndentedBreakingList - (groupAndPrint - ~xf:(fun (_, layout) -> layout) - ~getLoc:(fun (loc, _) -> loc) - ~comments:self#comments - items) - + | Psig_recmodule decls -> self#psig_recmodule decls | Psig_attribute a -> self#floating_attribute a | Psig_extension (({loc}, _) as ext, attrs) -> let {stdAttrs; docAttrs} = @@ -7616,6 +7621,39 @@ let printer = object(self:'self) | Pmod_constraint _ | Pmod_structure _ -> self#simple_module_expr x + method recmodule ?extension decls = + let items = List.mapi (fun i xx -> + let {stdAttrs; docAttrs} = + partitionAttributes ~partDoc:true xx.pmb_attributes + in + let layout = + self#attach_std_item_attrs stdAttrs @@ + self#let_module_binding + (if i == 0 + then + add_extension_sugar "module" extension ^ " rec" + else "and") + (atom (moduleIdent xx.pmb_name)) + xx.pmb_expr + in + let layoutWithDocAttrs = + self#attachDocAttrsToLayout + ~stdAttrs + ~docAttrs + ~loc:xx.pmb_name.loc + ~layout + () + in + (extractLocModuleBinding xx, layoutWithDocAttrs) + ) decls + in + makeNonIndentedBreakingList + (groupAndPrint + ~xf:(fun (_, layout) -> layout) + ~getLoc:(fun (loc, _) -> loc) + ~comments:self#comments + items) + method structure ?(indent=Some 0) ?wrap structureItems = (* We don't have any way to know if an extension is placed at the top level by the parsetree while there's a difference syntactically (% for structure_items/expressons and %% for top_level). @@ -7629,6 +7667,13 @@ let printer = object(self:'self) `let%private a = 1` *) | Pstr_value (rf, vb_list) -> self#bindings ~extension (rf, vb_list) | Pstr_primitive vd -> self#primitive_declaration ~extension vd + | Pstr_module binding -> + let bindingName = atom ~loc:binding.pmb_name.loc (moduleIdent binding.pmb_name) in + let module_binding = + let prefix = add_extension_sugar "module" (Some extension) in + self#let_module_binding prefix bindingName binding.pmb_expr in + self#attach_std_item_attrs binding.pmb_attributes module_binding + | Pstr_recmodule decls -> self#recmodule ~extension decls | _ -> self#attach_std_item_attrs attrs (self#payload "%%" extension (PStr [item])) end | _ -> self#structure_item item @@ -7789,35 +7834,7 @@ let printer = object(self:'self) self#moduleExpressionToFormattedApplicationItems ~prefix:"include" moduleExpr - | Pstr_recmodule decls -> (* 3.07 *) - let items = List.mapi (fun i xx -> - let {stdAttrs; docAttrs} = - partitionAttributes ~partDoc:true xx.pmb_attributes - in - let layout = - self#attach_std_item_attrs stdAttrs @@ - self#let_module_binding - (if i == 0 then "module rec" else "and") - (atom (moduleIdent xx.pmb_name)) - xx.pmb_expr - in - let layoutWithDocAttrs = - self#attachDocAttrsToLayout - ~stdAttrs - ~docAttrs - ~loc:xx.pmb_name.loc - ~layout - () - in - (extractLocModuleBinding xx, layoutWithDocAttrs) - ) decls - in - makeNonIndentedBreakingList - (groupAndPrint - ~xf:(fun (_, layout) -> layout) - ~getLoc:(fun (loc, _) -> loc) - ~comments:self#comments - items) + | Pstr_recmodule decls -> self#recmodule decls | Pstr_attribute a -> self#floating_attribute a | Pstr_extension ((_extension, PStr []) as extension, attrs) -> (* Extension with attributes and without PStr gets printed inline *) diff --git a/test/general-syntax-rei.t/input.rei b/test/general-syntax-rei.t/input.rei index c8eab395f..2b535b6f4 100644 --- a/test/general-syntax-rei.t/input.rei +++ b/test/general-syntax-rei.t/input.rei @@ -46,3 +46,9 @@ external%foo bar: string => string = ""; [%%foo: let foo: bar]; let%foo foo: bar; +module%foo X: Y; + +module%foo X = Y; + +module%foo rec X: Y; + diff --git a/test/general-syntax-rei.t/run.t b/test/general-syntax-rei.t/run.t index e25ccfbaf..65b1aae1f 100644 --- a/test/general-syntax-rei.t/run.t +++ b/test/general-syntax-rei.t/run.t @@ -54,3 +54,9 @@ Format general interface syntax let%foo foo: bar; let%foo foo: bar; + + module%foo X: Y; + + module%foo X = Y; + + module%foo rec X: Y; diff --git a/test/modules.t/input.re b/test/modules.t/input.re index 2e953779f..9846a7660 100644 --- a/test/modules.t/input.re +++ b/test/modules.t/input.re @@ -523,3 +523,20 @@ module type TypeWithExternalExtension = { external%foo bar: string => string = ""; [%%foo: external bar: int => int = "hello" ]; } + +module%foo X = Y + +module%foo X = { + let x = 1; +}; + +let x = { + let module%foo X = { + let x = 1; + }; + () +}; + +module%foo rec X: Y = { + let x = 1; +} diff --git a/test/modules.t/run.t b/test/modules.t/run.t index 9311b0434..dc3fe3913 100644 --- a/test/modules.t/run.t +++ b/test/modules.t/run.t @@ -689,4 +689,21 @@ Format modules external%foo bar: string => string; external%foo bar: int => int = "hello"; }; + + module%foo X = Y; + + module%foo X = { + let x = 1; + }; + + let x = { + module%foo X = { + let x = 1; + }; + (); + }; + + module%foo rec X: Y = { + let x = 1; + }; /* From http://stackoverflow.com/questions/1986374/ higher-order-type-constructors-and-functors-in-ocaml */