Lower-level Decoder.t

CHANGES.md

@@ -1,3 +1,7 @@
+## 1.0.0 (UNRELEASED)
+
+* Extract and expose `Decoder.t`, useful for "decoding" things outside of the JSON family.
+
 ## 0.7.0 (2022-05-11)
 
 * Add `Decode.field_opt_or` (#43, @c-cube)

Makefile

@@ -1,6 +1,8 @@
 .PHONY: all
 all: build test build-bs test-bs
 
+.PHONY: clean-all
+clean-all: clean clean-bs
 
 .PHONY: build
 build:

__tests__/decoders_bs_test.ml

@@ -1,7 +1,7 @@
 open Jest
 open Decoders_bs
 
-external parse_int: string -> int = "parseInt" [@@bs.scope "window"] [@@bs.val]
+external parse_int : string -> int = "parseInt" [@@bs.scope "window"] [@@bs.val]
 
 let () =
   describe
@@ -16,18 +16,20 @@ let () =
               let decoded = decode_string string json_str in
               expect decoded |> toEqual (Belt.Result.Ok "Hello world")))
 
+
 let () =
   describe
     "decoders-bs decode int"
     Expect.(
-    fun () ->
-    test
-      "int"
-      Decode.(
       fun () ->
-      let json_str = {|5078476151|} in
-      let decoded = decode_string int json_str in
-      expect decoded |> toEqual (Belt.Result.Ok (parse_int "5078476151" ))))
+        test
+          "int"
+          Decode.(
+            fun () ->
+              let json_str = {|5078476151|} in
+              let decoded = decode_string int json_str in
+              expect decoded |> toEqual (Belt.Result.Ok (parse_int "5078476151"))))
+
 
 let () =
   describe
@@ -43,8 +45,6 @@ let () =
               expect decoded |> toEqual (Belt.Result.Ok [| "a"; "b"; "c" |])))
 
 
-
-
 let () =
   describe
     "decoders-bs decode error"
@@ -56,15 +56,18 @@ let () =
             fun () ->
               let json_str = {|["a", 1, "c"]|} in
               let decoded = decode_string (array string) json_str in
-              expect decoded |> toEqual
-                (Belt.Result.Error
-                   (Decoders.Decode.(
-                       Decoder_tag
-                         ("while decoding an array",
-                          (Decoder_errors
-                             [Decoder_tag
-                                ("element 1",
-                                 Decoder_error ("Expected a string", Some (Js.Json.number 1.)))])))) )))
+              expect decoded
+              |> toEqual
+                   (Belt.Result.Error
+                      Decoders.Error.(
+                        tag_group
+                          "while decoding an array"
+                          [ tag
+                              "element 1"
+                              (make
+                                 "Expected a string"
+                                 ~context:(Js.Json.number 1.) )
+                          ]) )))
 
 
 let () =

bsconfig.json

