script/conllu2korapxml

#!/usr/bin/env perl
use strict;
use warnings;
use POSIX;
use Getopt::Long qw(GetOptions :config no_auto_abbrev);
use Log::Any '$log';
use Log::Any::Adapter;
use Encode;
use IO::Compress::Zip qw(zip $ZipError :constants);
use File::Basename;
use Pod::Usage;

my $_COMPRESSION_METHOD = ZIP_CM_DEFLATE;
my %opts;
my %processedFilenames;

our $VERSION = '0.7.0';
our $VERSION_MSG = "\nconllu2korapxml - v$VERSION\n";

use constant {
    # Set to 1 for minimal more debug output (no need to be parametrized)
    DEBUG => $ENV{KORAPXMLCONLLU_DEBUG} // 0
};

GetOptions(
    'force-foundry|f=s'            => \(my $foundry_name = ''),
    'text-sigle|s=s'               => \(my $text_sigle_template = ''),
    'base-text'                    => \(my $base_text = 0),
    'log|l=s'                      => \(my $log_level = 'warn'),
    'output|o=s'                   => \(my $outh = '-'),
    'base-tokens'                  => \(my $base_tokens = 0),
    'help|h'                       => sub {
      pod2usage(
          -verbose  => 99,
          -sections => 'NAME|DESCRIPTION|SYNOPSIS|ARGUMENTS|OPTIONS|EXAMPLES',
          -msg      => $VERSION_MSG,
          -output   => '-'
      )
    },
    'version|v'                    => sub {
      pod2usage(
          -verbose => 0,
          -msg     => $VERSION_MSG,
          -output  => '-'
      );
    }
);

# Validate text-sigle template format
if ($text_sigle_template) {
    my $test_sigle = $text_sigle_template;
    $test_sigle =~ s/\{ID\}/PLACEHOLDER/gi;
    my @tpl_parts = split('/', $test_sigle);
    if (scalar @tpl_parts != 3) {
        die "ERROR: text-sigle template must produce exactly 3"
            . " slash-separated parts (CORPUS/DOC/TEXT), got "
            . scalar(@tpl_parts) . " from '$text_sigle_template'\n";
    }
    if (grep { $_ eq '' } @tpl_parts) {
        die "ERROR: text-sigle template '$text_sigle_template'"
            . " must not contain empty parts\n";
    }
}

# Establish logger
binmode(STDERR, ':encoding(UTF-8)');
Log::Any::Adapter->set('Stderr', log_level => $log_level);
$log->notice('Debugging is activated') if DEBUG;

my $docid="";
my $zip = undef;
my $parser_file;
my $parse;
my $morpho_file;
my $morpho;
my @spansFrom;
my @spansTo;
my $current;
my ($unknown, $known) = (0, 0);
my $sentence_text = '';
my $doc_offset = 0;
my $text_pos = 0;
my $compute_offsets_mode = 0;
# Buffer dependency arcs until all token offsets in a sentence are known
my @dep_buffer;

# Struct layer tracking for sentence and paragraph spans
my @sentence_spans;
my @paragraph_spans;
my $current_sent_id = '';
my $pending_newpar_id = '';
my $current_par_from = -1;
my $last_sent_to = -1;
my $has_sent_ids = 0;
my $sent_counter = 0;
my $par_counter = 0;

my ($write_morpho, $write_syntax, $base) = (1, 0, 0);
my @doc_texts;
my @token_spans;
my $token_counter = 0;
my $filename;
my $first=1;
my @conllu_files = @ARGV;
push @conllu_files, "-" if (@conllu_files == 0);
my $fh;

my $dependency_foundry_name = $foundry_name;
if ($foundry_name =~ /(.*) dependency:(.*)/) {
  $foundry_name = $1;
  $dependency_foundry_name = $2;
}

