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.02
  13
  14 =cut
  15
  16 our $VERSION = '0.02';
  17
  18 =head1 DESCRIPTION
  19
  20 A functor takes a L<LaTeX::TikZ::Set> tree and returns a new, transmuted version of it according to certain rules.
  21 It recursively visits all the nodes of the tree, building a new set out of the result of the functor on the child sets.
  22
  23 Rules are stored as L<LaTeX::TikZ::Functor::Rule> objects.
  24 They can apply not only to L<LaTeX::TikZ::Set> consumer objects, but also to the L<LaTeX::TikZ::Mod> consumer objects they contain.
  25 When the functor is called against a set object and that the returned set is different from the original (as told by C<==>, which defaults to object identity), then the functor is also applied to all the mods of the set, and their transformed counterparts are added to the new set.
  26
  27 When the functor is called onto a set or mod object, all its associated rules are tried successively, and the handler of the first matching rule is executed with :
  28
  29 =over 4
  30
  31 =item *
  32
  33 the functor object as its first argument ;
  34
  35 =item *
  36
  37 the current set or mod object as its second argument ;
  38
  39 =item *
  40
  41 the arguments passed to the functor itself starting at the third argument.
  42
  43 =back
  44
  45 The handler is expected to return the new set or mod that will replace the old one in the resulting set tree.
  46
  47 If no matching rule is found, the object is returned as-is.
  48
  49 =cut
  50
  51 use Carp ();
  52
  53 use Sub::Name ();
  54
  55 use LaTeX::TikZ::Functor::Rule;
  56
  57 use LaTeX::TikZ::Interface;
  58
  59 use LaTeX::TikZ::Tools;
  60
  61 my $lts_tc = LaTeX::TikZ::Tools::type_constraint('LaTeX::TikZ::Set');
  62
  63 my $validate_spec;
  64 BEGIN {
  65  $validate_spec = Sub::Name::subname('validate_spec' => sub {
  66   my ($spec) = @_;
  67
  68   my ($replace, $target);
  69   if (defined $spec and ref $spec eq ''
  70     and $spec =~ /^(\+?)([A-Za-z][A-Za-z0-9_]*(?:::[A-Za-z][A-Za-z0-9_]*)*)$/) {
  71    $replace = defined($1) && $1 eq '+';
  72    $target  = $2;
  73   } else {
  74    Carp::confess("Invalid rule spec $spec");
  75   }
  76
  77   return $target, $replace;
  78  });
  79 }
  80
  81 =head1 METHODS
  82
  83 =head2 C<< new rules => [ $spec1 => $handler1, $spec2 => $handler2, ... ] >>
  84
  85 Creates a new functor object that will use both the default and the user-specified rules.
  86 The functor is also a code reference that expects to be called against L<LaTeX::TikZ::Set> objects.
  87
  88 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.
  89
  90     # The default is a clone method
  91     my $clone = Tikz->functor;
  92     my $dup = $set->$clone;
  93
  94 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 inserted into the list of default rules after all its descendants' rules and before all its ancestors' rules.
  95
  96     # A translator
  97     my $translate = Tikz->functor(
  98      # Only replace the way point sets are cloned
  99      'LaTeX::TikZ::Set::Point' => sub {
 100       my ($functor, $set, $x, $y) = @_;
 101
 102       $set->new(
 103        point => [
 104         $set->x + $x,
 105         $set->y + $y,
 106        ],
 107        label => $set->label,
 108        pos   => $set->pos,
 109       );
 110      },
 111     );
 112     my $shifted = $set->$translate(1, 1);
 113
 114 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).
 115
 116     # A mod stripper
 117     my $strip = Tikz->functor(
 118      # Replace all existent mod rules by this simple one
 119      '+LaTeX::TikZ::Mod' => sub { return },
 120     );
 121     my $naked = $set->$strip;
 122
 123 The functor will map unhandled sets and mods to themselves without cloning them, since it has no way to know how to do it.
 124 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.
 125
 126 =cut
 127
 128 my @default_set_rules;
 129 my @default_mod_rules;
 130
 131 sub new {
 132  my ($class, %args) = @_;
 133
 134  my @set_rules = @default_set_rules;
 135  my @mod_rules = @default_mod_rules;
 136
 137  my @user_rules = @{$args{rules} || []};
 138  while (@user_rules) {
 139   my ($spec, $handler) = splice @user_rules, 0, 2;
 140
 141   my ($target, $replace) = $validate_spec->($spec);
 142
 143   my $rule = LaTeX::TikZ::Functor::Rule->new(
 144    target  => $target,
 145    handler => $handler,
 146   );
 147
 148   $rule->insert(
 149    into      => $rule->is_set ? \@set_rules : \@mod_rules,
 150    overwrite => 1,
 151    replace   => $replace,
 152   );
 153  }
 154
 155  my %dispatch = map { $_->target => $_ } @set_rules, @mod_rules;
 156
 157  my $self;
 158
 159  $self = bless sub {
 160   my $set = shift;
 161
 162   $lts_tc->assert_valid($set);
 163
 164   my $rule = $dispatch{ref($set)};
 165   unless ($rule) {
 166    for (@set_rules) {
 167     if ($_->handles($set)) {
 168      $rule = $_;
 169      last;
 170     }
 171    }
 172   }
 173   return $set unless $rule;
 174
 175   my $new_set = $rule->handler->($self, $set, @_);
 176   return $set if $new_set == $set;
 177
 178   my @new_mods;
 179 MOD:
 180   for my $mod ($set->mods) {
 181    my $rule = $dispatch{ref($mod)};
 182    unless ($rule) {
 183     for (@mod_rules) {
 184      if ($_->handles($mod)) {
 185       $rule = $_;
 186       last;
 187      }
 188     }
 189    }
 190    push @new_mods, $rule ? $rule->handler->($self, $mod, @_)
 191                          : $mod;
 192   }
 193   $new_set->mod(@new_mods);
 194
 195   return $new_set;
 196  }, $class;
 197 }
 198
 199 LaTeX::TikZ::Interface->register(
 200  functor => sub {
 201   shift;
 202
 203   __PACKAGE__->new(rules => \@_);
 204  },
 205 );
 206
 207 =head2 C<< default_rule $spec => $handler >>
 208
 209 Adds to all subsequently created functors a default rule for the class or role C<$spec>.
 210
 211 An exception is thrown if there is already a default rule for C<$spec> ; otherwise, the new rule is inserted into the current list of default rules after all its descendants' rules and before all its ancestors' rules.
 212 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).
 213
 214 Returns true if and only if an existent rule was replaced.
 215
 216 =cut
 217
 218 sub default_rule {
 219  shift;
 220  my ($spec, $handler) = @_;
 221
 222  my ($target, $replace) = $validate_spec->($spec);
 223
 224  my $rule = LaTeX::TikZ::Functor::Rule->new(
 225   target  => $target,
 226   handler => $handler,
 227  );
 228
 229  $rule->insert(
 230   into      => $rule->is_set ? \@default_set_rules : \@default_mod_rules,
 231   overwrite => 0,
 232   replace   => $replace,
 233  );
 234 }
 235
 236 =head1 SEE ALSO
 237
 238 L<LaTeX::TikZ>, L<LaTeX::TikZ::Functor::Rule>.
 239
 240 =head1 AUTHOR
 241
 242 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 243
 244 You can contact me by mail or on C<irc.perl.org> (vincent).
 245
 246 =head1 BUGS
 247
 248 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>.
 249 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 250
 251 =head1 SUPPORT
 252
 253 You can find documentation for this module with the perldoc command.
 254
 255     perldoc LaTeX::TikZ
 256
 257 =head1 COPYRIGHT & LICENSE
 258
 259 Copyright 2010 Vincent Pit, all rights reserved.
 260
 261 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 262
 263 =cut
 264
 265 1; # End of LaTeX::TikZ::Functor