feat(compiler): Providing, including, reproviding exceptions (#1849)

compiler/src/formatting/format.re

@@ -3917,7 +3917,8 @@ and print_expression_inner =
               switch (item) {
               | PUseValue({loc})
               | PUseModule({loc})
-              | PUseType({loc}) => loc
+              | PUseType({loc})
+              | PUseException({loc}) => loc
               };
             };
 
@@ -3961,6 +3962,8 @@ and print_expression_inner =
                 Doc.concat([Doc.text("module "), item_name(name, alias)])
               | PUseType({name, alias}) =>
                 Doc.concat([Doc.text("type "), item_name(name, alias)])
+              | PUseException({name, alias}) =>
+                Doc.concat([Doc.text("exception "), item_name(name, alias)])
               };
             };
 
@@ -5068,6 +5071,7 @@ let rec toplevel_print =
             switch (item) {
             | PProvideValue({loc})
             | PProvideModule({loc})
+            | PProvideException({loc})
             | PProvideType({loc}) => loc
             };
           };
@@ -5112,6 +5116,8 @@ let rec toplevel_print =
               Doc.concat([Doc.text("module "), item_name(name, alias)])
             | PProvideType({name, alias}) =>
               Doc.concat([Doc.text("type "), item_name(name, alias)])
+            | PProvideException({name, alias}) =>
+              Doc.concat([Doc.text("exception "), item_name(name, alias)])
             };
           };
 

compiler/src/language_server/definition.re

@@ -71,6 +71,7 @@ let process =
     | [Pattern({definition}), ..._]
     | [Type({definition}), ..._]
     | [Declaration({definition}), ..._]
+    | [Exception({definition}), ..._]
     | [Module({definition}), ..._] =>
       switch (definition) {
       | None => send_no_result(~id)

compiler/src/language_server/hover.re

@@ -125,6 +125,13 @@ let declaration_lens = (ident: Ident.t, decl: Types.type_declaration) => {
   grain_type_code_block(Printtyp.string_of_type_declaration(~ident, decl));
 };
 
+let exception_declaration_lens =
+    (ident: Ident.t, ext: Types.extension_constructor) => {
+  grain_type_code_block(
+    Printtyp.string_of_extension_constructor(~ident, ext),
+  );
+};
+
 let process =
     (
       ~id: Protocol.message_id,
@@ -161,6 +168,12 @@ let process =
         ~range=Utils.loc_to_range(loc),
         declaration_lens(ident, decl),
       )
+    | [Exception({ident, ext, loc}), ..._] =>
+      send_hover(
+        ~id,
+        ~range=Utils.loc_to_range(loc),
+        exception_declaration_lens(ident, ext),
+      )
     | [Module({path, decl, loc}), ..._] =>
       send_hover(~id, ~range=Utils.loc_to_range(loc), module_lens(decl))
     | _ => send_no_result(~id)

compiler/src/language_server/sourcetree.re

@@ -157,6 +157,12 @@ module type Sourcetree = {
         loc: Location.t,
         definition: option(Location.t),
       })
+    | Exception({
+        ident: Ident.t,
+        ext: Types.extension_constructor,
+        loc: Location.t,
+        definition: option(Location.t),
+      })
     | Module({
         path: Path.t,
         decl: Types.module_declaration,
@@ -236,6 +242,12 @@ module Sourcetree: Sourcetree = {
         loc: Location.t,
         definition: option(Location.t),
       })
+    | Exception({
+        ident: Ident.t,
+        ext: Types.extension_constructor,
+        loc: Location.t,
+        definition: option(Location.t),
+      })
     | Module({
         path: Path.t,
         decl: Types.module_declaration,
@@ -387,6 +399,15 @@ module Sourcetree: Sourcetree = {
                                    definition: Some(value.val_loc),
                                  }),
                                )
+                             | TUseException({name, ext, loc}) => (
+                                 loc_to_interval(loc),
+                                 Exception({
+                                   ident: Ident.create(name),
+                                   ext,
+                                   loc,
+                                   definition: Some(ext.ext_loc),
+                                 }),
+                               )
                              }
                            },
                            items,

compiler/src/middle_end/linearize.re

