refactor: more logic in ast_untagged_variants

Author: cristianoc

compiler/ml/ast_untagged_variants.ml

@@ -91,6 +91,12 @@ type switch_names = {consts: tag array; blocks: block array}
 
 let untagged = "unboxed"
 
+let block_type_can_be_undefined = function
+ | IntType | StringType | FloatType | BigintType | BooleanType | InstanceType _
+ | FunctionType | ObjectType ->
+ false
+ | UnknownType -> true
+
 let has_untagged (attrs : Parsetree.attributes) =
  Ext_list.exists attrs (function {txt}, _ -> txt = untagged)
 
@@ -328,23 +334,35 @@ let check_invariant ~is_untagged_def ~(consts : (Location.t * tag) list)
  invariant loc block.tag.name
  | None -> ())
 
+let get_cstr_loc_tag (cstr : Types.constructor_declaration) =
+ ( cstr.cd_loc,
+ {
+ name = Ident.name cstr.cd_id;
+ tag_type = process_tag_type cstr.cd_attributes;
+ } )
+
+let constructor_declaration_from_constructor_description ~env
+ (cd : Types.constructor_description) : Types.constructor_declaration option
+ =
+ match cd.cstr_res.desc with
+ | Tconstr (path, _, _) -> (
+ match Env.find_type path env with
+ | {type_kind = Type_variant cstrs} ->
+ Ext_list.find_opt cstrs (fun cstr ->
+ if cstr.cd_id.name = cd.cstr_name then Some cstr else None)
+ | _ -> None)
+ | _ -> None
+
 let names_from_type_variant ?(is_untagged_def = false) ~env
  (cstrs : Types.constructor_declaration list) =
- let get_cstr_name (cstr : Types.constructor_declaration) =
- ( cstr.cd_loc,
- {
- name = Ident.name cstr.cd_id;
- tag_type = process_tag_type cstr.cd_attributes;
- } )
- in
  let get_block (cstr : Types.constructor_declaration) : block =
- let tag = snd (get_cstr_name cstr) in
+ let tag = snd (get_cstr_loc_tag cstr) in
  {tag; tag_name = get_tag_name cstr; block_type = get_block_type ~env cstr}
  in
  let consts, blocks =
  Ext_list.fold_left cstrs ([], []) (fun (consts, blocks) cstr ->
  if is_nullary_variant cstr.cd_args then
- (get_cstr_name cstr :: consts, blocks)
+ (get_cstr_loc_tag cstr :: consts, blocks)
  else (consts, (cstr.cd_loc, get_block cstr) :: blocks))
  in
  check_invariant ~is_untagged_def ~consts ~blocks;

compiler/ml/parmatch.ml

@@ -544,26 +544,23 @@ let all_record_args lbls =
  _,
  [({pat_desc = Tpat_construct (_, cd, _)} as pat_construct)] )
  when lbl_is_optional () -> (
- let block_type =
- match cd.cstr_res.desc with
- | Tconstr (path, _, _) -> (
- match Env.find_type path pat.pat_env with
- | {type_kind = Type_variant cstrs} ->
- Ext_list.find_opt cstrs (fun cstr ->
- if cstr.cd_id.name = cd.cstr_name then
- Ast_untagged_variants.get_block_type ~env:pat.pat_env
- cstr
- else None)
- | _ -> None)
- | _ -> None
+ let cdecl =
+ Ast_untagged_variants
+ .constructor_declaration_from_constructor_description
+ ~env:pat.pat_env cd
  in
- match block_type with
- | Some
- ( IntType | StringType | FloatType | BigintType | BooleanType
- | InstanceType _ | FunctionType | ObjectType ) ->
- (* These types cannot be undefined *)
- (id, lbl, pat_construct)
- | _ -> x)
+ match cdecl with
+ | None -> x
+ | Some cstr -> (
+ match
+ Ast_untagged_variants.get_block_type ~env:pat.pat_env cstr
+ with
+ | Some block_type
+ when not
+ (Ast_untagged_variants.block_type_can_be_undefined
+ block_type) ->
+ (id, lbl, pat_construct)
+ | _ -> x))
  | _ -> x
  in
  t.(lbl.lbl_pos) <- x)