(module hyde

(load-hyde-file
 initialize-site
 generate-page
 serve
 source-dir
 output-dir
 layouts-dir
 default-layout
 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)
(require-extension regex)
(import irregex)

(use posix
     (rename filepath (filepath:make-relative pathname-relative-from))
     environments
     sxml-transforms
     sxml-fu
     sxml-shortcuts
     doctype
     matchable
     scss
     scss-plus
     spiffy
     srfi-18
     colorize
     intarweb
     uri-common
     svnwiki-sxml)


(define source-dir (make-parameter "src"))
(define output-dir (make-parameter "out"))
(define layouts-dir (make-parameter "layouts"))
(define default-layout (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 page-vars (make-parameter '()))
(define pages (make-parameter '()))
(define page-eval-env (make-parameter (environment-copy (interaction-environment) #t)))
(environment-set! (page-eval-env) '$ (lambda (name)
				       (alist-ref name (page-vars))))


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

(define (colorize-code language code)
  (html-colorize language (with-output-to-string (cut for-each pp code))))

(define sxml-colorize-rules
  `((highlight *preorder* . ,(lambda (tag language . code)
			       `(inject ,(colorize-code language code))))
    ,@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" 1))
  
  (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-layout)))))
    (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))))))
	 (referer (uri-path (header-value 'referer 
					  (request-headers (current-request))
					  (uri-reference ""))))
	 (referer (and (pair? referer) (last referer))))

    (and (file-exists? file)
	 referer
	 (or (string=? "" referer)
	     (string=? "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 (call-with-returning value proc)
  (proc value)
  value)

(define (wrap-with-layout layout contents)
  (with-input-from-source-file layout
    (lambda (meta)
      (let ((translator (translator-for layout)))
	(if translator
	    (begin
	      (page-vars (append meta (page-vars)))
	      (environment-set! (page-eval-env) 'contents contents)
	      (translator))
	    (error (format "unknown layout format: ~A" layout)))))))

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

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

(define (write-to-target-file-for source-file contents)
  (let* ((target-file (make-output-path source-file (page-vars)))
	 (relative-source-file (pathname-relative-from (source-dir) source-file))
	 (current-path (car (alist-ref relative-source-file (pages) string=?))))

    (environment-set! (page-eval-env) 'source-file relative-source-file)
    (environment-set! (page-eval-env) 'current-path current-path)
    (environment-set! (page-eval-env) 'pages (pages))

    (with-output-to-file target-file 
      (lambda ()
	(wrap-with-layouts contents)))

    target-file))

(define (compile-by-extension file #!optional (vars (default-page-vars)) (env (environment-copy (page-eval-env))))
  (let ((translator (translator-for file)))
    (if translator
	(with-input-from-source-file file 
	  (lambda (meta)
	    (parameterize ((page-vars (append meta vars))
			   (page-eval-env env))
	      (write-to-target-file-for file (translator)))))
	(call-with-returning (make-output-path file)
	  (cut file-copy file <> #t)))))

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

(define (load-page-vars file)
  (let ((page-vars (if (translator-for file) (with-input-from-file file read) '())))
    (pages (cons (list (pathname-relative-from (source-dir) file)
		       (make-pathname "/" (pathname-relative-from (output-dir) (make-output-path file page-vars)))
		       page-vars) (pages)))))

(define (compile-page source-file)
  (display "* ")
  (display (pathname-relative-from (source-dir) source-file))
  (let ((target-file (compile-by-extension source-file)))
    (print " -> " (pathname-relative-from (output-dir) target-file))))

(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 (path _)
		  (unless (directory? path)
		    (load-page-vars path))))

    (print "compiling pages")
    (find-files (source-dir)
		exclude-file?
		(lambda (path _) 
		  (if (directory? path)
		      (create-directory (make-output-path path))
		      (compile-page path))))))

(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 shortcut-rules sxml-colorize-rules sxml-conversion-rules)))

(translators (alist-cons "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 (alist-cons "md" translate/markdown (translators)))

(define (translate/scss)
  (page-vars (append (page-vars) '((ext . css)
				   (layout))))

  (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 (alist-cons "scss" translate/scss (translators)))

(define (translate/svnwiki)
  (output-xml (svnwiki->sxml (current-input-port)) 
	      (list sxml-colorize-rules sxml-conversion-rules)))

(translators (alist-cons "sw" translate/svnwiki (translators)))

)