# vim: set ts=4 sw=4 et :
# Known deficiencies:
# - cannot tell if (foo)-1 is typecast or subtraction so -1 is always Number
# - does not attach the leading u or U of C99 Unicode strings to the string
# - printf-like formats in strings are not highlighted
# - cannot parse GCC hexadecimal floating point literals
package GtkDocHighlight;

use warnings;
use strict;
use Exporter;
use vars qw(@ISA @EXPORT);

@ISA = qw(Exporter);
@EXPORT = qw(AddHighlightSymbols HighlightC);

use constant {
    ACCESS        => 'a',
    BACKSLASH     => 'h',
    BINARY        => 'b',
    CHARACTER     => 'c',
    COMMENT       => 'o',
    COMMENT_START => 't',
    DIGRAPH       => 'd',
    ELLIPSIS      => 'e',
    FILENAME      => 'f',
    GARBAGE       => 'g',
    IDENTIFIER    => 'i',
    INCRDECR      => 'r',
    MULTDIV       => 'm',
    NUMBER        => 'n',
    PASTE         => 'j',
    PREPROC       => 'p',
    SINGLE        => 'x',
    STRING        => 's',
    STRING_START  => 'q',
    TRIGRAPH      => 'v',
    UNARY         => 'u',
    WHITESPACE    => 'w',
    XXX           => ' ',
    CONSTANT      => 'C',
    DEPRECATED    => 'D',
    FUNCTION      => 'F',
    KEYWORD       => 'K',
    STRING_ESCAPE => 'S',
    TYPE          => 'T',
    VARIABLE      => 'V',
};

# Tokens that become highlighted as preproc inside macro definitions.
# The constants do not work here.
my %preproc_eats;
foreach (qw(a b e g i m r u x)) { $preproc_eats{$_} = 1 }

# Correspondence between token types and HTML <span> classes.
my %class_revmap = (
    'constant' => 'Cn', 'string' => 'csf', 'keyword' => 'K', 'function' => 'FV',
    'special' => 'dvjhS', 'preproc' => 'p', 'type' => 'T', 'comment' => 'o',
    'deprecated' => 'D',
);
my %class_map = &ReverseMap(\%class_revmap);

# Correspondence between neutral syntax file symbol kinds and token types.
my %gtkdoc_class_map = (
    'Keyword' => 'K',
    'Constant' => 'C', 'Define' => 'C', 'Macro' => 'p',
    'Enum' => 'T', 'Struct' => 'T', 'Union' => 'T', 'Typedef' => 'T',
    'UserFunction' => 'T', 'Type' => 'T',
    'Function' => 'F', 'Variable' => 'V',
    # And anything ending with 'Deprecated' is implicitly mapped to 'D'
);

my %symbols;

