lib/Text/Tradition/Collation/Relationship.pm

   1 package Text::Tradition::Collation::Relationship;
   2
   3 use Moose;
   4 use Moose::Util::TypeConstraints;
   5 ## CAREFUL in our use of Moose::Util::TypeConstraints.  That 'from'
   6 ## clashes with Graph::Easy::Edge 'from', so we'll need to unimport
   7 ## TypeConstraints after defining the types.  Or else we would have to
   8 ## finally split out our types into another module.
   9 use MooseX::NonMoose;
  10
  11 extends 'Graph::Easy::Edge';
  12
  13 enum 'RelationshipType' => qw( spelling orthographic grammatical repetition lexical );
  14
  15 subtype 'RelationshipVector',
  16     => as 'ArrayRef',
  17     => where { @$_ == 2
  18                && $_->[0]->isa( 'Graph::Easy::Node' )
  19                && $_->[1]->isa( 'Graph::Easy::Node' )
  20              },
  21     message { 'Argument should be [ SourceReading, TargetReading ]' };
  22
  23 subtype 'RelationshipTokenVector',
  24     => as 'ArrayRef',
  25     => where { @$_ == 2 },
  26     message { 'Argument should be [ \'source\', \'target\' ]' };
  27
  28 no Moose::Util::TypeConstraints;  ## see comment above
  29
  30 has 'sort' => (
  31     is => 'rw',
  32     isa => 'RelationshipType',
  33     required => 1,
  34 );
  35
  36 has 'orig_relation' => (
  37     is => 'rw',
  38     isa => 'RelationshipVector',
  39     required => 1,
  40 );
  41
  42 has 'related_readings' => (
  43     is => 'rw',
  44     isa => 'RelationshipTokenVector',
  45 );
  46
  47 has 'global' => (
  48     is => 'rw',
  49     isa => 'Bool',
  50     default => 0,
  51 );
  52
  53 has 'non_correctable' => (
  54     is => 'rw',
  55     isa => 'Bool',
  56     );
  57
  58 has 'non_independent' => (
  59     is => 'rw',
  60     isa => 'Bool',
  61     );
  62
  63 sub FOREIGNBUILDARGS {
  64     my $class = shift;
  65     my %args = @_;
  66
  67     # Make the label match our 'sort' attribute.
  68     my @superclass_args;
  69     if( exists $args{'sort'} ) {
  70         push( @superclass_args, 'label', $args{'sort'} );
  71     }
  72     return @superclass_args;
  73 }
  74
  75 sub BUILD {
  76     my( $self, $args ) = @_;
  77
  78     $self->set_attribute( 'class', 'relationship' );
  79
  80     my( $source, $target ) = @{$self->orig_relation};
  81     if( $source->has_position && $target->has_position
  82         && $source->position ne $target->position ) {
  83         die "Cannot set relationship between readings in different positions";
  84     }
  85     unless( $self->related_readings ) {
  86         $self->related_readings( [ $self->orig_relation->[0]->label,
  87                                    $self->orig_relation->[1]->label ] );
  88     }
  89 }
  90
  91 no Moose;
  92 __PACKAGE__->meta->make_immutable;