;;; This file is the implementation for the teachpack
;;;    xexpr210.ss
;;; Change any functions here, but if you change
;;; what functions are import/exported, be sure to change xexpr210.ss.
;;;
;;; Also note that this file doesn't run stand-alone, since it
;;; requires some libraries (xml.ss, file.ss, function.ss).



(collapse-whitespace true) ; When reading xml, collapse all white space to a single space.


;; Some renames:
;;
(define (false? x) (and (boolean? x) (not x))) ; Useful for checking for a sentinel return value.
(define (true?  x) (and (boolean? x)      x )) ; Probably not useful, but included for completeness.

(define  list-ref0          list-ref)
(define (list-ref1 items n) (list-ref items (sub1 n)))

(define (one? n) (= n 1))
(define (length1? lst) (one? (length lst)))




;; pad2: number-->string
;; Like number->string but string has length 2 (padded with leading 0 if needed).
;; Bug: well, this prepends a 0 any time the number was only one digit.
;;
(define (pad2 num)
  (let* {[str  (number->string num)]}
    (if (one? (string-length str))
        (string-append "0" str)
        str)))

;; date->ian-string:
;; Like date->string, but in the format i like.
;; (Cf. date-display-format)
;;
(define date->ian-string 
  (case-lambda 
   [(date)
    (date->ian-string date true)]
   [(date include-time?)
    (let* {[weekday-names-short '("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat")]
           [month-names-short   '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")]
           [date-string (format "~a.~a.~a (~a)"
                                (date-year date)
                                (list-ref1 month-names-short (date-month date))
                                (pad2 (date-day date)) 
                                (list-ref0 weekday-names-short (date-week-day date)))]
           [time-string (format "~a:~a:~a"
                                (pad2 (date-hour date)) (pad2 (date-minute date)) (pad2 (date-second date)))]}
      (if include-time?
          (string-append date-string ", " time-string)
          date-string))]))

;; current-date-string: boolean --> string
;; Return the string representation of the current date;
;; include the time if the argument is true.
;; 
;; See also date->string, date-display-format, and current-seconds
;; (in help-desk).
;;
(define (current-date-string include-time?)
  (date->ian-string (seconds->date (current-seconds)) include-time?))




;; has-suffix?:   string, string --> boolean
;; remove-suffix: string, string --> string
;; Test for, or remove, suff at the end of str.
;;
(define (has-suffix?   str suff)
  (and (>= (string-length str) (string-length suff))
       (string-ci=? suff (substring str (- (string-length str) (string-length suff))
                                        (string-length str)))))
   
(define (remove-suffix str suff)
  (unless (has-suffix? str suff)  (error 'remove-suffix (format "~s doesn't end in ~s." str suff)))
  (substring str 0 (- (string-length str) (string-length suff))))



;;;;;;;

;; with-output-overwrite?-file: string thunk boolean boolean --> (void)
;; Like with-output-to-file, except that if overwrite? is true,
;; delete any already-existing file by that name.
;; If verbose? is true, print a message.
;;
;; BUG: probably this should (have a flag allowing) output to a temporary file,
;;      and only delete the original once the output succeeded.
;;
(define (with-output-overwrite?-file pathname thunk overwrite? verbose?)
  (begin (when (and overwrite? (file-exists? pathname)) 
           (if verbose? (printf "Over"))
           (delete-file pathname))
         (if verbose? (printf "Writing ~s.." pathname))
         (with-output-to-file pathname thunk)
         (if verbose? (printf ".done.~n"))))



;; trim-white-string: string --> string
;; trim-white-chars: (list* char) --> (list* char)
;; Remove all leading and trailing white-space.
;;
(define (trim-white-chars chars)
  (cond [(empty? chars) empty]
        [(char-whitespace? (first chars))
         (trim-white-chars (rest chars))]
        [else chars]))
(define (trim-white-string str)
  (list->string (reverse (trim-white-chars (reverse (trim-white-chars (string->list str)))))))


;(trim-white-string "   \t hello   \nthere\n") = "hello  \nthere"


;; xexpr->file: See contract in xexpr210.ss.
;;
(define xexpr->file
  (case-lambda [(xexpr fname overwrite?)
                (xexpr->file xexpr fname true overwrite? true)]
               [(xexpr fname attrs-as-tags? overwrite? verbose?)
                (let* {[the-expr (if attrs-as-tags? (tags->attrs xexpr) xexpr)]}
                  (begin
                    (with-output-overwrite?-file 
                     fname 
                     (lambda () (write-xml/content (xexpr->xml the-expr)))
                     overwrite?
                     verbose?)
                    true))]))


;; file->xexpr: See contract in xexpr210.ss.
;;
(define file->xexpr 
  (case-lambda [(fname)
                (file->xexpr fname true)]
               [(fname attrs-as-tags?)
                (let* {[the-expr
                        (with-input-from-file fname
                          (lambda () (xml->xexpr ((eliminate-whitespace '() identity) 
                                                  (document-element (read-xml))))))]}
                  (if attrs-as-tags? (attrs->tags the-expr) the-expr))]))

#|
(xexpr->file "sample-gallery.xml"
             '(gallery (title "Me at the Britney Spears Concert")
                       (picture (filename "pict01.jpg")
                                (caption "Waiting in line for a Pepsi."))
                       (picture (filename "pict07.jpg")
                                (caption "Waiting in line for " (em "another") " Pepsi."))
                       (picture (caption "Waiting in line for the bathroom.")
                                (filename "pict19.jpg")))
             false
             true)
|#

;; attrs->tags: xexpr --> xexpr
;; Replace a real xexpr (whose second item is the attribute-list),
;; with an xexpr with no attribute list, but with
;; sub-tags '(attr key val).
;; For use with the simplified definition for comp210-hw05 01.fall.
;; (really, the hw should have included the attr-list.)
;;
(define (attrs->tags xexpr)
  (cond [(not (cons? xexpr)) xexpr]
        [else (let* {[tag   (first xexpr)]
                     [attrs (second xexpr)]
                     [body  (rest (rest xexpr))]
                     [body-processed (map attrs->tags body)]
                     [tags  (map (lambda (pr) `(attr ,(first pr) ,(second pr))) attrs)]}
                `(,tag ,@tags ,@body-processed))]))

;(attrs->tags '(gallery () (title () "hi") (picture [(img "foo.jpeg") (alt "oops")] (caption () "boring picture"))))

 

;; attrs->tags: xexpr --> xexpr
;; The inverse of tags->attrs:
;; take an xexpr where EVERY tagged xexpr includes an attribute list as its second item,
;; and return an xexpr w/o attribute list, 
;; but with a bunch of <attr><sym> <string></attr> elements.
;;
(define (tags->attrs xexpr)
  (cond [(not (cons? xexpr)) xexpr]
        [else (let* {[tag (first xexpr)]
                     [is-attr? (lambda (xexpr) (and (cons? xexpr) 
                                                    (symbol? (first xexpr)) 
                                                    (symbol=? 'attr (first xexpr))))]
                     [body (rest xexpr)]
                     [body-no-attrs (filter (lambda (x) (not (is-attr? x))) (rest xexpr))]
                     [body-processed (map tags->attrs body-no-attrs)]
                     [body-attrs    (filter is-attr? (rest xexpr))]
                     [attr-list  (map (lambda (attr) (list (second attr) (third attr))) body-attrs)]}
                `(,tag ,attr-list ,@body-processed))]))
         
;(tags->attrs '(gallery (title "hi") (picture (attr img "foo.jpeg") (attr alt "oops") (caption "boring picture"))))