(module hyde

(load-hyde-file
 initialize-site
 generate-page
 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
 markdown-program)

(import chicken scheme files data-structures extras srfi-1 ports srfi-13 utils)
(require-extension regex)
(import irregex)

(use posix
     (rename filepath (filepath:make-relative pathname-relative-from))
     environments
     sxml-transforms
     doctype
     matchable
     scss
     scss-plus
     spiffy
     srfi-18
     colorize
     intarweb
     uri-common
     svnwiki-sxml
     defstruct
     (rename multidoc (html-transformation-rules
		       multidoc-html-transformation-rules)))

(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 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 markdown-program (make-parameter "markdown"))

(define translators (make-parameter '()))
(define current-page (make-parameter #f))
(define pages (make-parameter '()))
(define page-eval-env (make-parameter (environment-copy (interaction-environment) #t)))

(for-each (lambda (b)
	    (environment-set! (page-eval-env) (car b) (cdr b)))
	  `((read-page . ,read-page)
	    (page-vars . ,page-vars)
	    (page-path . ,page-path)
	    (page-type . ,page-type)
	    (page-source-path . ,page-source-path)
	    (sort . ,sort)
	    ($ . ,(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 (handle-exceptions exn
				  code
				  (map (lambda (s)
					 (html-colorize language s))
				       code))))

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

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

(define sxml-conversion-rules 
  `((inject *preorder* . ,(project 1))
    ,@doctype-rules
    ,@universal-conversion-rules*))

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

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

(define (load-hyde-file)
  (if (file-exists? "hyde.scm")
      (load "hyde.scm")
      (die "no hyde.scm found" 1)))

(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 (generate-page ext title)
  (let* ((title (string-intersperse title))
	 (path  (string-downcase title))
	 (path  (irregex-replace/all '(or (submatch (+ space)) (submatch (+ (~ alpha)))) path "-" ""))
	 (path  (string-trim-both path #\-))
	 (path  (make-pathname (source-dir) path ext)))
    (with-output-to-file path (cut write `((title . ,title))))
    (print path)))

(define (requested-page-fresh-enough?)
  (let* ((file (fold (flip make-pathname) 
		     (root-path)
		     (cdr (uri-path (request-uri (current-request))))))
	 (extension (pathname-extension file))
	 (referer (uri-path (header-value 'referer 
					  (request-headers (current-request))
					  (uri-reference ""))))
	 (referer (and (pair? referer) (last referer))))

    (and (file-exists? file)
	 extension
	 (not (string=? extension "html"))
	 referer
	 (or (equal? "" referer)
	     (equal? "html" (pathname-extension referer))))))

(define (serve)
  (root-path (output-dir))
  
  (let ((m (make-mutex)))
    (vhost-map `((".*" . 
		  ,(lambda (continue)
		     (condition-case (mutex-lock! m)
			 ((abandoned-mutex-exception) #t))
		     (if (requested-page-fresh-enough?)
			 (continue)
			 (begin
			   (compile-pages)
			   (newline)
			   (continue)))

		     (mutex-unlock! m))))))

  (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-vars)
  (let ((output-file (make-pathname (output-dir) (pathname-relative-from (source-dir) path))))
    (if page-vars
	(pathname-replace-extension output-file (->string (or (alist-ref 'ext page-vars) (default-extension))))
	output-file)))

(define (make-access-path path #!optional page-vars)
  (make-pathname "/" (pathname-relative-from (output-dir) (make-output-path path page-vars))))

(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))

	(environment-set! (page-eval-env) 'source-file (page-source-path page))
	(environment-set! (page-eval-env) 'current-path (page-path page))
	(environment-set! (page-eval-env) 'pages (pages))
		 
	(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 (classify-path path)
  (let ((source-path (pathname-relative-from (source-dir) path)))
    (cons source-path
	  (cond ((translator-for path) => 
		 (lambda (translator)
		   (let* ((translate (car translator))
			  (translator-page-vars (cdr translator))
			  (page-vars (or (with-input-from-file path read) '()))
			  (page-vars (append page-vars (default-page-vars) translator-page-vars))
			  (page (make-page type: 'dynamic
					   source-path: source-path
					   path: (make-access-path path page-vars)
					   vars: page-vars))
			  (reader (let ((contents #f))
				    (lambda ()
				      (if contents
					  contents
					  (begin
					    (set! contents (compile-page-by-extension path translate page))
					    contents)))))
			  (writer (lambda () 
				    (with-output-to-file (make-output-path path page-vars)
				      (lambda ()
					(parameterize ((current-page page))
					  (display (wrap-with-layouts (reader)))))))))
		     (update-page page writer: writer reader: reader))))
		((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)))))
		(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 (compile-page page)
  (unless (eq? 'directory (page-type page))
    (display "* ")
    (display (page-source-path page))
    (print " -> " (substring (page-path page) 1)))
  (write-page page))

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

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

  (parameterize ((pages '()))

    (print "preparing compilation")
  
    (find-files (source-dir)
		exclude-file?
		(lambda (file _)
		  (pages (cons (classify-path file) (pages)))))

    (print "compiling pages")

    (for-each (compose compile-page cdr) (reverse (pages)))))

(define (read/write-lines)
  (port-for-each print read-line))

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

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

(define (translate/markdown)
  (receive (in out pid err)
    (process* (markdown-program))
    (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)))

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

(define (translate/scss)
  (let loop ((sexp (read)))
    (unless (eof-object? sexp)
      (let ((scss (eval sexp (page-eval-env))))
	(print (match scss
		 (('css  . ...) (scss->css scss))
		 (('css+ . ...) (scss-plus->css scss))
		 (...           (scss-plus->css (cons 'css+ scss))))))
      (loop (read)))))

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

(define (translate/svnwiki)
  (let ((doc (svnwiki->sxml (current-input-port))))
    (output-xml doc (multidoc-html-transformation-rules doc))))

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

)