path: root/lib/Bread/Board.pm

use v6;

module Bread::Board;

class Container {...}
class Dependency {...}

# XXX it'd be nice if this wasn't necessary, but i don't know how to tell # '
# whether an attribute has been set if that attribute is supposed to hold
# type objects
role Lifecycle { }

role Traversable {
    has Traversable $.parent is rw;

    method fetch (Str $path is copy) {
        # PERL6: substitutions don't return a useful value? # '
        # if $path ~~ s/^ \/ // {
        if $path ~~ m[^ '/' ] {
            $path ~~ s[^ '/' ] = '';
            return self.get_root_container._fetch($path);
        }
        else {
            return self.get_enclosing_container._fetch($path);
        }
    }

    method get_root_container {
        my $root = self;
        $root = $root.parent while $root.parent;
        return $root;
    }

    method get_enclosing_container {...}

    method _fetch (Str $path) {
        return self if $path eq '';

        my @parts = $path.split('/').grep(* ne '');
        my $rest = @parts[1..*-1].join('/');

        return $.parent._fetch($rest)
            if @parts[0] eq '..';

        return self._fetch_single(@parts[0])._fetch($rest);
    }

    method _fetch_single (Str $path) {...}
}

role Service does Traversable {
    has Str $.name;
    has $.lifecycle;

    method get {...}

    method get_enclosing_container {
        return $.parent;
    }

    method _fetch_single (Str $name) {
        die "Couldn't find $name in $.name";
    }
}

role HasDependencies {
    # PERL6: typed hashes NYI
    # has Hash of Dependency $.dependencies = {};
    has $.dependencies = {};

    # PERL6: type coercions NYI
    method _coerce_dependencies ($deps is copy) {
        if $deps ~~ Array {
            $deps = $deps.map(-> $dep {
                my ($name, $obj);
                if ($dep ~~ Dependency) {
                    $name = $dep.service_path.split('/').[*-1];
                    $obj  = $dep;
                }
                else {
                    $name = $dep.split('/').[*-1];
                    $obj  = Dependency.new(service_path => $dep);
                }
                $name => $obj
            }).hash;
        }

        my $ret = {};
        for $deps.keys -> $name {
            my $dep = $deps{$name};
            $ret{$name} = $dep.isa(Dependency)
                ?? $dep
                !! Dependency.new(service => $dep);
        }
        return $ret;
    }

    # PERL6: there doesn't appear to be any way for roles to do things at # '
    # construction time without breaking things - so, just call this method
    # in the constructor of all classes that use this role manually
    method _set_dependency_parents {
        for $.dependencies.values -> $dep {
            $dep.parent = self;
        }

        # PERL6: for loops are currently lazy, so won't get evaluated until # '
        # something evaluates the return value if they are the last statement
        # in a method. this may change in the future, because it's pretty # '
        # weird
        return;
    }

    method get_dependency (Str $name) {
        return $.dependencies{$name};
    }

    method _fetch_single (Str $name) {
        return self.get_dependency($name)
            // die "No dependency $name found for $.name";
    }
}

role HasParameters {
    # PERL6: typed hashes NYI
    # has Hash of Hash $.parameters = {};
    has $.parameters = {};

    method get_parameter (Str $name) {
        return $.parameters{$name};
    }

    method check_parameters (%params) {
        for $.parameters.keys -> $name {
            if not %params{$name}:exists {
                die "Required parameter $name not given";
            }
        }

        for %params.keys -> $name {
            if not $.parameters{$name}:exists {
                die "Unknown parameter $name given";
            }
            if not %params{$name}.isa($.parameters{$name}<isa>) {
                die "{%params{$name}.perl} is not a valid value "
                  ~ "for the $name parameter";
            }
        }

        # PERL6: for loops are currently lazy, so won't get evaluated until # '
        # something evaluates the return value if they are the last statement
        # in a method. this may change in the future, because it's pretty # '
        # weird
        return;
    }

    method _fetch_single (Str $name) {
        return self.get_parameter($name)
            // die "No parameter $name found for $.name";
    }
}

role HasClass {
    has $.class;
}

