Ast_pattern: augment API with ebool, pbool helper, and a new map.

CHANGES.md

@@ -1,6 +1,8 @@
 unreleased
 ------------------
 
+- Ast_pattern now has ebool, pbool helper, and a new map.(#402, @burnleydev1)
+
 - multiple errors are now reported in `metaquot`. (#397, @burnleydev1)
 
 - Add `Attribute.declare_with_attr_loc` (#396, @dvulakh)

src/ast_pattern.ml

@@ -66,6 +66,14 @@ let int64 v = cst ~to_string:Int64.to_string v
 let nativeint v = cst ~to_string:Nativeint.to_string v
 let bool v = cst ~to_string:Bool.to_string v
 
+let bool' (T func) =
+  T
+    (fun ctx loc x k ->
+      match x with
+      | "true" -> func ctx loc true k
+      | "false" -> func ctx loc false k
+      | _ -> fail loc "Bool")
+
 let false_ =
   T
     (fun ctx loc x k ->
@@ -175,6 +183,9 @@ let map1' (T func) ~f =
 let map2' (T func) ~f =
   T (fun ctx loc x k -> func ctx loc x (fun a b -> k (f loc a b)))
 
+let map_value (T func) ~f = T (fun ctx loc x k -> func ctx loc (f x) k)
+let map_value' (T func) ~f = T (fun ctx loc x k -> func ctx loc (f loc x) k)
+
 let alt_option some none =
   alt (map1 some ~f:(fun x -> Some x)) (map0 none ~f:None)
 
@@ -221,6 +232,8 @@ let pint64 t = ppat_constant (const_int64 t)
 let pnativeint t = ppat_constant (const_nativeint t)
 let single_expr_payload t = pstr (pstr_eval t nil ^:: nil)
 let no_label t = cst Asttypes.Nolabel ~to_string:(fun _ -> "Nolabel") ** t
+let ebool t = pexp_construct (lident (bool' t)) none
+let pbool t = ppat_construct (lident (bool' t)) none
 
 let extension (T f1) (T f2) =
   T

src/ast_pattern.mli

@@ -118,6 +118,8 @@ val map2' :
   f:(Location.t -> 'v1 -> 'v2 -> 'v) ->
   ('a, 'v -> 'b, 'c) t
 
+val map_value : ('a, 'b, 'c) t -> f:('d -> 'a) -> ('d, 'b, 'c) t
+val map_value' : ('a, 'b, 'c) t -> f:(location -> 'd -> 'a) -> ('d, 'b, 'c) t
 val nil : (_ list, 'a, 'a) t
 val ( ^:: ) : ('a, 'b, 'c) t -> ('a list, 'c, 'd) t -> ('a list, 'b, 'd) t
 val many : ('a, 'b -> 'c, 'c) t -> ('a list, 'b list -> 'c, 'c) t
@@ -129,6 +131,8 @@ val int32 : int32 -> (int32, 'a, 'a) t
 val int64 : int64 -> (int64, 'a, 'a) t
 val nativeint : nativeint -> (nativeint, 'a, 'a) t
 val bool : bool -> (bool, 'a, 'a) t
+val ebool : (bool, 'a, 'b) t -> (expression, 'a, 'b) t
+val pbool : (bool, 'a, 'b) t -> (pattern, 'a, 'b) t
 
 val cst :
   to_string:('a -> string) -> ?equal:('a -> 'a -> bool) -> 'a -> ('a, 'b, 'b) t