lib/LaTeX/TikZ/Functor.pm

   1 package LaTeX::TikZ::Functor;
   2
   3 use strict;
   4 use warnings;
   5
   6 =head1 NAME
   7
   8 LaTeX::TikZ::Functor - Build functor methods that recursively visit nodes of a LaTeX::TikZ::Set tree.
   9
  10 =head1 VERSION
  11
  12 Version 0.01
  13
  14 =cut
  15
  16 our $VERSION = '0.01';
  17
  18 =head1 DESCRIPTION
  19
  20 A functor takes a L<LaTeX::TikZ::Set> tree and clones it according to certain rules.
  21 Rules can apply not only to L<LaTeX::TikZ::Set> objects, but also to the L<LaTeX::TikZ::Mod> objects they contain.
  22
  23 =cut
  24
  25 use Carp ();
  26
  27 use Sub::Name ();
  28
  29 use LaTeX::TikZ::Functor::Rule;
  30
  31 use LaTeX::TikZ::Interface;
  32
  33 use LaTeX::TikZ::Tools;
  34
  35 my $lts_tc = LaTeX::TikZ::Tools::type_constraint('LaTeX::TikZ::Set');
  36
  37 my $validate_spec;
  38 BEGIN {
  39  $validate_spec = Sub::Name::subname('validate_spec' => sub {
  40   my ($spec) = @_;
  41
  42   my ($replace, $target);
  43   if (defined $spec and ref $spec eq ''
  44     and $spec =~ /^(\+?)([A-Za-z][A-Za-z0-9_]*(?:::[A-Za-z][A-Za-z0-9_]*)*)$/) {
  45    $replace = defined($1) && $1 eq '+';
  46    $target  = $2;
  47   } else {
  48    Carp::confess("Invalid rule spec $spec");
  49   }
  50
  51   return $target, $replace;
  52  });
  53 }
  54
  55 =head1 METHODS
  56
  57 =head2 C<< new rules => [ $spec1 => $handler1, $spec2 => $handler2, ... ] >>
  58
  59 Creates a new functor object that will use both the default and these user-specified rules.
  60 The functor is also a code reference that expects to be called against L<LaTeX::TikZ::Set> objects.
  61
  62 The default set and mod rules clone their relevant objects, so you get a clone functor (for the default set types) if you don't specify any user rule.
  63
  64     # The default is a clone method
  65     my $clone = Tikz->functor;
  66     my $dup = $set->$clone;
  67
  68 If there is already a default rule for one of the C<$spec>s, it is replaced by the new one ; otherwise, the user rule is appended to the list of default rules.
  69
  70     # A translator
  71     my $translate = Tikz->functor(
  72      # Only replace the way point sets are cloned
  73      'LaTeX::TikZ::Set::Point' => sub {
  74       my ($functor, $set, $x, $y) = @_;
  75
  76       $set->new(
  77        point => [
  78         $set->x + $x,
  79         $set->y + $y,
  80        ],
  81        label => $set->label,
  82        pos   => $set->pos,
  83       );
  84      },
  85     );
  86     my $shifted = $set->$translate(1, 1);
  87
  88 But if one of the C<$spec>s begins with C<'+'>, the rule will replace I<all> default rules that apply to subclasses or subroles of C<$spec> (including C<$spec> itself).
  89
  90     # A mod stripper
  91     my $strip = Tikz->functor(
  92      # Replace all existent mod rules by this simple one
  93      '+LaTeX::TikZ::Mod' => sub { return },
  94     );
  95     my $naked = $set->$strip;
  96
  97 The functor will map unhandled sets and mods to themselves without cloning them, since it has no way to know how to do it.
  98 Thus, if you define your own L<LaTeX::TikZ::Set> or L<LaTeX::TikZ::Mod> object, be sure to register a default rule for it with the L</default_rule> method.
  99
 100 =cut
 101
 102 my @default_set_rules;
 103 my @default_mod_rules;
 104
 105 sub new {
 106  my ($class, %args) = @_;
 107
 108  my @set_rules = @default_set_rules;
 109  my @mod_rules = @default_mod_rules;
 110
 111  my @user_rules = @{$args{rules} || []};
 112  while (@user_rules) {
 113   my ($spec, $handler) = splice @user_rules, 0, 2;
 114
 115   my ($target, $replace) = $validate_spec->($spec);
 116
 117   my $rule = LaTeX::TikZ::Functor::Rule->new(
 118    target  => $target,
 119    handler => $handler,
 120   );
 121
 122   $rule->insert(
 123    into      => $rule->is_set ? \@set_rules : \@mod_rules,
 124    overwrite => 1,
 125    replace   => $replace,
 126   );
 127  }
 128
 129  my %dispatch = map { $_->target => $_ } @set_rules, @mod_rules;
 130
 131  my $self;
 132
 133  $self = bless sub {
 134   my $set = shift;
 135
 136   $lts_tc->assert_valid($set);
 137
 138   my $rule = $dispatch{ref($set)};
 139   unless ($rule) {
 140    for (@set_rules) {
 141     if ($_->handles($set)) {
 142      $rule = $_;
 143      last;
 144     }
 145    }
 146   }
 147   my $new_set = $rule ? $rule->handler->($self, $set, @_)
 148                       : $set;
 149   my $is_new  = $new_set ne $set;
 150
 151   my @new_mods;
 152 MOD:
 153   for my $mod ($set->mods) {
 154    my $rule = $dispatch{ref($mod)};
 155    unless ($rule) {
 156     for (@mod_rules) {
 157      if ($_->handles($mod)) {
 158       $rule = $_;
 159       last;
 160      }
 161     }
 162    }
 163    push @new_mods, $rule ? $rule->handler->($self, $mod, @_)
 164                          : $mod;
 165   }
 166
 167   $new_set->mod(@new_mods) if $is_new;
 168
 169   return $new_set;
 170  }, $class;
 171 }
 172
 173 LaTeX::TikZ::Interface->register(
 174  functor => sub {
 175   shift;
 176
 177   __PACKAGE__->new(rules => \@_);
 178  },
 179 );
 180
 181 =head2 C<< default_rule $spec => $handler >>
 182
 183 Adds to all subsequently created functors a default rule for the class or role C<$spec>.
 184
 185 An exception is thrown if there is already a default rule for C<$spec> ; otherwise, the new rule is appended to the current list of rules.
 186 But if C<$spec> begins with C<'+'>, the rule will replace I<all> default rules that apply to subclasses or subroles of C<$spec> (including C<$spec> itself).
 187
 188 Returns true if and only if an existent rule was replaced.
 189
 190 =cut
 191
 192 sub default_rule {
 193  shift;
 194  my ($spec, $handler) = @_;
 195
 196  my ($target, $replace) = $validate_spec->($spec);
 197
 198  my $rule = LaTeX::TikZ::Functor::Rule->new(
 199   target  => $target,
 200   handler => $handler,
 201  );
 202
 203  $rule->insert(
 204   into      => $rule->is_set ? \@default_set_rules : \@default_mod_rules,
 205   overwrite => 0,
 206   replace   => $replace,
 207  );
 208 }
 209
 210 =head1 SEE ALSO
 211
 212 L<LaTeX::TikZ>.
 213
 214 =head1 AUTHOR
 215
 216 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 217
 218 You can contact me by mail or on C<irc.perl.org> (vincent).
 219
 220 =head1 BUGS
 221
 222 Please report any bugs or feature requests to C<bug-latex-tikz at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=LaTeX-TikZ>.
 223 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 224
 225 =head1 SUPPORT
 226
 227 You can find documentation for this module with the perldoc command.
 228
 229     perldoc LaTeX::TikZ
 230
 231 =head1 COPYRIGHT & LICENSE
 232
 233 Copyright 2010 Vincent Pit, all rights reserved.
 234
 235 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 236
 237 =cut
 238
 239 1; # End of LaTeX::TikZ::Functor