class Dependency does Traversable {
    has Str $.service_path;
    has Service $.service;

    # XXX is this the best way to do this?
    # we can't do it at construction time, since $.parent doesn't get set
    # until the current object is completely constructed
    method service handles 'get' {
        # PERL6: // is broken on role type objects
        # PERL6: also, have to use .DEFINITE instead of defined because calling
        # most methods on role type objects with required methods blows up
        #$!service //= self.fetch($.service_path);
        $!service = self.fetch($.service_path)
            unless $!service.DEFINITE;
        return $!service;
    }

    method get_enclosing_container {
        return $.parent.parent;
    }

    method _fetch_single (Str $name) {
        die "Can't fetch $name from a dependency";
    }
}

class Parameters {
    has Hash $.params;
    # XXX do we really want to keep this API? or should this really just be
    # the service object?
    has $.class;

    method param (Str $name) {
        return $.params{$name};
    }
}

class ConstructorInjection does Service does HasParameters does HasDependencies does HasClass {
    has Str $.constructor_name is rw = 'new';

    method new (*%params is copy) {
        if %params<dependencies> -> $deps {
            # PERL6: type coercions NYI
            %params<dependencies> = self._coerce_dependencies($deps);
        }

        my $self = callwith(|%params);

        # XXX see above
        $self._set_dependency_parents;

        $self does $self.lifecycle
            if $self.lifecycle ~~ Lifecycle;

        return $self;
    }

    method get (*%params is copy) {
        # XXX remove more duplication?
        self.check_parameters(%params);
        for $.dependencies.keys -> $name {
            %params{$name} = $.dependencies{$name}.get;
        }
        return $.class."$.constructor_name"(|%params);
    }

    method _fetch_single (Str $name) {
        # PERL6: self.Role::method calls the method with the role type object
        # as the invocant, rather than self
        #return try { self.HasDependencies::_fetch_single($name) }
        #    // try { self.HasParameters::_fetch_single($name) }
        #    // die "Couldn't find dependency or parameter $name in $.name";
        return self.get_dependency($name)
            // self.get_parameter($name)
            // die "Couldn't find dependency or parameter $name in $.name";
    }
}

class BlockInjection does Service does HasParameters does HasDependencies does HasClass {
    has Callable $.block;

    method new (*%params is copy) {
        if %params<dependencies> -> $deps {
            # PERL6: type coercions NYI
            %params<dependencies> = self._coerce_dependencies($deps);
        }

        my $self = callwith(|%params);

        # XXX see above
        $self._set_dependency_parents;

        $self does $self.lifecycle
            if $self.lifecycle ~~ Lifecycle;

        return $self;
    }

    method get (*%params is copy) {
        # XXX remove more duplication?
        self.check_parameters(%params);
        for $.dependencies.keys -> $name {
            %params{$name} = $.dependencies{$name}.get;
        }
        return $.block.(
            Parameters.new(
                params => %params,
                class  => $.class,
            )
        );
    }

    method _fetch_single (Str $name) {
        # PERL6: self.Role::method calls the method with the role type object
        # as the invocant, rather than self
        #return try { self.HasDependencies::_fetch_single($name) }
        #    // try { self.HasParameters::_fetch_single($name) }
        #    // die "Couldn't find dependency or parameter $name in $.name";
        return self.get_dependency($name)
            // self.get_parameter($name)
            // die "Couldn't find dependency or parameter $name in $.name";
    }
}

class Literal does Service {
    has $.value;

    method get {
        return $.value;
    }
}

class Container does Traversable {
    has Str $.name;
    # PERL6: typed hashes NYI
    # has Hash of Container $.sub_containers = {};
    # has Hash of Service $.services = {};
    has $.sub_containers = {};
    has $.services = {};

    # PERL6: type coercions NYI
    method new (*%params is copy) {
        if %params<sub_containers>.isa(Array) {
            %params<sub_containers> = %params<sub_containers>.map(
                -> $c { $c.name => $c }
            ).hash;
        }
        if %params<services>.isa(Array) {
            %params<services> = %params<services>.map(
                -> $c { $c.name => $c }
            ).hash;
        }
        my $container = callwith(|%params);
        if %params<sub_containers>:exists {
            for %params<sub_containers>.values -> $c {
                $c.parent = $container;
            }
        }
        if %params<services>:exists {
            for %params<services>.values -> $c {
                $c.parent = $container;
            }
        }
        return $container;
    }

