;;;;
;;;; preproc.stk     -- various stuff for pre-processing Text file with STlklos
;;;;
;;;; Copyright © 2021-2023 Erick Gallesio <eg@stklos.net>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date: 24-Dec-2021 11:10
;;;;


(define-module stklos/preproc/env
  (export stklos-pp-version)
  ;; This module contains the variables accessible from the document
  ;; environment. New bindings can be added with defines embedded in the
  ;; document or with metadata definitions

  ;; Predefined functions/variables
  (define (stklos-pp-version) "0.3")
)

;; ----------------------------------------------------------------------
;;
;;  The (stklos preproc) module
;;
;; ______________________________________________________________________
(define-module stklos/preproc
  (import (stklos preproc env))
  (export stklos-pp-version verbosity parse-metadata process-file process-string
          translate document-value)

  (define *printing*      #t)
  (define *print-stack*   '())
  (define *md-env*        (find-module 'stklos/preproc/env))
  (define *command-chars* '(#\{ #\}))

  ;;
  ;; Utilities
  ;;
  (define (tprintf lvl fmt . args)  ;; eventually print a trace
    (when (>= (verbosity) lvl)
      (apply eprintf fmt args)))

  (define (alphabetic? obj)
    (and (not (eof-object? obj))
         (char? obj)
         (or (char-alphabetic? obj)
             (char=? obj #\-))))

  (define (warning port fmt . args)
    (fprintf (current-error-port) "~a:~a: warning " (port-file-name port) (port-current-line port))
    (apply fprintf (current-error-port) fmt args))

  ;; ----------------------------------------------------------------------

  (define verbosity (make-parameter 0 (lambda (x)
                                        (if (integer? x)
                                            x
                                            (error "bad integer" x)))))

  ;;
  ;; stklos-pp predefined functions
  ;;
  (define (Include file)
    (let ((port (open-input-file file)))
      (let Loop ()
        (call-with-values
            (lambda () (read-line port))
          (lambda (line delim)
            (unless (eof-object? line)
              (display line)
              (unless (eof-object? delim) (display delim))
              (Loop)))))))

  (define (Include* file)
    (process-file file))

  (define (System str)
    (Include (string-append "| " str)))

  (define (exec-internal-command expr)
    (let ((len (length expr))
          (cmd (car expr)))
      (case len
        ((2) (let ((val (eval (cadr expr) *md-env*)))
               (case cmd
                 ((If)
                  (set! *print-stack* (cons *printing* *print-stack*))
                  (set! *printing* val))
                 ((Include)
                  (when *printing* (Include val)))
                 ((Include*)
                  (when *printing* (Include* val)))
                 ((System)
                  (when *printing* (System val)))
                 (else
                  (die (format "command ~s cannot have parameter" cmd))))))
        ((1) (case cmd
               ((Else)
                (set! *printing* (not *printing*)))
               ((End)
                (set! *printing* (car *print-stack*))
                (set! *print-stack* (cdr *print-stack*)))
               (else
                (die (format "command ~s must have a parameter" cmd)))))
        (else
         (die (format "bad command call ~s" expr))))))

  ;;;;
  ;;;; document-value
  ;;;;
  (define (document-value symbol . default)
    (apply symbol-value symbol (find-module 'stklos/preproc/env) default))
  

  ;;;; 
  ;;;; parse-metadata
  ;;;;
  (define (parse-metadata port :optional (test-end-markup? #t))
    (let ((seen-end? #f))  ;; Seen the final '---'

      (let Loop ((var (read port)))
        (cond
         ((eof-object? var)
          #void)

         ((equal? var '|---|)
          (unless (eq? (peek-char port) #\newline)
            (warning port "newline expected after the closing '---' markup"))
          (read-char port)
          (set! seen-end? #t))

         ((keyword? var)
          (let ((value (read-line port)))
            ;; Simulate a variable definition in the (stklos preproc) environment
            (let ((var (string->symbol (string-lower (keyword->string var))))
                  (val (regexp-replace "^ *(.*)([^ ]) *"    ;; A simple trim regexp
                                       value
                                       "\\1\\2")))
              (tprintf 2 "*** defining variable ~s to ~s\n" var val)
              (eval `(define ,var ,val) *md-env*))
            (let ((ch (peek-char port)))
              (when (or (alphabetic? ch) (eq? ch #\-))
                (Loop (read port))))))

         (else ;; Not a keyword rewrite what we have read
          (write var))))
      (when (and test-end-markup? (not seen-end?))
        (warning port "markup '---' absent to close the header"))))


  ;;;;
  ;;;; read-header
  ;;;;
  (define (read-header port)
    (let ((ch (peek-char port)))
      (cond
       ((eq? ch #\-)
        ;; NOTE: This code doesn't permit to use mustaches in the first
        ;; four characters of an "interactive" port (other ports are
        ;; rewinded if we don't have a header)
        (let ((str (read-string 4 port)))
          (if (equal? str "---\n")
              (parse-metadata port)
              (unless (eof-object? str)
                (if (interactive-port? port)
                    (display str)
                    (rewind-file-port port))))))

       ((alphabetic? ch)
        (parse-metadata port #f)))))

  ;;;;
  ;;;; read-command
  ;;;;
  (define (read-command port open close)

    (define (skip-spaces)
      (let ((ch (peek-char port)))
        (when (and (not (eof-object? ch)) (char-whitespace? ch))
          (read-char port)
          (skip-spaces))))

    (define (verify-close)
      (let ((ch (read-char port)))
        (unless (char=? ch close)
          (warning  port "expected closing ~S" close))
        ;; skip a newline if it just follows a end delimiter (bad idea)
        #;(let ((ch (peek-char port)))
          (when (and (not (eof-object? ch)) (char=? ch #\newline))
            (read-char port)))))

    (define (evaluate expr)
      (with-handler
       (lambda (x)
         (fprintf (current-error-port) "~a:~a: " (port-file-name port) (port-current-line port))
         (fprintf (current-error-port) "warning when evaluating embedded expression '~s'\n" expr)
         (fprintf (current-error-port) "    message was ~s\n" (condition-message x))
         #f)
       (eval expr *md-env*)))

    ;; Fist delimiter is already read
    (let ((ch (peek-char port)))
      (if (char=? ch open)
          (let* ((expr (read port)))
            (skip-spaces)
            (verify-close)
            (cond
             ((member (car expr) '(If Else End Include Include* System))
              ;; This is and internal command)
              (exec-internal-command expr))

             ((= (length expr) 1)
              ;; A single component in the command
              (let ((res (evaluate (car expr))))
                (if (procedure? res)
                    (set! res (apply res '())))
                res))

             (else
              ;; a function/macro call
              (let ((res (evaluate expr)))
                res))))
          ;; A single opening delimiter
          open)))

  ;;;
  ;;; do-read
  ;;;
  (define (do-read port)
    (read-header port)
    (let Loop ((ch (read-char port))
               (prev #\space))
      (when (eq? ch #\\)
        ;; We have a protected character
        (set! prev ch)
        (set! ch (read-char port)))

      (if (eof-object? ch)
          'nothing 
          ;;(unless (null? *print-stack*)
          ;;  (error "unclosed if/else"))      ;; FIXME: add opening line and FILE
          (let ((val (cond
                      ((eq? prev #\\)
                       ch)
                      ((eq? ch (car *command-chars*))
                       (apply read-command port *command-chars*))
                      (else
                       ch))))
            (when (and *printing* (not (equal? val #void)))
              (display val))
            (Loop (read-char port) ch)))))

  ;;;
  ;;; process-file
  ;;;
  (define (process-file file)
    (with-output-to-string
      (lambda ()
        (let ((port (if (equal? file "-")
                        (current-input-port)
                        (open-input-file file))))
          (do-read port)))))

  ;;;
  ;;; process-string
  ;;;
  (define (process-string str)
    (with-output-to-string
      (lambda ()
        (do-read (open-input-string str)))))

  (define (translate file)

    (define (call-document-processor cmd body)
      (tprintf 1 "*** call document processor: ~S\n" cmd)
      (let ((tmpfile (create-temp-file)))
        (with-handler (lambda (e) e)
          ;; Send the body string to the processor command
          (with-output-to-file (format "| ~a > ~a" cmd tmpfile)
            (lambda () (display body)))

          ;; Copy the tmpfile to current-output-port
          (with-input-from-file tmpfile
            (lambda () (copy-port (current-input-port) (current-output-port)))))
        (delete-file tmpfile)))

    ;; First process the user file since it contains metadata definitions
    (let ((body (process-file file))
          (pre  "")                     ;; content of prelude template
          (post ""))                    ;; content of postlude template

      ;; Eventually load a global config file
      (let ((conf-file (symbol-value* 'conf-file       *md-env* #f)))
        (when conf-file
          (tprintf 1 "*** loading file ~s\n" conf-file)
          (load conf-file)))

      (let ((template  (symbol-value* 'template        *md-env* #f))
            (cmd       (symbol-value* 'process-command *md-env* #f))
            (args      (symbol-value* 'process-args    *md-env* "")))

        ;; build prelude and postlude templates
        (when (string? template)
          (let ((prelude-file (string-append template "-prelude.templ"))
                (postlude-file (string-append template "-postlude.templ")))
            (unless (file-exists? prelude-file)
              (die (format "cannot find prelude template file ~s" prelude-file)))
            (unless (file-exists? postlude-file)
              (die (format "cannot find postlude template file ~s" postlude-file)))
            (set! pre  (process-file prelude-file))
            (set! post (process-file postlude-file))))

        ;; Display pre + body (eventually sent to an external document processor) + post
        ;; External document processor can be pandoc, markdown, asciidoc ...
        (display pre)
        (if cmd
            (call-document-processor (string-append cmd " " args) body)
            (display body))
        (display post))))


  ;;
  ;; Define the reader for braces
  ;;
  (define (read-brace port)
    ;; skip opening brace which has been pushed back by the reader
    (read-char port)
    ;; read a list finished by a closing brace
    (%read-list port #\}))

  ;; Change the STklos reader for braces
  (eval `(define %read-brace ,read-brace)
        (find-module 'STklos))

) ;; End of module preproc

(provide "stklos/preproc")
