Added incorpus queries to check for corpus constraints in query matches
Change-Id: Iffc4aca87576be7a70e225e42ee4c2653e756568
diff --git a/lib/Krawfish/Koral/Query/Builder.pm b/lib/Krawfish/Koral/Query/Builder.pm
index 722e986..6ffe14c 100644
--- a/lib/Krawfish/Koral/Query/Builder.pm
+++ b/lib/Krawfish/Koral/Query/Builder.pm
@@ -7,6 +7,7 @@
use Krawfish::Koral::Query::Term;
use Krawfish::Koral::Query::Token;
use Krawfish::Koral::Query::Span;
+use Krawfish::Koral::Query::InCorpus;
use Krawfish::Koral::Query::Sequence;
use Krawfish::Koral::Query::Repetition;
use Krawfish::Koral::Query::TermGroup;
@@ -67,8 +68,7 @@
sub term {
shift;
- my $term = shift;
- return Krawfish::Koral::Query::Term->new(TOKEN_PREF . $term);
+ return Krawfish::Koral::Query::Term->new(TOKEN_PREF . shift);
};
sub term_neg {
@@ -126,6 +126,7 @@
);
};
+
# Position construct
sub position {
my $self = shift;
@@ -144,6 +145,13 @@
};
+# Search with reference to a specific supcorpus
+sub in_corpus {
+ shift;
+ Krawfish::Koral::Query::InCorpus->new(@_);
+};
+
+
# Create reference query
sub reference {
shift;
diff --git a/lib/Krawfish/Koral/Query/InCorpus.pm b/lib/Krawfish/Koral/Query/InCorpus.pm
new file mode 100644
index 0000000..57b9319
--- /dev/null
+++ b/lib/Krawfish/Koral/Query/InCorpus.pm
@@ -0,0 +1,140 @@
+package Krawfish::Koral::Query::InCorpus;
+use parent 'Krawfish::Koral::Query';
+use Krawfish::Util::Bits;
+use Krawfish::Query::InCorpus;
+use strict;
+use warnings;
+
+# Create a query that will check if a certain
+# match is associated to certain classes.
+
+# Accepts the nesting query and a number of valid
+# corpus classes
+
+# Constructor
+sub new {
+ my $class = shift;
+ bless {
+ operands => [shift],
+ corpus_classes => [@_]
+ }, $class;
+};
+
+
+# Query type
+sub type { 'incorpus' };
+
+
+# Normalize unique query
+sub normalize {
+ my $self = shift;
+
+ my $span;
+ unless ($span = $self->operand->normalize) {
+ $self->copy_info_from($self->operand);
+ return;
+ };
+
+ $self->operands([$span]);
+
+ return $self;
+};
+
+
+# Optimize query to potentially need sorting
+sub optimize {
+ my ($self, $segment) = @_;
+
+ my $span;
+
+ # Not plannable
+ unless ($span = $self->operand->optimize($segment)) {
+ $self->copy_info_from($self->span);
+ return;
+ };
+
+ # Span has no match
+ if ($span->max_freq == 0) {
+ return $self->builder->nowhere;
+ };
+
+ return Krawfish::Query::InCorpus->new(
+ $span,
+ classes_to_flags(@{$self->{corpus_classes}})
+ );
+};
+
+
+# Stringification
+sub to_string {
+ my $self = shift;
+ return 'inCorpus(' . join(',',@{$self->{corpus_classes}}) . ':' . $self->operand->to_string . ')';
+};
+
+
+# Serialization to KQ
+sub to_koral_fragment {
+ ...
+};
+
+
+# TODO: Identical to class/unique
+
+sub is_anywhere {
+ $_[0]->operand->is_anywhere;
+};
+
+
+sub is_optional {
+ $_[0]->operand->is_optional;
+};
+
+
+sub is_null {
+ $_[0]->operand->is_null;
+};
+
+
+sub is_negative {
+ $_[0]->operand->is_negative;
+};
+
+
+sub is_extended {
+ $_[0]->operand->is_extended;
+};
+
+
+sub is_extended_right {
+ $_[0]->operand->is_extended_right;
+};
+
+
+sub is_extended_left {
+ $_[0]->operand->is_extended_left;
+};
+
+
+sub is_classed {
+ $_[0]->operand->is_classed;
+};
+
+
+sub maybe_unsorted {
+ $_[0]->operand->maybe_unsorted;
+};
+
+
+# A unique query always spans its operand span
+sub min_span {
+ $_[0]->operand->min_span;
+};
+
+
+# A unique query always spans its operand span
+sub max_span {
+ $_[0]->operand->max_span;
+};
+
+
+1;
diff --git a/lib/Krawfish/Koral/Query/Or.pm b/lib/Krawfish/Koral/Query/Or.pm
index 7209169..23d2374 100644
--- a/lib/Krawfish/Koral/Query/Or.pm
+++ b/lib/Krawfish/Koral/Query/Or.pm
@@ -14,7 +14,7 @@
# Deal with optionality in groups!
# (a|b?|c?) -> (a|b|c)?
-use constant DEBUG => 1;
+use constant DEBUG => 0;
# Constructor
sub new {
diff --git a/lib/Krawfish/Koral/Query/Term.pm b/lib/Krawfish/Koral/Query/Term.pm
index 617fceb..4aeaf5f 100644
--- a/lib/Krawfish/Koral/Query/Term.pm
+++ b/lib/Krawfish/Koral/Query/Term.pm
@@ -439,7 +439,9 @@
sub is_extended_right { 0 };
sub is_extended_left { 0 };
sub maybe_unsorted { 0 };
-
+sub uses_classes {
+ undef;
+};
sub from_koral {
my $class = shift;