diogenes-perl-interface.el

;;; diogenes-perl-interface.el --- Perl interface for diogenes.el -*- lexical-binding: t -*-

;; Copyright (C) 2024 Michael Neidhart
;;
;; Author: Michael Neidhart <mayhoth@gmail.com>
;; Keywords: classics, tools, philology, humanities

;;; Commentary:

;; This file contains the Perl interface used by diogenes.el

;;; Code:
(require 'cl-lib)
(require 'seq)
(require 'diogenes-lisp-utils)

(defvar diogenes--debug-perl nil
  "Switch to easily debug perl scripts generated by `diogenes-perl-interface'.")

;;; Functions to debug perl scripts created by this package
(defun diogenes--debug-perl (script)
  "Output a script generated by a diognes--*script function in a new buffer.
It can then be edited, saved to file and called directly for better testing."
  (switch-to-buffer (generate-new-buffer "*diogenes-perldebug*"))
  (insert script)
  (cperl-mode))

(defun diogenes--perl-execute-current-buffer (in-buffer)
  "Execute the contents of a buffer as a perl program"
  (interactive "b")
  (with-current-buffer in-buffer
    (let ((out-buffer (diogenes--get-fresh-buffer "perl-run")))
      (make-process :name    "perl-run"
		    :buffer  out-buffer
		    :command (list diogenes-perl-executable
				   "-e" (buffer-string)
				   (diogenes--include-server)
				   (diogenes--include-cpan))
		    :coding  'utf-8)
      (pop-to-buffer out-buffer))))



;;; Low Level Perl Interface
(defmacro diogenes--perl-script (&rest lines)
  `(string-join (list (format "use v%.2f;" diogenes-perl-min-version)
		      "use strict;"
		      "use warnings;"
		      ;;diogenes--discard-perl-stderr
		      ,@lines)
		"\n"))

(defconst diogenes--perl-to-lisp-sub
  "sub perl_to_lisp {
  my $elt = shift;
  my $arr = shift;  # lisp arrays
  unless ($elt) {}
  elsif (ref $elt eq 'ARRAY') {
    my $str = join ' ', map { perl_to_lisp($_, $arr) } @$elt;
    if ($arr) { '['. $str . ']' }
    else      { '('. $str . ')' }
  }
  elsif (ref $elt eq 'HASH') {
    my $str = join ' ',
      map { ':' . $_ . perl_to_lisp($elt->{$_}, $arr) } sort keys %$elt;
    '(' . $str . ')';
  }
  elsif (ref $elt) {
    die 'No rule for ', ref $elt, 'defined!';
  }
  # elsif ($elt =~ /^\\d+$/) { $elt }
  else { '\"' . $elt . '\"' }
}"
  "Source for a perl sub that prints perl data for the LISP reader.")

(defconst diogenes--discard-perl-stderr
  "local *STDERR;
my $junk = '';
open *STDERR, '>', \\$junk;"
  "Perl source that discards all output to STDERR in current scope.")

(defun diogenes--elt->perl (elt)
  "Transform lisp data structures to analogous perl ones.

An ordinary list becomes a arrayref, a plist with keywords at odd
positions an arrayref."
  (cl-typecase elt
    (list (diogenes--list->perl elt t))
    (vector (diogenes--list->perl elt t))
    (keyword (prin1-to-string
	      (replace-regexp-in-string "-" "_"
					(diogenes--keyword->string elt))))
    (t (prin1-to-string elt))))

(defun diogenes--list->perl (lst &optional ref)
  "Transform a lisp list (or vector) into a perl list/array.

If ref is non-nil, make the list into a hash- or an arrayref."
  (when (vectorp lst)
    (setq lst (mapcar #'identity lst)))
  (unless (or (listp lst))
    (error "Not a list: %s" lst))
  (if (and lst
	   (diogenes--plist-keyword-keys-p lst))
      (format (if ref "{ %s }" "%s")
	      (diogenes--plist->perlpairs lst))
    (format (if ref "[ %s ]" "%s")
	    (mapconcat #'diogenes--elt->perl lst ", "))))

(defun diogenes--plist->perlpairs (plist)
  (when plist
    (concat (diogenes--elt->perl (car plist))
	    " => "
	    (diogenes--elt->perl (cadr plist))
	    (let ((next-pair (diogenes--plist->perlpairs (cddr plist))))
	      (when next-pair (concat ", " next-pair))))))



;;; Perl Runners
(defun diogenes--start-perl (type code &optional filter sentinel)
  "Starts and a perl process named diogenes-type.
It is associated with a buffer with the same name, in asterisks."
  (when diogenes--debug-perl (diogenes--debug-perl code))
  (let ((buffer (diogenes--get-fresh-buffer type)))
    (make-process :name    (format "diogenes-%s" type)
		  :buffer  buffer
		  :command (list diogenes-perl-executable
				 "-e" code
				 (diogenes--include-server)
				 (diogenes--include-cpan))
		  :coding  'utf-8
		  :stderr  " *diogenes-warnings*"
		  :noquery t
		  :filter filter
		  :sentinel sentinel)
    (pop-to-buffer buffer)))

(defun diogenes--get-fresh-buffer (type)
  "Returns a fresh buffer for the mode to use."
  (if (get-buffer (format "*diogenes-%s*" type))
      (cl-loop for i from 1
	       unless (get-buffer (format "*diogenes-%s<%d>*" type i))
	       return (get-buffer-create (format "*diogenes-%s<%d>*" type i)))
    (get-buffer-create (format "*diogenes-%s*" type))))

(defun diogenes--get-comint-buffer (mode)
  "Returns a fresh buffer for comint to use."
  (if (get-buffer (format "*%s*" mode))
      (cl-loop for i from 1
	       unless (get-buffer (format "*%s<%d>*" mode i))
	       return (get-buffer-create (format "*%s<%d>*" mode i)))
    (get-buffer-create (format "*%s*" mode))))

(defun diogenes--make-comint (mode script)
  "Make a new buffer and connect it to a perl script.
Mode should be a maior mode derived from comint-mode."
  (let* ((name (replace-regexp-in-string "-mode$" ""
					   (symbol-name mode)))
	 (buffer (diogenes--get-comint-buffer name)))
    (make-comint-in-buffer name buffer "perl" nil
			   "-e" script
			   (diogenes--include-server)
			   (diogenes--include-cpan))
    (pop-to-buffer buffer)
    (funcall mode)))



;;; Perl Callers
(defun diogenes--read-info (script)
  (when diogenes--debug-perl (diogenes--debug-perl script))
  (read
   (with-temp-buffer
     (unless (zerop (call-process diogenes-perl-executable
				  nil '(t nil) nil
				  "-e" script
				  (diogenes--include-server)
				  (diogenes--include-cpan)))
       (error "Perl exited with errors, no data received!"))
     (buffer-string))))

(let ((cache (make-hash-table :test 'equal)))
  (defun diogenes--get-info (script &optional options1 options2)
    (let ((key (list script options1 options2)))
      (or (gethash key cache)
	  (setf (gethash key cache)
		(prog2
		  (message "Retrieving information from Diogenes...")
		  (diogenes--read-info (apply script
					      (list options1 options2)))
		  (message "")))))))

(defun diogenes--get-author-list (options &optional author-regex)
  (diogenes--get-info #'diogenes--list-authors-script
		      options author-regex))

(defun diogenes--get-works-list (options author)
  (diogenes--get-info #'diogenes--list-works-script options author))

(defun diogenes--get-work-labels (options author-and-work)
  (diogenes--get-info #'diogenes--list-work-labels-script
		      options author-and-work))

(defun diogenes--get-tlg-categories ()
  (diogenes--get-info #'diogenes--get-tlg-categories-script))

(defun diogenes--get-wordlist-matches (options pattern)
  (diogenes--get-info #'diogenes--get-wordlist-matches-script
		      options pattern))

(defun diogenes--get-filter-file ()
  (diogenes--get-info #'diogenes--get-filter-file-script))



;;; Perl scripts
(defun diogenes--search-script (option-plist &optional authors-plist)
  "Return a perl script that executes a Diogenes search.

option-plist is an plist that will be converted into a perl hash
accepted by the Diogenes::Search constructor. authors-plist, when supplied,
contains the arguments for the select_authors method."
  (plist-put option-plist :chunk-size "inf")
  (diogenes--perl-script
   "use Diogenes::Search;"
   "use Diogenes::Indexed;"
   "use utf8;"
   (format "my $q = Diogenes::Search->new(%s);"
	   (diogenes--list->perl option-plist))
   (when authors-plist
     (format "$q->select_authors(%s);"
	     (diogenes--list->perl authors-plist)))
   "$q->do_search"))

(defun diogenes--indexed-search-script (option-plist word-list &optional authors-plist)
  "Return a perl script that executes an indexed Diogenes search.

option-plist is an plist that will be converted into a perl hash
accepted by the Diogenes::Indexed constructor, wordlist is the list of words that will be searched.
authors-plist, when supplied, contains the arguments for the select_authors method."
  (plist-put option-plist :chunk-size "inf")
  (diogenes--perl-script
   "use Diogenes::Search;"
   "use Diogenes::Indexed;"
   "use utf8;"
   (format "my $q = Diogenes::Indexed->new(%s);"
	   (diogenes--list->perl option-plist))
   (format "my @words = (%s);"
	   (diogenes--list->perl word-list))
   (when authors-plist
     (format "$q->select_authors(%s);"
	     (diogenes--list->perl authors-plist)))
   "my %seen;"
   "for my $uc ( @words ) {"
   "  $uc =~ tr/a-z/A-Z/;"
   "  next if $seen{$uc};"
   "  $q->{input_raw} = 1;"
   "  my ($ref, @wlist) = $q->read_index( $uc =~ s/[^ A-Z]//gr );"
   "  warn qq{$uc is not in the word-list!\\n} unless exists $ref->{$uc};"
   "  $seen{$_}++ for @wlist;"
   "}"
   "$q->do_search( map [$_], @words );"))


(defun diogenes--list-authors-script (option-plist &optional author-regex)
  "Return a perl script that returns a list of all authors in a corpus."
  (diogenes--perl-script
   "use Diogenes::Browser;"
   diogenes--perl-to-lisp-sub
   (format "my $q = Diogenes::Browser->new(%s);" (diogenes--list->perl option-plist))
   (format "my %%a = $q->browse_authors(\"%s\");" (or author-regex ""))
   "print perl_to_lisp([ map {[ $a{$_}, $_ ]} sort keys %a ]);"))

(defun diogenes--list-works-script (option-plist author)
  "Return a perl script that returns a list of all works of an
author in a corpus."
  (diogenes--perl-script
   "use Diogenes::Browser;"
   diogenes--perl-to-lisp-sub
   (format "my $q = Diogenes::Browser->new(%s);" (diogenes--list->perl option-plist))
   (format "my %%w = $q->browse_works(\"%s\");" author)
   "print perl_to_lisp([ map {[ \"$w{$_} ($_)\", $_ ]} sort keys %w ]);"))

(defun diogenes--list-work-labels-script (option-plist author-and-work)
  "Return a perl script that returns a list of the defined labels for a work."
  (diogenes--perl-script
   "use Diogenes::Browser;"
   diogenes--perl-to-lisp-sub
   (format "my $q = Diogenes::Browser->new(%s);" (diogenes--list->perl option-plist))
   (format "my @l = $q->browse_location(%s);" (diogenes--list->perl author-and-work))
   "print perl_to_lisp(\\@l);"))

(defun diogenes--get-tlg-categories-script (&rest junk)
  "Return a perl script that returns a list of all categories in the tlg."
  (diogenes--perl-script
   "use Diogenes::Search;"
   diogenes--perl-to-lisp-sub
   "my $q = Diogenes::Search->new(type => 'tlg');"
   "my $c = $q->select_authors(get_tlg_categories => 1);"
   "print perl_to_lisp($c);"))

(defun diogenes--define-corpus-script (option-plist authors-plist)
  "Return a perl script that returns a corpus matching authors-plist."
  (diogenes--perl-script
   "use Diogenes::Base;"
   diogenes--perl-to-lisp-sub
   (format "my $q = Diogenes::Base->new(%s);"
	   (diogenes--list->perl option-plist))
   (format "() = $q->select_authors(%s);"
	     (diogenes--list->perl authors-plist))
   "my %auths = %{ $q->{req_authors} };"
   "my %wks   = %{ $q->{req_auth_wk} };"
   "if (%wks) {"
   "  $auths{$_} = [ sort keys %{ $wks{$_} } ]"
   "    for keys %wks;"
   "  print perl_to_lisp \\%auths, 1;"
   "}"
   "elsif (%auths) {"
   "  print perl_to_lisp $q->{prev_list}, 1;"
   "}"
   "else {"
   "  print 'nil';"
   "}"))

(defun diogenes--get-filter-file-script (&rest junk)
  "Returns a perl script that prints the path of the file where the user defined 
corpora are saved."
  (diogenes--perl-script
   "use Diogenes::Base;"
   "print '\"', Diogenes::Base->new()->{filter_file}, '\"';"))

(defun diogenes--get-wordlist-matches-script (option-plist pattern)
  "Return a perl script that returns a alist of all word that match
PATTERN in a wordlist and the frequency of their occurrence in the corpus."
  (diogenes--perl-script
   "use Diogenes::Search;"
   "use Diogenes::Indexed;"
   diogenes--perl-to-lisp-sub
   (format "my $q = Diogenes::Indexed->new(%s);"
	   (diogenes--list->perl option-plist))
   (format "my $pat = \"%s\";" pattern)
   "$pat =~ tr/a-z/A-Z/;"
   "$pat =~ s/[^ A-Z]//g;"
   "$q->{input_raw} = 1;"
   "my ($ref, @wlist) = $q->read_index($pat);"
   "my @results = map { [$_, $ref->{$_}] } @wlist;"
   "print perl_to_lisp( \\@results );"))

(defun diogenes--browser-script (option-plist passage)
  "Return a perl script that opens a work with the Diogenes Browser."
  (diogenes--perl-script
   "use Diogenes::Browser;"
   (format "my $q = Diogenes::Browser->new(%s);"
	   (diogenes--list->perl option-plist))
   (format "$q->seek_passage(%s);"
	   (diogenes--list->perl passage))
   ;; "$q->browse_half_backward();"
   "$q->browse_forward();"))

(defconst diogenes--browse-interactively-parse-capture-sub
   "my $capture = '';
open my $fh, '>', \\$capture;
select $fh;
sub parse_capture {
  my $out = '';
  $capture =~ s/([()\"])/\\\\$1/g;
  $capture =~ s/\\0\\n?//g;
  my @parts  = split /\\n\\n/, $capture;
  my $header = shift @parts;
  my $body   = pop @parts;
  my @header_lines = split /\\n/, $header;
  my $last_header_line = @parts 
    ? shift @parts
    : pop @header_lines;
  die \"Too many parts in:\\n $capture\"
    if @parts;
  my @levels = $last_header_line =~ /(\\S+)(?:,|$)/g;
  $out .= qq#(\"$last_header_line\" #;
  $out .= '(';
  $out .= join ' ', map qq#\"$_\"#, @header_lines;
  $out .= ') ';
  for my $line (split /\\n/, $body) {
    my ($label, $text) = $line =~ /^(\\S*)(.*)$/g;
    next unless $text && $text =~ /\\S/;
    $text = substr $text, 14 - length $label;
    if ($label and not $label =~ /^\\D/) {
      @levels = split /\\./, $label 
    }
    $out .= qq#((@levels) . \"$text\")#;
    if ( $levels[-1] eq 't' ) { $levels[-1] = 1 }
    else                      { $levels[-1]++ }
  }
  $out .= qq#)\\n#;
  $capture = '';
  print STDOUT $out;
  STDOUT->eof();
}\n"
   "Source code for a perl sub that captures and parses the browser output.

It addes the missing line numbers and prints a LISP list
containing the header as a string an a series of a-lists whose keys are a
lists of the citations and whose values are the lines.")

(defun diogenes--browse-interactively-script (option-plist passage)
  "Return a perl script that browses a work form a corpus interactively."
  (diogenes--perl-script
   "use Diogenes::Browser;"
   "STDOUT->autoflush(1);"
   ;; diogenes--discard-perl-stderr
   diogenes--browse-interactively-parse-capture-sub
   "my ($beg, $end);"
   (format "my ($author, $work) = ( \"%s\", \"%s\" );"
	   (car passage) (cadr passage))
   (format "my $b = Diogenes::Browser::Stateless->new(%s);"
	   (diogenes--list->perl option-plist))
   (format "($beg, $end) = $b->seek_passage(%s);"
	   (diogenes--list->perl passage))
   "(undef, $end) = $b->browse_forward( $beg, $end, $author, $work );"
   "parse_capture;"
   "# When type is `phi', read_phi_biblio resets $/, so we have to correct it"
   "$/ = \"\\n\";"
   "while (<STDIN>) {"
   "  chomp;"
   "  if (s/^(\\d+)//) { $b->{browse_lines} = $1 - 1 }"
   "  if    (/^q$/) { last }"
   "  elsif (/^[nf]$/) {"
   "    (undef, $end) = $b->browse_forward( $beg, $end, $author, $work );"
   "    parse_capture;"
   "  }"
   "  elsif (/^[pb]$/)  {"
   "    ($beg, undef) = $b->browse_backward( $beg, $end, $author, $work );"
   "    parse_capture;"
   "  }"
   "}"))


(provide 'diogenes-perl-interface)

;;; diogenes-perl-interface.el ends here