diff options
| -rw-r--r-- | dune-project | 16 | ||||
| -rw-r--r-- | lib/dune | 3 | ||||
| -rw-r--r-- | lib/input.ml | 42 | ||||
| -rw-r--r-- | lib/lockfile.ml | 41 | ||||
| -rw-r--r-- | lib/manifest.ml | 24 | ||||
| -rw-r--r-- | lib/name.ml | 18 | ||||
| -rw-r--r-- | nix/package/dev-shell.nix | 2 | ||||
| -rw-r--r-- | nix/package/nixtamal.nix | 3 | ||||
| -rw-r--r-- | nixtamal.opam | 6 | ||||
| -rw-r--r-- | test/dune | 2 |
10 files changed, 110 insertions, 47 deletions
diff --git a/dune-project b/dune-project index de7d7f5..3289e94 100644 --- a/dune-project +++ b/dune-project @@ -17,7 +17,21 @@ (name nixtamal) (synopsis "Fulfilling Nix version pinning") (description "TODO") - (depends aloctest cmdliner eio eio_main fmt jingoo jsont kdl logs uri) + (depends + cmdliner + eio + eio_main + fmt + jingoo + jsont + kdl + logs + ppx_deriving + ppx_deriving_qcheck + uri + (alcotest :with-test) + (qcheck :with-test) + (qcheck-alcotest :with-test)) (tags ("nix"))) ; See the complete stanza docs at https://dune.readthedocs.io/en/stable/reference/dune-project/index.html @@ -8,4 +8,5 @@ ppx_deriving.eq ppx_deriving.ord ppx_deriving.make - ppx_deriving.show))) + ppx_deriving.show + ppx_deriving_qcheck))) diff --git a/lib/input.ml b/lib/input.ml index 6ff5e6e..3e9fd0f 100644 --- a/lib/input.ml +++ b/lib/input.ml @@ -10,7 +10,7 @@ module Template = struct type t = Template of string [@@unboxed] - [@@deriving show] + [@@deriving show, qcheck] let [@inline]make t = Template t let [@inline]take (Template t) = t @@ -22,16 +22,16 @@ module Latest = struct module Cmd = struct type 'a non_empty_list = ('a * 'a list) - [@@deriving show] + [@@deriving show, qcheck] type cmd = { prog: Template.t; args: Template.t list; } - [@@deriving show, make] + [@@deriving show, make, qcheck] type t = cmd non_empty_list - [@@deriving show] + [@@deriving show, qcheck] let (~$) x = (x, []) let (|:) (x, xs) x' = (x, x' :: xs) @@ -42,7 +42,7 @@ module Latest = struct cmd: Cmd.t option; value: string option; } - [@@deriving show, make] + [@@deriving show, make, qcheck] end (* KINDS **********************************************************************) @@ -52,7 +52,7 @@ module File = struct url: Template.t; mirrors: Template.t list; } - [@@deriving show, make] + [@@deriving show, make, qcheck] end module Archive = struct @@ -60,7 +60,7 @@ module Archive = struct url: Template.t; mirrors: Template.t list; } - [@@deriving show, make] + [@@deriving show, make, qcheck] end module Git = struct @@ -69,7 +69,7 @@ module Git = struct | `Branch of string | `Ref of string ] - [@@deriving show] + [@@deriving show, qcheck] end type t = { @@ -81,7 +81,7 @@ module Git = struct lfs: bool; [@default false] latest_revision: string option; } - [@@deriving show, make] + [@@deriving show, make, qcheck] let default_latest_cmd git : Latest.Cmd.t = let open Latest.Cmd in @@ -98,11 +98,17 @@ end module Darcs = struct module Reference = struct + type context_grounds = [ + | `Assumed of string option + | `Stated of string + ] + [@@deriving show, qcheck] + type t = [ - | `Context of [`Assumed of string option | `Stated of string] + | `Context of context_grounds | `Tag of string ] - [@@deriving show] + [@@deriving show, qcheck] end type t = { @@ -112,7 +118,7 @@ module Darcs = struct datetime: string option; (* ISO 8601 RFC 3339 *) latest_weak_hash: string option; } - [@@deriving show, make] + [@@deriving show, make, qcheck] let pp fmt t = Fmt.pf fmt "%s" (show t) end @@ -124,7 +130,7 @@ module Pijul = struct | `State of string | `Change of string ] - [@@deriving show] + [@@deriving show, qcheck] end type t = { @@ -134,7 +140,7 @@ module Pijul = struct datetime: string option; (* ISO 8601 RFC 3339 *) latest_state: string option; } - [@@deriving show, make] + [@@deriving show, make, qcheck] end module Hash = struct @@ -142,7 +148,7 @@ module Hash = struct | SHA256 | SHA512 | BLAKE3 - [@@deriving enum, eq, ord, show] + [@@deriving enum, eq, ord, show, qcheck] let algorithm_to_string = function | SHA256 -> "SHA256" @@ -169,7 +175,7 @@ module Hash = struct (* used to assert in fetching for manually-updated pins *) expected: string option; } - [@@deriving show, make] + [@@deriving show, make, qcheck] end (* INPUT *******************************************************************) @@ -182,7 +188,7 @@ module Kind = struct | `Darcs of Darcs.t | `Pijul of Pijul.t ] - [@@deriving show] + [@@deriving show, qcheck] end let make_kind_file ~url ?mirrors () = @@ -209,7 +215,7 @@ type t = { hash: Hash.t; [@default Hash.make ()] frozen: bool; [@default false] } -[@@deriving show, make] +[@@deriving show, make, qcheck] let latest_cmd (input : t) : Latest.Cmd.t option = match input.latest.cmd with diff --git a/lib/lockfile.ml b/lib/lockfile.ml index af496bf..e109312 100644 --- a/lib/lockfile.ml +++ b/lib/lockfile.ml @@ -10,12 +10,26 @@ let filename = "lock.json" let encode_tag = Util.Jsont.encode_tag +module Uri = struct + include Uri + (* good enough for this *) + let gen = + let open QCheck.Gen in + let a_to_z = (char_range 'a' 'z') in + let* scheme = QCheck.Gen.oneofl ["http"; "https"; "ftp"; "sftp"] in + let* host = string_size ~gen: a_to_z (int_bound 20) in + let* tld = string_size ~gen: a_to_z (int_bound 5) in + let* path_opt = option (string_size ~gen: a_to_z (int_bound 10)) in + let uri = Uri.of_string Fmt.(str "%s://%s.%s/%a" scheme host tld (option string) path_opt) in + return uri +end + module File = struct type t = { url: Uri.t; mirrors: Uri.t list; } - [@@deriving show] + [@@deriving show, qcheck] let [@inline]to_lock ~(models : Input.jg_models2) @@ -43,7 +57,7 @@ module Archive = struct url: Uri.t; mirrors: Uri.t list; } - [@@deriving show] + [@@deriving show, qcheck] let [@inline]to_lock ~(models : Input.jg_models2) ({url; mirrors; _}: Input.Archive.t) : t = let to_uri = Fun.compose Uri.of_string (Input.Template.fill ~models) in @@ -100,7 +114,7 @@ module Git = struct lfs: bool; latest_revision: string option; } - [@@deriving show] + [@@deriving show, qcheck] let [@inline]to_lock ~(models : Input.jg_models2) @@ -138,7 +152,7 @@ end module Darcs = struct module Reference = struct type t = Input.Darcs.Reference.t - [@@deriving show] + [@@deriving show, qcheck] let jsont : t Jsont.t = let open Jsont in @@ -193,7 +207,7 @@ module Darcs = struct reference: Reference.t; latest_weak_hash: string option; } - [@@deriving show] + [@@deriving show, qcheck] let [@inline]to_lock ~(models : Input.jg_models2) @@ -262,7 +276,7 @@ module Pijul = struct (*reference: Reference.t;*) latest_state: string option; } - [@@deriving show] + [@@deriving show, qcheck] let [@inline]to_lock ~(models : Input.jg_models2) @@ -298,7 +312,7 @@ module Kind = struct | `Darcs of Darcs.t | `Pijul of Pijul.t ] - [@@deriving show] + [@@deriving show, qcheck] let to_lock ~(models : Input.jg_models2) : Input.Kind.t -> t = function | `File f -> `File (File.to_lock ~models f) @@ -348,7 +362,7 @@ end module Hash = struct type algorithm = Input.Hash.algorithm - [@@deriving show] + [@@deriving show, qcheck] let algorithm_jsont = let gen_algo i = @@ -364,7 +378,7 @@ module Hash = struct algorithm: algorithm; value: string option; } - [@@deriving show] + [@@deriving show, qcheck] let [@inline]to_lock ({algorithm; value; _}: Input.Hash.t) : t = {algorithm; value} @@ -385,7 +399,7 @@ module Input' = struct hash: Hash.t; latest_value: string option; } - [@@deriving show] + [@@deriving show, qcheck] let [@inline]to_lock ~(models : Input.jg_models2) (input : Input.t) : t = { kind = Kind.to_lock ~models input.kind; @@ -402,11 +416,14 @@ module Input' = struct |> Object.finish end +type inputs = Input'.t NameMap.t +[@@deriving show, qcheck] + type t = { version: string; - inputs: Input'.t NameMap.t; + inputs: inputs; } -[@@deriving show] +[@@deriving show, qcheck] let lockfile : t option ref = ref None diff --git a/lib/manifest.ml b/lib/manifest.ml index b79ebb9..68d5690 100644 --- a/lib/manifest.ml +++ b/lib/manifest.ml @@ -39,7 +39,7 @@ module File = struct url: Template.t; mirrors: Template.t list; } - [@@deriving show, make] + [@@deriving show, make, qcheck] let [@inline]to_manifest ({url; mirrors; _}: Input.File.t) : t = make ~url ~mirrors () @@ -78,7 +78,7 @@ module Archive = struct url: Template.t; mirrors: Template.t list; } - [@@deriving show, make] + [@@deriving show, make, qcheck] let [@inline]to_manifest ({url; mirrors; _}: Input.Archive.t) : t = make ~url ~mirrors () @@ -115,7 +115,7 @@ end module Git = struct module Reference = struct type t = Input.Git.Reference.t - [@@deriving show] + [@@deriving show, qcheck] let codec : t Util.KDL.node_codec = { to_node = (fun ref -> @@ -147,7 +147,7 @@ module Git = struct submodules: bool; [@default false] lfs: bool; [@default false] } - [@@deriving show, make] + [@@deriving show, make, qcheck] let [@inline]to_manifest ({repository; mirrors; reference; submodules; lfs; _}: Input.Git.t) : t = make ~repository ~mirrors ~reference ~submodules ~lfs () @@ -209,7 +209,7 @@ end module Darcs = struct module Reference = struct type t = Input.Darcs.Reference.t - [@@deriving show] + [@@deriving show, qcheck] let codec : t Util.KDL.codec = { to_kdl = (fun ref -> @@ -240,7 +240,7 @@ module Darcs = struct mirrors: Template.t list; reference: Reference.t; } - [@@deriving show, make] + [@@deriving show, make, qcheck] let [@inline]to_manifest ({repository; mirrors; reference; _}: Input.Darcs.t) : t = make ~repository ~mirrors ~reference () @@ -281,7 +281,7 @@ end module Pijul = struct module Reference = struct type t = Input.Pijul.Reference.t - [@@deriving show] + [@@deriving show, qcheck] let codec : t Util.KDL.node_codec = { to_node = (fun ref -> @@ -314,7 +314,7 @@ module Pijul = struct mirrors: Template.t list; reference: Reference.t; } - [@@deriving show, make] + [@@deriving show, make, qcheck] let [@inline]to_manifest ({remote; mirrors; reference; _}: Input.Pijul.t) : t = make ~remote ~mirrors ~reference () @@ -360,7 +360,7 @@ module Hash = struct algorithm: Input.Hash.algorithm; [@default Input.Hash.default_algorithm] expected: string option; } - [@@deriving show, make] + [@@deriving show, make, qcheck] let [@inline]to_manifest ({algorithm; expected; _}: Input.Hash.t) : t = make ~algorithm ?expected () @@ -441,7 +441,7 @@ module Kind = struct | `Darcs of Darcs.t | `Pijul of Pijul.t ] - [@@deriving show] + [@@deriving show, qcheck] let to_manifest : Input.Kind.t -> t = function | `File f -> `File (File.to_manifest f) @@ -498,7 +498,7 @@ module Input' = struct hash: Hash.t; frozen: bool; [@default false] } - [@@deriving show, make] + [@@deriving show, make, qcheck] let [@inline]to_manifest (input : Input.t) : t = { name = input.name; @@ -623,7 +623,7 @@ type t = { version: string; inputs: Input'.t list; } -[@@deriving show, make] +[@@deriving show, make, qcheck] let document_to_t (doc : Kdl.t) : t Util.KDL.Valid.t = let open Util.KDL.L in diff --git a/lib/name.ml b/lib/name.ml index 4abebfe..dfc338c 100644 --- a/lib/name.ml +++ b/lib/name.ml @@ -6,7 +6,7 @@ module Name = struct type t = Name of string [@@unboxed] - [@@deriving eq] + [@@deriving eq, qcheck] let [@inline]make n = Name n let [@inline]take (Name n) = n @@ -36,8 +36,18 @@ module NameHashtbl : sig end = Hashtbl.Make(struct type t = Name.t + let equal = Name.equal + let hash n = Hashtbl.hash (Name.take n) + + let gen gen_val = + let open QCheck.Gen in + let* n = int_bound 32 in + let* vals = list_size (return n) (pair Name.gen gen_val) in + let htbl = Hashtbl.create n in + List.iter (fun (k, v) -> Hashtbl.add htbl k v) vals; + return htbl end) module NameMap = struct @@ -57,6 +67,12 @@ module NameMap = struct fmt (bindings map) + let gen gen_val = + let open QCheck.Gen in + let* n = int_bound 32 in + let* vals = list_size (return n) (pair Name.gen gen_val) in + return (List.fold_left (fun m (k, v) -> Impl.add k v m) Impl.empty vals) + let jsont ?kind ?doc (type' : 'a Jsont.t) : 'a t Jsont.t = let name_map = let dec_empty () = empty diff --git a/nix/package/dev-shell.nix b/nix/package/dev-shell.nix index 4ace75c..77a9ac1 100644 --- a/nix/package/dev-shell.nix +++ b/nix/package/dev-shell.nix @@ -23,6 +23,8 @@ mkShell { topiary ocamlPackages.alcotest + ocamlPackages.qcheck + ocamlPackages.qcheck-alcotest ocamlPackages.ocaml-lsp ocamlformat-rpc-bin # 💢 why does the LSP depend on ocamlformat‽ ]; diff --git a/nix/package/nixtamal.nix b/nix/package/nixtamal.nix index ab4fa2d..d9dfb25 100644 --- a/nix/package/nixtamal.nix +++ b/nix/package/nixtamal.nix @@ -81,6 +81,7 @@ ocamlPackages.buildDunePackage { kdl logs ppx_deriving + ppx_deriving_qcheck saturn uri ]); @@ -96,6 +97,8 @@ ocamlPackages.buildDunePackage { checkInputs = with ocamlPackages; [ alcotest + qcheck + qcheck-alcotest ]; passthru.tests.version = testers.testVersion { diff --git a/nixtamal.opam b/nixtamal.opam index bb1b01d..984aa67 100644 --- a/nixtamal.opam +++ b/nixtamal.opam @@ -8,7 +8,6 @@ license: "GPL-3.0-or-later" tags: ["nix"] depends: [ "dune" {>= "3.20"} - "aloctest" "cmdliner" "eio" "eio_main" @@ -17,7 +16,12 @@ depends: [ "jsont" "kdl" "logs" + "ppx_deriving" + "ppx_deriving_qcheck" "uri" + "alcotest" {with-test} + "qcheck" {with-test} + "qcheck-alcotest" {with-test} "odoc" {with-doc} ] build: [ @@ -1,6 +1,6 @@ (test (name test_main) - (libraries nixtamal alcotest)) + (libraries nixtamal alcotest ppx_deriving_qcheck qcheck)) (test (name test_nixtamal)) |