# -*-cperl-*-
## BNCweb extension of the CEQL grammar

use warnings;
use strict;

package bncCEQL;
use base 'CWB::CEQL';

use Encode;
use HTML::Entities;

=head1 NAME

bncCEQL - BNCweb extension of the Common Elementary Query Language (CEQL)

=head1 SYNOPSIS

  use bncCEQL;
  our $CEQL = new bncCEQL;

  $CEQL->SetParam("default_ignore_case", 0); # case-sensitive query mode
  $CEQL->SetParam("default_ignore_diac", 1); # (optional:) ignore accents by default

  # $ceql_query must be in canonical BNCweb encoding (Latin-1 + HTML entities)
  $cqp_query = $CEQL->Parse($ceql_query);    # returns CQP query in canonical BNCweb encoding

  if (not defined $cqp_query) {
    $html_msg = $ceql->HtmlErrorMessage;     # ready-made HTML error message
    print "<html><body>$html_msg</body></html>\n";
    exit 0;
  }

=cut

# constructor: set up attribute names and define simplified POS tags
sub new {
  my $class = shift;
  my $self = new CWB::CEQL;
  $self->SetParam("lemma_attribute", "hw"); # corresponds to lemma in standard CEQL grammar
  my $table = { # define lookup table for simple POS tags (refer to class attribute)
               "A" => "ADJ",
               "ADJ" => "ADJ",
               "N" => "SUBST",
               "SUBST" => "SUBST",
               "V" => "VERB",
               "VERB" => "VERB",
               "ADV" => "ADV",
               "ART" => "ART",
               "CONJ" => "CONJ",
               "INT" => "INTERJ",
               "INTERJ" => "INTERJ",
               "PREP" => "PREP",
               "PRON" => "PRON",
               '$' => "STOP",
               "STOP" => "STOP",
               "UNC" => "UNC",
              };
  $self->SetParam("simple_pos", $table);
  $self->SetParam("simple_pos_attribute", "class");
  my %xml_tags = map { $_ => 1 } # list of s-attribute regions in the BNC version used by BNCweb
    (qw(text u div head quote sp speaker stage lg l list label item note bibl corr hi trunc p s mw), # from CWB registry file
     # nested attributes are accepted, but should perhaps better be inserted automagically
     qw(div1 div2 div3 quote1 list1 list2 item1 item2 hi1 p1 p2));
  $self->SetParam("s_attributes", \%xml_tags);
  return bless($self, $class);
}

# BNCweb::CEQL expects its input to be in the canonical BNCweb encoding, i.e. Latin-1 + HTML entities;
# the "default" rule first converts the input to a Perl Unicode string, and then re-encodes the resulting CQP query in Latin-1
sub default {
  my ($self, $input) = @_;
  my $unicode = decode("iso-8859-1", $input);
  decode_entities($unicode);
  ## ***ADD***
  my $modifier = ($unicode =~ s/^\s*(\({2}[A-Za-z]+\){2}\s*)//) ? $1 : ""; # pass through query modifiers ((all)), ((longest))
  my $cqp_unicode = $self->Call("ceql_query", $unicode);
  ## ***ADD***
  $cqp_unicode = $modifier.$cqp_unicode;
  return encode("iso-8859-1", $cqp_unicode, Encode::FB_CROAK);
}

# override literal_string rule to insert HTML entities (for non-Latin-1 characters and special treatment of ")
sub literal_string {
  my ($self, $input) = @_;
  $input =~ s/\\//g; # remove backslashes (used to escape CEQL metacharacters)
  encode_entities($input, '<>&');            # unsafe characters <, >, & are HTML entities in the canonical BNCweb encoding
  encode_entities($input, '^\x{00}-\x{FF}'); # encode non-Latin-1 characters as HTML entities (but keep $input in Unicode for now)
  $input =~ s/([.?*+|(){}\[\]\^\$])/\\$1/g;  # escape CQP regexp metacharacters (" is treated separately below)
  $input =~ s/"/&(lsquo|rsquo);/g;           # special handling of " to match both left and right quotes
  return $input;
}

# override lemma_pattern rule to provide support for {book/V} notation
sub lemma_pattern {
  my ($self, $lemma) = @_;
  my $simple_pos = $self->GetParam("simple_pos");
  die "simplified POST tags are not available (internal error)\n"
    unless ref($simple_pos) eq "HASH";
  # split lemma into headword pattern and optional simple POS constraint
  my ($hw, $tag, $extra) = split /(?<!\\)\//, $lemma;
  die "only a single ''/'' separator is allowed between headword and simplified POS in lemma constraint\n"
    if defined $extra;
  die "missing headword in lemma constraint (did you mean ''_{$tag}''?)\n"
    if $hw eq "";
  # translate wildcard pattern for headword and look up simple POS if specified
  my $regexp = $self->Call("wildcard_pattern", $hw);
  if (defined $tag) {
    # simple POS specified => look up in $simple_pos an combine with $regexp
    my $tag_regexp = $simple_pos->{$tag};
    if (not defined $tag_regexp) {
      my @valid_tags = sort keys %$simple_pos;
      die "'' $tag '' is not a valid simple part-of-speech tag (available tags: '' @valid_tags '')\n";
    }
    $regexp =~ s/^"//; $regexp =~ s/"$//; # remove double quotes around regexp so it can be combined with POS constraint
    return "lemma=\"($regexp)_${tag_regexp}\"";
  }
  else {
    # no simple POS specified => match hw attribute instead of lemma
    return "hw=$regexp";
  }
}

=head1 COPYRIGHT

Copyright (C) 1999-2008 Stefan Evert [http::/purl.org/stefan.evert]

This software is provided AS IS and the author makes no warranty as to
its use and performance. You may use the software, redistribute and
modify it under the same terms as Perl itself.

=cut

1;
