summaryrefslogtreecommitdiff
path: root/lib/utils.ml
diff options
context:
space:
mode:
Diffstat (limited to 'lib/utils.ml')
-rw-r--r--lib/utils.ml121
1 files changed, 121 insertions, 0 deletions
diff --git a/lib/utils.ml b/lib/utils.ml
new file mode 100644
index 0000000..00e003a
--- /dev/null
+++ b/lib/utils.ml
@@ -0,0 +1,121 @@
+module Decoder : sig
+ type 'a decoder
+
+ val decode : 'a decoder -> Yojson.Safe.t -> 'a option
+ val return : 'a -> 'a decoder
+ val fail : 'a decoder
+ val bind : 'a decoder -> ('a -> 'b decoder) -> 'b decoder
+ val map : ('a -> 'b) -> 'a decoder -> 'b decoder
+ val string : string decoder
+ val literal : string -> string decoder
+ val int : int decoder
+ val field : string -> 'a decoder -> 'a decoder
+ val list : 'a decoder -> 'a list decoder
+ val one_of : 'a decoder list -> 'a decoder
+
+ module Syntax : sig
+ val ( *> ) : 'a decoder -> 'b decoder -> 'b decoder
+ val ( <* ) : 'a decoder -> 'b decoder -> 'a decoder
+ val ( >>= ) : 'a decoder -> ('a -> 'b decoder) -> 'b decoder
+ val ( >>| ) : 'a decoder -> ('a -> 'b) -> 'b decoder
+ val ( <*> ) : ('a -> 'b) decoder -> 'a decoder -> 'b decoder
+ val ( <$> ) : ('a -> 'b) -> 'a decoder -> 'b decoder
+ val ( <: ) : string -> 'a decoder -> 'a decoder
+ val ( <|> ) : 'a decoder -> 'a decoder -> 'a decoder
+ end
+end = struct
+ type 'a decoder = Yojson.Safe.t -> 'a option
+
+ let decode decoder json = decoder json
+ let return v _ = Some v
+ let fail _ = None
+
+ let map f decoder json =
+ match decoder json with
+ | Some d -> Some (f d)
+ | None -> None
+ ;;
+
+ let bind decoder f json =
+ match decoder json with
+ | Some x -> f x `Null
+ | None -> None
+ ;;
+
+ let rec one_of decoders json =
+ match decoders with
+ | [] -> None
+ | decoder :: tl ->
+ (match decoder json with
+ | Some _ as x -> x
+ | None -> one_of tl json)
+ ;;
+
+ let string = function
+ | `String str -> Some str
+ | _ -> None
+ ;;
+
+ let literal str = function
+ | `String s when String.equal s str -> Some s
+ | _ -> None
+ ;;
+
+ let int = function
+ | `Int int -> Some int
+ | _ -> None
+ ;;
+
+ let field key decoder json =
+ try decoder @@ Yojson.Safe.Util.member key json with
+ | _ -> None
+ ;;
+
+ let list decoder json =
+ let rec helper acc = function
+ | [] -> Some []
+ | hd :: tl ->
+ (match decoder hd with
+ | Some _ as x -> helper (x :: acc) tl
+ | None -> None)
+ in
+ match json with
+ | `List list -> Option.map List.rev (helper [] list)
+ | _ -> None
+ ;;
+
+ module Syntax = struct
+ let ( *> ) decoder_a decoder_b yojson =
+ match decoder_a yojson with
+ | Some _ -> decoder_b yojson
+ | None -> None
+ ;;
+
+ let ( <* ) decoder_a decoder_b yojson =
+ match decoder_a yojson with
+ | Some value -> Option.map (fun _ -> value) (decoder_b yojson)
+ | None -> None
+ ;;
+
+ let ( >>= ) = bind
+ let ( >>| ) decoder f yojson = map f decoder yojson
+
+ let ( <*> ) decoder_a decoder_b input =
+ match decoder_a input with
+ | Some f ->
+ (match decoder_b input with
+ | Some x -> Some (f x)
+ | None -> None)
+ | None -> None
+ ;;
+
+ let ( <$> ) f decoder = decoder >>| f
+ let ( <: ) = field
+
+ let ( <|> ) decoder_a decoder_b input =
+ match decoder_a input with
+ | Some _ as value -> value
+ | None -> decoder_b input
+ ;;
+ end
+end