; Blogue for MzScheme
; Copyright 2005 Jay McCarthy <>
(module blogue mzscheme
  (require (lib "")
           (lib "")
           (lib "")
           (lib "")
           (lib ""))
  (require (planet "" ("jaymccarthy" "mmss.plt" 1))
           (planet "" ("jaymccarthy" "mmss.plt" 1))
           (planet "" ("jaymccarthy" "mmss.plt" 1)))
  (require ""
  (provide build-site)
  ; Util
  (define (Month->MonthName M)
    (month-name/number (string->number M)))
  ; Interface
  (define (build-site config@)
    (define site@
        (link (CONFIG : blogue-config^ (config@))
              (CORE : blogue^ (blogue@ CONFIG)))
    (invoke-unit/sig site@))
  ; Internal
  (define blogue@
    (unit/sig blogue^
      (import blogue-config^)                            
      ; Formatting         
      (define (gen-Post-FXexpr p)
        (let ([Body (Post-Content p)]
              [Permapath (Post-Permapath p)])
          (EntryTemplate Permapath
                         (Post-Date-tm p)
                         (map bytes->string/utf-8 (Post-Category p))
                         (Post-Title p)
                         ; Add paragraph level anchors
                         (let loop ([I Body] [x 1] [R '()])
                           (if (null? I) R
                               (let ([c (car I)])
                                 (if (and (list? c) (not (null? c)) (eq? (car c) 'p))
                                     (loop (cdr I) (+ x 1)
                                           (let ([p-id (string-append "e" (regexp-replace "Post" (regexp-replace* "/" (Post-Id p) "") "")
                                                                      "p" (number->string x))])
                                             (append R
                                                     `( (p ([id ,p-id])
                                                           ,@(cddr c)
                                                           (a ([class "pglink"] [href ,(string-append Permapath "/#" p-id)]) "#")) ))))
                                     (loop (cdr I) x (append R (list c))))))))))
      (define (format-Post! w pi)
        (let ([p (World-Post w pi)])
          (when (eq? (Post-FXexpr p) 'error)
            (set-World-Post! w (copy-struct Post p [Post-FXexpr (gen-Post-FXexpr p)])))
      (define (format-year w Y)
          ,@(map (lambda (M)
                   `(li (a ([href ,(format "/Archives/~a/~a" Y M)]) ,(Month->MonthName M))))
                 (reverse (World-DateMap-Year/Months w Y)))))
      (define (format-calendar w Y M Previous Next)
        (let ([Mn (Month->MonthName M)]
              [Date->Month (lambda (D) (match-let ([(list _ Year Month) (regexp-match "(....)/(..)" D)]) Month))])
          `(table ([class "calendar"])
                  (tr (td ([class "label"] [colspan "7"]) ,Mn " " ,Y))
                  (tr ([class "header"])
                      (td "Sun") (td "Mon") (td "Tue") (td "Wed") (td "Thu") (td "Fri") (td "Sat"))
                  ,@(map (lambda (week)
                           `(tr ,@(map (lambda (day-n)
                                         (if (not (number? day-n))
                                             `(td ,(let* ([sday (number->string day-n)]
                                                          [day (if (< day-n 10) (string-append "0" sday) sday)])
                                                     (if (World-DateMap-Year/Month/Day-Posts? w Y M day)
                                                         `(a ([href ,(format "/Archives/~a/~a/~a" Y M day)]) ,day)
                         (generate-calendar (string->number Y) (string->number M)))
                  (tr ([class "footer"])
                      (td ([colspan "7"]) 
                          ,@(if Previous 
                                `((a ([href ,(format "/Archives/~a" Previous)]) ,(Month->MonthName (Date->Month Previous))))
                                `(nbsp nbsp nbsp))
                          ,@(if Next
                                `((a ([href ,(format "/Archives/~a" Next)]) ,(Month->MonthName (Date->Month Next))))
                                `(nbsp nbsp nbsp)))))))
      (define (format-category w Category Subcategories Posts)
        `((div ([id "subcategories"])
               (ul ,@(map (lambda (Child)
                            `(li (a ([href ,(string-append "/Categories" Child)]) ,Child)))
                          (quicksort (map bytes->string/utf-8 Subcategories) string<?))))
          ,@(map (lambda (pi) (Post-FXexpr (World-Post w pi)))
                 (list-head (quicksort Posts string>?) PostsInCategory))))
      ; Writing     
      (define (write-template! Path Title Previous Next DisplayAds Body)
        (let* ([DirPath (build-path BuildRoot Path)]
               [Previous (if (not Previous) #f 
                             (string-append "/Archives/" (regexp-replace "^/(Archives|Post)/" Previous "")))]
               [Next (if (not Next) #f 
                         (string-append "/Archives/" (regexp-replace "^/(Archives|Post)/" Next "")))])
          (printf "~a => ~a~n" DirPath Title)
          (write-xml! (build-path DirPath "index.html")
                      (MainTemplate Title Previous Next DisplayAds Body))))
      (define (write-Post! w Previous pi Next)
        (let ([p (World-Post w pi)])
          (write-template! (apply build-path "Archives" (list-tail (explode-path (Post-Id p)) 2))
                           (Post-PageTitle p)
                           Previous Next #t
                           `(,(Post-FXexpr p)))))
      ; Main
      (define (main)      
        ; Read the posts in and generate the individual entry files
        (let ([w (load-World PostRoot format-Post!)])
          ; Generate each post
           (lambda (Previous pi Next)
             (write-Post! w Previous pi Next))
           (World-DateMap-Posts w))
          ; Generate Archive Top
          (write-template! (build-path "Archives")
                           (list "Archives") #f #f #f
                              ,@(map (lambda (Year)
                                       `(li (a ([href ,(format "/Archives/~a" Year)]) ,Year)
                                            ,(format-year w Year)))
                                     (World-DateMap-Years w)))))
          ; Generate Years
          (for-each/triple (lambda (Previous Year Next)
                             (write-template! (build-path "Archives" Year)
                                              (list Year) Previous Next #f
                                              `(,(format-year w Year))))
                           (World-DateMap-Years w))
          ; Generate Months
          (for-each/triple (lambda (Previous Date Next)
                             (match-let ([(list _ Year Month) (regexp-match "(....)/(..)" Date)])
                               (write-template! (build-path "Archives" Year Month)
                                                (list (Month->MonthName Month) " " Year) Previous Next #f
                                                `((div ([id "monthview"])
                                                       ,(format-calendar w Year Month Previous Next))))))
                           (World-DateMap-Months w))
          ; Generate Days
          (let ([Days (World-DateMap-Days w)])
            (define (Date->Entries D)
              (match-let ([(list _ Year Month Day) (regexp-match "(....)/(..)/(..)" D)])
                (map (lambda (pi) (World-Post w pi))
                     (World-DateMap-Year/Month/Day-Posts w Year Month Day))))
            (for-each/triple (lambda (Previous Date Next)
                               (match-let ([(list _ Year Month Day) (regexp-match "(....)/(..)/(..)" Date)])
                                  (build-path "Archives" Year Month Day)
                                  (list (Month->MonthName Month) " " Day ", " Year)
                                  Previous Next #t
                                  (map Post-FXexpr (reverse (Date->Entries Date))))))
            ; Map over categories
             (lambda (Category Subcategories Posts)
               (let ([path (if (equal? #"/" Category)
                               (build-path "Categories")
                               (build-path "Categories" (bytes->path (subbytes Category 1 (bytes-length Category)))))])
                 (write-template! path
                                  (map bytes->string/utf-8 (between #" > " (map path->bytes (rest (explode-path (build-path "/" path))))))
                                  #f #f #t
                                  (format-category w Category Subcategories Posts))))
            ; Grab last X days
            (let ([LastXDays (reverse (list-tail Days (max 0 (- (length Days) DaysInRSS))))])
              ; Make index the last day
              (copy-file (build-path BuildRoot "Archives" (car LastXDays) "index.html") (build-path BuildRoot "index.html"))
              ; Generate RSS from last X days
              (printf "Generating RSS...~n")
              (let ([RSSEntries (apply append (map reverse (map Date->Entries LastXDays)))])
                (write-xml! (build-path BuildRoot "RSS" "index.atom")
                            (Atom/2005 RSSEntries))
                (write-xml! (build-path BuildRoot "RSS" "index.rss")
                            (RSS/0.91 RSSEntries))
                (write-xml! (build-path BuildRoot "RSS" "index.xml")
                            (RSS/2.0 RSSEntries)))))
      (define (main/files)
        (when (directory-exists? BuildRoot)
          (delete-directory/files BuildRoot))
        (make-directory* BuildRoot)
         (lambda (Path)
           (make-file-or-directory-link Path
                                        (build-path BuildRoot (file-name-from-path Path))))