    method add_sub_container (Container $c) {
        $.sub_containers{$c.name} = $c;
        $c.parent = self;
    }

    method get_sub_container (Str $name) {
        return $.sub_containers{$name};
    }

    method add_service (Service $s) {
        $.services{$s.name} = $s;
        $s.parent = self;
    }

    method has_services {
        return $.services > 0;
    }

    method get_service (Str $name) {
        return $.services{$name};
    }

    method get_enclosing_container { self }

    method _fetch_single (Str $name) {
        return self.get_sub_container($name)
            // self.get_service($name)
            // die "Couldn't find service or container for $name in $.name";
    }

    method resolve (Str :$service) {
        return self.fetch($service).get;
    }

    method gist (:$indent = 0) {
        my $spaces = " " x $indent;
        my $str = "{$spaces}{$.name // '???'} \{\n";

        for $.sub_containers.values -> $c {
            $str ~= $c.gist(indent => $indent + 2);
        }

        for $.services.values -> $s {
            $str ~= "$spaces  {$s.name // '???'}\n";
            if ($s ~~ HasDependencies) {
                for $s.dependencies.kv -> $dep_name, $dep {
                    $str ~= "$spaces    $dep_name\: "
                          ~ "{$dep.service_path // '???'}\n";
                }
            }
            if ($s ~~ HasParameters) {
                for $s.parameters.keys -> $param_name {
                    $str ~= "$spaces    !$param_name\n";
                }
            }

        }

        $str ~= "$spaces\}\n";

        return $str;
    }
}

role Singleton does Lifecycle is export {
    has $!instance;
    has Bool $.has_instance;

    method get {
        if !$.has_instance {
            $!instance = callsame;
            $!has_instance = True;
        }
        return $!instance;
    }

    method flush_instance {
        $!instance = Any;
        $!has_instance = False;
    }
}

our $CC;
our $in_container = False;

our sub set_root_container (Container $c) {
    die "Can't set the root container when we're already in a container"
        if $in_container;
    $CC = $c;
}

proto container is export {*}
multi container (Container $c, Callable $body = sub {}) {
    $CC.add_sub_container($c)
        if $CC;
    # PERL6: temp doesn't work properly in multisubs # '
    #temp $CC = $c;
    #temp $in_container = True;
    #$body.();
    my $old_CC = $CC;
    my $old_in_container = $in_container;
    $CC = $c;
    $in_container = True;
    {
        LEAVE { $CC = $old_CC; $in_container = $old_in_container };
        $body.();
    }
    $c;
}
multi container (Str $name, Callable $body = sub {}) {
    container(Container.new(name => $name), $body);
}
multi container (Callable $body = sub {}) {
    container(Container.new, $body);
}

sub depends_on (Str $path) is export {
    Dependency.new(service_path => $path);
}

proto service is export {*}
multi service (*%params) {
    my $service;

    if (%params<value>:exists) {
        $service = Literal.new(|%params);
    }
    elsif (%params<block>:exists) {
        $service = BlockInjection.new(|%params);
    }
    elsif (%params<class>:exists) {
        $service = ConstructorInjection.new(|%params);
    }
    else {
        die "Couldn't create a service from {%params}";
    }

    $CC.add_service($service)
        if $CC;

    return $service;
}
multi service (Str $name, *%params) {
    service(name => $name, |%params);
}
multi service (Any $value) {
    service(value => $value);
}
multi service (Str $name, Any $value) {
    service(name => $name, value => $value);
}
multi service (Str $name, Parcel $params) {
    service(name => $name, |$params.hash);
}
multi service (Parcel $params) {
    service(|$params.hash);
}

sub wire_names (*@names) is export {
    return @names.map(-> $name { $name => depends_on($name) }).hash;
}

sub include (Str $path) is export {
    my $contents = slurp $path;
    eval $contents;
}

# vim:ft=perl6:foldmethod=manual