Merge pull request #1 from akabe/feature/v1

Prototype

.github/workflows/ocaml.yaml

@@ -0,0 +1,37 @@
+name: OCaml
+
+on:
+  push:
+    branches:
+      - '*'
+  pull_request:
+    branches:
+      - main
+
+jobs:
+  build:
+    runs-on: ubuntu-latest
+    strategy:
+      matrix:
+        ocaml-compiler:
+          - 4.10.0
+          - 4.11.0
+          - 4.12.0
+
+    steps:
+      - uses: actions/checkout@v2
+      - name: Set up OCaml ${{ matrix.ocaml-compiler }}
+        uses: ocaml/setup-ocaml@v2
+        with:
+          ocaml-compiler: ${{ matrix.ocaml-compiler }}
+      - name: Cache dependencies
+        uses: actions/cache@v2
+        with:
+          path: ~/.opam
+          key: ${{ runner.os }}-opam-${{ hashFiles('**/*.opam') }}
+          restore-keys: ${{ runner.os }}-opam-
+      - run: ./git/pre-commit.sh
+      - run: opam lint *.opam
+      - run: opam install . --deps-only --with-test
+      - run: opam exec -- dune build
+      - run: opam exec -- dune runtest

dune-project

@@ -0,0 +1,2 @@
+(lang dune 2.8)
+(name ppx_deriving_binary)

git/pre-commit.sh

@@ -0,0 +1,28 @@
+#!/bin/bash
+
+eval $(opam env)
+
+which ocp-indent 2>&1 >/dev/null || opam install -y 'ocp-indent>=1.7.0'
+
+[ -L ./.git/hooks/pre-commit ] || ln -s ../../git/pre-commit.sh .git/hooks/pre-commit
+
+exit_code=0
+
+for fname in $(find src tests -name '*.ml' -or -name '*.mli'); do
+    if [ "$(echo $fname | grep cppo)" == '' ]; then
+	d1=$(cat "$fname")
+	d2=$(ocp-indent "$fname")
+
+	if [[ "$d1" = "$d2" ]]; then
+	    echo -e "\033[32m[Passed]\033[0m $fname is already formatted."
+	else
+	    echo -e "\033[31m[Failed]\033[0m $fname is NOT formatted."
+	    ocp-indent -i "$fname"
+	    exit_code=1
+	fi
+    else
+	echo -e "\033[33m[Skipped]\033[0m $fname is skipped."
+    fi
+done
+
+exit $exit_code

ppx_deriving_binary.opam

@@ -0,0 +1,19 @@
+opam-version: "2.0"
+synopsis: "Type-driven generation of binary serializers and deserializers"
+maintainer: ["Akinori Abe"]
+authors: ["Akinori Abe"]
+license: "MIT"
+homepage: "https://github.com/akabe/ppx_deriving_binary"
+bug-reports: "https://github.com/akabe/ppx_deriving_binary/issues"
+build: [
+  [ "dune" "subst" ] {pinned}
+  [ "dune" "build" "-p" name "-j" jobs ]
+]
+depends: [
+  "ocaml" {>= "4.10.0"}
+  "base-threads"
+  "base-unix"
+  "ppx_deriving" {>= "5.0.0"}
+  "dune" {build & >= "1.0.0"}
+  "ounit2" {with-test & >= "2.0.0"}
+]

src/ppx/astmisc.ml

