(module template mzscheme
        (require "hwikireq.scm")
        (require "config.scm")
        (require "util.scm")
        (provide template)


        (def-class
         (this (template . args))
         (supers)
         (private
          (define _css     "")
          (define _parts   (list))
          (define _name    "default")
          (define _context #f)
          (define _paths   #f)

          (define (lock)
            #t)

          (define (unlock)
            #t)

          (define (load)
            (let ((tmpl (with-handlers ((exn:fail? (lambda (exn) (list _name (list (list "header" "header")
                                                                                   (list "left"   "left")
                                                                                   (list "right"  "right")
                                                                                   (list "footer" "footer")
                                                                                   (list "main" #f))))))
                          (let ((fh (open-input-file (-> _paths filename 'template _name))))
                            (let ((R (read fh)))
                              (close-input-port fh)
                              R)))))
              (set! _css   (car tmpl))
              (set! _parts (cadr tmpl))))

          (define (save)
            (lock)
            (let ((fh (open-output-file (-> _paths filename 'template _name) 'replace)))
              (write (list _css _parts) fh)
              (close-output-port fh))
            (unlock))

          )
         (public
          (define (template-names)
            (let ((files (-> _paths file-list 'template)))
              (debug "templates:" files)
              (cons "admin" (cons "default" (filter (lambda (f)
                                                      (cond ((string-ci=? "admin" f) #f)
                                                            ((string-ci=? "default" f) #f)
                                                            (else #t)))
                                                    (map path->string files))))))

          (define (name)          _name)

          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
          ;; css
          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

          (define (css)
            (-> _paths htmllink 'css _css))

          (define (css! css-name)
            (set! _css css-name)
            (save))

          (define (css-name)
            _css)

          (define (css-contents)
            (let ((C (with-handlers ((exn:fail? (lambda (exn) "")))
                       (let ((fh (open-input-file (-> _paths filename 'css _css))))
                         (let ((R (read-whole-string fh)))
                           (close-input-port fh)
                           R)))))
              C))

          (define (css-contents! t)
            (let ((fh (open-output-file (-> _paths filename 'css _css) 'replace)))
              (write-string t fh)
              (close-output-port fh)
              (copy-to (-> _paths filename 'css _css) (-> _paths htdocfile 'css _css))))

          (define (css-classes)
            (let ((contents (string-append "\n" (-> this css-contents))))
              (let ((re (pregexp "\n\r*\\s*[.]([A-Z][a-zA-Z]+)\\s*[{]")))
                (letrec ((f (lambda (C)
                              (let ((M (pregexp-match-positions re C)))
                                (if (eq? M #f)
                                    (list)
                                    (cons (substr C (caadr M) (cdadr M))
                                          (f (substr C (cdar M)))))))))
                  (let ((classes (f contents)))
                    (debug "css-classes:" classes)
                    classes)))))

          (define (parts)
            _parts)

          (define (parts! parts)
            (set! _parts parts)
            (save))

          (define (set-part! old-name new-name new-file)
            (if (string=? (string-trim-both new-file) "")
                (set! new-file #f))
            (set! _parts
                  (append
                   (letrec ((f (lambda (P)
                                 (if (null? P)
                                     (list)
                                     (if (string-ci=? old-name (caar P))
                                         (f (cdr P))
                                         (cons (car P) (f (cdr P))))))))
                     (f _parts))
                   (list (list new-name new-file))))
            (save))

          (define (remove-part! part)
            (set! _parts
                  (filter (lambda (p) (if (string-ci=? part (car p))
                                          #f
                                          #t))
                          _parts))
            (save))

          (define (get-part name)
            (letrec ((f (lambda (P)
                          (if (null? P)
                              #f
                              (if (string-ci=? name (caar P))
                                  (car P)
                                  (f (cdr P)))))))
              (f _parts)))

          (define (store)
            (save))

          (define (remove)
            (let ((F (-> _paths filename 'template _name)))
              (if (file-exists? F) (delete-file F))))

          )
         (constructor
          (set! _context (=> 'context args (error "Context object is mandatory")))
          (set! _paths   (cfile _context))
          (set! _name (=> 'name args "default"))
          (if (eq? _name #f) (set! _name "default"))
          (load))
         )

        )