(use sxml-transforms sxpath-lolevel doctype)

(define (with-class class element)
  (let* ((element (pre-post-order* element bootstrap-rules))
	 (old-class (or (sxml:attr element 'class) "")))
    (sxml:set-attr element `(class ,(string-join (list old-class class))))))

(define bootstrap-rules
  `((bs-page . ,(lambda (tag body)
		  (let ((title (car body)))
		    `(html 
		      (head 
		       (meta (@ (charset "utf-8")))
		       (meta (@ (http-equiv "X-UA-Compatible") (content "IE=edge")))
		       (meta (@ (name "viewport") (content "width=device-width, initial-scale=1")))
		       (link (@ (rel "stylesheet") (href "https://maxcdn.bootstrapcdn.com/bootstrap/3.3.2/css/bootstrap.min.css")))
		       (style 
			   "body {
                           padding-top: 50px;
                         }
                         .starter-template {
                           padding: 40px 15px;
                           text-align: center;
                         }
                         ")
		       (title ,title))
		      (body ,@(cdr body)
			    (script (@ (src "https://ajax.googleapis.com/ajax/libs/jquery/1.11.2/jquery.min.js")))
			    (script (@ (src "https://maxcdn.bootstrapcdn.com/bootstrap/3.3.2/js/bootstrap.min.js"))))))))
    (caret . ,(lambda (tag body)
		'(span (@ (class "caret")))))
    (container . ,(lambda (tag body)
		    `(div (@ (class "container"))
			  ,body)))
    (container-fluid . ,(lambda (tag body)
			  `(div (@ (class "container-fluid"))
				,body)))
    (row . ,(lambda (tag body)
	      `(div (@ (class "row"))
		    ,body)))
    (col . ,(lambda (tag body)
	      (let ((sizes (car body))
		    (body (cdr body)))
		`(div (@ (class ,(string-intersperse 
				  (map (lambda (size) 
					 (string-append "col-" (->string (car size)) "-" (->string (cadr size))))
				       sizes))))
		      ,body))))
    (navbar . ,(lambda (tag body)
		 `(nav (@ (class "navbar navbar-default"))
		       ,body)))
    (navbar-inverse . ,(lambda (tag body)
			 `(nav (@ (class "navbar navbar-inverse"))
			       ,body)))
    (navbar-fixed-top . ,(lambda (tag body)
			   `(nav (@ (class "navbar navbar-default navbar-fixed-top"))
				 (div (@ (class "container")) ,body))))
    (navbar-inverse-fixed-top . ,(lambda (tag body)
				   `(nav (@ (class "navbar navbar-inverse navbar-fixed-top"))
					 (div (@ (class "container")) ,body))))
    (navbar-fixed-bottom . ,(lambda (tag body)
			      `(nav (@ (class "navbar navbar-default navbar-fixed-bottom"))
				    (div (@ (class "container")) ,body))))
    (navbar-inverse-fixed-bottom . ,(lambda (tag body)
				      `(nav (@ (class "navbar navbar-inverse"))
					    (div (@ (class "container")) ,body))))    
    (navbar-header . ,(lambda (tag body)
			`(div (@ (class "navbar-header"))
			      ,body)))
    (navbar-toggle-btn . ,(lambda (tag body)
			    (let ((target-id (car body)))
			      `(button (@ (type "button")
					  (class "navbar-toggle collapsed")
					  (data-togle "collapse")
					  (data-target ,target-id))
				       (span (@ (class "sr-only")) "Toggle navigation")
				       (span (@ (class "icon-bar")))
				       (span (@ (class "icon-bar")))
				       (span (@ (class "icon-bar")))
				       ,@(cdr body)))))
    (navbar-brand . ,(lambda (tag body)
    		       (let ((path (car body)))
			 `(a (@ (class "navbar-brand")
				(href ,path))
			     ,@(cdr body)))))
    (navbar-collapse . ,(lambda (tag body)
			  (let ((id (car body)))
			    `(div (@ (id ,id)
				     (class "collapse navbar-collapse")) 
				  ,@(cdr body)))))
    (navbar-nav . ,(lambda (tag body)
		     `(ul (@ (class "nav navbar-nav"))
			  ,(map (lambda (item)
				  `(li ,item))
				body))))
    (nav-tabs . ,(lambda (tag body)
		   `(ul (@ (class "nav nav-tabs"))
			,@(map (lambda (item)
				 `(li (@ (role "presentation"))
				      ,item))
			       body))))
    (nav-pills . ,(lambda (tag body)
		    `(ul (@ (class "nav nav-pills"))
			 ,@(map (lambda (item)
				  `(li (@ (role "presentation"))
				       ,item))
				body))))
    (nav-stacked . ,(lambda (tag body)
		      (with-class "nav-stacked" `(nav-pills ,body))))
    (alert-success . ,(lambda (tag body)
			`(div (@ (class "alert alert-success"))
			      ,body)))
    (alert-info . ,(lambda (tag body)
		     `(div (@ (class "alert alert-info"))
			   ,body)))
    (alert-warning . ,(lambda (tag body)
			`(div (@ (class "alert alert-warning"))
			      ,body)))
    (alert-danger . ,(lambda (tag body)
		       `(div (@ (class "alert alert-danger"))
			     ,body)))
    (p-lead . ,(lambda (tag body)
		 `(p (@ (class "lead"))
		     ,body)))
    (list . ,(lambda (tag body)
	       (cons 'ol (map (lambda (x) (list 'li x)) body))))
    ,@alist-conv-rules*))

(define test-code
  `(bs-page "Starter Template for Bootstrap"
	    (navbar-inverse-fixed-top
	     (navbar-header
	      ((navbar-toggle-btn "#navbar")
	       (navbar-brand "#" "Project name")))
	     (navbar-collapse "navbar"
			      (navbar-nav
			       (a (@ (href "#")) "Home")
			       (a (@ (href "#about")) "About")
			       (a (@ (href "#contact")) "Contact"))))
	    (container 
	     (div (@ (class "starter-template"))
		  ((h1 "Bootstrap starter template")
		   (p (@ (class "lead")) 
		      "Use this document as a way to quickly start any new project"
		      (br)
		      "All you get is this text and a mostly barebones HTML document"))))))

(define result
  (pre-post-order* test-code
		   bootstrap-rules))

(define (res)
  (display result)
  (newline))

(SXML->HTML result)
(newline)

;;;; Another example
;; (define test-code
;;   `(bs-page 
;;     (container 
;;      (row 
;;       (col ((sm 2) (md 1) (lg 4))
;; 	   (alert-success "I'm on first position"))
;;       (col ((sm 4) (md 8) (lg 4))
;; 	   (alert-info "I'm on second position"))
;;       (col ((sm 6) (md 3) (lg 4))
;; 	   (alert-danger "I'm on third position")))
;;      (row
;;       (nav-stacked
;;        (a (@ (href "#")) "Home")
;;        (a (@ (href "#")) "Profile")
;;        (a (@ (href "#")) "About"))))))