(module hyde

(load-hyde-file
 hyde-environment
 hyde-environments
 define-hyde-environment
 initialize-site
 generate-page
 pathify
 make-external-translator
 serve
 source-dir
 output-dir
 layouts-dir
 default-layouts
 clean-before-build
 excluded-paths
 default-extension
 default-page-vars
 page-eval-env
 translators
 compile-pages
 uri-path-prefix
 markdown-program
 link-shortcuts
 sxml-conversion-rules
 ignore-page?)

(import chicken scheme)
(require-extension regex)
(import irregex)

(use files
     data-structures
     extras
     srfi-1
     ports
     srfi-13
     utils
     posix
     (rename filepath (filepath:make-relative pathname-relative-from))
     sxml-transforms
     doctype
     matchable
     scss
     spiffy
     srfi-18
     colorize
     intarweb
     uri-common
     svnwiki-sxml
     defstruct
     (rename multidoc (html-transformation-rules
                       multidoc-html-transformation-rules)))

(use hyde-page-eval-env)
(reexport (except hyde-page-eval-env current-page-eval-env))

(defstruct page source-path path (vars '()) reader writer type)

(define (with-page page proc #!optional (key page))
  (cond ((page? page) (parameterize ((current-page page)) (proc page)))
	((string? page) (with-page (alist-ref page (pages) string=?) proc page))
	(else (die (conc "unknown page: " key) 3))))

(define (write-page page)
  ((with-page page page-writer)))

(define (read-page page #!rest layouts)
  (with-page page
             (lambda (page)
               (parameterize ((current-page page))
                 (wrap-with-layouts ((with-page page page-reader)) layouts)))))

(define hyde-environment (make-parameter 'default))
(define hyde-environments (make-parameter '(default)))
(define source-dir (make-parameter "src"))
(define output-dir (make-parameter "out"))
(define layouts-dir (make-parameter "layouts"))
(define default-layouts (make-parameter '("default.sxml")))
(define clean-before-build (make-parameter #t))
(define excluded-paths (make-parameter (list (irregex '(seq "~" eos)))))
(define default-extension (make-parameter "html"))
(define default-page-vars (make-parameter '()))
(define uri-path-prefix (make-parameter ""))
(define markdown-program (make-parameter "markdown"))
(define link-shortcuts (make-parameter '()))
(define ignore-page? (make-parameter #f))

(define translators (make-parameter '()))
(define current-page (make-parameter #f))
(define pages (make-parameter '()))
(define page-eval-env
  (make-parameter (make-page-eval-env)))

(define-syntax define-hyde-environment 
  (syntax-rules ()
    ((_ name e1 e2 ...)
     (begin
       (hyde-environments (cons 'name (hyde-environments)))
       (when (eq? 'name (hyde-environment))
         e1 e2 ...)))))

(define (with-current-page-default accessor)
  (lambda (#!optional (page (current-page)))
    (accessor page)))
 
(for-each (lambda (b)
	    (environment-set! (page-eval-env) (car b) (cdr b)))
	  `((read-page . ,read-page)
	    (page-vars . ,(with-current-page-default page-vars))
	    (page-path . ,(with-current-page-default page-path))
	    (page-type . ,(with-current-page-default page-type))
	    (page-source-path . ,(with-current-page-default page-source-path))
	    (current-page . ,current-page)
	    ($ . ,(lambda (name #!optional (page (current-page)))
		    (alist-ref name (page-vars page))))))

(define default-layout-template #<<END
()
`((xhtml-1.0-strict)
  (html
   (head
    (title ,($ 'title)))
   (body
    (h1 ,($ 'title))
    (inject ,contents))))
END
)

(define (output-xml doc rules)
  (SRV:send-reply (fold (lambda (rule doc)
			  (pre-post-order* doc rule))
			doc
			rules)))

(define (colorize-code language code)
  (let* ((class (conc "highlight " language "-language"))
	 (code (map (lambda (s)
                      (handle-exceptions exn
                        (htmlize s)
                        (html-colorize language s)))
                    code)))

    `(pre (@ (class ,class)) (inject . ,code))))

(define sxml-colorize-rules
  `((highlight *macro* . ,(lambda (tag els)
                            (cons 'colorize els)))
    (colorize *preorder* . ,(lambda (tag els)
                              (colorize-code (car els) (cdr els))))
    ,@alist-conv-rules*))

(define sxml-conversion-rules 
  `((inject *preorder* . ,(lambda (tag sxml) sxml))
    (shortcut . ,(lambda (tag attrs)
                   (apply expand-link-shortcut attrs)))
    ,@doctype-rules
    ,@universal-conversion-rules*))

(define (expand-link-shortcut alias . args)
  (let ((uri-template (alist-ref alias (link-shortcuts))))
    (cond ((not uri-template)
           (error 'expand-link-shortcut
                  (format "invalid link shortcut: ~S" alias)))
          ((procedure? uri-template)
           (apply uri-template args))
          (else 
           (apply format uri-template (map uri-encode-string args))))))

(define (print-error error)
  (with-output-to-port (current-error-port)
    (cut print "ERROR: " error)))

(define (die error exit-code)
  (print-error error)
  (exit exit-code))

(define (load-hyde-file #!optional (die-when-missing? #t))
  (if (file-exists? "hyde.scm")
      (begin
        (load "hyde.scm")
        (unless (memq (hyde-environment) (hyde-environments))
          (die (format "environment '~A' is not defined for this site" (hyde-environment)) 1)))
      (begin
        (print-error "no hyde.scm found")
        
        (if die-when-missing? 
            (exit 1)
            (begin (newline) #f)))))

(define (create-directory-verbose name)
  (print "creating " name)
  (create-directory name #t))

(define (initialize-site)
  (unless (null? (directory))
    (die "unable to initialize site, directory is not empty" 2))
  
  (create-directory-verbose (layouts-dir))
  (create-directory-verbose (source-dir))
  (create-directory-verbose (output-dir))

  (print "creating hyde.scm")
  (with-output-to-file "hyde.scm" (cut write '(use hyde)))
  (let ((default-layout (make-pathname (layouts-dir) (car (default-layouts)))))
    (print "creating " default-layout)
    (with-output-to-file default-layout
      (cut print default-layout-template))))

(define (pathify string)
  (let* ((path  (string-downcase string))
         (path  (irregex-replace/all '(submatch (+ (~ alpha #\- #\space))) path ""))
         (path  (irregex-replace/all '(submatch (+ (" -"))) path "-")))
    (string-trim-both path #\-)))

(define (generate-page ext title)
  (let* ((title (string-intersperse title))
         (path (pathify title))
         (path (make-pathname (source-dir) path ext)))
    (with-output-to-file path (cut write `((title . ,title))))
    (print path)))

(define (page-by-path path)
  (let* ((path (if (string=? "" (car path))
                   path
                   (cons "" path)))
         (path (cons (car path)
                     (remove string-null? (cdr path))))
         (path (string-join path "/"))
         (path (if (string=? "" path) "/" path))
         (page (find (lambda (page)
                       (string=? (page-path (cdr page)) path))
                     (pages))))
    (and page (cdr page))))

(define (send-page page)
  (print-page-paths page)
  (send-response body: (parameterize ((current-page page))
                         (wrap-with-layouts (read-page page)))
                 headers: `((content-type ,(file-extension->mime-type
                                            (pathname-extension (page-path page)))))))

(define (serve)
  (root-path (source-dir))
  
  (vhost-map `((".*" . 
                ,(lambda (continue)
                   (with-pages
                    (lambda () 
                      (let* ((path (cdr (uri-path (request-uri (current-request)))))
                             (page (page-by-path path)))

                        (case (and page (page-type page))
                          ((dynamic) (send-page page))

                          ((directory) 
                           (call/cc (lambda (break)
                                      (for-each (lambda (index-file)
                                                  (let* ((index-path (append path (list index-file)))
                                                         (index-page (page-by-path index-path)))

                                                    (when index-page
                                                      (send-page index-page)
                                                      (break index-page))))
                                                (index-files))

                                      (continue))))

                          (else (continue))))))))))

  (print (format "spiffy serving hyde on port ~A" (server-port)))
  (start-server))

(define (cmd name . args)
  (receive (_ exited-normally status)
    (process-wait (process-run name args))
    (unless (and exited-normally (zero? status))
      (error (format "error executing ~A ~A" name (string-intersperse args))))))

(define (make-output-path path #!optional page)
  (let ((output-file (make-pathname (output-dir) (pathname-relative-from (source-dir) path))))
    (if page
	(pathname-replace-extension output-file (->string (or (alist-ref 'ext (page-vars page)) (default-extension))))
	output-file)))

(define (make-access-path path #!optional page)
  (let ((path (pathname-relative-from 
               (output-dir) 
               (make-output-path path page))))
    (make-absolute-pathname 
     (uri-path-prefix)
     (if (string=? path ".") 
         "/"
         path))))

(define (call-with-returning value proc)
  (proc value)
  value)

(define (wrap-with-layout layout contents)
  (with-input-from-source-file layout
    (lambda (meta)
      (match (translator-for layout)
	((translate . translator-page-vars)
	 (page-vars-set! (current-page) (append (page-vars (current-page)) meta translator-page-vars))
	 (environment-set! (page-eval-env) 'contents contents)
	 (translate))
	(else (format "unknown layout format: ~A" layout))))))

(define (wrap-with-layouts contents #!optional layouts)
  (let* ((layouts (or layouts (alist-ref 'layouts (page-vars (current-page))) (default-layouts))))
    (fold (cut wrap-with-layout <> <>)
	  contents
	  (map (cut make-pathname (layouts-dir) <>) layouts))))

(define (with-input-from-source-file source-file proc)
  (with-input-from-file source-file
    (lambda ()
      (proc (read)))))

(define (compile-page-by-extension file translate page #!optional (env (environment-copy (page-eval-env))))
  (with-input-from-source-file file 
    (lambda (meta)
      (parameterize ((current-page page) (page-eval-env env))
	(translate)))))

(define (translator-for file)
  (and-let* ((ext (pathname-extension file))
	     (translator (alist-ref ext (translators) string=?)))
    (cons (lambda () 
	    (with-output-to-string (car translator)))
	  (cdr translator))))

(define (default-page-vars-for page)
  (append-map cdr (filter (lambda (d)
                            (if (procedure? (car d))
                                ((car d) page)
                                (irregex-search (car d) (page-source-path page))))
                          (default-page-vars))))

(define (classify-path path)
  (let* ((source-path (pathname-relative-from (source-dir) path))
         (source-path (if (string=? "." source-path) "" source-path)))
    (cons source-path
	  (cond ((directory? path)
		 (make-page type: 'directory
			    source-path: source-path
			    path: (make-access-path path)
			    reader: (lambda () (directory path))
			    writer: (lambda () (create-directory (make-output-path path) #t))))
		((translator-for path) => 
		 (lambda (translator)
		   (let* ((translate (car translator))
			  (translator-page-vars (cdr translator))
			  (local-page-vars (or (with-input-from-file path read) '()))
                          (page (make-page type: 'dynamic
					   source-path: source-path
					   vars: (append local-page-vars translator-page-vars)))
                          (page (update-page page path: (make-access-path path page)))
                          (page (update-page page vars: (append local-page-vars
                                                                (default-page-vars-for page)
                                                                translator-page-vars)))
			  (reader (let ((contents #f))
				    (lambda ()
                                      (unless contents
                                        (set! contents (compile-page-by-extension path translate page)))
				      contents)))
			  (writer (lambda () 
				    (with-output-to-file (make-output-path path page)
				      (lambda ()
					(parameterize ((current-page page))
					  (display (wrap-with-layouts (reader)))))))))
		     (update-page page writer: writer reader: reader))))
		(else (make-page type: 'static
				 source-path: source-path
				 path: (make-access-path path)
				 reader: (lambda () (read-all path))
				 writer: (lambda () (file-copy path (make-output-path path) #t))))))))

(define (print-page-paths page)
  (display (page-source-path page))
  (print " -> " (substring (page-path page) 1)))

(define (compile-page page)
  (unless (and (ignore-page?) ((ignore-page?) page))
    (unless (eq? 'directory (page-type page))
      (print-page-paths page))
    (write-page page)))

(define (exclude-file? file)
  (any (cut irregex-search <> file) (excluded-paths)))

(define (with-pages thunk #!optional include-file?)
  (parameterize ((pages '()))
    (prepare-compilation (or include-file? (constantly #t)))
    (thunk)))

(define (prepare-compilation include-file?)
  (pages (list (classify-path (source-dir))))
  (environment-set! (page-eval-env) 'uri-path-prefix (uri-path-prefix))
  (environment-set! (page-eval-env) 'pages pages)

  (find-files (source-dir)
              test: (conjoin (complement exclude-file?)
                             include-file?)
              action: (lambda (file _)
                        (pages (cons (classify-path file) (pages))))))

(define (compile-pages path-prefixes)
  (when (clean-before-build)
    (print "cleaning output directory")
    (cmd "rm" "-rf" (output-dir))
    (create-directory (output-dir) #t))

  (print "preparing compilation")
  (with-pages
   (lambda ()
     (print "compiling pages")
     (for-each (compose compile-page cdr) (reverse (pages))))
   (and (not (null? path-prefixes))
        (lambda (file)
          (any (lambda (prefix)
                 (string-prefix? prefix file))
               path-prefixes)))))

(define (translate/sxml)
  (output-xml (map (lambda (e) (environment-eval e (page-eval-env))) (read-file))
	      (list sxml-colorize-rules sxml-conversion-rules)))

(translators (cons (list "sxml" translate/sxml) (translators)))

(define-syntax make-external-translator
  (syntax-rules ()
    ((_ name)
     (let ((read/write-lines
            (lambda () (port-for-each print read-line))))
       (lambda ()
         (receive (in out pid err)
                  (process* name)
                  (with-output-to-port out read/write-lines)
                  (close-output-port out)
                  (with-input-from-port in read/write-lines)
                  (close-input-port in)
                  (close-input-port err)))))))

(define translate/markdown (make-external-translator (markdown-program)))

(translators (cons (list "md" translate/markdown) (translators)))

(define (translate/scss)
  (let loop ((sexp (read)))
    (unless (eof-object? sexp)
      (let ((scss (environment-eval sexp (page-eval-env))))
        (scss->css (if (memq (car scss) '(css css+))
                       scss
                       (cons 'css+ scss))))
      (loop (read)))))

(translators (cons (list "scss" translate/scss '(ext . css) '(layouts))
		   (translators)))

(define +svnwiki-shortcut-link+ 
  (irregex `(seq (submatch (+ (~ #\:))) #\: (submatch (+ any)))))

(define (expand-link-shortcut/svnwiki tag attrs)
  (let* ((m (irregex-match +svnwiki-shortcut-link+ (car attrs)))
         (uri (cond ((and m (irregex-match-substring m 1)) =>
                     (lambda (alias)
                       (expand-link-shortcut (string->symbol alias)
                                             (irregex-match-substring m 2))))
                    (else (car attrs)))))
                                                      
    (list (if (absolute-uri? (uri-reference uri))
              'link
              'int-link)
          uri
          (cdr attrs))))

(define (translate/svnwiki)
  (let* ((doc (svnwiki->sxml (current-input-port)))
         (doc (pre-post-order* doc `((int-link . ,expand-link-shortcut/svnwiki)
                                     ,@alist-conv-rules*)))
         (rules (multidoc-html-transformation-rules doc))
         (rules (append (butlast rules)
                        (list (cons (assq 'inject sxml-conversion-rules)
                                    (last rules))))))

    (output-xml doc (cons sxml-colorize-rules rules))))

(translators (cons* (list "wiki" translate/svnwiki)
		    (list "sw" translate/svnwiki)
		    (translators)))

)