@@ -4,11 +4,16 @@
   "sources": [{
     "dir" : "src",
     "files" : [
-      "encode.mli",
       "decode.ml",
       "decode.mli",
+      "decoder.ml",
+      "decoder.mli",
       "decoders.ml",
-      "encode.ml"
+      "encode.ml",
+      "encode.mli",
+      "error.ml",
+      "error.mli",
+      "sig.ml"
     ]
   }, {
     "dir" : "src-bs"

src-bencode/decode.ml

@@ -70,11 +70,9 @@ end
 include Decode.Make (Bencode_decodeable)
 
 let int64 : int64 decoder =
-  { run =
-      (fun t ->
-        match t with
-        | Bencode.Integer value ->
-            Ok value
-        | _ ->
-            (fail "Expected an int64").run t)
-  }
+ fun t ->
+  match t with
+  | Bencode.Integer value ->
+      Ok value
+  | _ ->
+      (fail "Expected an int64") t

src-bs/decoders_bs.ml

@@ -2,7 +2,7 @@
 
 open Decoders
 
-type ('good, 'bad) result = ('good, 'bad) Decode.result =
+type ('good, 'bad) result = ('good, 'bad) Decoders_util.My_result.t =
   | Ok of 'good
   | Error of 'bad
 
@@ -27,13 +27,12 @@ module Json_decodeable : Decode.Decodeable with type value = Js.Json.t = struct
   let is_integer json =
     Js.Float.isFinite json && Js.Math.floor_float json == json
 
+
   let get_int json =
     Js.Json.decodeNumber json
     |. Belt.Option.flatMap (fun n ->
-           if is_integer n then
-             Some (Obj.magic (n : float) : int)
-           else
-             None)
+           if is_integer n then Some (Obj.magic (n : float) : int) else None )
+
 
   let get_float = Js.Json.decodeNumber
 
@@ -50,7 +49,7 @@ module Json_decodeable : Decode.Decodeable with type value = Js.Json.t = struct
     |. Belt.Option.map (fun dict ->
            Js.Dict.entries dict
            |. Array.to_list
-           |> List.map (fun (key, value) -> (Js.Json.string key, value)))
+           |> List.map (fun (key, value) -> (Js.Json.string key, value)) )
 
 
   let to_list values = Js.Json.array (Array.of_list values)
@@ -60,35 +59,34 @@ module Decode = struct
   module D = Decode.Make (Json_decodeable)
   include D
 
-  let tag_error (msg : string) (error : error) : error = Decoder_tag (msg, error)
-
-  let tag_errors (msg : string) (errors : error list) : error =
-    Decoder_tag (msg, Decoder_errors errors)
-
   let array : 'a decoder -> 'a array decoder =
-   fun decoder ->
-    { run =
-        (fun t ->
-          match Js.Json.decodeArray t with
-          | None ->
-              (fail "Expected an array").run t
-          | Some arr ->
-              let (oks, errs) =
-                arr
-                |> Js.Array.reducei (fun (oks, errs) x i ->
-                       match decoder.run x with
-                       | Ok a ->
-                          let _ = Js.Array.push a oks in
-                          (oks, errs)
-                       | Error e ->
-                         let _ = Js.Array.push (tag_error ("element " ^ Js.Int.toString i) e) errs in
-                             (oks, errs)) ([||], [||])
-              in
-              if (Js.Array.length errs > 0) then
-                Error (tag_errors "while decoding an array" (errs |> Array.to_list))
-              else
-                Ok oks)
-    }
+   fun decoder t ->
+    match Js.Json.decodeArray t with
+    | None ->
+        (fail "Expected an array") t
+    | Some arr ->
+        let oks, errs =
+          arr
+          |> Js.Array.reducei
+               (fun (oks, errs) x i ->
+                 match decoder x with
+                 | Ok a ->
+                     let _ = Js.Array.push a oks in
+                     (oks, errs)
+                 | Error e ->
+                     let _ =
+                       Js.Array.push
+                         (Error.tag ("element " ^ Js.Int.toString i) e)
+                         errs
+                     in
+                     (oks, errs) )
+               ([||], [||])
+        in
+        if Js.Array.length errs > 0
+        then
+          Error
+            (Error.tag_group "while decoding an array" (errs |> Array.to_list))
+        else Ok oks
 end
 
 module Json_encodeable = struct
@@ -112,7 +110,7 @@ module Json_encodeable = struct
     Js.Json.object_
       ( xs
       |. Belt.List.keepMap (fun (k, v) ->
-             Js.Json.decodeString k |. Belt.Option.map (fun k -> (k, v)))
+             Js.Json.decodeString k |. Belt.Option.map (fun k -> (k, v)) )
       |. Js.Dict.fromList )
 end
 

src-bs/shims_let_ops_.ml

@@ -1,22 +1,18 @@
 (* Note: copied from src/gen/mkshims.ml *)
-module type S = sig
-  type 'a t_let
-end
+module type I = sig
+  type ('i, 'a) t
+
+  val ( >|= ) : ('i, 'a) t -> ('a -> 'b) -> ('i, 'b) t
 
