;;;; getopt-utils.scm
;;;; Kon Lovett, Feb '13
;;;; Kon Lovett, Jan '21
;;;; Kon Lovett, Mar '24

;; Issues
;;
;; - getopt-long doesn't handle non-key arguments

(module getopt-utils

(;export
  #;Xmake-option-dispatch
  (opt-ref opt-cell-value)
  (opt-set! opt-cell-value)
  opt-rest
  opt-docstring
  opt-value opt-body
  opt-number opt-string
  string-read string->/?
  opt-usage
  opt-error
  opt-usage-error
  opt-exit-code
  (extend-opt-grammar process-extended)
  opt-parse
  usage-message)

(import scheme utf8
  (only (chicken base)
    when unless let-values make-parameter parameterize error and-let* cut receive
    current-error-port fixnum?
    warning define-constant void  exit identity alist-ref foldl
    atom?)
  (chicken type)
  (only (chicken pathname) pathname-strip-directory)
  (only (chicken condition) get-condition-property handle-exceptions make-property-condition)
  (only (chicken port) with-input-from-string)
  (only (chicken format) format)
  (only (chicken process-context) program-name)
  (only (chicken platform) feature?)
  (only (srfi 1) append! first second third every any fold filter partition drop-while)
  getopt-long)

(define-type alist (list-of (pair symbol *)))
(define-type arglist (list-of string))

(: opt-error (string arglist alist #!optional alist -> void))
(: opt-usage (alist #!optional alist -> void))

(: opt-exn-error (condition alist #!optional alist -> void))
(: opt-usage-error ((or string condition) list #!optional list fixnum -> void))

(: opt-docstring (string #!optional * --> string))

(: opt-parse (arglist alist #!optional alist -> alist))

;;

(define (->boolean obj) (and obj #t))

;;;

;from getopt-long
#;
(define (Xmake-option-dispatch opts options-desc-list)
  (let ...
    (lambda (name)
      (case name
        ((@)
          (alist-ref '@ opts))
        (else
          (let* ((spec (find (lambda (x) (eq? (option-spec-name x) name)) specifications))
                 (v (filter-map (lambda (x) (and (eq? (car x) name) (cdr x))) (cdr opts))) )
            (cond ((null? v)
                    (find (lambda (x) (eq? (car x) name)) defaults) )
                  ((option-spec-multiple? spec)
                    v )
                  (else
                    (car v) ) ) ) ) ) ) ) )

(define (opt-cell-value cell func-or-def)
  (let* ((func (if (procedure? func-or-def) func-or-def identity))
         (def (and (not (procedure? func-or-def)) func-or-def)) )
    (func (if cell (cdr cell) def)) ) )

;FIXME use of identity always ?
;FIXME use of default function rather than value ?

(define-syntax opt-ref
  (syntax-rules ()
    ;
    ((opt-ref ?key ?al)
      (opt-ref ?key ?al #f) )
    ;
    ((opt-ref ?key ?al ?func-or-def)
      (opt-cell-value (assq ?key ?al) ?func-or-def) ) ) )

;consistent return type - (not void)
(define-syntax opt-set!
  (syntax-rules ()
    ;
    ((opt-set! ?var ?key ?al)
      (opt-set! ?var ?key ?al #f) )
    ;
    ((opt-set! ?var ?key ?al ?func-or-def)
      (and-let* ((cell (assq ?key ?al)))
        (let ((func-or-def ?func-or-def))
          (set! ?var (opt-cell-value cell func-or-def))
          func-or-def ) ) ) ) )

(define (opt-rest params) (alist-ref '@ params eq? '()))

;;

#; ;
(define (grammar-extension? elm)
  ;(OPTION-NAME [DOCSTRING] (required OPTIONAL-OPTION-NAME-0 OPTIONAL-OPTION-NAME-1 ...))
  (match elm
    (((? symbol? (get! optn-name)) (and ('required (? symbol?) ...) (get! optn-rqrd)))
      #t )
    (((? symbol? (get! optn-name)) (? string? (get! optn-docs)) (and ('required (? symbol?) ...) (get! optn-rqrd)))
      #t ) ) )

(define (required-grammer-option? ls)
  (and (pair? ls)
       (eq? 'required (first ls))
       (<= 2 (length (cdr ls)))
       (every symbol? (cdr ls)) ) )

(define (grammar-components elm)
  (cond ((and (pair? elm) (symbol? (first elm))
              (= 2 (length elm))
              (required-grammer-option? (second elm)))
          (values (first elm) #f (second elm)) )
        ((and (pair? elm) (symbol? (first elm))
              (= 3 (length elm))
              (string? (second elm))
              (required-grammer-option? (third elm)))
          (values (first elm) (second elm) (third elm)) )
        (else
          (values #f #f #f) ) ) )

(define (grammar-extension? elm)
  (->boolean (car (receive (grammar-components elm)))) )

(define (split-extensions grammar)
  (partition grammar-extension? grammar) )

(define (check-grammar-extension params elm)
  (let-values (((nam doc dfs) (grammar-components elm)))
    (let ((rqrds (and dfs (opt-ref 'required dfs))))
          ;no extensions?
      (if (not rqrds) params
          ;else required extension
          (let ((prvs (and (pair? rqrds) (filter (cut assq <> params) rqrds))))
            (if prvs `((,nam . ,prvs) . ,params)
                (begin
                  ;(opt-error "missing #nam option")
                  (void) ) ) )
           ) ) ) )

(define (check-grammar-extensions params extd-grammar)
  (foldl check-grammar-extension params extd-grammar) )

(define (check-extensions params extd-grammar)
  (if (not (pair? extd-grammar)) params
      (check-grammar-extensions params extd-grammar) ) )

;;

(define (opt-docstring msg #!optional val)
  (if (not val) msg
      (string-append msg " " "(" "default" " " (->string val) ")")) )

;;

(define-constant EX_USAGE 64) ;from BSD sysexits.h

(define usage-message (make-parameter "<options> ..."))

;;

#; ;USELESS w/o incl (optn) value
(define (opt-widest grammar)
  (define (symplen sym)
    (string-length (symbol->string sym)) )
  (define (max-symlen optn pare)
    (let ((lngsym (first pare)))
      (if (< (symplen optn) (symplen lngsym)) lngsym
          optn )) )
  (foldl max-symlen '|| grammar) )

;width | separator | indent are getopt-long parameters
(define (get-usage-param key options)
  (define (or-param proc) (or (opt-ref key options) (proc)))
  (case key
    ;getopt-utils
    ((command)
      (opt-ref 'command options (pathname-strip-directory (program-name))))
    ((port)
      (opt-ref 'port options (current-error-port)))
    ;getopt-long
    ((long-option-value-cset)
      (or-param (lambda () default-long-option-value-cset)))
    ((long-option-value-quoting)
      (or-param long-option-value-quoting))
    ((message)
      (or-param usage-message))
    ((width)
      (or-param width))
    ((separator)
      (or-param separator))
    ((indent)
      (or-param indent)) ) )

(define (opt-usage-proto grammar #!optional (options '()))
  (format (get-usage-param 'port options)
          "usage: ~A ~A~%"
          (get-usage-param 'command options)
          (get-usage-param 'message options)) )

;;

(define (opt-usage-newline #!optional (options '()))
  (let ((port (get-usage-param 'port options)))
    (newline port) ) )

(define (opt-error msg args grammar #!optional (options '()))
  (let ((port (get-usage-param 'port options))
        (command (get-usage-param 'command options)) )
    (when command (format port "~A: " command))
    (display msg port)
    (unless (null? args)
      (display #\: port)
      (for-each (cut format port " ~S" <>) args) )
    (newline port) ) )

(define (opt-exn-error exn grammar #!optional (options '()))
  (opt-error (get-condition-property exn 'exn 'message "")
             (get-condition-property exn 'exn 'arguments '())
             grammar
             options) )

(define (opt-usage grammar #!optional (options '()))
  (let ((port (get-usage-param 'port options)))
    (opt-usage-proto grammar options)
    (parameterize ((usage-message (get-usage-param 'message options))
                   (width (get-usage-param 'width options))
                   (separator (get-usage-param 'separator options))
                   (indent (get-usage-param 'indent options)) )
      (display (usage grammar) port) ) ) )

(define (opt-usage-error exn grammar #!optional (options '()) (exit-code EX_USAGE))
  (opt-usage-newline options)
  (if (string? exn) (opt-error exn '() grammar options)
      (opt-exn-error exn grammar options) )
  (opt-usage-newline options)
  (opt-usage grammar options)
  (exit exit-code) )

;
(define (make-unknown-handler args grammar #!optional (options '()) (exit-code EX_USAGE))
  (lambda (opts)
    (opt-error "unknown options" opts grammar options)
    (opt-usage grammar options)
    (exit exit-code) ) )

;;

(define opt-exit-code (make-parameter 1 (lambda (x)
  (if (fixnum? x) x
      (begin
        (warning 'opt-exit-code "invalid exit code" x)
        (opt-exit-code))))))

;;

(define (process-extended elm)
  (let ((nam (first elm)))
    (if (atom? nam) elm
        (let ((lnam (first nam))
              (snam (second nam))
              (desc? (string? (second elm))) )
          (append! `(,lnam)
                   (if desc? `(,(second elm)) '())
                   `((single-char ,(string-ref (symbol->string snam) 0)))
                   (list-tail elm (if desc? 2 1))) ) ) ) )

(define-syntax extend-opt-grammar

  (syntax-rules ()
    ;
    ((extend-opt-grammar #f ?elm0 ...)
      (extend-opt-grammar () ?elm0 ...) )
    ;
    ((extend-opt-grammar #t ?elm0 ...)
      (extend-opt-grammar (((help h) "this message")) ?elm0 ...) )
    ;
    ((extend-opt-grammar (?src0 ...) ?elm0 ...)
      (map process-extended (append `(?elm0 ...) `(?src0 ...))) )
    ;
    ((extend-opt-grammar ?src ?elm0 ...)
      (map process-extended (append `(?elm0 ...) ?src)) ) ) )

;@kind `*' : (read) ->string function

(define (string-read s) (with-input-from-string s read))

(define-syntax string->/?
  (syntax-rules (identity)
    ((string->/? identity identity)
      identity )
    ((string->/? ?tran identity)
      ?tran )
    ((string->/? identity ?pred)
      (lambda (x) (and (?pred x) x)) )
    ((string->/? ?tran ?pred)
      (lambda (x) (and-let* ((a (?tran x)) ((?pred a))) a)) ) ) )

(define-syntax opt-value
  (syntax-rules (identity)
    ;
    ((opt-value (?ro ?k))
      (opt-value (?ro ?k) (identity identity)) )
    ;
    ((opt-value ?k)
      (opt-value (optional ?k)) )
    ;
    ((opt-value (?ro ?k) (?t))
      (opt-value (?ro ?k) (?t identity)) )
    ;
    ((opt-value (?ro ?k) (?t ?p?))
      (opt-value ?ro ?k ?t ?p?) )
    ;
    ((opt-value (?ro ?k) ?p?)
      (opt-value (?ro ?k) (identity ?p?)) )
    ;
    ((opt-value ?k (?t))
      (opt-value (optional ?k) (?t identity)) )
    ;
    ((opt-value ?k (?t ?p?))
      (opt-value (optional ?k) (?t ?p?)) )
    ;
    ((opt-value ?k ?p?)
      (opt-value (optional ?k) (identity ?p?)) )
    ;
    ((opt-value ?ro ?k identity identity)
      `((value (?ro ?k))) )
    ;
    ((opt-value ?ro ?k ?t identity)
      `((value
        (?ro ?k)
        (transformer ,?t))) )
    ;
    ((opt-value ?ro ?k identity ?p?)
      `((value
        (?ro ?k)
        (predicate ,?p?))) )
    ;
    ((opt-value ?ro ?k ?t ?p?)
      (let ((tp? (string->/? ?t ?p?)))
        `((value
          (?ro ?k)
          (predicate ,tp?)
          (transformer ,tp?))) ) ) ) )

(define-syntax opt-body
  (syntax-rules ()
    ;
    ((opt-body (?m ...))
      `(,(opt-docstring ?m ...)) )
    ;
    ((opt-body ?m)
      (opt-body (?m)) )
    ;
    ((opt-body (?m ...) ?R ...)
      `(,(opt-docstring ?m ...)
        ,@(opt-value ?R ...)) )
    ;
    ((opt-body ?m ?R ...)
      (opt-body (?m) ?R ...) ) ) )
    
(define-syntax opt-number
  (syntax-rules ()
    ;
    ((opt-number ?M)
      (opt-body ?M (string->number)) )
    ;
    ((opt-number ?M ?R)
      (opt-number ?M ?R identity) )
    ;
    ((opt-number ?M ?R ?p?)
      (opt-body ?M ?R (string->number ?p?)) ) ) )
    
(define-syntax opt-string
  (syntax-rules ()
    ;
    ((opt-string ?M)
      (opt-body ?M (identity)) )
    ;
    ((opt-string ?M ?R)
      (opt-string ?M ?R identity) )
    ;
    ((opt-string ?M ?R ?p?)
      (opt-body ?M ?R ?p?) ) ) )

;;

(define (perform-help help-obj grammar options)
  (opt-usage grammar options)
  (exit (opt-exit-code)) )

(define (app-arguments args)
  (if (not (feature? 'chicken-script)) args
      (if (or (null? args) (not (string=? "--" (car args)))) args
          (cdr args)) ) )

;grammar extensions:
;
; - (OPTION-NAME [DOCSTRING] (required OPTIONAL-OPTION-NAME-0 OPTIONAL-OPTION-NAME-1 ...))

;
; @args : CLI arguments
; @grammar : getopt-long option statement
; @options : list-of message | width | separator | indent | port | command
; @raw?    : treat chicken-script -- arguments as @args, default #f
; @ : alist - ((option . value) ...) where '@ is list-of unconsumed args
;
(define (opt-parse args grammar #!optional (options '()) (raw? #f))
  (let ((args (if raw? args (app-arguments args))))
    (if (null? args) args
        (handle-exceptions exn
          (begin
            ;doesn't return
            (opt-usage-error exn grammar options) )
          ;FIXME add options unknown-option-handler & long-option-value-cset
          (receive (extd-grammar base-grammar) (split-extensions grammar)
            (let* ((handler (make-unknown-handler args grammar options))
                   (cset (get-usage-param 'long-option-value-cset options))
                   (quoting? (get-usage-param 'long-option-value-quoting options))
                   (params
                     (parameterize ((long-option-value-quoting quoting?))
                       (getopt-long args base-grammar
                                         unknown-option-handler: handler
                                         long-option-value-cset: cset)) ) )
              (cond ((opt-ref 'help params)
                      => (cut perform-help <> grammar options))
                    (else
                      (check-extensions params extd-grammar) ) ) ) ) ) ) ) )

;;

;abstract 'help' into operators & handlers

) ;module getopt-utils