Source file keyed_container_clause.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
open! Base
open! Import
include Keyed_container_clause_intf

module Make (X : X) = struct
  let assert_arity_is_expected ~longident_loc ~actual_arity ~expected_arity =
    if actual_arity <> expected_arity
    then
      Location.raise_errorf
        ~loc:longident_loc.loc
        "The arity of `%s' was expected to be %d but was found to be %d"
        (Longident.name longident_loc.txt)
        expected_arity
        actual_arity
  ;;

  let match_on_submodule_form ~core_type =
    match core_type.ptyp_desc with
    | Ptyp_constr (longident_loc, type_parameters) ->
      (match Helpers.if_module_dot_t_then_module core_type with
       | None -> None
       | Some module_longident_loc ->
         (match Helpers.split_longident module_longident_loc.txt with
          | `prefix (Some prefix), `last last when String.(last = X.Submodule_form.name)
            ->
            assert_arity_is_expected
              ~longident_loc
              ~actual_arity:(List.length type_parameters)
              ~expected_arity:X.Submodule_form.arity;
            Some (prefix, X.Submodule_form.value_types ~type_parameters)
          | _ -> None))
    | _ -> None
  ;;

  let match_on_parameterized_form ~core_type =
    match core_type.ptyp_desc with
    | Ptyp_constr (longident_loc, type_parameters) ->
      (match
         Helpers.longident_is_like_t
           longident_loc.txt
           ~primitive_name:None
           ~first_module_name:X.Parameterized_form.name
       with
       | false -> None
       | true  ->
         assert_arity_is_expected
           ~longident_loc
           ~actual_arity:(List.length type_parameters)
           ~expected_arity:X.Parameterized_form.arity;
         let%bind atomic_type = X.Parameterized_form.key_type ~type_parameters in
         let children_types = X.Parameterized_form.value_types ~type_parameters in
         let atomic_longident =
           match Helpers.if_module_dot_t_then_module atomic_type with
           | Some longident_loc -> longident_loc.txt
           | None -> lident (String.capitalize (string_of_core_type atomic_type))
         in
         Some (atomic_longident, children_types))
    | _ -> None
  ;;

  let maybe_match type_ (_ : Ctx.t) =
    let%bind core_type = Type_.match_core_type type_ in
    let%map atomic_longident, children_types =
      Option.first_some
        (match_on_submodule_form     ~core_type)
        (match_on_parameterized_form ~core_type)
    in
    ({ children      = List.map children_types ~f:Type_.core_type
     ; apply_functor =
         (fun ctx children ->
            let loc = ctx.loc in
            Helpers.apply_streamable_dot
              ctx
              ~functor_name:[%string "Of_%{String.lowercase X.Parameterized_form.name}"]
              ~arguments:(pmod_ident ~loc (Loc.make ~loc atomic_longident) :: children))
     }
     : Clause.Match.t)
  ;;
end