# Match things that can appear in C/C++ code.
sub MatchCode {
    my $_ = shift;
    if (m/\A[\$A-Za-z_][\$A-Za-z_0-9]*/p) { return IDENTIFIER, ${^MATCH} }
    if (m/\A::/p) { return ACCESS, ${^MATCH} }
    if (m/\A\?\?[-\/'!()<>]/p) { return TRIGRAPH, ${^MATCH} }
    if (m/\A(?:#|%:|\?\?=)/p) { return PREPROC, ${^MATCH} }
    if (m/\A[][(){};,?:]/p) { return SINGLE, ${^MATCH} }
    if (m/\A##/p) { return PASTE, ${^MATCH} }
    if (m/\A(?:\/\*.*?\*\/|\/\/.*)/p) { return COMMENT, ${^MATCH} }
    if (m/\A\/\*.*/p) { return COMMENT_START, ${^MATCH} }
    if (m/\A(?:(?i)(?:\d*\.\d+|\d+\.?)(?:e[-+]?\d+)?i?[fl]?\b|(?:0x[a-f0-9]+|0[0-7]+|[-+]?\d+)(?:u?i(?:64)?)?[lu]*\b|[0-9][0-9a-f]*h\b)/p) { return NUMBER, ${^MATCH} }
    if (m/\A\.\.\./p) { return ELLIPSIS, ${^MATCH} }
    if (m/\A(?:<:|:>|<%|%>|%:%:)/p) { return DIGRAPH, ${^MATCH} }
    if (m/\A(?:(\.|->)\*?)/p) { return ACCESS, ${^MATCH} }
    if (m/\A(?:(?:&&|>>|<<|\|\||[%\/|<>=^])=?|[-+*&!~]=)/p) { return BINARY, ${^MATCH} }
    if (m/\A(?:\+\+|--)/p) { return INCRDECR, ${^MATCH} }
    if (m/\A[-+*&]/p) { return MULTDIV, ${^MATCH} }
    if (m/\A"(?:[^\\"]*\\.)*[^\\"]*"/p) { return STRING, ${^MATCH} }
    if (m/\A[!~]/p) { return UNARY, ${^MATCH} }
    if (m/\A(?:\'(?:\\.|[^\'\\]|\\[0-7]+|\\x[0-9a-fA-F]{2}){1,4}\')/p) { return CHARACTER, ${^MATCH} }
    if (m/\A'".*\\$/p) { return STRING_START, ${^MATCH} }
    if (m/\A\\$/p) { return BACKSLASH, ${^MATCH} }
    return XXX, undef;
}

# Match things that can appear in C/C++ #include.
sub MatchInclude {
    my $_ = shift;
    if (m/\A[\$A-Za-z_][\$A-Za-z_0-9]*/p) { return IDENTIFIER, ${^MATCH} }
    if (m/\A[][(){};,?:]/p) { return SINGLE, ${^MATCH} }
    if (m/\A(?:\/\*.*?\*\/|\/\/.*)/p) { return COMMENT, ${^MATCH} }
    if (m/\A\/\*.*/p) { return COMMENT_START, ${^MATCH} }
    if (m/\A<[^>]+>/p) { return FILENAME, ${^MATCH} }
    if (m/\A(?:(?i)(?:\d*\.\d+|\d+\.?)(?:e[-+]?\d+)?i?[fl]?\b|(?:0x[a-f0-9]+|0[0-7]+|[-+]?\d+)(?:u?i(?:64)?)?[lu]*\b|[0-9][0-9a-f]*h\b)/p) { return NUMBER, ${^MATCH} }
    if (m/\A\.\.\./p) { return ELLIPSIS, ${^MATCH} }
    if (m/\A(?:(\.|->)\*?)/p) { return ACCESS, ${^MATCH} }
    if (m/\A(?:(?:&&|>>|<<|\|\||[%\/|<>=^])=?|[-+*&!~]=)/p) { return BINARY, ${^MATCH} }
    if (m/\A[-+*&]/p) { return MULTDIV, ${^MATCH} }
    if (m/\A"(?:[^\\"]*\\.)*[^\\"]*"/p) { return STRING, ${^MATCH} }
    if (m/\A[!~]/p) { return UNARY, ${^MATCH} }
    if (m/\A(?:\'(?:\\.|[^\'\\]|\\[0-7]+|\\x[0-9a-fA-F]{2}){1,4}\')/p) { return CHARACTER, ${^MATCH} }
    if (m/\A\\$/p) { return BACKSLASH, ${^MATCH} }
    return XXX, undef;
}

# Match things that can appear in C/C++ #error.
sub MatchError {
    my $_ = shift;
    if (m/\A(?:\/\*.*?\*\/|\/\/.*)/p) { return COMMENT, ${^MATCH} }
    if (m/\A\/\*.*/p) { return COMMENT_START, ${^MATCH} }
    if (m/\A"(?:[^\\"]*\\.)*[^\\"]*"/p) { return STRING, ${^MATCH} }
    if (m/\A\\$/p) { return BACKSLASH, ${^MATCH} }
    if (m/\A(?:[^\/\\]+|\/[^\/*]|\/$)/p) { return GARBAGE, ${^MATCH} }
    return XXX, undef;
}

#############################################################################
# Function:    StringSpecials
# Description: Transform a string token to sequence of one or more tokens
#              representing plain parts of the string and specials.
#
# Arguments:   String token text.
# Returns:     List of tokens.
#############################################################################

sub StringSpecials {
    my $s = $_[0];
    my @tokens;
    while ($s =~ m/\\[0-7]{1,3}|\\x[0-9a-fA-F]{2}|\\u(?:[0-9a-fA-F]){1,2}|\\./p) {
        if (${^PREMATCH}) { push @tokens, [STRING, ${^PREMATCH}] }
        push @tokens, [STRING_ESCAPE, ${^MATCH}];
        $s = ${^POSTMATCH};
    }
    if ($s) { push @tokens, [STRING, $s] }
    return @tokens;
}

#############################################################################
# Function:    Tokenize
# Description: Convert C/C++ source code to a list of tokens (plus a few
#              non-token item types such as whitespace).
#
# Arguments:   List of lines to tokenize.
# Returns:     List of tokens, each is an array reference to a two-item array
#              ($type, $text).  $type is WHITESPACE, FUNCTION, PREPROC,
#              COMMENT, etc.; $text is whatever text constitues the item,
#              possibly including newlines and anything.
#############################################################################

sub Tokenize {
    my $in_comment = 0;  # Are we in a multi-line comment?
    my $in_string  = 0;  # Are we in a multi-line string?
    my $in_preproc = 0;  # Are we in a backslash-continued preproc block?
    my $in_include = 0;  # Are we in an #include?
    my $in_error   = 0;  # Are we in an #error?
    my $want_word  = 0;  # Are we looking for a word (preproc directive)?

    # Initialization for empty files
    my $line_continued = 0;
    my $lineno = 0;
    my $token;
    my $type;
    my @tokens;

    foreach my $line (@_) {
        my $start_of_line = not $line_continued;
        $lineno++;
        $line_continued = 0;
        $line =~ s/\s*$//s;

        # Comment continuation
        if ($in_comment) {
            if ($line !~ m/\*\//p) {
                $token .= $line . "\n";
                next;
            }

            # Finish multiline comment and continue line processing.
            $token .= ${^PREMATCH} . ${^MATCH};
            $line = ${^POSTMATCH};
            push @tokens, [COMMENT, $token];
            $in_comment = 0;
        }

        # String continuation
        if ($in_string) {
            if ($line !~ m/\A(?:[^\\"]*\\.)*[^\\"]*"/p) {
                $token .= $line . "\n";
                next;
            }

            # Finish multiline string and continue line processing.
            $token .= ${^PREMATCH} . ${^MATCH};
            $line = ${^POSTMATCH};
            push @tokens, &StringSpecials($token);
            $in_string = 0;
        }

        # Tokenize line
        LINE: while ($line) {
            # Whitespace
            if ($line =~ /\A\s+/p) {
                push @tokens, [WHITESPACE, ${^MATCH}];
                $line = ${^POSTMATCH};
            }

            if ($in_include) { ($type, $token) = &MatchInclude($line) }
            elsif ($in_error) { ($type, $token) = &MatchError($line) }
            else { ($type, $token) = &MatchCode($line) }

            last if $type eq XXX;
            $line = substr $line, length $token;

            if ($type eq COMMENT_START) {
                # Unterminated comment, break out of the inner cycle
                $in_comment = 1;
                $token .= "\n";
                last LINE;
            }
            if ($type eq STRING_START) {
                # Unterminated string literal, break out of the inner cycle
                $in_string = 1;
                $token .= "\n";
                last LINE;
            }
            if ($type eq PREPROC) {
                if ($in_preproc) { $type = PASTE }  # Strinfigy operator
                else {
                    # Preprocessor directive, must be the first
                    # thing on the line (except comments, we allow them
                    # too)
                    if ($start_of_line) {
                        $in_preproc = 1;
                        $want_word = 1;
                    }
                    else {
                        warn "Preproc in the middle of a line at line $lineno: $line\n";
                    }
                }
            }
            elsif ($want_word and $type eq IDENTIFIER) {
                # We are looking for preprocessor directive in order to
                # special-case some of them
                $want_word = 0;
                $type = PREPROC;
                if ($token eq 'include') { $in_include = 1 }
                elsif ($token eq 'error' or $token eq 'warning') { $in_error=  1 }
            }
            elsif ($type eq NUMBER and @tokens) {
                # We cannot tell if (foo)-1 is a typecast or subtraction.  At
                # least split the minus to a separate token in ]-1 and foo-1.
                my $t = substr $token, 0, 1;
                if ($t eq '-' or $t eq '+') {
                    my $prev = $tokens[$#tokens];
                    if ($prev->[0] eq 'i' or $prev->[1] eq ']') {
                        push @tokens, [BINARY, $t];
                        $token = substr $token, 1;
                    }
                }
            }

            if ($type ne COMMENT) { $start_of_line = 0 }
            if ($type eq BACKSLASH) { $line_continued = 1 }
            if ($type eq IDENTIFIER and exists $symbols{$token}) {
                $type = $symbols{$token}
            }
            if ($in_preproc and exists $preproc_eats{$type}) { $type = PREPROC }

            if ($type eq STRING) { push @tokens, &StringSpecials($token) }
            else { push @tokens, [$type, $token] }
        }

        next if $in_comment or $in_string;

        # Line noise, call it garbage and skip the rest of the line.
        if ($line) {
            warn "Cannot tokenize $line at line $lineno\n";
            push @tokens, [GARBAGE, $line];
        }
        if ($in_preproc and not $line_continued) {
            # The last line of a backslash-continued preprocessor directive
            # (possibly multiline-comment-continued too).
            $in_preproc = 0;
            $in_include = 0;
            $in_error = 0;
            $want_word = 0;
        }
        push @tokens, [WHITESPACE, "\n"];
    }

    # Try to deal with ending in the middle of something
    if ($in_comment) { push @tokens, [COMMENT, $token] }
    elsif ($in_string) { push @tokens, &StringSpecials($token) }

    return @tokens;
}

#############################################################################
# Function:    HTMLize
# Description: Transform a chunk of text to a classed <span>, fixing <, > and
#              & characers to entities.  If the class is empty, no <span>
#              wrapper is emitted.
#
# Arguments:   $text - The chunk of text.
#              $class - The <span> class.
# Returns:     HTML string.
#############################################################################

sub HTMLize {
    my ($text, $class) = @_;
    my @out;
    if ($class) { push @out, "<span class=\"$class\">" }
    $text =~ s/&/&amp;/g;
    $text =~ s/</&lt;/g;
    $text =~ s/>/&gt;/g;
    push @out, $text;
    if ($class) { push @out, "</span>" }
    return @out;
}

#############################################################################
# Function:    Highlight
# Description: Transform list of tokens to HTML text using the global
#              %class_map to map token types to <span> classes.
#
# Arguments:   List of tokens, as returned by Tokenize, see there.
# Returns:     HTML string.
#############################################################################

sub Highlight {
    my $class = '';
    my $textblock = '';
    my @out;

    foreach my $t (@_) {
        my $type = $t->[0];
        my $text = $t->[1];
        my $new_class = exists $class_map{$type} ? $class_map{$type} : '';
        if ($new_class ne $class) {
            push @out, &HTMLize($textblock, $class);
            $class = $new_class;
            $textblock = $text;
        }
        else { $textblock .= $text }
    }
    push @out, &HTMLize($textblock, $class);
    return @out;
}

#############################################################################
# Function:    AddHighlightSymbols
# Description: Load identifiers to highlight from neutral syntax files
#              generated by gtkdoc-syntax.  They will be subsequently used by
#              HighlightC.
#
# Arguments:   List of files to read (extension .syn is implied if not given).
# Returns:     Nothing.
#############################################################################

sub AddHighlightSymbols {
    foreach my $filename (@_) {
        if (not open(FH, $filename)) {
            if (not open(FH, "$filename.syn")) {
                warn "Cannot open highlighting symbol list $filename: $!\n";
                next;
            }
        }
        foreach my $line (<FH>) {
            $line =~ s/\s+$//s;
            my @symlist = split /\s+/, $line;
            my $type = shift @symlist;
            if ($type =~ m/Deprecated$/) { $type = DEPRECATED }
            elsif (exists $gtkdoc_class_map{$type}) {
                $type = $gtkdoc_class_map{$type}
            }
            else {
                warn "Unknown symbol type $type in $filename\n";
                next;
            }
            foreach (@symlist) { $symbols{$_} = $type }
        }
        close(FH);
    }
}

sub ReverseMap {
    my %rmap = %{$_[0]};
    my %map;
    foreach my $x (keys %rmap) {
        foreach (split //, $rmap{$x}) { $map{$_} = $x }
    }
    return %map;
}

#############################################################################
# Function:    HighlightC
# Description: Highlight C source code to HTML.
#
# Arguments:   Either a single string or list of lines with the source code
#              to highlight.
# Returns:     HTML string.
#############################################################################

sub HighlightC {
    my @lines = @_;
    # If we get a string, split it to lines.
    if (scalar @lines == 1) {
        my $line = $lines[0];
        $line =~ s/\s+\$//s;
        @lines = split /\n/, $line;
    }
    return join('', &Highlight(&Tokenize(@lines)));
}

1;
