package streamable
A collection of types suitable for incremental serialization
Install
Dune Dependency
Authors
Maintainers
Sources
v0.16.1.tar.gz
md5=c410b847f5a0f0be3c67b3403af04282
sha512=62cdeea4d38110bc6bd318e564e8277355928156c947400ee3e023998b60009a9d20073e8f7efedbe3bbada739bea56c6ff7d1eaba26898f6675ab690f03aadb
doc/src/ppx_streamable/variant_clause.ml.html
Source file variant_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 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185open! Base open! Import let pcstr_tuple_core_types ~loc ~constructor_declaration = match constructor_declaration.pcd_args with | Pcstr_tuple core_types -> core_types | Pcstr_record _ -> Helpers.unsupported_use ~loc ~why: [%string "variant constructor `%{constructor_declaration.pcd_name.txt}' contains an \ anonymous record argument, which isn't supported"] ;; let if_no_arg ~loc ~constructor_declaration ~then_ ~else_ = match pcstr_tuple_core_types ~loc ~constructor_declaration with | [] -> then_ () | core_types -> else_ core_types ;; let constructor_declarations type_dec = match type_dec.ptype_kind with | Ptype_variant constructor_declarations -> Some constructor_declarations | _ -> None ;; let children ~loc ~constructor_declarations = List.map constructor_declarations ~f:(fun constructor_declaration -> if_no_arg ~loc ~constructor_declaration ~else_:(fun core_types -> ptyp_tuple ~loc core_types) ~then_:(fun () -> Helpers.core_type_with_atomic_attribute ~loc ~module_dot_t:"Core.Unit.t")) ;; let streamable_module (ctx : Ctx.t) children = match List.map ~f:snd children with | [] -> Helpers.apply_streamable_dot ctx ~functor_name:"Of_atomic" ~arguments: [ pmod_ident ~loc:ctx.loc (Loc.make ~loc:ctx.loc (Longident.parse "Core.Nothing")) ] | _ -> Nested_variant.streamable_of_variant ctx children ;; let to_streamable_fun ~loc ~constructor_declarations = match constructor_declarations with | [] -> [%expr function | (_ : t) -> .] | _ -> let cases = List.mapi constructor_declarations ~f:(fun constructor_index constructor_declaration -> let lhs_tuple = if_no_arg ~loc ~constructor_declaration ~then_:(fun () -> None) ~else_:(fun core_types -> Some (ppat_tuple ~loc (List.mapi core_types ~f:(fun core_type_index (_ : core_type) -> let var = Loc.make ~loc (Helpers.lowercase_name_of_num core_type_index) in ppat_var ~loc var)))) in let lhs_pattern = ppat_construct ~loc (Loc.map constructor_declaration.pcd_name ~f:lident) lhs_tuple in let rhs_tuple = if_no_arg ~loc ~constructor_declaration ~then_:(fun () -> [%expr ()]) ~else_:(fun core_types -> pexp_tuple ~loc (List.mapi core_types ~f:(fun core_type_index (_ : core_type) -> let ident = Loc.make ~loc (lident (Helpers.lowercase_name_of_num core_type_index)) in pexp_ident ~loc ident))) in let rhs_expression = match List.length constructor_declarations with (* Don't map to a variant if there is only one constructor. *) | 1 -> rhs_tuple (* Else, wrap the tuple in a variant. *) | _ -> pexp_variant ~loc (Helpers.uppercase_name_of_num constructor_index) (Some rhs_tuple) in case ~lhs:lhs_pattern ~guard:None ~rhs:rhs_expression) in pexp_function ~loc cases ;; let of_streamable_fun ~loc ~constructor_declarations = match constructor_declarations with | [] -> [%expr Core.Nothing.unreachable_code] | _ -> let cases = List.mapi constructor_declarations ~f:(fun constructor_index constructor_declaration -> let lhs_tuple = if_no_arg ~loc ~constructor_declaration ~then_:(fun () -> [%pat? ()]) ~else_:(fun core_types -> ppat_tuple ~loc (List.mapi core_types ~f:(fun core_type_index (_ : core_type) -> ppat_var ~loc (Loc.make ~loc (Helpers.lowercase_name_of_num core_type_index))))) in let lhs_pattern = match List.length constructor_declarations with (* Don't map to a variant if there is only one constructor. *) | 1 -> lhs_tuple | _ -> (* Else, wrap the tuple in a variant. *) ppat_variant ~loc (Helpers.uppercase_name_of_num constructor_index) (Some lhs_tuple) in let rhs_tuple = if_no_arg ~loc ~constructor_declaration ~then_:(fun () -> None) ~else_:(fun core_types -> Some (pexp_tuple ~loc (List.mapi core_types ~f:(fun core_type_index (_ : core_type) -> let ident = Loc.make ~loc (lident (Helpers.lowercase_name_of_num core_type_index)) in pexp_ident ~loc ident)))) in let rhs_expression = pexp_construct ~loc (Loc.map constructor_declaration.pcd_name ~f:lident) rhs_tuple in case ~lhs:lhs_pattern ~guard:None ~rhs:rhs_expression) in pexp_function ~loc cases ;; let maybe_match type_ (_ : Ctx.t) = Helpers.type_declaration_match type_ ~payload:constructor_declarations ~children:(fun ~loc ~payload -> children ~loc ~constructor_declarations:payload) ~streamable_module ~to_streamable_fun:(fun ~loc ~payload -> to_streamable_fun ~loc ~constructor_declarations:payload) ~of_streamable_fun:(fun ~loc ~payload -> of_streamable_fun ~loc ~constructor_declarations:payload) ;;