; Blogue for MzScheme
; Copyright 2005 Jay McCarthy <jay@kenyamountain.com>
(module blogue mzscheme
  (require (lib "unitsig.ss")
           (lib "list.ss")
           (lib "file.ss")
           (lib "struct.ss")
           (lib "plt-match.ss"))
  (require (planet "list.ss" ("jaymccarthy" "mmss.plt" 1))
           (planet "xml.ss" ("jaymccarthy" "mmss.plt" 1))
           (planet "date.ss" ("jaymccarthy" "mmss.plt" 1)))
  (require "blogue-post.ss"
           "blogue-world.ss"
           "blogue-sig.ss")
  (provide build-site)
  
  ; Util
  (define (Month->MonthName M)
    (month-name/number (string->number M)))
  
  ; Interface
  (define (build-site config@)
    (define site@
      (compound-unit/sig 
        (import)
        (link (CONFIG : blogue-config^ (config@))
              (CORE : blogue^ (blogue@ CONFIG)))
        (export)))
    (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)])))
          w))
      
      (define (format-year w Y)
        `(ul
          ,@(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)
                                             `(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)
                                                         day)))))
                                       week)))
                         (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))
                          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
          (for-each/triple
           (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
                           `((ul
                              ,@(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)])
                                 (write-template! 
                                  (build-path "Archives" Year Month Day)
                                  (list (Month->MonthName Month) " " Day ", " Year)
                                  Previous Next #t
                                  (map Post-FXexpr (reverse (Date->Entries Date))))))
                             Days)
            
            ; Map over categories
            (for-each/World-Category
             (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))))
             w)
            
            ; 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)
        
        (for-each 
         (lambda (Path)
           (make-file-or-directory-link Path
                                        (build-path BuildRoot (file-name-from-path Path))))
         Link)
        
        (main))
      
      (main/files)
      
      )))