@@ -0,0 +1,104 @@
+(* ppx_deriving_binary
+
+   Copyright (c) 2021 Akinori Abe
+
+   Permission is hereby granted, free of charge, to any person obtaining a copy
+   of this software and associated documentation files (the "Software"), to deal
+   in the Software without restriction, including without limitation the rights
+   to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+   copies of the Software, and to permit persons to whom the Software is
+   furnished to do so, subject to the following conditions:
+
+   The above copyright notice and this permission notice shall be included in
+   all copies or substantial portions of the Software.
+
+   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+   AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+   OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+   SOFTWARE. *)
+
+open Ppx_deriving.Ast_convenience
+open Ppxlib
+open Ppxlib.Ast_helper
+
+let mklid ?(loc = Location.none) s = { loc; txt = Longident.Lident s }
+
+let pint ?loc ?suffix x = Pat.constant ?loc (Const.int ?suffix x)
+let eint ?loc ?suffix x = Exp.constant ?loc (Const.int ?suffix x)
+let estring ?loc x = Exp.constant ?loc (Const.string x)
+
+let attr_base_type ~deriver attrs =
+  let open Ppx_deriving in
+  match attr ~deriver "base_type" attrs with
+  | Some { attr_payload = PTyp core_type; _ } -> Some core_type
+  | _ -> None
+
+let attr_base_type_exn ~deriver ~loc attrs =
+  let open Ppx_deriving in
+  match attr_base_type ~deriver attrs with
+  | Some core_type -> core_type
+  | None ->
+    Ppx_deriving.raise_errorf ~loc
+      "ppx_deriving_binary requires [@base_type: t] for variants or polymorphic variants"
+
+let attr_length ~deriver attrs =
+  Ppx_deriving.(attrs |> attr ~deriver "length" |> Arg.(get_attr ~deriver int))
+
+let attr_length_exn ~deriver ~loc attrs =
+  match attr_length ~deriver attrs with
+  | Some x -> x
+  | None ->
+    Ppx_deriving.raise_errorf ~loc
+      "ppx_deriving_binary requires [@length] for string, bytes, list and array"
+
+let attr_offset ~deriver attrs =
+  Ppx_deriving.(attrs |> attr ~deriver "offset" |> Arg.(get_attr ~deriver int))
+
+(** Collect labelled arguments from an expression of
+    form [fun ~lb1 ~lb2 ... -> ...]. *)
+let get_labelled_args_from_fun efun =
+  let rec aux acc e = match e.pexp_desc with
+    | Pexp_fun (Labelled s, _, _, e') -> aux (s :: acc) e'
+    | _ -> List.rev acc in
+  aux [] efun
+
+let parametrize_expression type_params expr =
+  List.fold_right (fun (typ, _) acc ->
+      let loc = typ.ptyp_loc in
+      let ppar = match typ.ptyp_desc with
+        | Ptyp_any -> Pat.any ()
+        | Ptyp_var s -> Pat.var (mknoloc ("poly_" ^ s))
+        | _ ->
+          Ppx_deriving.raise_errorf "Unexpected type parameter: %s"
+            (Ppx_deriving.string_of_core_type typ) in
+      [%expr fun [%p ppar] -> [%e acc]])
+    type_params expr
+
+let create_str_value ~mkexp affix type_decls =
+  let value_bindings =
+    List.map
+      (fun type_decl ->
+         let body = mkexp type_decl in
+         let fun_name = Ppx_deriving.mangle_type_decl affix type_decl in
+         Vb.mk ~loc:type_decl.ptype_loc (pvar fun_name) body)
+      type_decls in
+  let recflag =
+    match type_decls with
+    | [] | [_] -> Nonrecursive
+    | _ -> Recursive (* maybe mutual recursion is required *) in
+  Str.value recflag value_bindings
+
+let create_sig_value ~mktype affix type_decl =
+  let loc = type_decl.ptype_loc in
+  let typename = mklid ~loc type_decl.ptype_name.txt in
+  let return_t = Typ.constr typename (List.map fst type_decl.ptype_params) in
+  let fun_name = Ppx_deriving.mangle_type_decl affix type_decl in
+  List.fold_right
+    (fun (t, _) acc -> [%type: ([%t mktype t]) -> [%t acc]])
+    type_decl.ptype_params
+    (mktype return_t)
+  |> Val.mk ~loc (mkloc fun_name loc)
+  |> Sig.value ~loc

src/ppx/bitfield.ml

@@ -0,0 +1,56 @@
+(* ppx_deriving_cstruct
+
+   Copyright (c) 2021 Akinori Abe
+
+   Permission is hereby granted, free of charge, to any person obtaining a copy
+   of this software and associated documentation files (the "Software"), to deal
+   in the Software without restriction, including without limitation the rights
+   to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+   copies of the Software, and to permit persons to whom the Software is
+   furnished to do so, subject to the following conditions:
+
+   The above copyright notice and this permission notice shall be included in
+   all copies or substantial portions of the Software.
+
+   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+   AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+   OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+   SOFTWARE. *)
+
+open Ppx_deriving.Ast_convenience
+open Ppxlib
+open Ppxlib.Ast_helper
+
+type t =
+  {
+    rbf_name : string;
+    rbf_offset : int;
+    rbf_length : int;
+    rbf_mask : int;
+    rbf_loc : Location.t;
+  }
+
+let of_ocaml_label_declarations ~deriver label_decls =
+  let aux (default_ofs, acc) ld =
+    let ofs =
+      match Astmisc.attr_offset ~deriver ld.pld_attributes with
+      | Some n -> n
+      | None -> default_ofs in
+    let len =
+      match Astmisc.attr_length ~deriver ld.pld_attributes with
+      | Some n -> n
+      | None -> 1 in
+    let field = {
+      rbf_name = ld.pld_name.txt;
+      rbf_offset = ofs;
+      rbf_length = len;
+      rbf_mask = 1 lsl len - 1;
+      rbf_loc = ld.pld_loc;
+    } in
+    (ofs + len, field :: acc)
+  in
+  let _, rev_fields = List.fold_left aux (0, []) label_decls in
+  List.rev rev_fields