;;;;
;;;; 37.stk                -- Implementation of SRFI-37
;;;;
;;;; Copyright © 2020 Jeronimo Pellegrini - <j_p@aleph0.info>
;;;;
;;;;
;;;; 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 3 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.
;;;;
;;;; This file is a derivative work from the  implementation of
;;;; this SRFI in Guile; it is copyrighted as:
;;;;
;;;;;   Copyright (C) 2007, 2008, 2013 Free Software Foundation, Inc.
;;;;;
;;;;; This library is free software; you can redistribute it and/or
;;;;; modify it under the terms of the GNU Lesser General Public
;;;;; License as published by the Free Software Foundation; either
;;;;; version 3 of the License, or (at your option) any later version.
;;;;;
;;;;; This library 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
;;;;;; Lesser General Public License for more details.
;;;;;
;;;;; You should have received a copy of the GNU Lesser General Public
;;;;; License along with this library; if not, write to the Free Software
;;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
;;;;           Author: Jeronimo Pellegrini [j_p@aleph0.info]
;;;;    Creation date: 03-Jul-2020 06:39 (jpellegrini)
;;;;


(define-module srfi/37
  (import (srfi 13))
  
  (export option option-names option-required-arg?
          option-optional-arg? option-processor
          args-fold)

(define-record-type srfi-37:option
  (option names required-arg? optional-arg? processor)
  option?
  (names option-names)
  (required-arg? option-required-arg?)
  (optional-arg? option-optional-arg?)
  (processor option-processor))

(define (error-duplicate-option option-name)
  (error 'args-fold
         "Duplicate option name `~A~A'"
         (if (char? option-name) #\- "--")
         option-name))

;; mimic the behavior of Guile's hash-create-handle!
(define (hash-create-handle! h k v)
  (when (not (hash-table-exists? h k))
    (hash-table-set! h k v))
  (cons k (hash-table-ref h k)))

(define (build-options-lookup options)
  "Answer an `equal?' Guile hash-table that maps OPTIONS' names back
to the containing options, signalling an error if a name is
encountered more than once."
  ;; Guile sets the size : (* 2 (length options)))))
  ;; Guile doesn't set a comparison predicate; in STklos, it wouldn't work.
  (let ((lookup (make-hash-table equal?)))
    (for-each
     (lambda (opt)
       (for-each (lambda (name)
                   (let ((assoc (hash-create-handle!
                                 lookup name #f)))
                     (if (cdr assoc)
                         (error-duplicate-option (car assoc))
                         (hash-table-set! lookup name opt))))
                 ;; above ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
                 ;; Guile does (set-cdr! assoc opt), because
                 ;; hash-create-handle! in Guile returns a cons
                 ;; whose CDR is the actual place of the stored value.
                 (option-names opt)))
     options)
    lookup))

(define (args-fold args options unrecognized-option-proc
                   operand-proc . seeds)
  "Answer the results of folding SEEDS as multiple values against the
program-arguments in ARGS, as decided by the OPTIONS'
`option-processor's, UNRECOGNIZED-OPTION-PROC, and OPERAND-PROC."
  (let ((lookup (build-options-lookup options)))
    ;; The Guile implementors did override error. We don't need it.
    ;;
    ;; I don't like Guile's `error' here
    ;; (define (error msg . args)
    ;;   (scm-error 'misc-error "args-fold" msg args #f))

    (define (mutate-seeds! procedure . params)
      (set! seeds (call-with-values
                      (lambda ()
                        (apply procedure (append params seeds)))
                    list)))

    ;; Clean up the rest of ARGS, assuming they're all operands.
    (define (rest-operands)
      (for-each (lambda (arg) (mutate-seeds! operand-proc arg))
                args)
      (set! args '()))

    ;; Call OPT's processor with OPT, NAME, an argument to be decided,
    ;; and the seeds.  Depending on OPT's *-arg? specification, get
    ;; the parameter by calling REQ-ARG-PROC or OPT-ARG-PROC thunks;
    ;; if no argument is allowed, call NO-ARG-PROC thunk.
    (define (invoke-option-processor
             opt name req-arg-proc opt-arg-proc no-arg-proc)
      (mutate-seeds!
       (option-processor opt) opt name
       (cond ((option-required-arg? opt) (req-arg-proc))
             ((option-optional-arg? opt) (opt-arg-proc))
             (else (no-arg-proc) #f))))

    ;; Compute and answer a short option argument, advancing ARGS as
    ;; necessary, for the short option whose character is at POSITION
    ;; in the current ARG.
    (define (short-option-argument position)
      (cond ((< (+ 1 position) (string-length (car args)))
             (let ((result (substring (car args) (+ 1 position) (string-length (car args)))))
               (set! args (cdr args))
               result))
            ((pair? (cdr args))
             (let ((result (cadr args)))
               (set! args (cddr args))
               result))
            ((pair? args)
             (set! args (cdr args))
             #f)
            (else #f)))

    ;; Interpret the short-option at index POSITION in (car ARGS),
    ;; followed by the remaining short options in (car ARGS).
    (define (short-option position)
      (if (>= position (string-length (car args)))
          (begin
            (set! args (cdr args))
            (next-arg))
          (let* ((opt-name (string-ref (car args) position))
                 (option-here (hash-table-ref lookup opt-name)))
            (cond ((not option-here)
                   (mutate-seeds! unrecognized-option-proc
                                  (option (list opt-name) #f #f
                                          unrecognized-option-proc)
                                  opt-name #f)
                   (short-option (+ 1 position)))
                  (else
                   (invoke-option-processor
                    option-here opt-name
                    (lambda ()
                      (or (short-option-argument position)
                          (error "Missing required argument after `-~A'" opt-name)))
                    (lambda ()
                      ;; edge case: -xo -zf or -xo -- where opt-name=#\o
                      ;; GNU getopt_long resolves these like I do
                      (short-option-argument position))
                    (lambda () #f))
                   (if (not (or (option-required-arg? option-here)
                                (option-optional-arg? option-here)))
                       (short-option (+ 1 position))))))))

    ;; Process the long option in (car ARGS).  We make the
    ;; interesting, possibly non-standard assumption that long option
    ;; names might contain #\=, so keep looking for more #\= in (car
    ;; ARGS) until we find a named option in lookup.
    (define (long-option)
      (let ((arg (car args)))
        (let place-=-after ((start-pos 2))
          (let* ((index (string-index arg #\= start-pos))
                 (opt-name (substring arg 2 (or index (string-length arg))))
                 (option-here (hash-table-ref/default lookup opt-name #f)))
            (if (not option-here)
                ;; look for a later #\=, unless there can't be one
                (if index
                    (place-=-after (+ 1 index))
                    (mutate-seeds!
                     unrecognized-option-proc
                     (option (list opt-name) #f #f unrecognized-option-proc)
                     opt-name #f))
                (invoke-option-processor
                 option-here opt-name
                 (lambda ()
                   (if index
                       (substring arg (+ 1 index) (string-length arg))
                       (error "Missing required argument after `--~A'" opt-name)))
                 (lambda () (and index (substring arg (+ 1 index) (string-length arg))))
                 (lambda ()
                   (if index
                       (error "Extraneous argument after `--~A'" opt-name))))))))
      (set! args (cdr args)))

    ;; Process the remaining in ARGS.  Basically like calling
    ;; `args-fold', but without having to regenerate `lookup' and the
    ;; funcs above.
    (define (next-arg)
      (if (null? args)
          (apply values seeds)
          (let ((arg (car args)))
            (cond ((or (string-null? arg)
                       (not (char=? #\- (string-ref arg 0)))
                       (= 1 (string-length arg))) ;"-"
                   (mutate-seeds! operand-proc arg)
                   (set! args (cdr args)))
                  ((char=? #\- (string-ref arg 1))
                   (if (= 2 (string-length arg)) ;"--"
                       (begin (set! args (cdr args)) (rest-operands))
                       (long-option)))
                  (else (short-option 1)))
            (next-arg))))

    (next-arg)))
) ;; END OF DEFINE-MODULE
;;;; ======================================================================

(provide "srfi/37")
