build.scm

#!/usr/bin/env gosh

(use file.util)
(use gauche.generator)
(use gauche.parameter)
(use scheme.list)
(use srfi-13)
(use srfi-19)
(use srfi-26)
(use srfi-42)

(define-syntax ->
  (syntax-rules ()
    [(_ x) x]
    [(_ x (fn . args) . rest) (-> (fn x . args) . rest)]
    [(_ x fn . rest) (-> (fn x) . rest)]))

(define-syntax ->>
  (syntax-rules ()
    [(_ x) x]
    [(_ x (fn args ...) . rest) (->> (fn args ... x) . rest)]
    [(_ x fn . rest) (->> (fn x) . rest)]))

(define (main args)
  (let ([usage (^[] (usage "CMD [ARG...]"
                           "Extract keywords from Gauche texinfo source files."
                           "Commands:"
                           "    tsv"
                           "    macro"
                           "    specialform"
                           "    qualifier"
                           "    function"
                           "    parameter"
                           "    variable"
                           "    constant"
                           "    module"
                           "    class"
                           "    syntax"
                           "    ftplugin"))]
        [args (cdr args)])
    (if (null? args)
        (usage)
        (let ([cmd (car args)]
              [args (cdr args)])
          (case (string->symbol cmd)
            [(tsv) (build-tsv args)]
            [(macro) (build-macro args)]
            [(specialform) (build-specialform args)]
            [(qualifier) (build-qualifier args)]
            [(function) (build-function args)]
            [(parameter) (build-parameter args)]
            [(variable) (build-variable args)]
            [(constant) (build-constant args)]
            [(module) (build-module args)]
            [(class) (build-class args)]
            [(syntax) (build-syntax args)]
            [(ftplugin) (build-ftplugin args)]
            [else (usage)])))))

