diff --git a/adt.nix b/adt.nix new file mode 100644 index 0000000..b54e539 --- /dev/null +++ b/adt.nix @@ -0,0 +1,273 @@ +let + list = import ./list.nix; + set = import ./set.nix; + string = import ./string.nix; + types = import ./types.nix; + + unique = xs: + let + xs' = builtins.sort builtins.lessThan xs; + in builtins.length xs <= 1 || list.all (x: x) (list.zipWith (x: y: x != y) xs' (list.tail xs')); +in +rec { + fields = rec { + /* positional :: [{ name: string, type: type }] -> ConstructorSpecification + + Specifies that the variant should contain the provided field names, but + the constructor and match function both expect appropriate positional + arguments. The field names are only used in the internal representation. + + > point = adt.struct "point" (adt.fields.positional [{ name = "x"; type = types.int; } { name = "y"; type = types.int; }]) + > p = point.ctors.make 1 2 + > p + { _type = "point"; x = 1; y = 2; } + > point.match p { make = x: y: x + y; } + 3 + */ + positional = fields: + assert builtins.isList fields + && builtins.all + (f: + builtins.isAttrs f + && f ? name && builtins.isString f.name + && f ? type + ) + fields; + fields; + + /* positional_ :: [string] -> ConstructorSpecification + + Like `fields.positional`, but the fields are untyped. + */ + positional_ = fields: + assert builtins.isList fields && builtins.all builtins.isString fields; + assert unique fields; + positional (list.map (f: { name = f; type = types.any; }) fields); + + /* record :: { string: type } -> ConstructorSpecification + + Specifies that the variant should contain the provided field names, but + the constructor and match function both expect a single attrset argument + with the appropriate fields. + + > point = adt.struct "point" (adt.fields.record { x = types.int; y = types.int; }) + > p = point.ctors.make { x = 1; y = 2; } + > p + { _type = "point"; x = 1; y = 2; } + > point.match p { make = { x, y }: x + y; } + 3 + */ + record = fields: + assert builtins.isAttrs fields; + fields; + + /* record_ :: [string] -> ConstructorSpecification + + Like `fields.record`, but the fields are untyped. + */ + record_ = fields: + assert builtins.isList fields && builtins.all builtins.isString fields; + assert unique fields; + list.fold set.monoid (list.map (x: { ${x} = types.any; }) fields); + + /* none :: ConstructorSpecification + + Specifies that the variant should contain no fields. The constructor will + not be a function, but a singleton attrset. The corresponding match + branch will expect a value, not a function, when matching. + + > optional = adt.enum "optional" { just = adt.fields.positional_ ["value"]; nothing = adt.fields.none; } + > optional.ctors.just 5 + { _tag = "just"; _type = "optional"; value = 5; } + > optional.ctors.nothing + { _tag = "nothing"; _type = "optional"; } + > optional.match optional.ctors.nothing { just = x: x + 2; nothing = 7; } + 7 + */ + none = null; + + /* anon :: [type] -> ConstructorSpecification + + Like `fields.positional`, but instead of providing the names for the + fields, the given number of anonymous field names are used instead. + + > point = adt.struct "point" (adt.fields.anon [types.int types.int]) + > p = point.ctors.make 1 2 + > p + { _type = "point"; _0 = 1; _1 = 2; } + > point.match p { make x: y: x + y; } + 3 + */ + anon = types: + assert builtins.isList types; + positional (list.imap (i: t: { name = "_${builtins.toString i}"; type = t; }) types); + + /* anon_ :: int -> ConstructorSpecification + + Like `fields.anon`, but the fields are untyped. + */ + anon_ = x: + assert builtins.isInt x && x > 0; + positional_ (list.map (n: "_${builtins.toString n}") (list.range 0 (x - 1))); + }; + + /* struct :: string -> ConstructorSpecification -> ADT + + Create a new algebraic data type with one one constructor, named 'make'. + */ + struct = name: constructor: new name { make = constructor; }; + + /* enum :: string -> { string: ConstructorSpecification } | [ string ] -> ADT + + Create a new algebraic data type, with the provided constructors acting as + variants of the sum type. The constructor specification, if an attribute + set, has the same format as 'adt.new'. If the constructor specification is + a list of strings, each constructor will be assumed to be unary; that is, + each will be specified to 'adt.fields.none'. + */ + enum = name: ctors: + if builtins.isList ctors then + assert builtins.all builtins.isString ctors; + let + toUnary = ctorName: { "${ctorName}" = fields.none; }; + in new name (list.fold set.monoid (list.map toUnary ctors)) + else + new name ctors; + + /* new :: string -> { string: ConstructorSpecification } -> ADT + + Create a new algebraic data type based on a specification of its + constructors. + + Examples: + + > adt.new "optional" { + just = adt.fields.positional_ [ "value" ]; + nothing = adt.fields.none; + } + + > adt.new "result" { + ok = adt.fields.anon_ 1; + err = adt.fields.anon_ 1; + } + + > adt.new "pair" { + make = adt.fields.anon_ 2; + } + + > adt.new "point" { + make = adt.fields.record_ [ "x" "y" ]; + } + */ + new = name: constructors: + assert builtins.isString name; + assert builtins.isAttrs constructors; + assert builtins.all + (spec: + builtins.any (x: x) [ + (spec == null) + ( + builtins.isList spec + && + builtins.all + (f: + builtins.isAttrs f + && f ? name && builtins.isString f.name + && f ? type + ) + spec + ) + (builtins.isAttrs spec) + ] + ) + (builtins.attrValues constructors); + assert builtins.all (name: !builtins.elem name [ "_tag" "_type" ]) (builtins.attrNames constructors); + let + only = as: as.${builtins.head (builtins.attrNames as)}; + needsTag = builtins.length (builtins.attrNames constructors) > 1; + genNaryCtor = base: args: + let + len = builtins.length args; + go = acc: i: + if i >= len + then acc + else + let + field = builtins.elemAt args i; + in x: go (acc // { ${field.name} = x; }) (i + 1); + in go base 0; + applyList = f: xs: list.foldl' (f': x: f' x) f xs; + makeCtor = ctorName: spec: + let + baseAttrs = if needsTag then { _tag = ctorName; _type = name; } else { _type = name; }; + in + if spec == null then + # nullary + baseAttrs + else if builtins.isList spec then + # positional, struct field named by string + genNaryCtor baseAttrs spec + else if builtins.isAttrs spec then + # one attrset argument, fields named by strings both ways + # TODO: could just intersectAttrs here, but wouldn't get checking that + # all keys are present + args: list.foldl' (x: y: x // { ${y} = args.${y}; }) baseAttrs (builtins.attrNames spec) + else + builtins.throw "std.adt.new: invalid constructor specification for constructor ${string.escapeNixString ctorName}"; + ctors = set.map makeCtor constructors; + match = + let + makeApply = _: spec: + if spec == null then + # nullary + (f: _: f) + else if builtins.isList spec then + (f: v: applyList f (list.map (k: v.${k.name}) spec)) + else # attrs + (f: v: f (set.map (k: _: v.${k}) spec)) + ; + apply = set.map makeApply constructors; + in + if builtins.length (builtins.attrNames constructors) == 0 then + builtins.throw "std.adt: match on empty ADT: ${string.escapeNixString name}" + else if !needsTag then + val: matches: + let + matcher = + if builtins.isAttrs matches then + only matches + else + builtins.throw "std.adt: expected attrset for matcher on ${string.escapeNixString name}"; + in (only apply) matcher val + else + val: matches: + if builtins.isAttrs matches then + apply.${val._tag} matches.${val._tag} val + else + builtins.throw "std.adt: expected attrset for matcher on ${string.escapeNixString name}"; + check = + let + makeCtorCheck = ctorName: spec: + if spec == null then + _: true + else if builtins.isList spec then + t: builtins.all ({ name, type }: builtins.hasAttr name t && type.check t.${name}) spec + else if builtins.isAttrs spec then + t: builtins.all (name: builtins.hasAttr name t && spec.${name}.check t.${name}) (builtins.attrNames spec) + else + builtins.throw "std.adt.new: invalid constructor specification for constructor ${string.escapeNixString ctorName}" + ; + ctorChecks = set.map makeCtorCheck constructors; + in t: + (t ? _type && t._type == name) + && + ( + if needsTag then + t ? _tag + && builtins.elem t._tag (builtins.attrNames constructors) + && ctorChecks.${t._tag} t + else + (only ctorChecks) t + ); + in { inherit match check ctors; }; +} diff --git a/default.nix b/default.nix index 5ee4045..73e3338 100644 --- a/default.nix +++ b/default.nix @@ -1,4 +1,6 @@ rec { + adt = import ./adt.nix; + applicative = import ./applicative.nix; bool = import ./bool.nix; diff --git a/types.nix b/types.nix index 48d0b90..671fdeb 100644 --- a/types.nix +++ b/types.nix @@ -94,6 +94,12 @@ rec { inherit name check description show; }; + any = { + name = "any"; + check = _: true; + description = "any value"; + }; + bool = mkType { name = "bool"; description = "boolean";