feat(nix): add nix.tag, a way of discriminating via tagged unions r/2166

Introduces the concept of a “tag”, a single-keyed attrset which
annotates a nix value with a name.
This can be used to implement tagged unions (by implying the list of
possible tags is well-known), which has some overlap with how
`nix.yants` does it.

However, the more fascinating use-case is in concert with a
so-called discriminator, `match` and hylomorphisms.

The discriminator can take a nix value, and add tags to it based on
some predicate.
With `match`, we can then use that information to convert the
discriminated values again.
With `hylo`, we can combine both the “constructive” discriminator step
with the “destructive” match step to recursively walk over a nix data
structure (based on a description of how to recurse, e.g. through attrset
values or list values), and then apply a transformation in one go.

Change-Id: Ia335ca8b0881447fbbcb6bcd80f49feb835f1715
Reviewed-on: https://cl.tvl.fyi/c/depot/+/2434
Tested-by: BuildkiteCI
Reviewed-by: sterni <sternenseemann@systemli.org>

2 files changed, 237 insertions, 0 deletions

diff --git a/nix/tag/default.nix b/nix/tag/default.nix
new file mode 100644
index 0000000000..832305368f
--- /dev/null
+++ b/nix/tag/default.nix
@@ -0,0 +1,149 @@
+{ depot, lib, ... }:
+let
+  # Takes a tag, checks whether it is an attrset with one element,
+  # if so sets `isTag` to `true` and sets the name and value.
+  # If not, sets `isTag` to `false` and sets `errmsg`.
+  verifyTag = tag:
+    let cases = builtins.attrNames tag;
+        len = builtins.length cases;
+    in
+    if builtins.length cases == 1
+    then let name = builtins.head cases; in {
+      isTag = true;
+      name = name;
+      val = tag.${name};
+      errmsg = null;
+    }
+    else {
+      isTag = false;
+      errmsg =
+        ( "match: an instance of a sum is an attrset "
+        + "with exactly one element, yours had ${toString len}"
+        + ", namely: ${lib.generators.toPretty {} cases}" );
+      name = null;
+      val = null;
+    };
+
+  # like `isTag`, but throws the error message if it is not a tag.
+  assertIsTag = tag:
+    let res = verifyTag tag; in
+    assert lib.assertMsg res.isTag res.errmsg;
+    { inherit (res) name val; };
+
+
+  # Discriminator for values.
+  # Goes through a list of tagged predicates `{ <tag> = <pred>; }`
+  # and returns the value inside the tag
+  # for which the first predicate applies, `{ <tag> = v; }`.
+  # They can then later be matched on with `match`.
+  #
+  # `defTag` is the tag that is assigned if there is no match.
+  #
+  # Examples:
+  #   discrDef "smol" [
+  #     { biggerFive = i: i > 5; }
+  #     { negative = i: i < 0; }
+  #   ] -100
+  #   => { negative = 100; }
+  #   discrDef "smol" [
+  #     { biggerFive = i: i > 5; }
+  #     { negative = i: i < 0; }
+  #   ] 1
+  #   => { smol = 1; }
+  discrDef = defTag: fs: v:
+    let res = lib.findFirst
+                (t: t.val v)
+                null
+                (map assertIsTag fs);
+    in
+      if res == null
+      then { ${defTag} = v; }
+      else { ${res.name} = v; };
+
+  # Like `discrDef`, but fail if there is no match.
+  discr = fs: v:
+    let res = discrDef null fs v; in
+      assert lib.assertMsg (res != null)
+        "tag.discr: No predicate found that matches ${lib.generators.toPretty {} v}";
+      res;
+
+  # The canonical pattern matching primitive.
+  # A sum value is an attribute set with one element,
+  # whose key is the name of the variant and
+  # whose value is the content of the variant.
+  # `matcher` is an attribute set which enumerates
+  # all possible variants as keys and provides a function
+  # which handles each variant’s content.
+  # You should make an effort to return values of the same
+  # type in your matcher, or new sums.
+  #
+  # Example:
+  #   let
+  #      success = { res = 42; };
+  #      failure = { err = "no answer"; };
+  #      matcher = {
+  #        res = i: i + 1;
+  #        err = _: 0;
+  #      };
+  #    in
+  #       match success matcher == 43
+  #    && match failure matcher == 0;
+  #
+  match = sum: matcher:
+    let cases = builtins.attrNames sum;
+    in assert
+      let len = builtins.length cases; in
+        lib.assertMsg (len == 1)
+          ( "match: an instance of a sum is an attrset "
+          + "with exactly one element, yours had ${toString len}"
+          + ", namely: ${lib.generators.toPretty {} cases}" );
+    let case = builtins.head cases;
+    in assert
+        lib.assertMsg (matcher ? ${case})
+        ( "match: \"${case}\" is not a valid case of this sum, "
+        + "the matcher accepts: ${lib.generators.toPretty {}
+            (builtins.attrNames matcher)}" );
+    matcher.${case} sum.${case};
+
+  # A `match` with the arguments flipped.
+  # “Lam” stands for “lambda”, because it can be used like the
+  # `\case` LambdaCase statement in Haskell, to create a curried
+  # “matcher” function ready to take a value.
+  #
+  # Example:
+  #   lib.pipe { foo = 42; } [
+  #     (matchLam {
+  #       foo = i: if i < 23 then { small = i; } else { big = i; };
+  #       bar = _: { small = 5; };
+  #     })
+  #     (matchLam {
+  #       small = i: "yay it was small";
+  #       big = i: "whoo it was big!";
+  #     })
+  #   ]
+  #   => "whoo it was big!";
+  matchLam = matcher: sum: match sum matcher;
+
+  tests = import ./tests.nix {
+    inherit
+      depot
+      lib
+      verifyTag
+      discr
+      discrDef
+      match
+      matchLam
+      ;
+  };
+
+in {
+   inherit
+     verifyTag
+     assertIsTag
+     discr
+     discrDef
+     match
+     matchLam
+     tests
+     ;
+}
diff --git a/nix/tag/tests.nix b/nix/tag/tests.nix
new file mode 100644
index 0000000000..8c9c738074
--- /dev/null
+++ b/nix/tag/tests.nix
@@ -0,0 +1,88 @@
+{ depot, lib, verifyTag, discr, discrDef, match, matchLam }:
+
+let
+  inherit (depot.nix.runTestsuite)
+    runTestsuite
+    assertEq
+    it
+    ;
+
+  isTag-test = it "checks whether something is a tag" [
+    (assertEq "is Tag"
+      (verifyTag { foo = "bar"; })
+      {
+        isTag = true;
+        name = "foo";
+        val = "bar";
+        errmsg = null;
+      })
+    (assertEq "is not Tag"
+      (removeAttrs (verifyTag { foo = "bar"; baz = 42; }) ["errmsg"])
+      {
+        isTag = false;
+        name = null;
+        val = null;
+      })
+  ];
+
+  discr-test = it "can discr things" [
+    (assertEq "id"
+      (discr [
+        { a = lib.const true; }
+      ] "x")
+      { a = "x"; })
+    (assertEq "bools here, ints there"
+      (discr [
+        { bool = lib.isBool; }
+        { int = lib.isInt; }
+      ] 25)
+      { int = 25; })
+    (assertEq "bools here, ints there 2"
+      (discr [
+        { bool = lib.isBool; }
+        { int = lib.isInt; }
+      ] true)
+      { bool = true; })
+    (assertEq "fallback to default"
+      (discrDef "def" [
+        { bool = lib.isBool; }
+        { int = lib.isInt; }
+      ] "foo")
+      { def = "foo"; })
+  ];
+
+  match-test = it "can match things" [
+    (assertEq "match example"
+      (let
+        success = { res = 42; };
+        failure = { err = "no answer"; };
+        matcher = {
+          res = i: i + 1;
+          err = _: 0;
+        };
+      in {
+        one = match success matcher;
+        two = match failure matcher;
+      })
+      { one = 43;
+        two = 0; })
+    (assertEq "matchLam & pipe"
+      (lib.pipe { foo = 42; } [
+        (matchLam {
+          foo = i: if i < 23 then { small = i; } else { big = i; };
+          bar = _: { small = 5; };
+        })
+        (matchLam {
+          small = i: "yay it was small";
+          big = i: "whoo it was big!";
+        })
+      ])
+      "whoo it was big!")
+  ];
+
+in
+  runTestsuite "tag" [
+    isTag-test
+    discr-test
+    match-test
+  ]