foreach my $conllu_file (@conllu_files) {
  if ($conllu_file eq '-') {
    $fh = \*STDIN;
  } else {
    open($fh, "<", $conllu_file) or die "Cannot open $conllu_file";
  }
  my $i=0; my $s=0; my $first_in_sentence=0;
  my $lastDocSigle="";
  MAIN: while (<$fh>) {
    if(/^\s*(?:#|0\.\d)/) {
      if(/^(?:#|0\.1)\s+filename\s*[:=]\s*(.*)/) {
        $filename=$1;
        if(!$first) {
          closeDoc(0);
        } else {
          $first=0;
        }
        if($processedFilenames{$filename}) {
          $log->warn("WARNING: $filename is already processed");
        }
        $processedFilenames{$filename}=1;
        $i=0;
        $doc_offset = 0;
        $sentence_text = '';
        $compute_offsets_mode = 0;
        @doc_texts = ();
        @token_spans = ();
        $token_counter = 0;
        @sentence_spans = ();
        @paragraph_spans = ();
        $current_sent_id = '';
        $pending_newpar_id = '';
        $current_par_from = -1;
        $last_sent_to = -1;
        $has_sent_ids = 0;
        $sent_counter = 0;
        $par_counter = 0;
      } elsif (/^#\s*newdoc\s+id\s*=\s*(.*)/ && $text_sigle_template) {
        my $newdoc_id = $1;
        $newdoc_id =~ s/\s+$//;

        if (!$first) {
          closeDoc(0);
        } else {
          $first = 0;
        }

        my $text_sigle = $text_sigle_template;
        $text_sigle =~ s/\{ID\}/$newdoc_id/gi;

        my @parts = split('/', $text_sigle);
        if (scalar @parts != 3 || grep { $_ eq '' } @parts) {
            die "ERROR: Expanded text sigle '$text_sigle' is not"
                . " in valid CORPUS/DOC/TEXT format\n";
        }

        $filename = "$text_sigle/base/tokens.xml";
        if ($processedFilenames{$filename}) {
          $log->warn("WARNING: $filename is already processed");
        }
        $processedFilenames{$filename} = 1;
        $i = 0;

        my $last = pop @parts;
        $docid = join('_', @parts) . '.' . $last;

        my $docSigle = $docid;
        $docSigle =~ s/\..*//;
        if ($docSigle ne $lastDocSigle) {
          $log->info("Analyzing $docSigle");
          $lastDocSigle = $docSigle;
        }
        $known = $unknown = 0;
        $current = "";
        @sentence_spans = ();
        @paragraph_spans = ();
        $current_sent_id = '';
        $pending_newpar_id = '';
        $current_par_from = -1;
        $last_sent_to = -1;
        $has_sent_ids = 0;
        $sent_counter = 0;
        $par_counter = 0;

        $morpho_file = "$text_sigle/$foundry_name/morpho.xml";
        $parser_file = "$text_sigle/$dependency_foundry_name/dependency.xml";

        $parse = $morpho = layer_header($docid);
      } elsif(/^#\s*foundry\s*[:=]\s*(.*)/) {
        if(!$foundry_name) {
          $dependency_foundry_name = $foundry_name = $1;
          if ($foundry_name =~ /(.*) dependency:(.*)/) {
            $foundry_name = $1;
            $dependency_foundry_name = $2;
          } 
          $log->debug("Foundry: $foundry_name\n");
        } else {
          $log->debug("Ignored foundry name: $1\n");
        }
      } elsif(/^#\s*generator\s*[=]\s*udpipe/i) {
        if(!$foundry_name) {
          $dependency_foundry_name = $foundry_name = "ud";
          $log->debug("Foundry: $foundry_name\n");
        } else {
          $log->debug("Ignored foundry name: ud\n");
        }
      } elsif(/^(?:#|0\.2)\s+text_id\s*[:=]\s*(.*)/) {
        $docid=$1;
        $docid =~ s/\s+$//;
        my $docSigle = $docid;
        $docSigle =~ s/\..*//;
        if($docSigle ne $lastDocSigle) {
          $log->info("Analyzing $docSigle");
          $lastDocSigle = $docSigle;
        }
        $known=$unknown=0;
        $current="";
        $parser_file = dirname($filename);
        $parser_file =~ s@(.*)/[^/]+$@$1@;
        $morpho_file = $parser_file;
        $morpho_file .= "/$foundry_name/morpho.xml";
        $parser_file .= "/$dependency_foundry_name/dependency.xml";
        $parse = $morpho = layer_header($docid);
      }  elsif (/^(?:#|0\.3)\s+(?:start_offsets|from)\s*[:=]\s*(.*)/) {
        @spansFrom = split(/\s+/, $1);
      }  elsif (/^(?:#|0\.4)\s+(?:end_offsets|to)\s+[:=]\s*(.*)/) {
        @spansTo = split(/\s+/, $1);
      }  elsif (/^#\s*text\s*=\s*(.*)/) {
        $sentence_text = decode('UTF-8', $1);
        if ($base_text) {
          my $txt = $1;
          $txt =~ s/\s+$//;
          push @doc_texts, $txt;
        }
      }  elsif (/^#\s*sent_id\s*=\s*(.*)/) {
        $current_sent_id = $1;
        $current_sent_id =~ s/\s+$//;
        $has_sent_ids = 1;
      }  elsif (/^#\s*newpar(?:\s+id\s*=\s*(.*))?/) {
        my $pid = defined($1) ? $1 : '';
        $pid =~ s/\s+$//;
        $pending_newpar_id = $pid || '__NEWPAR__';
      }
    } elsif ( !/^\s*$/ ) {
      # Pre-split columns before offset computation needs the raw form
      my @raw_cols = split('\t');
      chomp $raw_cols[$#raw_cols] if @raw_cols;

      # Enter offset computation mode when no explicit offsets given
      if (!$compute_offsets_mode && scalar @spansFrom == 0
          && $sentence_text && $docid) {
        $compute_offsets_mode = 1;
        @spansFrom = ();
        @spansTo = ();
        # Sentence-level span covers the full sentence text
        $spansFrom[0] = $doc_offset;
        $spansTo[0] = $doc_offset + length($sentence_text);
        $text_pos = 0;
      }

      # Locate each token form in sentence text via index()
      if ($compute_offsets_mode && @raw_cols >= 2 && $raw_cols[0] =~ /^\d+$/) {
        my $raw_form = decode('UTF-8', $raw_cols[1]);
        my $t_num = $raw_cols[0];
        # Find token starting from current position (handles SpaceAfter)
        my $pos_in_text = index($sentence_text, $raw_form, $text_pos);
        if ($pos_in_text >= 0) {
          $spansFrom[$t_num] = $doc_offset + $pos_in_text;
          $spansTo[$t_num] = $spansFrom[$t_num] + length($raw_form);
          # Advance past this token for the next search
          $text_pos = $pos_in_text + length($raw_form);
        } else {
          $log->warn("WARNING: Token form not found in sentence text in $conllu_file line $.");
        }
      }

      if ( !$docid || scalar @spansTo == 0 || scalar @spansFrom == 0 ) {
        if ( !$docid ) {
          $log->warn("WARNING: Invalid input in $conllu_file: text_id (e.g. '# text_id = GOE_AGA.00000') missing in line $. when writing to $outh");
        }
        if ( scalar @spansTo == 0 || scalar @spansFrom == 0 ) {
          $log->warn("WARNING: Invalid input in $conllu_file: token offsets missing in line $. when writing to $outh");
        }

        # Skip to next potentially valid document
        while (<$fh>) {
          next MAIN if m!^\s*$!s;
        }
      };
      my @parsed = map {
        my $s = $_;
        $s =~ s/&/&amp;/g;
        $s =~ s/</&lt;/g;
        $s =~ s/>/&gt;/g;
        $s;
      } @raw_cols;
      if (@parsed != 10) {
        $log->warn("WARNING: skipping strange parser output line in $docid");
        $i++;
        next;
      }
      my $t=$parsed[0];
      if($t == 1) {
        $s++;
        $first_in_sentence = $i;
      }
      if($parsed[6] =~ /\d+/ && $parsed[7] !~ /_/) {
        $write_syntax=1;
        # Buffer dep arcs; flushed at end of sentence when offsets are ready
        push @dep_buffer, [$s, $t, $parsed[6], $parsed[7]];
      }
      my $pos = $parsed[4];
      my $upos = $parsed[3];
      $pos =~ s/\|.*//;
      $morpho .= qq(  <span id="s${s}_n$t" from="$spansFrom[$t]" to="$spansTo[$t]">
   <fs type="lex" xmlns="http://www.tei-c.org/ns/1.0">
    <f name="lex">
     <fs>
);
      if($pos ne "_") {
        $morpho .= qq(      <f name="pos">$pos</f>\n);
      }
      if($upos ne "_") {
        $morpho .= qq(      <f name="upos">$upos</f>\n);
      }
      $morpho .= qq(      <f name="lemma">$parsed[2]</f>\n) if($parsed[2] ne "_" || $parsed[1] eq '_');
      $morpho .= qq(      <f name="msd">$parsed[5]</f>\n) if($parsed[5] ne "_");
      # Filter SpaceAfter from MISC column
      if ($parsed[9] ne "_") {
        my @misc_parts = grep { !/^Spaces?After/ } split(/\|/, $parsed[9]);
        $parsed[9] = @misc_parts ? join('|', @misc_parts) : '_';
      }
      if($parsed[9] ne "_") {
        if ($parsed[9] =~ /[0-9.e]+/) {
          $morpho .= qq(      <f name="certainty">$parsed[9]</f>\n)
        }
        else {
          $morpho .= qq(      <f name="misc">$parsed[9]</f>\n)
        }
      }
      $morpho .= qq(     </fs>
    </f>
   </fs>
  </span>
);
        # Collect token span for optional base/tokens.xml output
        if ($base_tokens) {
          push @token_spans, [$spansFrom[$t], $spansTo[$t]];
        }
        $i++;
    } else {
      # Empty line = end of sentence
      flush_dep_buffer();
      if ($compute_offsets_mode) {
        $doc_offset += length($sentence_text) + 1;
        @spansFrom = ();
        @spansTo = ();
        $compute_offsets_mode = 0;
      }
      $sentence_text = '';
      record_sentence_struct();
    }
  }
  # Flush last sentence if input lacks trailing empty line
  record_sentence_struct();
  $current .= "\n";
  closeDoc(1);
  $zip->close() if $zip;
  close($fh);
}
exit;

sub newZipStream {
  my ($fname) = @_;
  if (defined $zip) {
    $zip->newStream(Zip64 => 1, TextFlag => 1, Method => $_COMPRESSION_METHOD,
        Append            => 1, Name => $fname, ExtAttr =>  0100666 << 16)
        or die "ERROR ('$fname'): zip failed: $ZipError\n";
  } else {
    $zip = new IO::Compress::Zip $outh, Zip64 => 1, TextFlag => 1,
        Method => $_COMPRESSION_METHOD, Append => 0, Name => "$fname", ExtAttr =>  0100666 << 16
        or die "ERROR ('$fname'): zip failed: $ZipError\n";
  }
}

# Write buffered dependency arcs now that all token offsets are resolved
sub flush_dep_buffer {
  foreach my $dep (@dep_buffer) {
    my ($ds, $dt, $dhead, $dlabel) = @$dep;
    $parse .= qq@<span id="s${ds}_n$dt" from="$spansFrom[$dt]" to="$spansTo[$dt]">
<rel label="$dlabel">
<span from="$spansFrom[$dhead]" to="$spansTo[$dhead]"/>
</rel>
</span>
@;
  }
  @dep_buffer = ();
}

sub record_sentence_struct {
  return unless $has_sent_ids && $current_sent_id && scalar @spansFrom > 0;
  $sent_counter++;
  push @sentence_spans, ["s$sent_counter", $spansFrom[0], $spansTo[0]];
  if ($pending_newpar_id) {
    if ($current_par_from >= 0 && $last_sent_to >= 0) {
      $par_counter++;
      push @paragraph_spans, ["p$par_counter", $current_par_from, $last_sent_to];
    }
    $current_par_from = $spansFrom[0];
    $pending_newpar_id = '';
  }
  $last_sent_to = $spansTo[0];
  $current_sent_id = '';
}

sub closeDoc {
  flush_dep_buffer();
  if ($write_morpho && $morpho_file) {
    newZipStream($morpho_file);
    $zip->print($morpho, qq( </spanList>\n</layer>\n));
  }
  if ($write_syntax && $parser_file) {
    $write_syntax = 0;
    newZipStream($parser_file);
    $zip->print($parse, qq(</spanList>\n</layer>\n));
  }
  if ($base_text && $filename && @doc_texts) {
    my $text_dir = dirname($filename);
    $text_dir =~ s@(.*)/[^/]+$@$1@;
    my $data_path = "$text_dir/data.xml";
    my $full_text = join(' ', @doc_texts);
    $full_text =~ s/&/&amp;/g;
    $full_text =~ s/</&lt;/g;
    $full_text =~ s/>/&gt;/g;
    newZipStream($data_path);
    $zip->print(
      qq(<?xml version="1.0" encoding="UTF-8"?>\n),
      qq(<?xml-model href="text.rng" type="application/xml"),
      qq( schematypens="http://relaxng.org/ns/structure/1.0"?>\n),
      qq(<raw_text docid="$docid"),
      qq( xmlns="http://ids-mannheim.de/ns/KorAP">\n),
      qq(<text>$full_text</text>\n),
      qq(</raw_text>\n)
    );
    @doc_texts = ();
  }
  if ($base_tokens && $filename && @token_spans) {
    my $text_dir = dirname($filename);
    $text_dir =~ s@(.*)/[^/]+$@$1@;
    my $tokens_path = "$text_dir/base/tokens.xml";
    my $tokens_out = layer_header($docid);
    for my $idx (0 .. $#token_spans) {
      my ($from, $to) = @{$token_spans[$idx]};
      $tokens_out .= qq(  <span id="t_$idx" from="$from" to="$to"/>\n);
    }
    newZipStream($tokens_path);
    $zip->print($tokens_out, qq(</spanList>\n</layer>\n));
  }
  if ($has_sent_ids && $filename) {
    if ($current_par_from >= 0 && $last_sent_to >= 0) {
      $par_counter++;
      push @paragraph_spans, ["p$par_counter", $current_par_from, $last_sent_to];
    }
    my $text_dir = dirname($filename);
    $text_dir =~ s@(.*)/[^/]+$@$1@;
    my $struct_path = "$text_dir/base/struct.xml";
    my $struct = layer_header($docid);
    my @all_spans;
    for my $span (@sentence_spans) {
      push @all_spans, [$span->[0], $span->[1], $span->[2], 's'];
    }
    for my $span (@paragraph_spans) {
      push @all_spans, [$span->[0], $span->[1], $span->[2], 'p'];
    }
    @all_spans = sort { $a->[1] <=> $b->[1] || $a->[2] <=> $b->[2] } @all_spans;
    for my $span (@all_spans) {
      my ($id, $from, $to, $name) = @$span;
      $struct .= qq(  <span id="$id" from="$from" to="$to">\n)
               . qq(   <fs type="struct" xmlns="http://www.tei-c.org/ns/1.0">\n)
               . qq(    <f name="name">$name</f>\n)
               . qq(   </fs>\n)
               . qq(  </span>\n);
    }
    newZipStream($struct_path);
    $zip->print($struct, qq(</spanList>\n</layer>\n));
  }
}

sub layer_header {
  my ($docid) = @_;
  return(qq(<?xml version="1.0" encoding="UTF-8"?>
<?xml-model href="span.rng" type="application/xml" schematypens="http://relaxng.org/ns/structure/1.0"?>
<layer docid="$docid" xmlns="http://ids-mannheim.de/ns/KorAP" version="KorAP-0.4">
<spanList>
));
}

=pod

=encoding utf8

=head1 NAME

conllu2korapxml - Conversion of KorAP-XML CoNLL-U to KorAP-XML zips

=head1 SYNOPSIS

  conllu2korapxml < zca15.tree_tagger.conllu > zca15.tree_tagger.zip

=head1 DESCRIPTION

C<conllu2korapxml> converts CoNLL-U files that follow KorAP-specific comment conventions
 and contain morphosyntactic and/or dependency annotations to
 corresponding KorAP-XML zip files.

=head1 INSTALLATION

  $ cpanm https://github.com/KorAP/KorAP-XML-CoNLL-U.git

=head1 OPTIONS

=over 2

=item B<--force-foundry|-f>

Set foundry name and ignore foundry names in the input.

=item B<--text-sigle|-s>

Text sigle template with C<{ID}> placeholder for standard UD CoNLL-U
input. When C<# newdoc id = E<lt>IDE<gt>> is encountered, C<{ID}> is
replaced by the document id to derive the KorAP-XML text sigle,
filename, and docid.

=item B<--base-text>

Generate a C<data.xml> file containing the reconstructed plain text
of each document. The text is built from C<# text> comment lines
in the CoNLL-U input, joined by single spaces.

=item B<--help|-h>

Print help information.

=item B<--version|-v>

Print version information.


=item B<--log|-l>

Loglevel for I<Log::Any>. Defaults to C<warn>.

=item B<--output|-o>

Output file. Defaults to C<-> (stdout).

=back

=head1 EXAMPLES

 conllu2korapxml -f tree_tagger < t/data/wdf19.morpho.conllu > wdf19.tree_tagger.zip

 conllu2korapxml -f "tree_tagger dependency:malt" < t/data/wdf19.tt-malt.conllu > wdf19.tree_tagger.zip

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2021-2024, L<IDS Mannheim|https://www.ids-mannheim.de/>

Author: Marc Kupietz

Contributors: Nils Diewald

L<KorAP::XML::CoNNL-U> is developed as part of the L<KorAP|https://korap.ids-mannheim.de/>
Corpus Analysis Platform at the
L<Leibniz Institute for the German Language (IDS)|http://ids-mannheim.de/>,
member of the
L<Leibniz-Gemeinschaft|http://www.leibniz-gemeinschaft.de/>.

This program is free software published under the
L<BSD-2 License|https://opensource.org/licenses/BSD-2-Clause>.