set up QCheck

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
diff --git a/lib/dune b/lib/dune
index bd587da..e0f17c8 100644
--- a/lib/dune
+++ b/lib/dune
@@ -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: [
diff --git a/test/dune b/test/dune
index b4163ca..21bfd8b 100644
--- a/test/dune
+++ b/test/dune
@@ -1,6 +1,6 @@
 (test
  (name test_main)
- (libraries nixtamal alcotest))
+ (libraries nixtamal alcotest ppx_deriving_qcheck qcheck))
 
 (test
  (name test_nixtamal))