Always call ->assert_valid after ->coerce

[perl/modules/LaTeX-TikZ.git] / lib / LaTeX / TikZ / Scope.pm

diff --git a/lib/LaTeX/TikZ/Scope.pm b/lib/LaTeX/TikZ/Scope.pm
index 7b2eadafe97da7c09de89e883c617d79cf7b39d8..3686beb28b5e7f73d4b5302524f41b8d317b7fb8 100644 (file)
--- a/lib/LaTeX/TikZ/Scope.pm
+++ b/lib/LaTeX/TikZ/Scope.pm
@@ -39,12 +39,14 @@ has '_mods_cache' => (
 
 has '_body' => (
  is       => 'rw',
- isa      => 'LaTeX::TikZ::Scope|Str',
+ isa      => 'LaTeX::TikZ::Scope|ArrayRef[Str]',
  init_arg => 'body',
 );
 
-my $my_tc   = LaTeX::TikZ::Tools::type_constraint(__PACKAGE__);
-my $ltmf_tc = LaTeX::TikZ::Tools::type_constraint('LaTeX::TikZ::Mod::Formatted');
+my $my_tc    = LaTeX::TikZ::Tools::type_constraint(__PACKAGE__);
+my $ltmf_tc  = LaTeX::TikZ::Tools::type_constraint('LaTeX::TikZ::Mod::Formatted');
+my $_body_tc = __PACKAGE__->meta->find_attribute_by_name('_body')
+                                ->type_constraint;
 
 sub mod {
  my $scope = shift;
@@ -52,7 +54,8 @@ sub mod {
  my $cache = $scope->_mods_cache;
 
  for (@_) {
-  my $mod = $ltmf_tc->check($_) ? $_ : $ltmf_tc->coerce($_);
+  my $mod = $ltmf_tc->coerce($_);
+  $ltmf_tc->assert_valid($mod);
   my $tag = $mod->tag;
   next if exists $cache->{$tag};
   $cache->{$tag} = $mod;
@@ -69,24 +72,23 @@ sub body {
   $scope->_body($_[0]);
   $scope;
  } else {
-  $scope->_body;
+  @{$scope->_body};
  }
 }
 
 use overload (
- '.'  => \&concat,
- '""' => \&stringify,
+ '@{}' => 'dereference',
 );
 
 sub flatten {
  my ($scope) = @_;
 
  do {
-  my $body = $scope->body;
+  my $body = $scope->_body;
   return $scope unless $my_tc->check($body);
   $scope = $scope->new
                  ->mod ($scope->mods, $body->mods)
-                 ->body($body->body)
+                 ->body($body->_body)
  } while (1);
 }
 
@@ -112,38 +114,13 @@ my $inter = Sub::Name::subname('inter' => sub {
  return \@left, \@common, \@right;
 });
 
-sub concat {
- my ($scope, $str, $rev) = @_;
+sub instantiate {
+ my ($scope) = @_;
 
  $scope = $scope->flatten;
 
- my $body = $scope->body;
- my @mods = $scope->mods;
-
- if ($my_tc->check($str)) {
-  $str = $str->flatten;
-
-  my ($only_scope, $common, $only_str) = $inter->(
-   $scope->_mods_cache,
-   $str->_mods_cache,
-  );
-
-  if (@$common) {
-   my $x = $scope->new
-                 ->mod(@$only_scope)
-                 ->body($body);
-   my $y = $scope->new
-                 ->mod(@$only_str)
-                 ->body($str->body);
-   ($x, $y) = ($y, $x) if $rev;
-   return $scope->new
-                ->mod(@$common)
-                ->body($x . $y);
-  }
- }
-
  my ($layer, @clips, @raw_mods);
- for (@mods) {
+ for ($scope->mods) {
   my $type = $_->type;
   if ($type eq 'clip') {
    unshift @clips, $_->content;
@@ -155,11 +132,13 @@ sub concat {
   }
  }
 
+ my @body = $scope->body;
+
  my $mods_string = @raw_mods ? ' [' . join(',', @raw_mods) . ']' : undef;
 
- if (@raw_mods and $body =~ /^\s*\\draw\b\s*([^\[].*)\s*$/) {
-  $body = "\\draw$mods_string $1\n"; # Has trailing semicolon
-  $mods_string = undef;              # Done with mods
+ if (@raw_mods and @body == 1 and $body[0] =~ /^\s*\\draw\b\s*([^\[].*)\s*$/) {
+  $body[0]     = "\\draw$mods_string $1"; # Has trailing semicolon
+  $mods_string = undef;                   # Done with mods
  }
 
  for (0 .. $#clips) {
@@ -167,37 +146,89 @@ sub concat {
   my $clip_string = "\\clip $clip ;";
   my $mods_string = ($_ == $#clips and defined $mods_string)
                      ? $mods_string : '';
-  1 while chomp $body;
-  $body = <<"  CLIP";
-\\begin{scope}$mods_string
-$clip_string
-$body
-\\end{scope}
-  CLIP
+  unshift @body, "\\begin{scope}$mods_string",
+                 $clip_string;
+  push    @body, "\\end{scope}",
  }
 
  if (not @clips and defined $mods_string) {
-  1 while chomp $body;
-  $body = <<"  MODS";
-\\begin{scope}$mods_string
-$body
-\\end{scope}
-  MODS
+  unshift @body, "\\begin{scope}$mods_string";
+  push    @body, "\\end{scope}";
  }
 
  if (defined $layer) {
-  1 while chomp $body;
-  $body = <<"  LAYER";
-\\begin{pgfonlayer}{$layer}
-$body
-\\end{pgfonlayer}
-  LAYER
+  unshift @body, "\\begin{pgfonlayer}{$layer}";
+  push    @body, "\\end{pgfonlayer}";
  }
 
- $rev ? $str . $body : $body . $str;
+ return @body;
 }
 
-sub stringify { $_[0]->concat('') }
+sub dereference { [ $_[0]->instantiate ] }
+
+sub fold {
+ my ($left, $right, $rev) = @_;
+
+ my (@left, @right);
+
+ if ($my_tc->check($left)) {
+  $left = $left->flatten;
+
+  if ($my_tc->check($right)) {
+   $right = $right->flatten;
+
+   my ($only_left, $common, $only_right) = $inter->(
+    $left->_mods_cache,
+    $right->_mods_cache,
+   );
+
+   my $has_different_layers;
+   for (@$only_left) {
+    if ($_->type eq 'layer') {
+     $has_different_layers = 1;
+     last;
+    }
+   }
+   unless ($has_different_layers) {
+    for (@$only_right) {
+     if ($_->type eq 'layer') {
+      $has_different_layers = 1;
+      last;
+     }
+    }
+   }
+
+   if (!$has_different_layers and @$common) {
+    my $x = $left->new
+                 ->mod(@$only_left)
+                 ->body($left->_body);
+    my $y = $left->new
+                 ->mod(@$only_right)
+                 ->body($right->_body);
+    return $left->new
+                ->mod(@$common)
+                ->body(fold($x, $y, $rev));
+   } else {
+    @right = $right->instantiate;
+   }
+  } else {
+   $_body_tc->assert_valid($right);
+   @right = @$right;
+  }
+
+  @left = $left->instantiate;
+ } else {
+  if ($my_tc->check($right)) {
+   return fold($right, $left, 1);
+  } else {
+   $_body_tc->assert_valid($_) for $left, $right;
+   @left  = @$left;
+   @right = @$right;
+  }
+ }
+
+ $rev ? [ @right, @left ] : [ @left, @right ];
+}
 
 __PACKAGE__->meta->make_immutable;