working on algebraic data types in perl6

ADT.pm6

module ADT;

#package EXPORT::DEFAULT { };

grammar hs_adt {
    has @.typevars;
    rule TOP {
        $<name>=<.ident> <params> '=' <definers>
    }
    rule params {
        '[' ~ ']' [ '::' $<typevar>=<.ident> { @.typevars.push($<typevar>.Str) }]+ % ',' |
    }
    rule parameters {
        '[' ~ ']' [$<typevar>=<.ident> { $0 ~~ @.typevars }]+ |
    }
    rule definers {
        [ <definition> ]+ % '|'
    }
    rule definition {
        $<constructor>=<.ident> [ $<typedecl>=<.ident><parameters> $<attrname>=<.ident> ]+ % ','
    }
}

# fix gist syntax highlighting: '

class hs_adt_actions {
    has @.attributes;
    method TOP($/) { make { name => $<name>.Str, params => $<params>.ast, definers => $<definers>.ast.Array } }
    method params($/) { make $/.Str ?? $<typevar>>>.Str.Array !! [] }
    method parameters($/) { make $/.Str ?? make $<typevar>>>.Str.Array !! make [] }
    method definers($/) { make $<definition>>>.ast.Array }
    method definition($/) {
        die "no two attributes may lowercase to the same string" if $<attrname>.lc ~~ @.attributes;
        push @.attributes, $<attrname>.lc;
        make { constructor => $<constructor>.Str, types => ($<typedecl>>>.Str Z $<attrname>>>.Str Z $<parameters>>>.ast).Array }
    }
}

# is parsed is NYI
#macro create_adt is parsed <hs_adt> {
#}

# our ADT is made up of many parts:
#
# - a class that serves as kind of an entry point, called C<container-type> i.e. Tree
# - an attribute for each constructor that handles the attributes of that constructor, i.E. Tree.branch handles <attr_a attr_b>
# - a constructor method new-foo for each of the constructors, i.E. new-branch, new-tree
#
# - one class for each Constructor as part of the containing class, i.e. Tree::Branch, Tree::Leaf
# - one subset for each Constructor of the container class that validates the .definedness of the constructor attribute

sub create_adt(Str $definition) {
    my $adt = hs_adt.parse($definition, :actions(hs_adt_actions.new)).ast;
    say $adt;

    # create the type object for the containing class
    my $container-type := Metamodel::ClassHOW.new_type($adt<name>);

    #| for each of the constructors, save what attribute names they have here
    my %handlers;

    my %resulting-types;

    #| create a class inside the container type for each of the constructors
    sub create_constructor($name, @attrs) {
        my $type := Metamodel::ClassHOW.new_type($name);

        for @attrs -> $atype, $aname, $type-params {
            # type-params is currently unused.
            $type.HOW.add_attribute($type, Attribute.new(
                    :name('$.' ~ $aname), :type(Any), # TODO: properly look up types :type(::{$atype}),
                    :has_accessor(1), :package($type)
                ));
            push %handlers{$name}, $aname;
        }

        $type.HOW.compose($type);
        return $type;
    }

    # create each constructor class first
    my %constructors = gather for @($adt<definers>) {
        take $_<constructor> => create_constructor($_<constructor>, $_<types>)
    }

    # the default new method should just die.
    $container-type.HOW.add_method($container-type, 'new', method {
            die "cannot create a $adt<name> this way. try any of " ~ ("new-$_" for %constructors.keys>>.lc).join(', ') ~ ' instead.';
        });

    for %constructors.kv -> $name, $type {
        # create one attribute for each of the constructors.
        my $attr := Attribute.new(
            :name('$.' ~ $name.lc), :type($type.WHAT),
            :has_accessor(1), :package($container-type));

        $container-type.HOW.add_attribute($container-type, $attr);
        # the constructor attribute shall handle each of the constructor's attribute
        # in the containing class
        trait_mod:<handles>($attr, -> {
                    %handlers{$name}
                }
            );

        # also, create a new-foo method to create such a value.
        # it should take named and positional arguments
        $container-type.HOW.add_multi_method($container-type, "new-$name.lc()", method (|c) {
                if +c.hash {
                    self.bless(*, |($name.lc => $type.new(|c)))
                } elsif c.list -> @args {
                    self.bless(*, |($name.lc => $type.new(|(%handlers{$name} Z=> @args).hash)))
                }
            });
    }

    # create a pretty-printer
    for <perl gist> -> $methname {
        $container-type.HOW.add_method($container-type, $methname, method {
                for %constructors.keys {
                    if self."$_.lc()"().defined {
                        my $result = self."$_.lc()"()."$methname"();
                        substr-rw($result, 0, $_.chars + ".new".chars) = $adt<name> ~ ".new-$_.lc()";
                        return $result;
                    }
                }
                return;
            });
    }

    # it's imperative that we compose our class before we attempt to create the subsets.
    $container-type.HOW.compose($container-type);

    for %constructors.keys -> $name {
        # lastly, create a Subset of the containing class that checks for the definedness of our attribute.
        my Mu $refinee := $container-type;
        my $refinement = {$_."$name.lc()"().defined};
        %resulting-types{$name} = Metamodel::SubsetHOW.new_type(:$name, :$refinee, :$refinement);
    }

    %resulting-types{$adt<name>} = $container-type;

    return %resulting-types;
}

{
    my %res = create_adt("Tree = Branch Tree left, Tree right | Leaf Str storage");
    my \Tree = %res<Tree>;
    my \Branch = %res<Branch>;
    my \Leaf = %res<Leaf>;
    my $t =
        Tree.new-branch(
            :left(Tree.new-branch(
                :left(Tree.new-leaf(:storage(1))),
                :right(Tree.new-leaf(:storage(2))))),
            :right(Tree.new-leaf(:storage(3))));
    say $t.gist;
    my $t2 =
        Tree.new-branch(
            Tree.new-branch(
                Tree.new-leaf(1),
                Tree.new-leaf(2)),
            Tree.new-leaf(3));
    say $t2.gist;
    sub treemap($t, *&code) {
        given $t {
            when Branch { return Tree.new-branch(treemap($t.left, &code), treemap($t.right, &code)) }
            when Leaf { return Tree.new-leaf(code($t.storage)) }
        }
    }
    say treemap($t2, * * 10).gist;
}

#create_adt("Tree[::A] = Branch Tree[A] left, Tree[A] right | Leaf A storage");

#create_adt("Either[::A, ::B] = Left A | Right B");

create_adt("Faliure = Left Str bar | Right Str Bar");