feat(bidi-combinators): Combinator library for bidirectional parsing

Author: brendanzab

README.md

@@ -4,6 +4,8 @@ A repository of Fathom-related binary parsing experiments.
 
 ## Language projects
 
+- [**bidi-combinators**](./lang-bidi-combinators/):
+  A library of bidirectional parser combinators.
 - [**ll1-combinators**](./lang-ll1-combinators):
   Linear-time parser combinators based on Neel Krishnaswami’s blog post.
 - [**ll1-dsl**](./lang-ll1-dsl):

dune-project

@@ -28,6 +28,11 @@
 
 ; Language experiments
 
+(package
+  (name bidi-combinators)
+  (depends
+    sized-numbers))
+
 (package
   (name ll1-combinators)
   (depends

lang-bidi-combinators/README.md

@@ -0,0 +1,11 @@
+# Bidirectional combinators
+
+A library of bidirectional parser combinators.
+
+## Resources
+
+- “Composing Bidirectional Programs Monadically”
+  [[doi:10.1007/978-3-030-17184-1_6](https://doi.org/10.1007/978-3-030-17184-1_6)]
+- Codec: Easy bidirectional serialization in Haskell
+  [[hackage:codec](https://hackage.haskell.org/package/codec>)]
+  [[github:chpatrick/codec](https://github.com/chpatrick/codec>)]

lang-bidi-combinators/decoder.ml

@@ -0,0 +1,41 @@
+type 'a t = bytes -> int -> ('a * int) option
+
+let ( let+ ) x f = Option.map f x
+let ( let* ) = Option.bind
+
+let pure (type a) (x : a) : a t =
+  fun _ pos -> Some (x, pos)
+
+let map (type a b) (f : a -> b) (x : a t) : b t =
+  fun buf pos ->
+    let+ x, pos = x buf pos in
+    (f x, pos)
+
+let both (type a b) (x : a t) (y : b t) : (a * b) t =
+  fun buf pos ->
+    let* (x, pos) = x buf pos in
+    let+ (y, pos) = y buf pos in
+    ((x, y), pos)
+
+let apply (type a b) (f : (a -> b) t) (x : a t) : b t =
+  both f x |> map (fun (f, x) -> f x)
+
+let bind (type a b) (x : a t) (y : a -> b t) : b t =
+  fun buf pos ->
+    let* (x, pos) = x buf pos in
+    (y x) buf pos
+
+let fail (type a) : a t =
+  fun _ _ -> None
+
+module Syntax = struct
+
+  let ( <$> ) = map
+  let ( <*> ) = apply
+
+  let ( let+ ) x f = map f x
+  let ( and+ ) = both
+  let ( let* ) = bind
+  let ( and* ) = both
+
+end

lang-bidi-combinators/dune

@@ -0,0 +1,5 @@
+(library
+  (name bidi_combinators)
+  (public_name bidi-combinators)
+  (libraries
+    sized-numbers))

lang-bidi-combinators/encoder.ml

@@ -0,0 +1,53 @@
+(** The type of an encoder, parameterized by:
+
+    - ['ctx]: the context of the encoder
+    - ['a]: the type of the decoded value (used for dependent encoders)
+*)
+type ('ctx, 'a) t = Buffer.t -> 'ctx -> 'a option
+
+let ( let+ ) x f = Option.map f x
+let ( let* ) = Option.bind
+
+let pure (type ctx a) (x : a) : (ctx, a) t =
+  fun _ _ -> Some x
+
+let map (type ctx a b) (f : a -> b) (x : (ctx, a) t) : (ctx, b) t =
+  fun buf c ->
+    let+ x = x buf c in
+    f x
+
+let both (type ctx a b) (x : (ctx, a) t) (y : (ctx, b) t) : (ctx, a * b) t =
+  fun buf c ->
+    let* x = x buf c in
+    let+ y = y buf c in
+    (x, y)
+
+let apply (type ctx a b) (f : (ctx, a -> b) t) (x : (ctx, a) t) : (ctx, b) t =
+  both f x |> map (fun (f, x) -> f x)
+
+let bind (type ctx a b) (x : (ctx, a) t) (y : a -> (ctx, b) t) : (ctx, b) t =
+  fun buf c ->
+    let* x = x buf c in
+    (y x) buf c
+
+let fail (type ctx a) : (ctx, a) t =
+  fun _ _ ->
+    failwith "encoding fail format"
+
+let comap (type ctx ctx' a) (f : ctx' -> ctx) (x : (ctx, a) t) : (ctx', a) t =
+  fun buf c ->
+    x buf (f c)
+
+module Syntax = struct
+
+  let ( <$> ) = map
+  let ( <*> ) = apply
+
+  let ( @= ) = comap
+
+  let ( let+ ) x f = map f x
+  let ( and+ ) = both
+  let ( let* ) = bind
+  let ( and* ) = both
+
+end

lang-bidi-combinators/examples/dune

@@ -0,0 +1,4 @@
+(library
+  (name examples)
+  (libraries
+    bidi-combinators))

lang-bidi-combinators/examples/image.ml

@@ -0,0 +1,20 @@
+open Bidi_combinators
+
+type t = {
+  width : int;
+  height : int;
+  data : int32 array;
+}
+
+let width x = x.width
+let height x = x.height
+let data x = x.data
+
+let format : (t, t) Format.t =
+  let open Format.Syntax in
+
+  let* width = width @= Format.int16_be
+  and+ height = height @= Format.int16_be in
+  let+ data = data @= Format.Array.repeat_len Format.int32_be (width * height) in
+
+  { width; height; data }

lang-bidi-combinators/examples/image_with_header.ml

@@ -0,0 +1,37 @@
+open Bidi_combinators
+
+module Header = struct
+
+  type t = {
+    width : int;
+    height : int;
+  }
+
+  let width x = x.width
+  let height x = x.height
+
+  let format : (t, t) Format.t =
+    let open Format.Syntax in
+
+    let+ width = width @= Format.int16_be
+    and+ height = height @= Format.int16_be in
+
+    { width; height }
+
+end
+
+type t = {
+  header : Header.t;
+  data : int32 array;
+}
+
+let header x = x.header
+let data x = x.data
+
+let format =
+  let open Format.Syntax in
+
+  let* header = header @= Header.format in
+  let+ data = data @= Format.Array.repeat_len Format.int32_be (header.width * header.height) in
+
+  { header; data }

lang-bidi-combinators/format.ml

@@ -0,0 +1,186 @@
+(** The type of a format, parameterized by:
+
+    - ['ctx]: the context of the encoder
+    - ['a]: the type of the decoded value (used for dependent encoders)
+*)
+type ('ctx, 'a) t = {
+  decode : 'a Decoder.t;
+  encode : ('ctx, 'a) Encoder.t;
+}
+
+let ( let+ ) x f = Option.map f x
+let ( let* ) = Option.bind
+
+let pure (type ctx a) (x : a) : (ctx, a) t = {
+  decode = Decoder.pure x;
+  encode = Encoder.pure x;
+}
+
+let map (type ctx a b) (f : a -> b) (x : (ctx, a) t) : (ctx, b) t = {
+  decode = Decoder.map f x.decode;
+  encode = Encoder.map f x.encode;
+}
+
+let both (type ctx a b) (x : (ctx, a) t) (y : (ctx, b) t) : (ctx, a * b) t = {
+  decode = Decoder.both x.decode y.decode;
+  encode = Encoder.both x.encode y.encode;
+}
+
+let apply (type ctx a b) (f : (ctx, a -> b) t) (x : (ctx, a) t) : (ctx, b) t =
+  both f x |> map (fun (f, x) -> f x)
+
+let bind (type ctx a b) (x : (ctx, a) t) (y : a -> (ctx, b) t) : (ctx, b) t = {
+  decode = Decoder.bind x.decode (fun x -> (y x).decode);
+  encode = Encoder.bind x.encode (fun x -> (y x).encode);
+}
+
+let fail (type ctx a) : (ctx, a) t = {
+  decode = Decoder.fail;
+  encode = Encoder.fail;
+}
+
+let comap (type ctx ctx' a) (f : ctx' -> ctx) (x : (ctx, a) t) : (ctx', a) t =
+  { x with encode = Encoder.comap f x.encode }
+
+module Syntax = struct
+
+  let ( <$> ) = map
+  let ( <*> ) = apply
+
+  let ( @= ) = comap
+
+  let ( let+ ) x f = map f x
+  let ( and+ ) = both
+  let ( let* ) = bind
+  let ( and* ) = both
+
+end
+
+open Sized_numbers
+
+(* TODO: Unsigned formats *)
+
+let int8 : (int, int) t = (* FIXME: int8 *)
+  let decode buf pos = if pos < Bytes.length buf then Some (Bytes.get_int8 buf pos, pos + 1) else None
+  and encode buf c = Buffer.add_int8 buf c; Some c in
+  { decode; encode }
+
+let int16_be : (int, int) t = (* FIXME: int16 *)
+  let open Syntax in
+
+  let+ b0 = (fun x -> x lsl 8) <$> (fun x -> x lsr 8) @= int8
+  and+ b1 = int8 in
+
+  b0 lor b1
+
+let int16_le : (int, int) t = (* FIXME: int16 *)
+  let open Syntax in
+
+  let+ b0 = int8
+  and+ b1 = (fun x -> x lsl 8) <$> (fun x -> x lsr 8) @= int8 in
+
+  b0 lor b1
+
+let int32_be : (int32, int32) t =
+  let open Syntax in
+  let open Int32.O in
+
+  let+ b0 = Int32.(fun x -> (of_int x) lsl 24) <$> Int32.(fun x -> to_int (x lsr 24)) @= int8
+  and+ b1 = Int32.(fun x -> (of_int x) lsl 16) <$> Int32.(fun x -> to_int (x lsr 16)) @= int8
+  and+ b2 = Int32.(fun x -> (of_int x) lsl 8) <$> Int32.(fun x -> to_int (x lsr 8)) @= int8
+  and+ b3 = Int32.of_int <$> Int32.to_int @= int8 in
+
+  b0 lor b1 lor b2 lor b3
+
+let int32_le : (int32, int32) t =
+  let open Syntax in
+  let open Int32.O in
+
+  let+ b0 = Int32.of_int <$> Int32.to_int @= int8
+  and+ b1 = Int32.(fun x -> (of_int x) lsl 8) <$> Int32.(fun x -> to_int (x lsr 8)) @= int8
+  and+ b2 = Int32.(fun x -> (of_int x) lsl 16) <$> Int32.(fun x -> to_int (x lsr 16)) @= int8
+  and+ b3 = Int32.(fun x -> (of_int x) lsl 24) <$> Int32.(fun x -> to_int (x lsr 24)) @= int8 in
+
+  b0 lor b1 lor b2 lor b3
+
+let int64_be : (int64, int64) t =
+  let open Syntax in
+  let open Int64.O in
+
+  let+ b0 = Int64.(fun x -> (of_int x) lsl 56) <$> Int64.(fun x -> to_int (x lsr 56)) @= int8
+  and+ b1 = Int64.(fun x -> (of_int x) lsl 48) <$> Int64.(fun x -> to_int (x lsr 48)) @= int8
+  and+ b2 = Int64.(fun x -> (of_int x) lsl 40) <$> Int64.(fun x -> to_int (x lsr 40)) @= int8
+  and+ b3 = Int64.(fun x -> (of_int x) lsl 32) <$> Int64.(fun x -> to_int (x lsr 32)) @= int8
+  and+ b4 = Int64.(fun x -> (of_int x) lsl 24) <$> Int64.(fun x -> to_int (x lsr 24)) @= int8
+  and+ b5 = Int64.(fun x -> (of_int x) lsl 16) <$> Int64.(fun x -> to_int (x lsr 16)) @= int8
+  and+ b6 = Int64.(fun x -> (of_int x) lsl 8) <$> Int64.(fun x -> to_int (x lsr 8)) @= int8
+  and+ b7 = Int64.of_int <$> Int64.to_int @= int8 in
+
+  b0 lor b1 lor b2 lor b3 lor b4 lor b5 lor b6 lor b7
+
+let int64_le : (int64, int64) t =
+  let open Syntax in
+  let open Int64.O in
+
+  let+ b0 = Int64.of_int <$> Int64.to_int @= int8
+  and+ b1 = Int64.(fun x -> (of_int x) lsl 8) <$> Int64.(fun x -> to_int (x lsr 8)) @= int8
+  and+ b2 = Int64.(fun x -> (of_int x) lsl 16) <$> Int64.(fun x -> to_int (x lsr 16)) @= int8
+  and+ b3 = Int64.(fun x -> (of_int x) lsl 24) <$> Int64.(fun x -> to_int (x lsr 24)) @= int8
+  and+ b4 = Int64.(fun x -> (of_int x) lsl 32) <$> Int64.(fun x -> to_int (x lsr 32)) @= int8
+  and+ b5 = Int64.(fun x -> (of_int x) lsl 40) <$> Int64.(fun x -> to_int (x lsr 40)) @= int8
+  and+ b6 = Int64.(fun x -> (of_int x) lsl 48) <$> Int64.(fun x -> to_int (x lsr 48)) @= int8
+  and+ b7 = Int64.(fun x -> (of_int x) lsl 56) <$> Int64.(fun x -> to_int (x lsr 56)) @= int8 in
+
+  b0 lor b1 lor b2 lor b3 lor b4 lor b5 lor b6 lor b7
+
+
+module List = struct
+
+  open Syntax
+
+  let repeat_len (type a) (elem : (a, a) t) (len : int) : (a list, a list) t =
+    let rec repeat_len i =
+      if i < len then
+        (* FIXME: List.hd and List.tl fail on the empty list*)
+        let* x = List.hd @= elem in
+        let+ xs = List.tl @= repeat_len (i + 1) in
+        x :: xs
+      else
+        pure []
+    in
+    repeat_len 0
+
+end
+
+module Array = struct
+
+  let repeat_len (type a) (elem : (a, a) t) (len : int) : (a array, a array) t =
+    (* FIXME: No clue if this actually works - write some tests! *)
+    let decode buf pos =
+      if len <= 0 then Some ([||], pos) else
+        let* (x, pos) = elem.decode buf pos in
+        let xs = Array.make len x in
+        let rec go i buf pos =
+          if i < len then
+            let* (x, pos) = elem.decode buf pos in
+            Array.set xs i x;
+            (go [@tailcall]) (i + 1) buf pos
+          else
+            Some (xs, pos)
+        in
+        go 1 buf pos
+
+    and encode =
+      let rec go i buf xs =
+        if i <= Array.length xs then
+          let* _ = elem.encode buf (Array.get xs i) in
+          (go [@tailcall]) (i + 1) buf xs
+        else
+          Some xs
+      in
+      go 0
+    in
+
+    { decode; encode }
+
+end