#!/usr/bin/perl
use warnings; use strict;

# edit these:

my $browser = "w3m -o confirm_qq=0 -o display_image=0";
my $conf_dir = $ENV{HOME}.'/.htmlman';
my $fifo = "$conf_dir/completions_fifo";

# ----------------

my @types = qw(generic mysql haddock);
my $index_name;

sub usage {
  print STDERR <<EOF;
htmlman -d DBNAME -b [-t TYPE] DIRS
htmlman -d DBNAME [-l] [-a] QUERY

where DIRS is a list of directories in which to search for html files,
TYPE is a specific type of documentation to tune indexing for, and
QUERY is a tag to search for.

-h print this message
-d select an index database
-b build mode
-t tune indexing for this type of documentation
-l list all or matching entries
-a show a summary collecting all matches in an html file
EOF
  exit 0;
}

my $tmpdir = "/tmp";

my %index;
my $index_handle;
my $type = "generic";
my $map_lower;

sub init_index;
sub completions;

# TODO: implement a server mode which listens for completion requests
# on a unix domain socket; --completions will start a server
# automatically if necessary

# sub server_mode {
#   unlink $fifo;
#   mkfifo $fifo;
#   open FIFO, $fifo, '<';
#   while(<FIFO>) {
#     exit 0 if($_ =~ /^\#exit/);
#     chomp;
#     my @args = split /(?<!\\);/, $_;
#   }
# }

my ($list_entries, $build_mode, $list_all) = (0,0,0);
my $completion_mode;
if ($ARGV[0] && $ARGV[0] eq "--completions") {
  shift;
  $completion_mode = 1;
}

my $verbose;
use Getopt::Long;
Getopt::Long::Configure ("bundling", "no_ignore_case");
Getopt::Long::Configure ("pass_through") if $completion_mode;
GetOptions('-h|help' => \&usage,
           '-l' => \$list_entries,
           '-b' => \$build_mode,
           '-a' => \$list_all,
           '-t=s' => \$type,
           '-d=s' => \$index_name,
           '-v' => \$verbose
          ) or $completion_mode or exit 1;

$map_lower = 1 if $type eq 'stl' || $type eq 'mysql';

my $debug=0;
sub dmsg { print STDERR @_, "\n" if($debug); }

dmsg "parsed options";

use File::Basename;

sub file_complete {
  my $f = shift;
  my ($d,$b,$pre);
  if($f =~ m!^(.*)/([^/]*)$!) {
    $d=$1; $b=$2;
    $pre="$d/";
  } else {
    $d="."; $b=$f;
    $pre="";
  }
  opendir DIR, glob $d or return ();
  my @rd = readdir DIR;
  my @l = grep { $_ ne '.' && $_ ne '..' &&
                   (substr $_, 0, length($b)) eq $b } @rd;
  closedir DIR;
  if (@l == 1) {
    return ($pre,"$l[0]");
  } else {
    return ($pre, map { $_ } @l);
  }
}

