package Bio::MUST::Core::SeqId;
# ABSTRACT: Modern and legacy MUST-compliant sequence id
# CONTRIBUTOR: Mick VAN VLIERBERGHE <mvanvlierberghe@doct.uliege.be>

use Moose;
use namespace::autoclean;

# AUTOGENERATED CODE! DO NOT MODIFY THIS FILE!

use autodie;
use feature qw(say);

use Smart::Comments;

use Carp;
use Const::Fast;

use Bio::MUST::Core::Types;
use Bio::MUST::Core::Constants qw(:ncbi);


has 'full_id' => (
    is       => 'ro',
    isa      => 'Str',
    required => 1,
    writer   => '_set_full_id',
);


has 'is_' . $_ => (
    traits   => ['Bool'],
    is       => 'ro',
    isa      => 'Bool',
    init_arg => undef,
    default  => 0,
    handles  => {
        '_set_' . $_ => 'set',
    },
) for qw(foreign new);


has $_ => (
    is       => 'ro',
    isa      => 'Maybe[Str]',
    init_arg => undef,
    default  => undef,
    writer   => '_set_' . $_,
) for qw(family tag genus species strain accession tail
         taxon_id gca gca_novers gca_vers gca_prefix gca_number
         gi database identifier);


# array of parts from NCBI FASTA-style GNL ids
# Note: all_parts accessor returns an empty list if undef
has 'parts' => (
    traits   => ['Array'],
    is       => 'ro',
    isa      => 'ArrayRef[Str]',
    init_arg => undef,
    default  => sub { [] },
    writer   => '_set_parts',
    handles  => {
        count_parts => 'count',
          all_parts => 'elements',
          get_part  => 'get',
    },
);

# file-scope constants

