;;; Dezyne --- Dezyne command line tools
;;;
;;; Copyright © 2018, 2019 Rob Wieringa <Rob.Wieringa@verum.com>
;;; Copyright © 2018, 2019 Rutger van Beusekom <rutger.van.beusekom@verum.com>
;;; Copyright © 2018, 2019, 2021 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Dezyne.
;;;
;;; Dezyne is free software: you can redistribute it and/or modify it
;;; under the terms of the GNU Affero General Public License as
;;; published by the Free Software Foundation, either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; Dezyne 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
;;; Affero General Public License for more details.
;;;
;;; You should have received a copy of the GNU Affero General Public
;;; License along with Dezyne.  If not, see <http://www.gnu.org/licenses/>.
;;;
;;; Commentary:
;;;
;;; Code:

(define-module (dzn templates)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 match)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 peg)
  #:use-module (ice-9 peg codegen)

  #:use-module ((oop goops) #:renamer (lambda (x) (if (member x '(<port> <foreign>)) (symbol-append 'goops: x) x)))
  #:use-module (dzn config)
  #:use-module (dzn goops)
  #:use-module (dzn command-line)
  #:use-module (dzn misc)

  #:export (define-templates-base
             define-templates-macro
             display-template))

(eval-when (compile load expand)
  (define (template->tree file-name)
    (define-peg-string-patterns
      "script       <-- pegtext*
       pegtext      <-  (!pegprocedure (escape '#' / .))* pegprocedure?
       pegsep       <   [ ]?
       escape       <   '#'
       pegprocedure <-- '#' [-!$%&'*+,./0-9:<=>?A-Z^_a-z{|}~]([-!#$%&'*+,./0-9:<=>?A-Z^_a-z{|}~])* pegsep")
    (let* ((text (with-input-from-file file-name read-string))
           (text (string-trim-right text))
           (result (match-pattern script text))
           (end (peg:end result)))
      (peg:tree result)))

  (define (display-template o)
    (cond (((disjoin char? number? string?) o) (display o))
          ((symbol? o) (display (symbol->string o)))))

  (define (tree->body tree template)
    (define (tree->body tree)
      (match tree
        ('script '())
        (('script t ...) (tree->body t))
        (('pegprocedure s) (let ((name (string->symbol (string-drop s 1))))
                             (list (list 'display-template (list name 'o)))))
        ((? string?) (list (list 'display tree)))
        ((t ...) (append-map tree->body t))))
    (let* ((template (list 'display-template template))
           (body (tree->body tree)))
      (cons
       (list 'if (list 'getenv "DZN_DEBUG_TEMPLATE_TREE")
             (list 'display-template template)
             ''(()))
       body)))

  (define* (display-join proc name dir o #:optional (grammar-alist '((#f . ("")))))
    "Like STRING-JOIN, allowing \"PRE\" 'pre and \"POST\" 'post in GRAMMAR"
    (define (display-o o)
      (when (and (is-a? o <ast>) (getenv "DZN_DEBUG_TEMPLATE"))
        (let* ((klas (symbol->string (class-name (class-of o))))
               (klas (string-trim-both klas (lambda (c) (or (eqv? c #\<) (eqv? c #\>))))))
          (format #t "/*\n~a~a@~a:0: */\n" dir name klas)))
      (cond (((disjoin char? number? string? symbol?) o) (display o))
            ((null? o))
            (else (proc o))))
    (let* ((grammar (or (and (pair? o)
                             (assoc-ref grammar-alist ((compose string->symbol ast-name car) o)))
                        (assoc-ref grammar-alist #f)))
           (grammar? (> (length grammar) 1))
           (g-alist (if (not grammar?) (car grammar)
                        (reduce-sexp grammar)))
           (infix (if (not grammar?) ""
                      (or (and=> (xassoc '(infix) g-alist)
                                 car) "")))
           (suffix (if (not grammar?) ""
                       (or (and=> (xassoc '(suffix) g-alist)
                                  car) "")))
           (prefix (if (not grammar?) ""
                       (or (and=> (xassoc '(prefix) g-alist)
                                  car) "")))
           (pre (if (not grammar?) ""
                    (or (and=> (xassoc '(pre) g-alist)
                               car) "")))
           (post (if (not grammar?) ""
                     (or (and=> (xassoc '(post) g-alist)
                                car) ""))))
      (unless (null? o) (display pre))
      (if (pair? o)
          (let loop ((lst o))
            (when (pair? lst)
              (let ((o (car lst)))
                (unless (and (string? o) (string-null? o)) (display prefix))
                (display-o o)
                (unless (and (string? o) (string-null? o)) (display suffix)))
              (when (pair? (cdr lst)) (display infix))
              (loop (cdr lst))))
          (display-o o))
      (unless (null? o) (display post))))

  (define (reduce-sexp l)
    (unfold null? (compose (cut apply list <>) (cut list-head <> 2)) cddr l))

  (define (xassoc key alist) (find (compose (cut equal? key <>) cdr) alist))

  (define (isdir? path)
    (and (access? path F_OK) (eq? 'directory (stat:type (stat path)))))

  (define (ls dir)
    (map (lambda (path)
           (if (isdir? (string-append dir path))
               (string-append path "/")
               path))
         (sort (filter (negate (cut string-every #\. <>))
                       (scandir (if (string-null? dir) (getcwd) dir))) string<?))))

(define (drop-<> o)
  (string->symbol (string-drop (string-drop-right (symbol->string o) 1) 1)))

(define-syntax compile-template
  (lambda (x)

    (syntax-case x ()
      ((_ name class language)
       (let* ((tname (datum->syntax x (symbol-append 't: (syntax->datum #'name))))
              (class-name (drop-<> (syntax->datum #'class)))
              (template (symbol->string (symbol-append 'dzn/templates/ (syntax->datum #'language) '/ (syntax->datum #'name) '@ class-name)))
              (tree (template->tree (syntax->datum template)))
              (body (datum->syntax x (tree->body tree (syntax->datum template))))
              (o (datum->syntax x 'o)))
         #`(define-method (#,tname (#,o class)) #,@body))))))

(define-syntax define-templates-base
  (lambda (x)
    (define (body language name xname tname func sep)
      (let ((dir (string-append "dzn/templates/" (symbol->string (syntax->datum language)) "/")))
        (define (read-sep file-name)
          (with-input-from-file (string-append dir file-name) read))
        (let* ((o (datum->syntax x 'o))
               (name@ (string-append (symbol->string (syntax->datum name)) "@"))
               (files (ls dir))
               (types (map (compose string->symbol
                                    (cut string-append "<" <> ">")
                                    (cute string-drop <> (string-length name@)))
                           (filter (cute string-prefix? name@ <>) files)))
               (grammars (or
                          (and (syntax->datum sep)
                               (let* ((sep ((compose symbol->string syntax->datum) sep))
                                      (sep-files (filter (cute string-prefix? sep <>) files)))
                                 (map (lambda (sep)
                                        (let* ((at (string-index sep #\@))
                                               (type (and at ((compose string->symbol
                                                                       (cut string-drop <> (1+ at))) sep))))
                                          (cons type (read-sep sep)))) sep-files)))
                             '()))
               (grammars (append grammars '((#f . ("\n" infix)))))
               (grammars (datum->syntax x grammars)))
          #`(begin
              #,@(map (lambda (t) #`(compile-template #,name #,(datum->syntax x t) #,language)) (syntax->datum types))
              (if (and #,(null? (syntax->datum types)) (not (defined? '#,tname)))
                  (define-method (#,tname (o <top>)) (throw 'missing-template-overload: (string-append "template: " (symbol->string '#,name) " for type: " (symbol->string (class-name (class-of o)))))))
              (define (#,xname #,o)
                (let ((f (#,func #,o)))
		  (when (getenv "DZN_DEBUG_TEMPLATE_ACCESSOR")
		    (display "// ") (display '#,func) (newline))
                  (display-join #,tname '#,name #,dir f '#,grammars)))))))

    (syntax-case x ()
      ((_  language name xname tname)
       (body #'language #'name #'xname #'tname #'identity #f))
      ((_  language name xname tname func)
       (body #'language #'name #'xname #'tname #'func #f))
      ((_  language name xname tname func sep)
       (body #'language #'name #'xname #'tname #'func #'sep)))))

(define-syntax define-templates-macro
  (lambda (x)
    (syntax-case x ()
      ((_ name language)
       #'(define-syntax name
           (lambda (x)
             (syntax-case x ()
               ((_ name)
                (with-syntax ((tname (datum->syntax x (symbol-append 't: (syntax->datum #'name))))
                              (xname (datum->syntax x (symbol-append 'x: (syntax->datum #'name)))))
                  #`(define-templates-base language name xname tname identity #f)))
               ((_ name func)
                (with-syntax ((tname (datum->syntax x (symbol-append 't: (syntax->datum #'name))))
                              (xname (datum->syntax x (symbol-append 'x: (syntax->datum #'name)))))
                  #`(define-templates-base language name xname tname func #f)))
               ((_ name func sep)
                (with-syntax ((tname (datum->syntax x (symbol-append 't: (syntax->datum #'name))))
                              (xname (datum->syntax x (symbol-append 'x: (syntax->datum #'name)))))
                  #`(define-templates-base language name xname tname func sep))))))))))
