#lang racket/base

(require gregor
         racket/match
         racket/string
         txexpr)

(provide ->text
         first-words
         ymd->english)

(module+ test (require rackunit))

;; Concatenate the string elements of a txexpr or list together
(define (->text v)
  (match v
    [(txexpr _ _ elements) (->text elements)]
    [(list elements ...) (string-append* (map ->text elements))]
    [(? string? s) s]
    [_ ""]))

;; Return the first N words out of a list of txexprs. This function will unpack the strings out of
;; the elements of one txexpr at a time until it finds the requested number of words. It aims to be
;; both reliable and fast for any size of list you pass it, and smart about the punctuation it
;; allows through.

(define punc-allowed-in-word '(#\- #\' #\% #\$ #\‘ #\’ #\# #\& #\/ #\. #\!))
  
(define (word-boundary? c) (or (char-whitespace? c) (equal? c #\null) (eof-object? c)))
(define (word-char? c) (or (char-alphabetic? c) (char-numeric? c)))

(define (first-words txprs words-needed)
  (define in (open-input-string (->text (car txprs))))
  (define out (open-output-string))
  
  (define words-found
    (let loop ([words-found 0] [last-c #\null] [last-c-in-word? #f])
      (define c (read-char in))

      (cond [(equal? words-found words-needed) words-found]
            [(eof-object? c)
             (cond [(positive? words-found) (if last-c-in-word? (+ 1 words-found) words-found)]
                   [else 0])]
            [else
             (define-values (write-this-char? new-word-count c-in-word?)
               (cond
                 ;; Spaces increment the word count if the previous character was part of,
                 ;; or adjacent to, a word
                 [(and (char-whitespace? c) last-c-in-word?)
                  (values (if (equal? words-needed (+ 1 words-found)) #f #t) (+ 1 words-found) #f)]
                 ;; Some punctuation survives if the previous or next char is part of a word
                 [(member c punc-allowed-in-word)
                  (cond [(or (word-char? last-c) (word-char? (peek-char in)))
                         (values #t words-found #t)]
                        [else (values #f words-found #f)])]
                 [(word-char? c)
                  (values #t words-found #t)]
                 ;; If c is a non-whitespace non-allowed character that immediately follows a word,
                 ;; do not write it out but count it as being part of the word.   
                 [(and (not (word-char? c)) (not (char-whitespace? c)) last-c-in-word?)
                  (values #f words-found #t)]
                 [else (values #f words-found #f)]))

             (cond [(and (char-whitespace? c) write-this-char?) (write-char #\space out)]
                   [write-this-char? (write-char c out)])
             (loop new-word-count c c-in-word?)])))
  
  (define words (get-output-string out))
  (cond [(equal? words-found words-needed) (string-append words "…")]
        [(equal? '() (cdr txprs)) words]
        [else (string-append words " " (first-words (cdr txprs) (- words-needed words-found)))]))

(module+ test
  (require rackunit)
  (define txs-decimals
    '((p "Four score and 7.8 years ago — our fathers brought forth on this continent etc etc")))
  (define txs-punc+split-elems
    '((p "“Stop!” she called.") (p "(She was never one to be silent.)")))
  (define txs-dashes
    '((p [[class "newthought"]] (span [[class "smallcaps"]] "One - and") " only one.")
      (p "That was all she would allow.")))
  (define txs-parens-commas
    '((p "She counted (" (em "one, two") "— silently, eyes unblinking")))
  (define txs-short
    '((span "Not much here!")))

  (check-equal? (first-words txs-decimals 5) "Four score and 7.8 years…")
  (check-equal? (first-words txs-punc+split-elems 5) "Stop! she called. She was…")
  (check-equal? (first-words txs-dashes 5) "One and only one. That…")
  (check-equal? (first-words txs-dashes 4) "One and only one.…")
  (check-equal? (first-words txs-parens-commas 5) "She counted one two silently…")
  (check-equal? (first-words txs-short 5) "Not much here!"))

;; ~~~ Convenience functions for YYYY-MM-DD date strings ~~~

;; These functions ignore everything after the first space in the input!
(define (ymd->dateformat ymd-string dateformat)
  (~t (iso8601->date (car (string-split ymd-string))) dateformat))

(define (ymd->english ymd-string)
  (ymd->dateformat ymd-string "MMMM d, yyyy"))

(module+ test
  (check-equal? (ymd->english "2018-08-12") "August 12, 2018")
  (check-equal? (ymd->dateformat "2018-08-12" "d MMM YYYY") "12 Aug 2018")

  ;; How we handle weird input
  (check-equal? (ymd->english "2018-08-12 everything after 1st space ignored") "August 12, 2018")
  (check-equal? (ymd->english "2018-08 omitting the day") "August 1, 2018")
  (check-equal? (ymd->english "2018 omitting month and day") "January 1, 2018")
  (check-equal? (ymd->dateformat "2018-08-12" "123") "123")

  ;; Stuff we just don't handle
  (check-exn exn:gregor:parse? (lambda () (ymd->english "2018-xyz"))))