# regexes for full_id (legacy and new) components
const my $FAMILY     => qr{ # underscore allowed
    [^\-\s@\#]+?            # single word without dash, space, '@', '#'
}xms;

const my $TAG        => qr{
    [a-z]{1,4}              # 1-4 letter(s) (lowercase)
}xms;

# list of standard tags:
#     c: contaminant
#     d: divergent
#     u: unknown taxonomy
#     cp: encoded in plastid genome
#     mt: encoded in mitochondrial genome
#     nm: encoded in nucleomorph genome
#     nucp: nuclear copy of plastid gene
#     numt: nuclear copy of mitochondrial gene

const my $GENUS      => qr{ # underscore and dash allowed
    [^\s@]+?                # single word without space, '@'
}xms;

const my $SPECIES    => qr{ # dash allowed
    [^_\s@]+?               # single word without underscore, space, '@'
}xms;

const my $STRAIN     => qr{ # as genus
    $GENUS
}xms;

const my $ACCESSION  => qr{
    $GENUS                  # as genus
}xms;

const my $TAIL       => qr{
    $GENUS                  # as genus
}xms;

const my $NEW        => qr{
    \#NEW\#                 # literal #NEW#
}xms;

# regex for parsing (valid) full_id
const my $FULL_ID    => qr{
    \A                      # begins with...
    (?: ($FAMILY)           # optional family
    - )?                    #   followed by a literal dash (-)
    (?: ($TAG)              # optional tag
    \# )?                   #   followed by a literal number sign (#)
    ($GENUS)                # genus
    \s+                     # whitespace
    ($SPECIES)              # species
    (?: _                   # optional literal underscore (_)
    ($STRAIN) )?            #   followed by strain
    @                       # literal at sign (@)
    ($ACCESSION)            # accession
    (?: \.{3}               # optional literal ellipsis (...)
    ($TAIL) )?              #   followed by a single-word tail
    (?: ($NEW) )?           # optional #NEW# tag
    \z                      # ... at the end
}xms;

# species regex for genus-only ids
const my $GENUSONLY  => qr{
    \A                      # nothing before!
    (?:
    sspp | ssp | spp | sp   # either species (sp), species pluralis (spp),
    )                       # subspecies (ssp) or subspecies pluralis (sspp)pa
    \.?                     # optionally followed by a dot
    \z                      # and nothing after!
}xms;

# tag regex for doubtful organisms (from a taxonomic POV)
const my $DOUBTFUL   => qr{
    \A
    [cdu]
    \z
}xms;

# regex for parsing taxonomy-enabled abbreviated ids
const my $TAXABBR_ID => qr{
    \A                      # begins with...
    ($NCBIPKEY|$NCBIGCA)    # NCBI primary key (= taxid) or NCBI GCA/GCF
    \|                      # literal pipe sign (|)
    ($ACCESSION)            # accession
    \z                      # ... at the end
}xms;

# regex for parsing NCBI FASTA-style GI ids
# TODO: merge with $GI_ID in Constants?
# TODO: improve handling of partial ids (e.g., gi|404160475| would fail)
const my $NCBIGI_ID => qr{
    \A                      # begins with...
    gi                      # literal 'gi'
    \|                      # literal pipe sign (|)
    ($NCBIPKEY)             # NCBI primary key (= GI number)
    (?: \|                  # optional literal pipe sign (|)
     $NCBIDBABBR            #   followed by NCBI database abbr (not captured)
    \|                      #   then literal pipe sign (|)
    ($NCBIACC) ) ?          #   then NCBI accession
                            # no end anchor to allow for additional stuff
}xms;

# regex for parsing NCBI FASTA-style GNL ids
# TODO: merge with $GNL_ID in Constants?
# Note: this regex actually returns the full_id for subsequent splitting
const my $NCBIGNL_ID => qr{
    \A                      # begins with...
    (gnl                    # literal 'gnl'
    (?: \|                  #   literal pipe sign (|)
    $NCBIPART)              #   NCBI part (very accommodating)
    {2,} )                  # at least twice but allowing for more
}xms;

BEGIN{

no warnings "qw";

# static lists of hyphenated genera and underscored species
# Note: in BEGIN block because the hash must be built before any call to BUILD

const my @GENERA  => qw(
    [% FOREACH species IN  is_hyphenated.keys.sort %][% species %]
    [% END %]);

const my @SPECIES => qw(
    [% FOREACH species IN is_underscored.keys.sort %][% species %]
    [% END %]);

my %is_hyphenated  = map { $_ => 1 } @GENERA;
my %is_underscored = map { $_ => 1 } @SPECIES;

sub _set_gca_and_or_taxon_id {
    my $self   = shift;
    my $strain = shift;

    # Note: we use named captures here (?<capture name> ... )

    ## no critic (ProhibitUnusedCapture)

    # handle GCA/GCF acting as taxon_ids
    if ($strain =~ m/\A (:?(?<strain>.*)_)? (?<gca>$NCBIGCA) \z/xms) {

        # truncate strain to optional non-GCA/GCF part (excl. underscore)...
        # ... and set taxon_id to full GCA/GCF
        $self->_set_strain($+{strain});
        my $gca = $+{gca};
        $self->_set_taxon_id($gca);
        $self->_set_gca(     $gca);     # alias

        # further store GCA/GCF components for easier comparison
        my ($gca_novers, $gca_vers) = split /\./xms, $gca;
        $self->_set_gca_novers($gca_novers);
        $self->_set_gca_vers(  $gca_vers  );
        my ($gca_prefix, $gca_number) = split /_/xms, $gca_novers;
        $self->_set_gca_prefix($gca_prefix);
        $self->_set_gca_number($gca_number);
    }

    # handle regular taxon_ids
    elsif ($strain =~ m/\A (:?(?<strain>.*)_)? (?<taxon_id>$NCBIPKEY) \z/xms) {
        # truncate strain to optional non-taxon_id part (excl. underscore)...
        # ... and set taxon_id
        $self->_set_strain(  $+{strain  });
        $self->_set_taxon_id($+{taxon_id});
    }

    ## use critic

    # ignore legacy strains
    return;
}

sub BUILD {
    my $self = shift;

    # parse potential taxonomy-aware abbreviated id
    # Note: such ids are still considered as foreign_ids
    {
        my ($strain, $acc) = $self->full_id =~ $TAXABBR_ID;
        if (defined $strain) {
            $self->_set_gca_and_or_taxon_id($strain);
            $self->_set_accession($acc);
            $self->_set_foreign;
            return;
        }
    }

    # parse potential NCBI FASTA-style GI id
    # Note: such ids are still considered as foreign_ids
    {
        my ($gi, $acc) = $self->full_id =~ $NCBIGI_ID;
        if (defined $gi) {
            $self->_set_gi($gi);
            $self->_set_accession($acc);
            $self->_set_foreign;
            return;
        }
    }

    # parse potential NCBI FASTA-style GNL id
    # Note: such ids are still considered as foreign_ids
    {
        my ($match) = $self->full_id =~ $NCBIGNL_ID;
        if ($match) {
            $self->_set_parts( [ split /\|/xms, $match ] );
            $self->_set_database(   $self->get_part(1) );   # official
            $self->_set_identifier( $self->get_part(2) );   # aliases
            $self->_set_foreign;
            return;
        }
    }

    # skip RiboDB ids that look like weird full_ids
    if ($self->full_id =~ m/~$NCBIGCA/xms) {
        $self->_set_foreign;
        return;
    }

    # check full_id validity
    my  ($family, $tag, $genus, $species, $strain, $acc, $tail, $new)
        = $self->full_id =~ $FULL_ID;
    unless (defined $genus) {

        # First try to coerce foreign full_id by replacing 1st '_' by ' '. If
        # this does not work, keep the original full_id and flag it as foreign.
        # This approach allows the transparent conversion of valid full_ids
        # from foreign software able to handle unlimited gap-free ids.
        # Note: This will fails if the optional family part contains an '_'.

        my $cand_id = $self->full_id =~ s{_}{ }xmsr;
        ($family, $tag, $genus, $species, $strain, $acc, $tail, $new)
            = $cand_id =~ $FULL_ID;
        unless (defined $genus) {
            $self->_set_foreign;
            return;
        }
        $self->_set_full_id($cand_id);
    }

    # handle hyphenated genera that could interfere with family definition
    if (defined $family) {
        my $hyphenated = $family . '-' . $genus;
        if (defined $is_hyphenated{$hyphenated}) {
            $family = undef;
            $genus = $hyphenated;
        }
    }

    # handle underscored species that could interfere with species definition
    if (defined $strain) {
        my $underscored = $species . '_' . $strain;
        if (defined $is_underscored{$underscored}) {
            $strain = undef;
            $species = $underscored;
        }
    }

    # populate legacy components from full_id (and tail)
    $self->_set_family($family);
    $self->_set_tag($tag);
    $self->_set_genus($genus);
    $self->_set_species($species);
    $self->_set_strain($strain);
    $self->_set_accession($acc);
    $self->_set_tail($tail);

    # populate modern components if available
    $self->_set_gca_and_or_taxon_id($strain) if defined $strain;
    $self->_set_gi($acc)                     if $acc =~ $PKEYONLY;

    # set new flag if needed
    $self->_set_new if $new;

    return;
}

}   # end of BEGIN block


around qr{ is_new | is_genus_only | is_doubtful | org $  }xms => sub {
    my $method = shift;
    my $self   = shift;

    # Note: we return an explicit undef to emulate other accessor behavior
    return undef if $self->is_foreign;      ## no critic (ProhibitExplicitReturnUndef)
    return $self->$method(@_);
};


=method is_genus_only

=cut

sub is_genus_only {
    my $self = shift;
    return 1 if $self->species =~ $GENUSONLY;
    return 0;
}

=method is_doubtful

=cut

sub is_doubtful {
    my $self = shift;
    return 1 if defined $self->tag && $self->tag =~ $DOUBTFUL;
    return 0;
}

=method org

=cut

sub org {
    my $self = shift;
    return $self->genus . q{ } . $self->species;
}

=method abbr_org

=cut

sub abbr_org {
    my $self = shift;
    return substr($self->genus, 0, 1) . q{. } . $self->species;
}

=method full_org

=cut

sub full_org {
    my $self = shift;
    my $sep  = shift // '_';        # default to underscore

    my $org = $self->org;
       $org .= $sep . $self->strain   if $self->strain;
       $org .= $sep . $self->taxon_id if $self->taxon_id;
                                    # also works with GCA/GCF!
    return $org;
}

=method family_then_full_org

=cut

sub family_then_full_org {                  ## no critic (RequireArgUnpacking)
    my $self = shift;

    my $family = $self->family // q{};
    $family .= '-' if $family;

    return $family . $self->full_org(@_);   # note the currying
}

=method contam_org

=cut

sub contam_org {
    my $self = shift;

    return undef unless $self->tail;        ## no critic (ProhibitExplicitReturnUndef)
    # Note: we return an explicit undef to emulate other accessor behavior

    # only replace the first underscore by a space (for consistency)
    return $self->tail =~ s{_}{ }xmsr;
}

=method foreign_id

=cut

sub foreign_id {
    my $self = shift;

    # do not alter full_id if already foreign!
    return $self->full_id if $self->is_foreign;

    # otherwise, only replace the first space by an underscore
    return $self->full_id =~ s{\ }{_}xmsr;
}

=method nexus_id

=cut

sub nexus_id {
    my $self = shift;

    # quoted named are not escaped by Bio::Phylo...
    # ... but cannot contain single quotes

    my $full_id = $self->full_id =~ tr/'//dr;       # remove quotes...
	return qq{'$full_id'};                          # ... and requote
}

# from Bio::Phylo::PhyloRole

# =item get_nexus_name()
#
# Gets invocant's name, modified to be safely used in nexus files. This means that:
#
# =item names with spaces in them that aren't 'single quoted' have their spaces replaced
# with underscores
#
# =item names with any of the following characters in them are single quoted:
#  -^*(){}[]+=;:"\<>/,
#
# =item names with single quotes inside them (i.e. not around them) are "double quoted"
#
#  Type    : Accessor
#  Title   : get_nexus_name
#  Usage   : my $name = $obj->get_nexus_name;
#  Function: Returns the object's name.
#  Returns : A string
#  Args    : None
#
# =cut
#
#     sub get_nexus_name {
#         my $self = shift;
#         my $name = $self->get_internal_name;
#         if ( $name =~ /\s/ && $name !~ /^'.+'$/ ) {
#             $name =~ s/\s/_/g;
#         }
#         if (   $name =~ /(?:\-|\^|\*|\(|\)|{|}|\[|\]|\+|=|;|:|"|\\|<|>|\/|,)/
#             && $name !~ /^'.+'$/ )
#         {
#             $name = "'${name}'";
#         }
#         if ( $name =~ /'/ && $name !~ /^".+"$/ && $name !~ /^'.+'$/ ) {
#             $name = "\"${name}\"";
#         }
#         return $name;
#     }


# class methods to build modern MUST-compliant id from NCBI components

=method new_with

=cut

sub new_with {                              ## no critic (RequireArgUnpacking)
    my $class = shift;
    my %args  = @_;                         # TODO: handle HashRef?

    my ($org, $taxon_id, $accession, $keep_strain)
        = @args{ qw(org taxon_id accession keep_strain) };
    $accession //= $args{gi};       # fall back to legacy argument name

    # extract components from organism name
    my ($genus, $species, $strain) = $class->parse_ncbi_name($org);
    # Note: genus, species and strain will have been cleaned-up at this stage

    # truncate name to Genus species (or sp. if none)
    # append strain (if asked to do so)
    # append NCBI taxon_id or GCA/GCF as pseudo-strain
    # append accession number (if provided)
    my $full_id
        = $genus . ' '
        . ($species   ? ( $species                               ) : 'sp.')
        . ($strain    ? ( $keep_strain ? ('_' . $strain  ) : q{} ) :  q{} )
        . ($taxon_id  ? ('_' . $taxon_id                         ) :  q{} )
        . ($accession ? ('@' . $accession                        ) :  q{} )
    ;

    return $class->new( full_id => $full_id );
}


=method parse_ncbi_name

=cut

sub parse_ncbi_name {
    my $class = shift;
    my $org   = shift;

    # clean org name
    $org = $class->clean_ncbi_name($org);

    # split org name into max 3 components: genus, species and strain
    # strain is a greedy component for trailing information
    my ($genus, $species, $strain) = split /\s+/xms, $org, 3;

    # clean strain of unwanted prefices and characters (if any)
    $strain = $class->clean_strain($strain) if $strain;

    return ($genus, $species, $strain);
}

=method clean_ncbi_name

=cut

sub clean_ncbi_name {
    my $class = shift;
    my $org   = shift;

    # remove unwanted prefices
    $org =~ s{uncultured \s+ candidatus \s+}{}xmsgi;
    $org =~ s{candidatus \s+}{}xmsgi;

    # remove cf.
    $org =~ s{\b cf \.? \s+}{}xmsgi
        if $org =~ m/\b cf \.? \s+ \D+ \s+/xmsgi;
    # Note: delete only if followed by a word without digits (not a strain)
    # hence when 'cf' does not stand for a species itself

    # remove unwanted characters
    $org =~ s{[\[\]\']}{}xmsgi;

    return $org;
}

=method clean_strain

=cut

sub clean_strain {
    my $class  = shift;
    my $strain = shift;

    # remove unwanted prefices and characters (if any)
    $strain =~ s{\b substr \b}{}xmsgi;
    $strain =~ s{\b strain \b}{}xmsgi;
    $strain =~ s{\b subsp  \b}{}xmsgi;
    $strain =~ s{\b str    \b}{}xmsgi;
    $strain =~ tr/A-Za-z0-9//cd;        # delete non-alphanumeric chars

    return $strain;
}

__PACKAGE__->meta->make_immutable;
1;


__END__

=head1 SYNOPSIS

    # TODO

=head1 DESCRIPTION

    # TODO