#!r6rs
;; Scheme includes pre-processor.
;;
;; All include/resolve statements are replaced with scheme data contained in the referenced file.
;; File content is placed within a (begin) block.
;;
;; TODO Remove headers print HACK in replace-source. Maybe via a (values) return?
;;
;; Written by Akce 2020.
;; SPDX-License-Identifier: Unlicense

(library (private install sipp)
  (export
    directory-separator-string
    join-string
    replace-source)
  (import
    (rnrs)
    (only (chezscheme) directory-separator))

  ;; [proc] replace-source: opens a scheme file, replacing all instances of (include/resolve) with contents of file.
  ;; [return] scheme list object with forms embedded.
  ;; HACK ALERT: this also prints the header lines to (current-output-port) assuming that callers will print the
  ;; HACK ALERT: returned object to this same port. It's an easy way to get all headers followed by code/data.
  (define replace-source
    (case-lambda
      [(path)
       (replace-source path #f)]
      [(path print-sipp-header)
       (with-input-from-file path
         (lambda ()
           (when print-sipp-header
             (display ";; DO NOT EDIT THIS FILE!!")(newline)
             (display ";; This inlined chez-srfi library code is autogenerated using command:")(newline)
             (display ";; $ ")(display (apply join-string " " (command-line)))(newline)
             (display ";; Source origin: https://github.com/arcfide/chez-srfi")(newline)
             (display ";; Please refer to project site for full credits and original code.")(newline))
           ;; Print initial header block. Hopefully that's a language tag and copyright info.
           ;; ie, print lines till we hit the first scheme statement or empty line.
           ;; NOTE: multiline comments are *not* handled.
           (display ";;;;;; File header: ")(display path)(newline)
           (let loop ()
             (case (peek-char)
               [(#\# #\;)
                (display (get-line (current-input-port)))
                (newline)
                (loop)]))
           (let loop ([obj (read)] [acc '()])
             (cond
               [(eof-object? obj)
                (reverse acc)]
               [else
                 (loop (read) (cons (replace-object obj) acc))]))))]))

  ;; [proc] replace-object: recurses through a scheme list object, replacing all (include/resolve) calls with the
  ;; contents of the referred to file.
  (define replace-object
    (lambda (obj)
      (cond
        [(pair? obj)
         (case (car obj)
           [(include/resolve)
            `(begin
               ,@(include/resolve (cdr obj)))
            ]
           [else
             (imap replace-object obj)])]
        [else
          obj])))

  (define directory-separator-string (list->string `(,(directory-separator))))

  ;; (include/resolve ((?dir ?dirn ...) ?filename))
  (define include/resolve
    (lambda (args)
      (let ([dir-args (car args)]
            [filename (cadr args)])
        ;; construct the path and let replace-source earn its keep.
        (replace-source (apply join-string directory-separator-string (append (cdr dir-args) (list filename)))))))

  ;; [proc] imap: simple map that handles improper lists.
  (define imap
    (lambda (proc ilist)
      (let loop ([i ilist])
        (cond
          [(null? i)
           i]
          [else #;(pair? i)
                (cons* (proc (car i))
                       (cond
                         [(list? (cdr i))
                          (loop (cdr i))]
                         [else
                           (proc (cdr i))]))]))))

  ;; [proc] string-join: join all string parts together using separator.
  ;;
  ;; Note that the signature to this version of join-string differs to string-join in SRFI-13.
  ;; The separator is the first arg and therefore always explicit which allows for the string
  ;; parts as regular arguments, rather than a list of strings.
  ;;
  ;; Naive implementation that uses (potentially) multiple calls to string-append.
  (define join-string
    (lambda (sep . str-parts)
      (cond
        [(null? str-parts)
         ""]
        [else
          (let loop ([acc (car str-parts)] [rest (cdr str-parts)])
            (cond
              [(null? rest)
               acc]
              [else
                (loop (string-append acc sep (car rest)) (cdr rest))]))])))
)