#lang racket

(require "spec-ast.rkt")

(provide/contract
 [print-usage (spec? . -> . any)]
 [print-command-usage (command? . -> . any)]
 [format-usage (spec? . -> . string?)]
 [format-command-usage (command? . -> . string?)])

;; format-usage :: Spec -> String
;; returns string w/ command usage
(define format-usage
  (lambda (spec)
    (let ([p (open-output-string)])
      (parameterize ([current-output-port p])
        (print-usage spec))
      (get-output-string p))))

(define format-command-usage
  (lambda (cmd)
    (let ([p (open-output-string)])
      (parameterize ([current-output-port p])
        (print-command-usage cmd))
      (get-output-string p))))

;; print-usage :: Spec -> void
;; prints usage information and tail-calls current current-usage-continuation
(define print-usage
  (lambda (spec)
    (printf "Usage: ~a <subcommand> <option> ... <arg> ...~n"
            (spec-program spec))
    (printf "~a~n~n" (spec-help spec))
    (printf "Available subcommands:~n")
    (for-each
     (lambda (cmd)
       (printf "  ~a: ~a~n" (command-name cmd) (command-short-help cmd)))
     (sort (spec-commands spec) string<? #:key command-name))))

;; print-command-usage :: Command -> alpha
;; prints detailed usage info for single command then tail-calls current
;; current-usage-continuation
(define print-command-usage
  (match-lambda
    [(and cmd
          (command name short-help long-help positional-args rest-arg flags _))
     (printf "~a: ~a~n" name short-help)
     (printf "usage: ~a~a~n"
             name
             (format-command-header cmd))
     (when (not (string=? long-help ""))
       (printf "~n~a~n" long-help)
       (when (not (null? flags))
         (printf "~n")))
     (when (not (null? flags))
       (printf "Valid options:~n")
       (print-flag-info flags))]))

;; print-flag-info :: (Listof Flag) -> ()
;; Writes info about flags of a single command to current output port
(define print-flag-info
  (match-lambda
    [(list)
     (printf "  --help : Show this help~n")
     ;; (printf "  -- : Do not treat any remaining argument as a switch~n")
     (printf " * Asterisks indicate options allowed multiple times.~n")
     (printf " /|\\ Brackets indicate mutually exclusive options.~n")]
    [(cons (optional-flag switches _ help args) rest)
     (print-flag-line " " switches args help)
     (print-flag-info rest)]
    [(cons (multi-flag switches _ help args) rest)
     (print-flag-line "*" switches args help)
     (print-flag-info rest)]
    [(cons (group (cons (optional-flag first-switches _ first-help first-args)
                        group-rest))
           rest)
     (print-flag-line "/" first-switches first-args first-help)
     (let loop [(flags group-rest)]
       (match flags
         [(list (optional-flag switches _ help args))
          (print-flag-line "\\" switches args help)
          (print-flag-info rest)]
         [(cons (optional-flag switches _ help args) rest)
          (print-flag-line "|" switches args help)
          (loop rest)]))]))


;; print-flag-line :: String (Set String) (Listof Symbol) (Listof String)
;;                 -> Unit
;; prints line describing a single flag
(define print-flag-line
  (lambda (prefix switches args help)
    (printf "~a~n"
            (string-join-non-empty
             (list*
              prefix
              (string-join (sort-for-printing (set->list switches)) ", ")
              (string-join (map format-arg args) " ")
              ":"
              help)
             " "))))

;; format-arg :: Symbol -> String
;; formats formal argument (either switch or positional) for printing
(define format-arg
  (lambda (arg)
    (format "<~a>" arg)))

;; sort-for-printing :: (Listof String) -> (Listof String)
;; returns switches with short before long, both sorted alphabetically.
;; WISH LIST: use case only as a tie-breaker, esp. for short switches.
(define sort-for-printing
  (lambda (switches)
    (sort switches
          (lambda (s1 s2)
            (cond
             [(and (short-switch? s1) (short-switch? s2))
              (string-case-tie-break<? s1 s2)]
             [(and (long-switch? s1) (long-switch? s2))
              (string-case-tie-break<? s1 s2)]
             [else (short-switch? s1)])))))

;; format-command-header :: Command -> String
;; formats header for detailed command help
(define format-command-header
  (lambda (cmd)
    (let* ([flags (if (null? (command-flags cmd)) "" "[<option> ...]")]
           [positional-args
            (string-join
             (map format-arg (command-positional-args cmd))
             " ")]
           [rest-arg
            (let ([rest-arg-name (command-rest-arg cmd)])
              (if rest-arg-name
                  (format "[<~a> ...]" rest-arg-name)
                  ""))]
           [short-arg-text
            (string-join-non-empty (list flags positional-args rest-arg) " ")])
      (if (string=? short-arg-text "")
          ""
          (string-append " " short-arg-text)))))

;; string-case-tie-break<? :: String String -> Boolean
;; compares two strings for order case insensitively, but uses case as a
;; tie-breaker.
(define string-case-tie-break<?
  (lambda (s1 s2)
    (if (string-ci=? s1 s2)
        (string<? s1 s2)
        (string-ci<? s1 s2))))

;; string-join-non-empty :: (Listof String) String -> String
;; like string-join, but filters out empty strings first
(define string-join-non-empty
  (lambda (strs delim)
    (string-join (filter (lambda (s) (not (string=? s ""))) strs) delim)))

;; set->list :: (Set a) -> (List a)
;; returns a list containing all elements of s
(define set->list
  (lambda (s)
    (set-map s (lambda (x) x))))