feat: Introduce composable type errors and type parameter checking

This refactoring moves the type definitions into a recursively
evaluated attribute set, which makes it possibe to refer to types in
the definitions of other types.

This functionality is used to type-check some of the type parameters
passed in to other types. This is not yet done for all higher-order
types because the evaluation semantics of Nix make it less useful for
some cases.

Further the definition of a type itself is now a stricter
representation that works for all types except typed functions, which
allows for composable error messages.

1 files changed, 268 insertions, 101 deletions

diff --git a/yants.nix b/yants.nix
index 26c5b317c9fb..17564b61b91e 100644
--- a/yants.nix
+++ b/yants.nix
@@ -6,123 +6,290 @@
 #
 # All types (should) compose as expected.
 
-{ toPretty ? ((import <nixpkgs> {}).lib.generators.toPretty {}) }:
+{ lib ?  (import <nixpkgs> {}).lib }:
 
 with builtins; let
-  typeError = type: val:
-  throw "Expected type '${type}', but value '${toPretty val}' is of type '${typeOf val}'";
+  prettyPrint = lib.generators.toPretty {};
 
-  typedef = name: check: {
-    inherit name check;
-    __functor = self: value:
-      if check value then value
-      else typeError name value;
-  };
+  # typedef' :: struct {
+  #   name = string;
+  #   checkType = function; (a -> result)
+  #   checkToBool = option function; (result -> bool)
+  #   toError = option function; (a -> result -> string)
+  #   def = option any;
+  #   match = option function;
+  # } -> type
+  #           -> (a -> b)
+  #           -> (b -> bool)
+  #           -> (a -> b -> string)
+  #           -> type
+  #
+  # This function creates an attribute set that acts as a type.
+  #
+  # It receives a type name, a function that is used to perform a
+  # check on an arbitrary value, a function that can translate the
+  # return of that check to a boolean that informs whether the value
+  # is type-conformant, and a function that can construct error
+  # messages from the check result.
+  #
+  # This function is the low-level primitive used to create types. For
+  # many cases the higher-level 'typedef' function is more appropriate.
+  typedef' = { name, checkType
+             , checkToBool ? (result: result.ok)
+             , toError ? (_: result: result.err)
+             , def ? null
+             , match ? null }: {
+    inherit name checkToBool toError;
+
+    # check :: a -> bool
+    #
+    # This function is used to determine whether a given type is
+    # conformant.
+    check = value: checkToBool (checkType value);
 
-  poly = n: c: { "${n}" = t: typedef "${n}<${t.name}>" (c t); };
+    # checkType :: a -> struct { ok = bool; err = option string; }
+    #
+    # This function checks whether the passed value is type conformant
+    # and returns an optional type error string otherwise.
+    inherit checkType;
 
-  poly2 = n: c: {
-    "${n}" = t1: t2: typedef "${n}<${t1.name},${t2.name}>" (c t1 t2);
+    # __functor :: a -> a
+    #
+    # This function checks whether the passed value is type conformant
+    # and throws an error if it is not.
+    #
+    # The name of this function is a special attribute in Nix that
+    # makes it possible to execute a type attribute set like a normal
+    # function.
+    __functor = self: value:
+    let result = self.checkType value;
+    in if checkToBool result then value
+       else throw (toError value result);
   };
 
-  typeSet = foldl' (s: t: s // (if t ? "name" then { "${t.name}" = t; } else t)) {};
+  typeError = type: val:
+  "expected type '${type}', but value '${prettyPrint val}' is of type '${typeOf val}'";
 
-  # Struct implementation. Checks that all fields match their declared
-  # types, no optional fields are missing and no unexpected fields
-  # occur in the struct.
+  # typedef :: string -> (a -> bool) -> type
   #
-  # Anonymous structs are supported (e.g. for nesting) by omitting the
-  # name.
-  checkField = def: value: current: field:
-  let fieldVal = if hasAttr field value then value."${field}" else null;
-      type = def."${field}";
-      checked = type.check fieldVal;
-  in if checked then (current && true)
-     else if isNull fieldVal then (throw "Missing required ${type.name} field '${field}'")
-          else  (throw "Field ${field} is of type ${typeOf fieldVal}, but expected ${type.name}");
-
-  checkExtraneous = name: def: present:
-  if (length present) == 0 then true
-  else if (hasAttr (head present) def)
-    then checkExtraneous name def (tail present)
-    else (throw "Found unexpected field '${head present}' in struct '${name}'");
-
-  struct' = name: def: {
-    inherit name def;
-    check = value:
-      let fieldMatch = foldl' (checkField def value) true (attrNames def);
-          noExtras = checkExtraneous name def (attrNames value);
-      in (isAttrs value && fieldMatch && noExtras);
-
-    __functor = self: value: if self.check value then value
-      else (throw "Expected '${self.name}'-struct, but ${toPretty value} is of type ${typeOf value}");
+  # typedef is the simplified version of typedef' which uses a default
+  # error message constructor.
+  typedef = name: check: typedef' {
+    inherit name;
+    checkType = check;
+    checkToBool = r: r;
+    toError = value: _result: typeError name value;
   };
 
