;;; Config --- Configuration specification in GNU Guile
;;; Copyright © 2017 Alex Sassmannshausen <alex@pompo.co>
;;;
;;; This file is part of Guile-Config.
;;;
;;; Config 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.
;;;
;;; Config 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 Guile-Config; if not, contact:
;;;
;;; Free Software Foundation           Voice:  +1-617-542-5942
;;; 59 Temple Place - Suite 330        Fax:    +1-617-542-2652
;;; Boston, MA  02111-1307,  USA       gnu@gnu.org

(define-module (config getopt-long)
  #:use-module (config api)
  #:use-module (ice-9 getopt-long)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:export (read-commandline))

(define (option-ref options key default)
  (match (filter-map (match-lambda
                       ((name . value) (and (equal? name key) value)))
                     options)
    (() default)
    ((unique) unique)
    (v v)))

;; We no longer use getopt-long's predicate functionality because using it
;; would result in running an option's handler twice during parsing.  This is
;; problematic when that handler performs side effects.
(define (read-commandline commandline settings codex)
  "Return a codex, with commandline merged into codex, getopt-long style."
  ;; Turn Codex into getopt-long construct, then query getopt-long with
  ;; commandline values and feed those back into codex.
  ;;
  ;; Specifically we pass reagents modified (not raw) commandline values to
  ;; getopt-long.
  (define (augment-keywords)
    "Return additional switches for help, usage, version, if requested."
    (filter-map (match-lambda
                  ((id chr #t)
                   (switch
                    (name id) (character chr) (test boolean?) (default #f)
                    (handler identity) (optional? #f))) 
                  ((_ _ (or #f ($ <empty>))) #f)
                  (n (throw 'augment-keywords "no matching pattern" n)))
                `((help #\h ,(codex-metadatum 'generate-help? codex))
                  (usage #f ,(codex-metadatum 'generate-usage? codex))
                  (version #f ,(codex-metadatum 'generate-version? codex))
                  (cmdtree #f ,(codex-metadatum 'generate-cmdtree? codex)))))
  (define (getopt-long-parse kwds port)
    "Attempt to parse COMMANDLINE with the keywords KWDS using getopt-long.
If the latter errors, parse errors into our format, and re-throw them."
    (define (find-kwd name)
      (find (compose (cute eqv? <> (string->symbol (string-drop name 2)))
                     (match-lambda
                       ((? switch? sw) (switch-name sw))
                       ((? setting? se) (setting-name se))))
            kwds))
    (define (find-val name)
      (catch 'found
        (λ _
          (for-each (λ (hay)
                      (match (string-match (string-append "^" name "=(.*)$")
                                           hay)
                        (#f #f)
                        (m (throw 'found (match:substring m 1)))))
                    commandline))
        (λ (_ needle) needle)))
    ;; getopt-long here causes unstructured exits.
    ;; We trigger them when:
    ;; - keyword argument is mandatory but not present
    ;;   + Message: $script: option must be specified: --$option
    ;; - unknown keyword argument provided
    ;;   + $script: no such option: --$option
    ;; - boolean keyword is assigned a value
    ;;   + $script: option does not support argument: --$option
    ;; - non-boolean keyword is not assigned a value
    ;;   + $script: option must be specified with argument: --$option
    (with-error-to-port port
      (λ _
        (catch 'quit
          (λ _
            (getopt-long (cons "_" commandline) (codex->getopt-spec kwds)))
          (match-lambda*
            (('quit 1)
             (apply throw 'getopt-long
                    (let ((str (get-output-string port)))
                      (close-output-port port)
                      (match (map string-trim-both (string-split str #\:))
                        ((_ "option must be specified with argument" name)
                         (list 'expect-value (find-kwd name) #f))
                        ((_ "option must be specified" name)
                         (list 'mandatory-missing (find-kwd name) #f))
                        ((_ "no such option" name)
                         (list 'unknown-keyword #f name))
                        ((_ "option does not support argument" name)
                         (list 'expect-boolean (find-kwd name)
                               (find-val name)))))))
            (('quit n)
             (throw 'unexpected-getopt-long
                    n (let ((str (get-output-string port)))
                        (close-output-port port)
                        str))))))))
  (let* ((vls (codex-valus codex))
         (kwds (append (valus-keywords vls) (augment-keywords)))
         (port (open-output-string))
         (gtl (getopt-long-parse kwds port)))
    (close-output-port port)
    ;; FIXME: test-codex is only called after handlers have been run against
    ;; commandline values. This means that we will get an ugly error message
    ;; when a handler chokes on commandline input.
    ;; The fix is to expect handlers may fail and to emit an appropriate error
    ;; at htat point too, much like when predicates fail.
    (test-codex
     (set-codex-valus
      codex
      (valus
       (parse-keywords kwds settings gtl)
       ;; Arguments can't be retrieved by name with getopt-long.  Instead,
       ;; fetch all args, then handle them ourselves.
       (parse-arguments (valus-arguments vls) (option-ref gtl '() '())))))))

(define (parse-keywords keywords settings getopt-long)
  "Cycle through KEYWORDS, the keywords of the codex, and update them with
values provided on the commandline or configuration file contained in
GETOPT-LONG, a getopt-long datastructure."
  (define (set-kw kwd value)
    (set-keyword-default kwd
                         ((keyword-handler kwd)
                          (match value
                            ((? list?)
                             (fold (keyword-merge-strategy kwd)
                                   '() value))
                            (_ value)))))
  (map (lambda (kwd)
         ;; When a value is provided on the commandline it should always
         ;; take precedence over config files or defaults.  Use it after
         ;; running it through handler & test
         (cond ((secret? kwd) kwd)      ; <secret>: default
               ((switch? kwd)           ; <switch>: cmdline | default
                (match (option-ref getopt-long (switch-name kwd) (empty))
                  (($ <empty>) kwd)     ; Not on cmdline, so default
                  (value                ; cmdline
                   (set-kw kwd value))))
               ((setting? kwd)          ; <setting>: cmdline | file | default
                (match (option-ref getopt-long (setting-name kwd) (empty))
                  (($ <empty>)     ; Not on cmdline, so config file or default
                   (or (and=> (assoc (setting-name kwd) settings)
                              (compose (cut set-keyword-default kwd <>)
                                       cdr))
                       kwd))
                  (value                ; cmdline
                   (set-kw kwd value))))))
       keywords))

(define* (parse-arguments arguments cmd-values #:optional (result '()))
  "Cycle through ARGUMENTS, the configuration's defined arguments, &
CMD-VALUES the arguments provided on the command-line, returning a new list of
arguments in RESULT after testing them & updating them from CMD-VALUES."
  (cond ((null? arguments)
         ;; Processed all arguments, -> done.
         (reverse result))
        ((null? cmd-values)
         ;; We're out of cmdline arguments, -> defaults for rest
         (append (reverse result) (map test-optional-argument arguments)))
        (else
         (parse-arguments
          (cdr arguments)
          (cdr cmd-values)
          (cons
           (set-argument-default (first arguments)
                                 ((argument-handler (first arguments))
                                  (first cmd-values)))
           result)))))

(define (test-optional-argument argument)
  "Return ARGUMENT if it is optional or emit an error."
  (if (argument-optional? argument)
      argument
      (throw 'getopt-long 'mandatory-missing argument #f)))

(define (test-codex cdx)
  (for-each (cute test-kwd/arg <> cdx)
            (let ((valus (codex-valus cdx)))
              (append (valus-keywords valus)
                      (valus-arguments valus))))
  cdx)

(define* (test-kwd/arg kwd/arg cdx)
  "Return VALUE if it passes TEST or throw an error pointing at NAME of TYPE."
  (define (test predicate value)
    (if (match (procedure-minimum-arity predicate)
          ((2 _ _) (predicate value cdx))
          (_ (predicate value)))
        value
        (throw 'getopt-long 'predicate-fails kwd/arg value)))
  (match kwd/arg
    ((? secret?) (secret-default kwd/arg))
    ((? setting?)
     (test (setting-test kwd/arg) (setting-default kwd/arg)))
    ((? switch?)
     (test (switch-test kwd/arg) (switch-default kwd/arg)))
    ((? argument?)
     (test (argument-test kwd/arg) (argument-default kwd/arg)))))

(define (codex->getopt-spec keywords)
  "Return the getopt-long option-spec corresponding to the <setting> and
    <switch> keywords in KEYWORDS."
  (reverse
   (fold
    (lambda (kwd done)
      (let ((character (keyword-character kwd)))
        (match kwd
          (($ <switch> name ($ <empty>) test handler _ _ _ _ #f)
           ;; A switch is only mandatory if optional is #f
           (cons (getopt-spec name test handler character #f #t) done))
          (($ <switch> name _ test handler _ _ _ _ optional)
           (cons (getopt-spec name test handler character optional #f) done))
          (($ <setting> name ($ <empty>) test handler _ _ _ _ optional)
           (cons (getopt-spec name test handler character optional #f) done))
          (($ <setting> name _ test handler _ _ _ _ optional)
           (cons (getopt-spec name test handler character optional #f) done))
          (_ done))))
    '()
    (filter (negate secret?)
            keywords))))

(define (getopt-spec name test handler single-char optional? required)
  "Create a getopt-long spec entry from NAME, TEST, HANDLER, SINGLE-CHAR,
    OPTIONAL? and REQUIRED."
  (define (value-entry)
    (match (procedure-name test)
      ;; If our test is boolean, we parse params as flags
      ('boolean? '((value #f)))
      ;; If optional?, parse param value as optional, else as valued.
      (_  (if optional?
              '((value optional))
              '((value #t))))))

  (apply list name `(required? ,required)
         (match single-char
           ((? char?) (cons `(single-char ,single-char)
                            (value-entry)))
           (#f        (value-entry))
           (n (throw 'getopt-spec "no matching pattern" n)))))