@@ -13,7 +13,7 @@ let compile_constructor_tag =
     fun
     | CstrConstant(i) => i
     | CstrBlock(i) => i
-    | CstrExtension(i, _, _) => i
+    | CstrExtension(i, _, _, _) => i
     | CstrUnboxed =>
       failwith("compile_constructor_tag: cannot compile CstrUnboxed")
   );

compiler/src/parsing/ast_mapper.re

@@ -190,6 +190,12 @@ module E = {
                     alias: Option.map(map_identifier(sub), alias),
                     loc: sub.location(sub, loc),
                   })
+                | PUseException({name, alias, loc}) =>
+                  PUseException({
+                    name: map_identifier(sub, name),
+                    alias: Option.map(map_identifier(sub), alias),
+                    loc: sub.location(sub, loc),
+                  })
                 | PUseModule({name, alias, loc}) =>
                   PUseModule({
                     name: map_identifier(sub, name),
@@ -432,6 +438,12 @@ module Pr = {
             alias: Option.map(map_identifier(sub), alias),
             loc: sub.location(sub, loc),
           })
+        | PProvideException({name, alias, loc}) =>
+          PProvideException({
+            name: map_identifier(sub, name),
+            alias: Option.map(map_identifier(sub), alias),
+            loc: sub.location(sub, loc),
+          })
         | PProvideModule({name, alias, loc}) =>
           PProvideModule({
             name: map_identifier(sub, name),

compiler/src/parsing/parser.messages

@@ -455,6 +455,18 @@ program: MODULE UIDENT EOL FROM UIDENT USE LBRACE MODULE YIELD
 
 Expected an uppercase type identifier.
 
+program: MODULE UIDENT EOL FROM UIDENT USE LBRACE EXCEPTION YIELD
+##
+## Ends in an error in state: 57.
+##
+## use_item -> EXCEPTION . aliasable(uid) [ RBRACE EOL COMMA ]
+##
+## The known suffix of the stack is as follows:
+## EXCEPTION
+##
+
+Expected an uppercase exception identifier.
+
 program: MODULE UIDENT EOL PROVIDE LBRACE MODULE UIDENT YIELD
 ##
 ## Ends in an error in state: 49.
@@ -558,6 +570,18 @@ program: MODULE UIDENT EOL PROVIDE LBRACE TYPE YIELD
 
 Expected a type identifier to provide.
 
+program: MODULE UIDENT EOL PROVIDE LBRACE EXCEPTION YIELD
+##
+## Ends in an error in state: 825.
+##
+## provide_item -> EXCEPTION . aliasable(uid) [ RBRACE EOL COMMA ]
+##
+## The known suffix of the stack is as follows:
+## EXCEPTION
+##
+
+Expected an exception identifier to provide.
+
 program: MODULE UIDENT EOL FROM UIDENT USE LBRACE LIDENT AS LIDENT YIELD
 ##
 ## Ends in an error in state: 62.

compiler/src/parsing/parser.mly

@@ -343,6 +343,7 @@ aliasable(X):
 use_item:
   | TYPE aliasable(uid) { PUseType { name=fst $2; alias = snd $2; loc=to_loc $loc} }
   | MODULE aliasable(uid) { PUseModule { name=fst $2; alias = snd $2; loc=to_loc $loc} }
+  | EXCEPTION aliasable(uid) { PUseException { name=fst $2; alias = snd $2; loc=to_loc $loc} }
   | aliasable(lid) { PUseValue { name=fst $1; alias = snd $1; loc=to_loc $loc} }
 
 use_items:
@@ -372,6 +373,7 @@ data_declaration_stmts:
 provide_item:
   | TYPE aliasable(uid) { PProvideType { name=fst $2; alias = snd $2; loc=to_loc $loc} }
   | MODULE aliasable(uid) { PProvideModule { name=fst $2; alias = snd $2; loc=to_loc $loc} }
+  | EXCEPTION aliasable(uid) { PProvideException { name=fst $2; alias = snd $2; loc=to_loc $loc} }
   | aliasable(lid) { PProvideValue { name=fst $1; alias = snd $1; loc=to_loc $loc} }
 
 provide_items:

compiler/src/parsing/parsetree.re

@@ -464,6 +464,11 @@ and use_item =
       alias: option(loc(Identifier.t)),
       loc: Location.t,
     })
+  | PUseException({
+      name: loc(Identifier.t),
+      alias: option(loc(Identifier.t)),
+      loc: Location.t,
+    })
   | PUseModule({
       name: loc(Identifier.t),
       alias: option(loc(Identifier.t)),
@@ -595,6 +600,11 @@ type provide_item =
       alias: option(loc(Identifier.t)),
       loc: Location.t,
     })
+  | PProvideException({
+      name: loc(Identifier.t),
+      alias: option(loc(Identifier.t)),
+      loc: Location.t,
+    })
   | PProvideModule({
       name: loc(Identifier.t),
       alias: option(loc(Identifier.t)),

compiler/src/parsing/parsetree_iter.re

@@ -124,6 +124,7 @@ and iter_provide = (hooks, items) => {
     item => {
       switch (item) {
       | PProvideType({name, alias, loc})
+      | PProvideException({name, alias, loc})
       | PProvideModule({name, alias, loc})
       | PProvideValue({name, alias, loc}) =>
         iter_ident(hooks, name);
@@ -290,6 +291,7 @@ and iter_expression =
         item => {
           switch (item) {
           | PUseType({name, alias, loc})
+          | PUseException({name, alias, loc})
           | PUseModule({name, alias, loc})
           | PUseValue({name, alias, loc}) =>
             iter_ident(hooks, name);

compiler/src/parsing/well_formedness.re

@@ -626,6 +626,7 @@ let no_local_include = (errs, super) => {
 type provided_multiple_times_ctx = {
   modules: Hashtbl.t(string, unit),
   types: Hashtbl.t(string, unit),
+  exceptions: Hashtbl.t(string, unit),
   values: Hashtbl.t(string, unit),
 };
 
@@ -666,6 +667,7 @@ let provided_multiple_times = (errs, super) => {
       {
         modules: Hashtbl.create(64),
         types: Hashtbl.create(64),
+        exceptions: Hashtbl.create(64),
         values: Hashtbl.create(64),
       },
     ]);
@@ -676,6 +678,7 @@ let provided_multiple_times = (errs, super) => {
         {
           modules: Hashtbl.create(64),
           types: Hashtbl.create(64),
+          exceptions: Hashtbl.create(64),
           values: Hashtbl.create(64),
         },
         ...ctx^,
@@ -689,7 +692,7 @@ let provided_multiple_times = (errs, super) => {
   };
 
   let enter_toplevel_stmt = ({ptop_desc: desc} as top) => {
-    let {values, modules, types} = List.hd(ctx^);
+    let {values, modules, types, exceptions} = List.hd(ctx^);
     switch (desc) {
     | PTopModule(Provided | Abstract, {pmod_name, pmod_loc}) =>
       if (Hashtbl.mem(modules, pmod_name.txt)) {
@@ -774,6 +777,13 @@ let provided_multiple_times = (errs, super) => {
             } else {
               Hashtbl.add(types, name, ());
             };
+          | PProvideException({name, alias, loc}) =>
+            let (_, name) = apply_alias(name, alias);
+            if (Hashtbl.mem(exceptions, name)) {
+              errs := [ProvidedMultipleTimes(name, loc), ...errs^];
+            } else {
+              Hashtbl.add(exceptions, name, ());
+            };
           | PProvideModule({name, alias, loc}) =>
             let (_, name) = apply_alias(name, alias);
             if (Hashtbl.mem(modules, name)) {

compiler/src/typed/datarepr.re

@@ -156,7 +156,7 @@ let extension_descr = (path_ext, ext) => {
     cstr_existentials: existentials,
     cstr_args,
     cstr_arity: List.length(cstr_args),
-    cstr_tag: CstrExtension(ext.ext_name.stamp, path_ext, cstr_ext_type),
+    cstr_tag: CstrExtension(ext.ext_name.stamp, path_ext, cstr_ext_type, ext),
     cstr_consts: (-1),
     cstr_nonconsts: (-1),
     cstr_loc: ext.ext_loc,

compiler/src/typed/env.re

@@ -78,6 +78,7 @@ type error =
   | Value_not_found_in_module(Location.t, string, string)
   | Module_not_found_in_module(Location.t, string, string, option(string))
   | Type_not_found_in_module(Location.t, string, string)
+  | Exception_not_found_in_module(Location.t, string, string)
   | Illegal_value_name(Location.t, string)
   | Cyclic_dependencies(string, dependency_chain);
 
@@ -941,6 +942,7 @@ let check_pers_struct = (~loc, name, filename) =>
       | Value_not_found_in_module(_) => assert(false)
       | Module_not_found_in_module(_) => assert(false)
       | Type_not_found_in_module(_) => assert(false)
+      | Exception_not_found_in_module(_) => assert(false)
       | Illegal_value_name(_) => assert(false)
       | Cyclic_dependencies(_) => assert(false)
       };
@@ -2222,6 +2224,37 @@ let use_partial_signature = (root, items, env0) => {
             );
             TUseType({name: new_name, declaration: decl, loc});
           };
+        | PUseException({name, alias, loc}) =>
+          let (old_name, new_name) = apply_alias(name, alias);
+          switch (Tbl.find(old_name, comps.comp_constrs)) {
+          | exception Not_found =>
+            error(
+              Exception_not_found_in_module(
+                name.loc,
+                old_name,
+                Path.name(root),
+              ),
+            )
+          | cstrs =>
+            let (ext, cstr_name) =
+              List.find_map(
+                cstr =>
+                  switch (cstr.cstr_tag) {
+                  | CstrExtension(_, _, _, ext) =>
+                    Some((ext, cstr.cstr_name))
+                  | _ => None
+                  },
+                cstrs,
+              )
+              |> Option.get;
+            new_comps.comp_constrs =
+              Tbl.add(
+                new_name,
+                Tbl.find(cstr_name, comps.comp_constrs),
+                new_comps.comp_constrs,
+              );
+            TUseException({name: new_name, ext, loc});
+          };
         }
       },
       items,
@@ -2609,6 +2642,8 @@ let report_error = ppf =>
     )
   | Type_not_found_in_module(_, name, path) =>
     fprintf(ppf, "Unbound type %s in module %s", name, path)
+  | Exception_not_found_in_module(_, name, path) =>
+    fprintf(ppf, "Unbound exception %s in module %s", name, path)
   | Cyclic_dependencies(dep, chain) =>
     fprintf(
       ppf,

compiler/src/typed/env.rei

@@ -39,6 +39,7 @@ type error =
   | Value_not_found_in_module(Location.t, string, string)
   | Module_not_found_in_module(Location.t, string, string, option(string))
   | Type_not_found_in_module(Location.t, string, string)
+  | Exception_not_found_in_module(Location.t, string, string)
   | Illegal_value_name(Location.t, string)
   | Cyclic_dependencies(string, dependency_chain);
 

compiler/src/typed/printtyp.re

@@ -1026,7 +1026,7 @@ let tree_of_extension_constructor = (id, ext, es) => {
 let extension_constructor = (id, ppf, ext) =>
   Oprint.out_sig_item^(
     ppf,
-    tree_of_extension_constructor(id, ext, TExtFirst),
+    tree_of_extension_constructor(id, ext, TExtException),
   );
 
 let extension_only_constructor = (id, ppf, ext) => {
@@ -1035,6 +1035,10 @@ let extension_only_constructor = (id, ppf, ext) => {
   Format.fprintf(ppf, "@[<hv>%a@]", Oprint.out_constr^, (name, args, None));
 };
 
+let string_of_extension_constructor = (~ident, ext) => {
+  asprintf("%a", extension_constructor(ident), ext);
+};
+
 /* Print a value declaration */
 let tree_of_value_description = (id, decl) => {
   let id = Ident.name(id);

compiler/src/typed/printtyp.rei

@@ -57,6 +57,8 @@ let tree_of_type_declaration:
 let type_declaration: (Ident.t, formatter, type_declaration) => unit;
 let string_of_type_declaration: (~ident: Ident.t, type_declaration) => string;
 let extension_constructor: (Ident.t, formatter, extension_constructor) => unit;
+let string_of_extension_constructor:
+  (~ident: Ident.t, extension_constructor) => string;
 let tree_of_module:
   (Ident.t, ~ellipsis: bool=?, module_type, rec_status) => out_sig_item;
 let modtype: (formatter, module_type) => unit;