(define (build-tsv names)
  (when (not (sys-getenv "GAUCHE_SRC"))
    (parameterize ([current-output-port (current-error-port)])
      (write-string "Please set GAUCHE_SRC to gauche source path\n"))
    (exit 1))
  (when (null? names)
    (usage "tsv [NAME...]"
           "Convert gauche document source files to a TSV table."
           "Args:"
           "    NAME        name of texinfo source file, suffix (.texi) can be omitted"))
  (->> (list-ec [: name names]
                [:let name (if (#/\.texi$/ name)
                               name
                               #"~|name|.texi")]
                [:let gauche-src (sys-getenv "GAUCHE_SRC")]
                [:generator line (->> name
                                      (build-path gauche-src "doc")
                                      (file->line-generator))]
                [if (#/^@def/ line)]
                [:let fields (-> line
                                 (string->fields)
                                 (fields-tidy))]
                (-> (cons name fields)
                    (string-join "\t")))
       (sort)
       (delete-duplicates)
       (for-each print))
  (exit))

(define (build-macro args)
  (when (null? args)
    (usage "macro TSV"
           "Generate vim syntax for Gauche macros."
           "Args:"
           "TSV        TSV file generated by tsv command"))
  (->> (list-ec [:let tsv (car args)]
                [:generator line (file->line-generator tsv)]
                [:let fields (string-split line #\tab)]
                [if (#/^@defmacx?$/ (~ fields 1))]
                (~ fields 3))
       (sort)
       (delete-duplicates)
       (filter (pa$ undefined-keyword-in? #/r7rs\w*SyntaxM?/))
       (filter-map (^[name] (rxmatch-case name
                              [#/^use$/ ()
                               #f]
                              [#/^define-/ ()
                               #"syn keyword r7rsSyntaxM ~name"]
                              [#/!/ ()
                               #"syn keyword r7rsSyntaxM ~name"]
                              [#/^\^c$/ ()
                               "syn match r7rsSyntax /\\^[_a-z]/"]
                              [else
                                #"syn keyword r7rsSyntax ~name"])))
       (for-each print))
  (exit))

(define (build-specialform args)
  (when (null? args)
    (usage "specialform TSV"
           "Generate vim syntax for Gauche specialforms."
           "Args:"
           "TSV        TSV file generated by tsv command"))
  (->> (list-ec [:let tsv (car args)]
                [:generator line (file->line-generator tsv)]
                [:let fields (string-split line #\tab)]
                [if (#/^@defspecx?$/ (~ fields 1))]
                (~ fields 3))
       (sort)
       (delete-duplicates)
       (filter (pa$ undefined-keyword-in? #/r7rs\w*SyntaxM?/))
       (filter-map (^[name] (rxmatch-case name
                              [#/^import$/ ()  ; skip it as it is handled in r7rs(|Gauche)Import
                               #f]
                              [#/^((define|select)-module|export-all|require)$/ ()
                               #"syn keyword r7rsSyntaxM ~name"]
                              [#/^define-/ ()
                               #"syn keyword r7rsSyntaxM ~name"]
                              [else
                                #"syn keyword r7rsSyntax ~name"])))
       (for-each print))
  (exit))

(define (build-qualifier args)
  (when (null? args)
    (usage "qualifier TSV"
           "Generate vim syntax for SRFI-42 qualifiers."
           "Args:"
           "TSV        TSV file generated by tsv command"))
  (->> (list-ec [:let tsv (car args)]
                [:generator line (file->line-generator tsv)]
                [:let fields (string-split line #\tab)]
                [if (and (#/^{ec qualifier}$/ (~ fields 2))
                         (not (#/^:/ (~ fields 3))))]
                (~ fields 3))
       (sort)
       (delete-duplicates)
       (filter (pa$ undefined-keyword-in? #/r7rs\w*SyntaxM?/))
       (filter-map (^[name] (rxmatch-case name
                              [else
                                #"syn keyword r7rsSyntax ~name"])))
       (for-each print))
  (exit))

(define (build-function args)
  (when (null? args)
    (usage "function TSV"
           "Generate vim syntax for Gauche functions."
           "Args:"
           "TSV        TSV file generated by tsv command"))
  (->> (list-ec [:let tsv (car args)]
                [:generator line (file->line-generator tsv)]
                [:let fields (string-split line #\tab)]
                [if (or (#/^@defunx?$/ (~ fields 1))
                        (#/^{(\w+ )?(function|method)}$/ (~ fields 2)))]
                (~ fields 3))
       (sort)
       (delete-duplicates)
       (map expand-@)
       (concatenate)
       (filter (pa$ undefined-keyword-in? #/r7rsFunctionM?/))
       (filter-map (^[name] (rxmatch-case name
                              [#/^next-method$/ ()
                               #"syn keyword r7rsFunctionM ~name"]
                              [#/^list-queue-fist-last$/ ()
                               #f]
                              [#/^flnevative\?$/ ()
                               #f]
                              [#/!/ ()
                               #"syn keyword r7rsFunctionM ~name"]
                              [else
                                #"syn keyword r7rsFunction ~name"])))
       (for-each print))
  (exit))

(define (build-parameter args)
  (when (null? args)
    (usage "parameter TSV"
           "Generate vim syntax for Gauche parameters."
           "Args:"
           "TSV        TSV file generated by tsv command"))
  (->> (list-ec [:let tsv (car args)]
                [:generator line (file->line-generator tsv)]
                [:let fields (string-split line #\tab)]
                [if (#/^{parameter}$/ (~ fields 2))]
                (~ fields 3))
       (sort)
       (delete-duplicates)
       (filter (pa$ undefined-keyword-in? #/r7rsFunction/))
       (filter-map (^[name] (rxmatch-case name
                              [else
                                #"syn keyword r7rsFunction ~name"])))
       (for-each print))
  (exit))

(define (build-variable args)
  (when (null? args)
    (usage "variable TSV"
           "Generate vim syntax for Gauche variables/comparators."
           "Args:"
           "TSV        TSV file generated by tsv command"))
  (->> (list-ec [:let tsv (car args)]
                [:generator line (file->line-generator tsv)]
                [:let fields (string-split line #\tab)]
                [if (or (#/^@defvarx?$/ (~ fields 1))
                        (#/^{comparator}$/ (~ fields 2)))]
                (~ fields 3))
       (sort)
       (delete-duplicates)
       (map expand-@)
       (concatenate)
       (filter (pa$ undefined-keyword-in? #/r7rsVariable/))
       (filter-map (^[name] (rxmatch-case name
                              [else
                                #"syn keyword r7rsVariable ~name"])))
       (for-each print))
  (exit))

(define (build-constant args)
  (when (null? args)
    (usage "constant TSV"
           "Generate vim syntax for Gauche constants."
           "Args:"
           "TSV        TSV file generated by tsv command"))
  (->> (list-ec [:let tsv (car args)]
                [:generator line (file->line-generator tsv)]
                [:let fields (string-split line #\tab)]
                [if (#/^{constant}$/ (~ fields 2))]
                (~ fields 3))
       (sort)
       (delete-duplicates)
       (filter (pa$ undefined-keyword-in? #/r7rsConstant/))
       (filter-map (^[name] (rxmatch-case name
                              [else
                                #"syn keyword r7rsConstant ~name"])))
       (for-each print))
  (exit))

(define (build-module args)
  (when (null? args)
    (usage "module TSV"
           "Generate vim syntax for Gauche module names."
           "Args:"
           "TSV        TSV file generated by tsv command"))
  (->> (list-ec [:let tsv (car args)]
                [:generator line (file->line-generator tsv)]
                [:let fields (string-split line #\tab)]
                [if (#/^{(\w+ )?module}$/ (~ fields 2))]
                (~ fields 3))
       (sort)
       (delete-duplicates)
       (map expand-@)
       (concatenate)
       (filter-map (^[name] (rxmatch-case name
                              [else
                                #"syn keyword r7rsGaucheModName ~name"])))
       (for-each print))
  (exit))

(define (build-class args)
  (when (null? args)
    (usage "class TSV"
           "Generate vim syntax for Gauche classes."
           "Args:"
           "TSV        TSV file generated by tsv command"))
  (->> (list-ec [:let tsv (car args)]
                [:generator line (file->line-generator tsv)]
                [:let fields (string-split line #\tab)]
                [if (or (#/^{((meta|\w+ )?class)}$/ (~ fields 2))
                        (#/{condition type}/ (~ fields 2)))]
                (~ fields 3))
       (sort)
       (delete-duplicates)
       (map expand-@)
       (concatenate)
       (filter-map (^[name] (rxmatch-case name
                              [else
                                #"syn keyword r7rsGaucheClass ~name"])))
       (for-each print))
  (exit))

(define (build-syntax args)
  (when (null? args)
    (usage "syntax PATH [VIM...]"
           "Rebuild syntax/gauche.vim from generated vim files."
           "Args:"
           "PATH       path to syntax/gauche.vim"
           "VIM...     files generated by tsv command (macro|specialform|...)"))
  (let* ([path (car args)]
         [vim-files (cdr args)]
         [lines (file->string-list path)])
    (call-with-temporary-file
      (^[port tmp]
        (parameterize ([current-output-port port])
          (->> (list (->> lines
                          (take-while (^a (not (#/^" Common expressions {{{1$/ a))))
                          (map update-timestamp))
                     '("\" Common expressions {{{1" "")
                     (->> (list-ec [: file vim-files]
                                   [:generator line (file->line-generator file)]
                                   line)
                          (sort)
                          (delete-duplicates))
                     '("")
                     (->> lines
                          (drop-while (^a (not (#/^" Special expressions {{{1$/ a))))))
               (concatenate)
               (for-each print))
          (flush))
        (copy-file tmp path :if-exists :supersede))))
  (exit))

(define (build-ftplugin args)
  (when (null? args)
    (usage "ftplugin PATH TSV"
           "Rebuild ftplugin/gauche.vim from generated vim files."
           "Args:"
           "PATH       path to ftplugin/gauche.vim"
           "TSV        TSV file generated by tsv command"))
  (let* ([path (car args)]
         [tsv (cadr args)]
         [lines (file->string-list path)]
         [lispwords (list-ec [:generator line (file->line-generator tsv)]
                             [:let fields (string-split line #\tab)]
                             [if (#/lispword/ (~ fields 4))]
                             (~ fields 3))])
    (call-with-temporary-file
      (^[port tmp]
        (parameterize ([current-output-port port])
          (->> (list (->> lines
                          (take-while (^a (not (#/^" lispwords {{{$/ a))))
                          (map update-timestamp))
                     '("\" lispwords {{{" "")
                     (->> lispwords
                          (sort)
                          (delete-duplicates)
                          (filter undefined-lispword?)
                          (filter-map (^[name] (rxmatch-case name
                                                 [else
                                                   #"setl lispwords+=~name"]))))
                     '("")
                     (->> lines
                          (drop-while (^a (not (#/^" }}}$/ a))))))
               (concatenate)
               (for-each print))
          (flush))
        (copy-file tmp path :if-exists :supersede))))
  (exit))

;; Show usage.
(define (usage synopsis desc . more)
  (let1 pname (car (command-line))
    (parameterize ([current-output-port (current-error-port)])
      (-> `(,#"Usage: ~pname ~synopsis" "" ,desc "" ,@more)
          (string-join "\n")
          (write-string))
      (newline)))
  (exit 1))

;; Split a string into a list of fields.
;; Each field must be either not surrounded by parens or surrounded by paired parens.
;; Example:
;;     (string->fields "a b {c (d e)} f") ==> '("a" "b" "{c (d e)}" "f")
(define (string->fields line)
  (let1 fields (string-split line #/[[:space:]]+/)
    (if (null? fields)
        fields
        (let1 done (list (pop! fields))
          (until (null? fields)
            (let ([current (car done)]
                  [next (pop! fields)])
              (if (or (not (#/^[\(\[{]/ current))
                      (#/^{.*}$/ current)
                      (#/^\(.*\)$/ current)
                      (#/^\[.*\]$/ current))
                  (push! done next)
                  (set! (car done) (string-join (list current next) " ")))))
          (reverse done)))))

;; Format raw fields like '(@def {category} name lispword?)
(define (fields-tidy fields)
  (let-values ([(f1 f2 f3) (apply values (take* fields 3 #t ""))])
    ;; If f2 does not match {category} then it is name
    (unless (#/^{[^\(\)]+}$/ f2)
      (set! f3 f2)
      (set! f2 ""))
    ;; Category name may have inconsistent cases; e.g. {Condition [tT]ype}
    (set! f2 (string-downcase f2))
    ;; Some identifiers are surrounded by {} (e.g. {(setter ...)}).
    (set! f3 (unwrap-setter f3))
    (let1 lispword (if (has-lispword? fields) "lispword" "")
      (list f1 f2 f3 lispword))))

;; Unwrap item enclosed as {(setter ITEM)}.
(define (unwrap-setter wrapped)
  (if-let1 matched (#/{\(setter (.+)\)}/ wrapped)
           (matched 1)
           wrapped))

;; Check whether the raw fields look like '(name arg ... body-ish ...).
;; If the fields contain a syntax that should be added as lispword, they end with something like
;; body ... or clause ....
;; Typical example:
;;     @defspec lambda formals body @dots{}
;; So NF > 4. However, there are false positive with NF > 4:
;;     @defmac cut expr-or-slot expr-or-slot2 @dots{}
;;     @defmac begin0 exp0 exp1 @dots{}
;; These examples are ideally
;;     @defmac cut expr-or-slot @dots{}
;;     @defmac begin0 exp @dots{}
;; By these translation, NF <= 4 and one can distinguish between lispword from others.
(define (has-lispword? fields)
  (let/cc return
    (let ([n (length fields)]
          [threshold 4])
      (unless (> n threshold)
        (return #f))
      (let ([def (first fields)]
            [maybe-name1 (second fields)]
            [maybe-name2 (third fields)]
            [maybe-dots (last fields)])
        ;; define-method and let(rec)?-syntax lack ending "body ..." but have "body".
        (when (any #/^(define-method|let(rec)?-syntax)$/
                   (list maybe-name1 maybe-name2))
          (return #t))
        (when (and (#/^@def(mac|spec)x?$/ def)
                   (#/^@dots\{\}$/ maybe-dots))
          (let* ([sdleif (reverse fields)]
                 [body1 (string-trim-right (third sdleif) #[[:digit:]])]
                 [body2 (string-trim-right (second sdleif) #[[:digit:]])]
                 [threshold (if (string= body1 body2)
                                (+ 1 threshold)
                                threshold)])
            (when (> n threshold)
              (return #t))))))
    #f))

(define (update-timestamp line)
  (let1 today (date->string (current-date) "~Y-~m-~d")
    (regexp-replace-all #/(?<=Last Change:[[:space:]]*)[0-9]{4}-[0-9]{2}-[0-9]{2}/i line today)))

(define (undefined-keyword-in? group word)
  (let* ([word (string-regexp-escape word)]
         [group (cond [(regexp? group) (regexp->string group)]
                      [(string? group) group]
                      [else (x->string group)])]
         [known? (string->regexp #"syn keyword ~|group| (?:.+ )?~|word|(?: |$)")])
    (not (any known? r7rs-keywords))))

(define (undefined-lispword? word)
  (let* ([word (string-regexp-escape word)]
         [known? (string->regexp #"setl lispwords\\+?=(?:.+,)?~|word|(?:,|$)")])
    (not (any known? r7rs-lispwords))))

;; Escape meta characters in EXTENDED regular expressions.
(define (string-regexp-escape str)
  (regexp-replace-all #/([*.^$+?])/ str "\\\\\\1"))

(define-constant r7rs-keywords
  (list-ec [: file '("./syntax/r7rs.vim"
                     "./syntax/r7rs-large.vim"
                     "./syntax/srfi.vim")]
           [:generator line (file->line-generator file)]
           [if (#/syn keyword/ line)]
           line))

(define-constant r7rs-lispwords
  (list-ec [: file '("./ftplugin/r7rs.vim"
                     "./ftplugin/r7rs-large.vim"
                     "./ftplugin/srfi.vim")]
           [:generator line (file->line-generator file)]
           [if (#/setl lispwords/ line)]
           line))

(define (expand-@ line)
  (rxmatch-case line
    [#/@@/ ()
     (map (pa$ regexp-replace #/@@/ line) @@)]
    [#/html:@var{element}/ ()
     (map (pa$ regexp-replace #/@var{element}/ line) HTML)]
    [else
      (list line)]))

(define-constant @@
  '("u8" "s8" "u16" "s16" "u32" "s32" "u64" "s64" "f16" "f32" "f64" "c32" "c64" "c128"))

(define-constant HTML
  '("a" "abbr" "acronym" "address" "area" "b" "base" "bdo" "big" "blockquote" "body" "br" "button"
    "caption" "cite" "code" "col" "colgroup" "dd" "del" "dfn" "div" "dl" "dt" "em" "fieldset" "form"
    "frame" "frameset" "h1" "h2" "h3" "h4" "h5" "h6" "head" "hr" "html" "i" "iframe" "img" "input"
    "ins" "kbd" "label" "legend" "li" "link" "map" "meta" "noframes" "noscript" "object" "ol"
    "optgroup" "option" "p" "param" "pre" "q" "samp" "script" "select" "small" "span" "strong"
    "style" "sub" "sup" "table" "tbody" "td" "textarea" "tfoot" "th" "thead" "title" "tr" "tt" "ul"
    "var"))