if ($completion_mode) {
  if ($#ARGV >= 0 && $ARGV[$#ARGV] =~ m!^-!) {
  } else {
    my $x = $ARGV[$#ARGV] || "";
    if ($build_mode) {
      print "$_\n" for(file_complete $x);
    } elsif (defined $index_name) {
      init_index(1);
      print "$_\n" for(completions 0, $x);
    }
  }
  exit 0;
}

if ($build_mode) {
  die "Wrong mode" if $list_entries || $list_all;
}

sub init_index {
  my ($rdonly) = @_;

  use BerkeleyDB;
  system "mkdir -p \Q$conf_dir\E";

  my $index_file = "$conf_dir/$index_name.db";

  $build_mode && unlink($index_file);

  $index_handle = tie %index, 'BerkeleyDB::Btree',
    -Filename => $index_file,
      -Flags => ($rdonly?DB_RDONLY:DB_CREATE),
        # use a huge cache for speed
      -Cachesize => 1024*1024
          or die "Cannot open file $index_file: $! $BerkeleyDB::Error\n";
}

# only open read-only if we have to
dmsg "initializing index...";
init_index ($build_mode?0:1);
dmsg "done initializing index...";

use URI::Escape;
use HTML::PullParser;

sub completions {
  # list_mode is for the -l option; otherwise, it is assumed we are
  # listing command line completions
  my ($list_mode, $query) = @_;
  my ($key, $value);
  my $cursor = $index_handle->db_cursor();
  my ($status);
  my $pre="";
  my @results;
  $key = $query;
  $pre=$1 if $query =~ /(.*:)[^:]*$/;
  $status = $cursor->c_get($key, $value, DB_SET_RANGE) == 0 and
    (substr($key, 0, length($query)) eq $query) or return ();
  push @results, [$key,$value];
  while ($cursor->c_get($key, $value, DB_NEXT) == 0
         && (substr($key, 0, length($query)) eq $query) ) {
    push @results, [$key,$value];
  }
  return @results if $list_mode;
  return $pre, map { substr $_->[0], length($pre) } @results;
}

if ($build_mode) {
  print STDERR "Building index\n";
  my @roots = @ARGV; @ARGV=();
  my $roots = join " ", map {quotemeta $_} @roots;
  my $cmd = "find $roots -type f -name \\*.html";
  dmsg "running: $cmd";
  open FILES, '-|', $cmd
    or die "Couldn't list files";
  my $c=0;
  while (<FILES>) {
    $c++;
    chomp;
    my $f = $_;

    my $rel = $f;
    $rel =~ s!\.html$!!;

    my ($module) = ($f =~ m!/([^/]*).html$!);
    $module = lc $module if $map_lower;
    if ($type eq 'haddock') {
      $module =~ s/-/./g;
    }
    $index{$module} .= "$rel;";
    if ($type eq 'haddock') {
      $index{"m:$module"} .= "$rel;";
    }

    print STDERR "Processing $f\n";
    open IN, '<', $f or die "Couldn't open $f for reading\n";
    my $p = HTML::PullParser->new(
                                  file   => \*IN,
                                  start => '"S", tagname, @attr',
                                  end   => '"E", tagname',
                                 ) or die "Couldn't open $f";
    while (my $token = $p->get_token) {
      if ($token->[0] eq "S" && 
          $token->[1] =~ /^a$/i &&
          $token->[2] =~ /^name$/i) {
        my $anchor = uri_unescape $token->[3];
        # don't index section numbers and stuff
        next if($anchor =~ /^\d+$/);
        next if $type eq 'mysql' && $anchor =~ /^IDX\d+$/;
        my $val = "$rel#$anchor";
        $anchor = lc $anchor if $map_lower;
        $index{$anchor} .= "$val;";
        if ($type eq 'haddock') {
          # additional indexing for haddock t:Type or v:value anchors
          if ($anchor =~ /^[a-zA-Z]:(.*)$/) {
            $index{$1} .= "$val;";
          }
        }
      }
      #      while($_ =~ /A\s+NAME\s*=\s*\"([^\"]+)\"(.*)$/) {
      #      }
    }
    close IN;
  }
  close FILES;
  die "No files found" if($c==0); # sanity check
  print "Writing...\n";
  $index_handle->db_sync;
  print "Done\n";
  exit 0;
}

my $query = shift;

if ($list_entries) {
  if (defined($query)) {
    for (completions 1, $query) {
      print $_->[0],"\t",$_->[1],"\n";
    }
  } else {
    for (keys(%index)) {
      if ($type ne 'haddoc' || $_ =~ /^[tv]:/) {
        print "$_\t$index{$_}\n";
      }
    }
  }
#  $index_handle->db_close;
  dmsg "DONE";
  exit 0;
}

die "Must specify a query\n" if !defined $query;

my $res = $index{$query};
if (!defined $res) {
  print STDERR "No entry matching \"$query\"\n";
  exit 1;
}

my @docs = split /;/, $res;

@docs = sort { length($a) <=> length($b) } @docs;

sub place_first (&@) {
  my ($block, @array) = @_;
  return ((grep {&$block} @array), (grep {!&$block} @array));
}

if($type eq 'haddock') {
  @docs = place_first {$_ !~ /GHC/} @docs;
  @docs = place_first {/Prelude/} @docs;
} elsif($type eq 'mysql') {
  @docs = place_first {$_ !~ /_toc\b/} @docs;
}

sub get_doc_url {
  my $doc = shift;
  if ($doc =~ /^(.*)\#(.*)$/) {
    my ($file, $anchor) = ($1, $2, $3);
    return "file://$file.html#".(uri_escape $anchor);
  } else {
    return "file://$doc.html";
  }
}

sub print_summary {
  my $f = shift;
  open OUT, '>', $f;
  print OUT "<html><head><title>Results</title></head><body>\n";
  for my $d (@docs) {
    print OUT "<a href=\"".(get_doc_url $d)."\">$d</a><br>\n";
  }
  print OUT "</body></html>\n";
  close OUT;
}

  if ($list_all) {
    my $tmpfile="$tmpdir/htmlman.$$.html";
    print_summary $tmpfile;
    system("$browser \Q$tmpfile\E") == 0 or die "Couldn't open browser $browser";
    unlink $tmpfile;
  } else {
    my $doc = get_doc_url $docs[0];
    my $cmd = "$browser \Q$doc\E";
    system($cmd) == 0 or die "Couldn't open browser $browser";
  }

#print "@docs\n";