-  struct = arg: if isString arg then (struct' arg)
-                else (struct' "anonymous" arg);
-
-  enum = name: values: rec {
-    inherit name values;
-    check = (x: elem x values);
-    __functor = self: x: if self.check x then x
-    else (throw "'${x}' is not a member of enum '${self.name}'");
-    match = x: actions: let
-      actionKeys = map (__functor { inherit name check; }) (attrNames actions);
-      missing = foldl' (m: k: if (elem k actionKeys) then m else m ++ [ k ]) [] values;
-    in if (length missing) > 0
-       then throw "Missing match action for members: ${toPretty missing}"
-       else actions."${__functor { inherit name check; } x}";
+  checkEach = name: t: l: foldl' (acc: e:
+    let res = t.checkType e;
+        isT = t.checkToBool res;
+    in {
+      ok = acc.ok && isT;
+      err = if isT
+        then acc.err
+        else acc.err + "${prettyPrint e}: ${t.toError e res}\n";
+    }) { ok = true; err = "expected type ${name}, but found:\n"; } l;
+in lib.fix (self: {
+  # Primitive types
+  any      = typedef "any" (_: true);
+  int      = typedef "int" isInt;
+  bool     = typedef "bool" isBool;
+  float    = typedef "float" isFloat;
+  string   = typedef "string" isString;
+  drv      = typedef "derivation" (x: isAttrs x && x ? "type" && x.type == "derivation");
+  function = typedef "function" (x: isFunction x || (isAttrs x && x ? "__functor"
+                                                 && isFunction x.__functor));
+
+  # Type for types themselves. Useful when defining polymorphic types.
+  type = typedef "type" (x:
+    isAttrs x
+    && hasAttr "name" x && self.string.check x.name
+    && hasAttr "checkType" x && self.function.check x.checkType
+    && hasAttr "checkToBool" x && self.function.check x.checkToBool
+    && hasAttr "toError" x && self.function.check x.toError
+  );
+
+  # Polymorphic types
+  option = t: typedef' rec {
+    name = "option<${t.name}>";
+    checkType = v:
+      let res = t.checkType v;
+      in {
+        ok = isNull v || (self.type t).checkToBool res;
+        err = "expected type ${name}, but value does not conform to '${t.name}': "
+         + t.toError v res;
+      };
   };
 
-  sum = name: values: let
-    isVariant = x:
-      let name = elemAt (attrNames x) 0;
-      in if hasAttr name values
-        then values."${name}".check x."${name}"
-        else false;
-    check = x: isAttrs x && length (attrNames x) == 1 && isVariant x;
-  in {
-    inherit name values check;
-    __functor = self: x: if self.check x
-      then x
-      else throw "'${toPretty x}' is not a valid variant of '${name}'";
+  either = t1: t2: typedef "either<${t1.name},${t2.name}>"
+    (x: (self.type t1).check x || (self.type t2).check x);
+
+  list = t: typedef' rec {
+    name = "list<${t.name}>";
+
+    checkType = v: if isList v
+      then checkEach name (self.type t) v
+      else {
+        ok = false;
+        err = typeError name v;
+      };
   };
 
-  mkFunc = sig: f: {
-    inherit sig;
-    __toString = self: foldl' (s: t: "${s} -> ${t.name}")
-                              "λ :: ${(head self.sig).name}" (tail self.sig);
-    __functor = _: f;
+  attrs = t: typedef' rec {
+    name = "attrs<${t.name}>";
+
+    checkType = v: if isAttrs v
+      then checkEach name (self.type t) (attrValues v)
+      else {
+        ok = false;
+        err = typeError name v;
+      };
   };
-  defun' = sig: func: if length sig > 2
-    then mkFunc sig (x: defun' (tail sig) (func ((head sig) x)))
-    else mkFunc sig (x: ((head (tail sig)) (func ((head sig) x))));
-
-  defun = sig: func: if length sig < 2
-    then (throw "Signature must at least have two types (a -> b)")
-    else defun' sig func;
-in (typeSet [
-  # Primitive types
-  (typedef "any" (_: true))
-  (typedef "int" isInt)
-  (typedef "bool" isBool)
-  (typedef "float" isFloat)
-  (typedef "string" isString)
-  (typedef "derivation" (x: isAttrs x && x ? "type" && x.type == "derivation"))
-  (typedef "function" (x: isFunction x || (isAttrs x && x ? "__functor"
-                                           && isFunction x.__functor)))
-  # Polymorphic types
-  (poly "option" (t: v: (isNull v) || t.check v))
 
-  (poly "list" (t: v: isList v && (foldl' (s: e: s && (
-    if t.check e then true
-    else throw "Expected list element of type '${t.name}', but '${toPretty e}' is of type '${typeOf e}'"
-  )) true v)))
+  # Structs / record types
+  #
+  # Checks that all fields match their declared types, no optional
+  # fields are missing and no unexpected fields occur in the struct.
+  #
+  # Anonymous structs are supported (e.g. for nesting) by omitting the
+  # name.
+  #
+  # TODO: Support open records?
+  struct =
+    # Struct checking is more involved than the simpler types above.
+    # To make the actual type definition more readable, several
+    # helpers are defined below.
+    let
+      # checkField checks an individual field of the struct against
+      # its definition and creates a typecheck result. These results
+      # are aggregated during the actual checking.
+      checkField = def: name: value: let result = def.checkType value; in rec {
+        ok = def.checkToBool result;
+        err = if !ok && isNull value
+          then "missing required ${def.name} field '${name}'\n"
+          else "field '${name}': ${def.toError value result}\n";
+      };
+
+      # checkExtraneous determines whether a (closed) struct contains
+      # any fields that are not part of the definition.
+      checkExtraneous = def: has: acc:
+        if (length has) == 0 then acc
+        else if (hasAttr (head has) def)
+          then checkExtraneous def (tail has) acc
+          else checkExtraneous def (tail has) {
+            ok = false;
+            err = acc.err + "unexpected struct field '${head has}'\n";
+          };
+
+      # checkStruct combines all structure checks and creates one
+      # typecheck result from them
+      checkStruct = def: value:
+        let
+          init = { ok = true; err = ""; };
+          extraneous = checkExtraneous def (attrNames value) init;
+
+          checkedFields = map (n:
+            let v = if hasAttr n value then value."${n}" else null;
+            in checkField def."${n}" n v) (attrNames def);
+
+          combined = foldl' (acc: res: {
+            ok = acc.ok && res.ok;
+            err = if !res.ok then acc.err + res.err else acc.err;
+          }) init checkedFields;
+        in {
+          ok = combined.ok && extraneous.ok;
+          err = combined.err + extraneous.err;
+        };
+
+      struct' = name: def: typedef' {
+        inherit name def;
+        checkType = value: if isAttrs value
+          then (checkStruct (self.attrs self.type def) value)
+          else { ok = false; err = typeError name value; };
+
+          toError = _: result: "expected '${name}'-struct, but found:\n" + result.err;
+      };
+    in arg: if isString arg then (struct' arg) else (struct' "anon" arg);
+
+  # Enums & pattern matching
+  enum =
+  let
+    plain = name: def: typedef' {
+      inherit name def;
+
+      checkType = (x: isString x && elem x def);
+      checkToBool = x: x;
+      toError = value: _: "'${prettyPrint value} is not a member of enum ${name}";
+    };
+    enum' = name: def: lib.fix (e: (plain name def) // {
+      match = x: actions: deepSeq (map e (attrNames actions)) (
+      let
+        actionKeys = attrNames actions;
+        missing = foldl' (m: k: if (elem k actionKeys) then m else m ++ [ k ]) [] def;
+      in if (length missing) > 0
+        then throw "Missing match action for members: ${prettyPrint missing}"
+        else actions."${e x}");
+    });
+  in arg: if isString arg then (enum' arg) else (enum' "anon" arg);
+
+  # Sum types
+  #
+  # The representation of a sum type is an attribute set with only one
+  # value, where the key of the value denotes the variant of the type.
+  sum =
+  let
+    plain = name: def: typedef' {
+      inherit name def;
+      checkType = (x:
+        let variant = elemAt (attrNames x) 0;
+        in if isAttrs x && length (attrNames x) == 1 && hasAttr variant def
+          then let t = def."${variant}";
+                   v = x."${variant}";
+                   res = t.checkType v;
+               in if t.checkToBool res
+                  then { ok = true; }
+                  else {
+                    ok = false;
+                    err = "while checking '${name}' variant '${variant}': "
+                          + t.toError v res;
+                  }
+          else { ok = false; err = typeError name x; }
+      );
+    };
+    sum' = name: def: lib.fix (s: (plain name def) // {
+    match = x: actions:
+    let variant = deepSeq (s x) (elemAt (attrNames x) 0);
+        actionKeys = attrNames actions;
+        defKeys = attrNames def;
+        missing = foldl' (m: k: if (elem k actionKeys) then m else m ++ [ k ]) [] defKeys;
+    in if (length missing) > 0
+      then throw "Missing match action for variants: ${prettyPrint missing}"
+      else actions."${variant}" x."${variant}";
+    });
+    in arg: if isString arg then (sum' arg) else (sum' "anon" arg);
+
+  # Typed function definitions
+  #
+  # These definitions wrap the supplied function in type-checking
+  # forms that are evaluated when the function is called.
+  #
+  # Note that typed functions themselves are not types and can not be
+  # used to check values for conformity.
+  defun =
+    let
+      mkFunc = sig: f: {
+        inherit sig;
+        __toString = self: foldl' (s: t: "${s} -> ${t.name}")
+                                  "λ :: ${(head self.sig).name}" (tail self.sig);
+        __functor = _: f;
+      };
 
-  (poly "attrs" (t: v: isAttrs v && (foldl' (s: e: s && (
-    if t.check e then true
-    else throw "Expected attribute set element of type '${t.name}', but '${toPretty e}' is of type '${typeOf e}'"
-  )) true (attrValues v))))
+      defun' = sig: func: if length sig > 2
+        then mkFunc sig (x: defun' (tail sig) (func ((head sig) x)))
+        else mkFunc sig (x: ((head (tail sig)) (func ((head sig) x))));
 
-  (poly2 "either" (t1: t2: v: t1.check v || t2.check v))
-]) // { inherit struct enum sum defun; }
+    in sig: func: if length sig < 2
+      then (throw "Signature must at least have two types (a -> b)")
+      else defun' sig func;
+})