-module Make (X : sig
-  type 'a t
-end) =
-struct
-  type 'a t_let = 'a X.t
+  val monoid_product : ('i, 'a) t -> ('i, 'b) t -> ('i, 'a * 'b) t
+
+  val ( >>= ) : ('i, 'a) t -> ('a -> ('i, 'b) t) -> ('i, 'b) t
 end
 
-module type S2 = sig
-  type ('a, 'b) t_let2
+module type S = sig
+  type ('i, 'a) t_let
 end
 
-module Make2 (X : sig
-  type ('a, 'b) t
-end) =
-struct
-  type ('a, 'b) t_let2 = ('a, 'b) X.t
+module Make (X : I) = struct
+  type ('i, 'a) t_let = ('i, 'a) X.t
 end

src-cbor/decode.ml

@@ -41,20 +41,22 @@ include Decode.Make (Cbor_decodeable)
 
 (* CBOR-specific decoders *)
 
-let undefined : unit decoder =
-  { run =
-      (function
-      | `Undefined -> Ok () | json -> (fail "Expected Undefined").run json)
-  }
+let undefined : unit decoder = function
+  | `Undefined ->
+      Ok ()
+  | json ->
+      (fail "Expected Undefined") json
 
 
-let simple : int decoder =
-  { run =
-      (function `Simple i -> Ok i | json -> (fail "Expected Simple").run json)
-  }
+let simple : int decoder = function
+  | `Simple i ->
+      Ok i
+  | json ->
+      (fail "Expected Simple") json
 
 
-let bytes : string decoder =
-  { run =
-      (function `Bytes b -> Ok b | json -> (fail "Expected bytes").run json)
-  }
+let bytes : string decoder = function
+  | `Bytes b ->
+      Ok b
+  | json ->
+      (fail "Expected bytes") json

src-msgpck/decode.ml

@@ -48,37 +48,50 @@ end
 
 include Decode.Make (Msgpck_decodeable)
 
-let string_strict : string decoder =
-  { run =
-      (function
-      | M.String b -> Ok b | m -> (fail "Expected string (strict)").run m)
-  }
+let string_strict : string decoder = function
+  | M.String b ->
+      Ok b
+  | m ->
+      (fail "Expected string (strict)") m
 
 
-let bytes : string decoder =
-  { run = (function M.Bytes b -> Ok b | m -> (fail "Expected bytes").run m) }
+let bytes : string decoder = function
+  | M.Bytes b ->
+      Ok b
+  | m ->
+      (fail "Expected bytes") m
 
 
-let int32 : _ decoder =
-  { run = (function M.Int32 i -> Ok i | m -> (fail "Expected int32").run m) }
+let int32 : _ decoder = function
+  | M.Int32 i ->
+      Ok i
+  | m ->
+      (fail "Expected int32") m
 
 
-let int64 : _ decoder =
-  { run = (function M.Int64 i -> Ok i | m -> (fail "Expected int64").run m) }
+let int64 : _ decoder = function
+  | M.Int64 i ->
+      Ok i
+  | m ->
+      (fail "Expected int64") m
 
 
-let uint32 : _ decoder =
-  { run = (function M.Uint32 i -> Ok i | m -> (fail "Expected uint32").run m)
-  }
+let uint32 : _ decoder = function
+  | M.Uint32 i ->
+      Ok i
+  | m ->
+      (fail "Expected uint32") m
 
 
-let uint64 : _ decoder =
-  { run = (function M.Uint64 i -> Ok i | m -> (fail "Expected uint64").run m)
-  }
+let uint64 : _ decoder = function
+  | M.Uint64 i ->
+      Ok i
+  | m ->
+      (fail "Expected uint64") m
 
 
-let ext : (int * string) decoder =
-  { run =
-      (function
-      | M.Ext (i, s) -> Ok (i, s) | m -> (fail "Expected extension").run m)
-  }
+let ext : (int * string) decoder = function
+  | M.Ext (i, s) ->
+      Ok (i, s)
+  | m ->
+      (fail "Expected extension") m