;; scss.scm: main module exports and implementations for SCSS
;; Copyright (C) 2007 Julian Graham

;; SCSS is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

(define-module (scss scss)
  #:export (scss:css->scss
	    scss:scss->css

	    scss:set-user-stylesheet!
	    scss:set-author-stylesheet!
	    scss:set-agent-stylesheet!

	    scss:create-cascade

	    scss:color->hex

	    scss:set-sxml-parent-function!
	    scss:set-dot-handler!
	    scss:set-id-handler!
	    scss:set-pseudo-class-handler!
	    scss:set-pseudo-element-handler!
	    scss:set-uri-import-handler!

	    scss:stylesheet?
	    scss:cascade?
	    scss:inherited?
	    scss:get-default-value

	    scss:select-value
	    scss:select-value-at-node
	    scss:clear-style-cache!

	    scss:parser-debug-messages))

(load "lexer.scm")
(load "parser.scm")

(use-modules (ice-9 regex) (srfi srfi-1))

;; Basically just a macro def. for cosmetic reasons...

(define s+ string-append)

;; The format of these regexes needs to stay consistent with the code for
;; replace-escapes

(define unicode-regex "(\\\\([0-9a-fA-F]{1,6})[[:space:]]?)")
(define unicode-regexc (make-regexp unicode-regex))
(define escape-regex (s+ "(" unicode-regex "|(\\\\[^[:space:]0-9a-fA-F])|"
			 "(\\\\[[:space:]]+))"))
(define escape-regexc (make-regexp escape-regex))

(define nonascii-regex "([^[:alnum:][:punct:]])")
(define nonascii-regexc (make-regexp nonascii-regex))
(define nmstart-regex (s+ "([_a-zA-Z]|" nonascii-regex "|" escape-regex ")"))
(define nmstart-regexc (make-regexp nmstart-regex))
(define nmchar-regex
  (s+ "([_a-zA-Z0-9-]|" nonascii-regex "|" escape-regex ")"))
(define nmchar-regexc (make-regexp nmchar-regex))
(define ident-regex (string-append "([-]?" nmstart-regex nmchar-regex "*)"))
(define ident-regexc (make-regexp ident-regex))
(define name-regex (string-append nmchar-regex "+"))
(define nl-regex "(\\n|(\\r\\n)|\\r|\\f)")
(define string1-regex "(\\\"((\\\\[nrf\\\"])|([^\\\\\\\"][^\\\"]?))*\\\")")
(define string2-regex "(\\'((\\\\[nrf\\'])|([^\\\\\\'][^\\']?))*\\')")
(define string-regex (string-append "(" string1-regex "|" string2-regex ")"))
(define string-regexc (make-regexp string-regex))
(define w-regex "([ \\t\\r\\n\\f]*)")
(define integer-regex "([+-]?[0-9]+)")
(define pos-integer-regex "(\\+?[0-9]+)")
(define number-regex (string-append "(" integer-regex "(\\.[0-9]+)?)"))
(define pos-number-regex (string-append "(" pos-integer-regex "(\\.[0-9]+)?)"))
(define angle-regex (string-append "(" number-regex "((deg)|(grad)|(rad)))"))
(define percentage-regex (string-append "(" number-regex "%)"))
(define pos-length-regex (s+ "(0|(" pos-number-regex
			     "((em)|(ex)|(px)|(in)|(cm)|(mm)|(pt)|(pc))))"))
(define length-regex (s+"(0|(" number-regex 
			"((em)|(ex)|(px)|(in)|(cm)|(mm)|(pt)|(pc))))"))
(define color-regex 
  (string-append "((maroon)|(red)|(orange)|(yellow)|(olive)|(purple)|"
		 "(fuchsia)|(white)|(lime)|(green)|(navy)|(blue)|(aqua)|"
		 "(teal)|(black)|(silver)|(gray)|(#[a-fA-F0-9]{3})|"
		 "(#[a-fA-F0-9]{6})|"
		 
		 "(rgb\\(" 
		 number-regex "%[[:space:]]*,[[:space:]]*" 
		 number-regex "%[[:space:]]*,[[:space:]]*" 
		 number-regex "%[[:space:]]*\\))|" 

		 "(rgb\\(" 
		 integer-regex "[[:space:]]*,[[:space:]]*" 
		 integer-regex "[[:space:]]*,[[:space:]]*" 
		 integer-regex "[[:space:]]*\\)))")) 

(define border-style-regex 
  (string-append "((none)|(hidden)|(dotted)|(dashed)|(solid)|(double)|"
		 "(groove)|(ridge)|(inset)|(outset))"))
(define border-width-regex (s+ "((thin)|(medium)|(thick)|" length-regex ")"))
(define svoice-regex (string-append "(" ident-regex "|" string-regex ")"))
(define gvoice-regex "((male)|(female)|(child))")

(define gfont-regex "((serif)|(sans-serif)|(cursive)|(fantasy)|(monospace))")
(define sfont-regex string-regex)

(define ffamily-regex 
  (string-append "(((" sfont-regex "|" gfont-regex ")(\\w+" sfont-regex "|" 
		 gfont-regex ")*)|(inherit))"))
(define fsize-regex 
  (string-append "(((xx-small)|(x-small)|(small)|(medium)|(large)|(x-large)|"
		 "(xx-large))|((larger)|(smaller))|" length-regex "|"
		 percentage-regex "|(inherit))"))
(define fstyle-regex "((normal)|(italic)|(oblique)|(inherit))")
(define fvariant-regex "((normal)|(small-caps)|(inherit))")
(define fweight-regex 
  (string-append "((normal)|(bold)|(bolder)|(lighter)|(100)|(200)|(300)|(400)|"
		 "(500)|(600)|(700)|(800)|(900)|(inherit))"))

(define lheight-regex (string-append "((normal)|" number-regex "|" length-regex
				     "|" percentage-regex "|(inherit))"))

;; This isn't 100% accurate, but...
(define uri-regex (string-append "(url\\(" string-regex "\\))"))

(define lsimage-regex (string-append "(" uri-regex "|(none))"))
(define lsposition-regex "((inside)|(outside))")
(define lstype-regex 
  (string-append "((disc)|(circle)|(square)|(decimal)|(decimal-leading-zero)|"
		 "(lower-roman)|(upper-roman)|(lower-greek)|(lower-latin)|"
		 "(lower-alpha)|(upper-latin)|(upper-alpha)|(armenian)|"
		 "(georgian)|(none))"))

(define margin-regex 
  (string-append "(" length-regex "|" percentage-regex "|(auto))"))

(define counter-regex 
  (s+ "(counter\\(" ident-regex "(, " lstype-regex ")?\\))"))

(define ocolor-regex (string-append "(" color-regex "|(invert))"))
(define ostyle-regex border-style-regex)
(define owidth-regex border-width-regex)

(define time-regex (string-append "(" number-regex "m?s)"))

(define padding-regex (s+ "(" pos-length-regex "|" percentage-regex ")"))
(define pcolor-regex (s+"(" color-regex "|(transparent)|(inherit))"))
(define pimage-regex (string-append "(" uri-regex "|(none)|(inherit))"))
(define prepeat-regex "((repeat)|(repeat-x)|(repeat-y)|(no-repeat)|(inherit))")
(define pattach-regex "((scroll)|(fixed)|(inherit))")

(define lposition
  (lambda (x)
    (or (exact-match (string-append "((" percentage-regex "|" length-regex 
				    "|(left)|(center)|(right))(" 
				    percentage-regex "|" length-regex 
				    "|(top)|(center)|(bottom))?)") x)
	((any-order-or-match "(left)|(center)|(right)" 
			     "(top)|(center)|(bottom)") x)
	(exact-match "inherit" x))))

;; NOTE: Changes to this regex will require updates to the selection 
;; functions!

(define attr-sel-regexc 
  (make-regexp (s+ "\\[" ident-regex "(([|~]?=)(" ident-regex "|" 
		   string-regex "))?\\]")))

(define color-table
  '(("maroon" "#800000") ("red" "#ff0000") ("orange" "#ffa500") 
    ("yellow" "#ffff00") ("olive" "#808000") ("purple" "#800080")
    ("fuchsia" "#ff00ff") ("white" "#ffffff") ("lime" "#00ff00") 
    ("green" "#008000") ("navy" "#000080") ("blue" "#0000ff") 
    ("aqua" "#00ffff") ("teal" "#008080") ("black" "#000000") 
    ("silver" "#c0c0c0") ("gray" "#808080")))

(define exact-match
  (lambda (pattern str)
    (let ((match (string-match pattern str)))
      (if match (equal? str (match:substring match 0)) match))))

(define exact-exec
  (lambda (pattern str)
    (let ((match (regexp-exec pattern str)))
      (and match 
	   (eqv? (match:start match) 0) 
	   (eqv? (match:end match) (string-length str))))))

(define any-order-or-match
  (lambda lst
    (lambda (input)
      (let ((l (copy-tree lst)))
	(if (not (null? input))
	    (let ((result #t))
	      (for-each (lambda (x)
			  (if (> (string-length x) 0)
			      (if (null? l) 
				  (set! result #f)
				  (let ((m (find (lambda (y)
						   (if (procedure? y)
						       (apply y (list x))
						       (exact-match y x)))
						 l)))
				    (if m (delete! m l) (set! result #f))))))
			(string-split input #\sp))
	      result)
	    #f)))))

(define mf (lambda (expr) (lambda (input) (exact-match expr input))))

(define property-table
  `((azimuth 
     ,(lambda (x)
	(or (exact-match angle-regex x)
	    (apply (any-order-or-match
		    (string-append "(left-side)|(far-left)|(left)|"
				   "(center-left)|(center)|(center-right)|"
				   "(right)|(far-right)|(right-side)")
		    "behind") (list x))
	    (exact-match "(leftwards)|(rightwards)|(inherit)" x)))
     ("center") #t)
    (background-attachment ,(mf pattach-regex) ("scroll") #f)
    (background-color ,(mf pcolor-regex) ("transparent") #f)
    (background-image ,(mf pimage-regex) ("none") #f)
    (background-position lposition ("0%" "0%") #f)
    (background-repeat ,(mf prepeat-regex) ("repeat") #f)
    (background
     ,(lambda (x)
	(or (apply (any-order-or-match pcolor-regex pimage-regex prepeat-regex
				       pattach-regex lposition)
		   (list x))
	    (exact-match "inherit" x)))
     ("black" "none" "no-repeat" "fixed" "0% 0%") #f)
    (border-collapse ,(mf "(collapse)|(separate)|(inherit)") ("separate") #t)
    (border-color 
     ,(mf (s+ "((" color-regex "|(transparent))\\s*){1,4}|(inherit)"))
     (color color color color) #t)
    (border-spacing
     ,(mf (s+ "(" length-regex "\\w+" length-regex "?)|(inherit)")) 
     ("0") #t)
    (border-style ,(mf (s+ "(" border-style-regex "\\s*){1,4}|(inherit)"))
		  ("none" "none" "none" "none") #f)
    ((border-top border-right border-bottom border-left)
     ,(lambda (x) 
	(or (apply (any-order-or-match border-width-regex 
				       border-style-regex 
				       pcolor-regex)
		   (list x))
	    (exact-match "inherit" x)))
     ("medium" "none" color) #f)
    ((border-top-color border-right-color border-left-color 
		       border-bottom-color)
     ,(mf pcolor-regex) (color) #t)
    ((border-top-style border-right-style border-left-style 
		       border-bottom-style)
     ,(mf (string-append border-style-regex "|(inherit)")) ("none") #f)
    ((border-top-width border-right-width border-bottom-width 
		       border-left-width)
     ,(mf (string-append border-width-regex "|(inherit)")) ("medium") #f)
    (border-width ,(mf (s+ "(" border-width-regex "\\s*){1,4}|(inherit)"))
		  ("medium" "medium" "medium" "medium") #f)
    (border
     ,(lambda (x) 
	(or (apply (any-order-or-match border-width-regex 
				       border-style-regex 
				       pcolor-regex)
		   (list x))
	    (exact-match "inherit" x)))
     ("medium none" color) #f)
    (bottom ,(mf (s+ length-regex "|" percentage-regex "|(auto)|inherit"))
	    ("auto") #f)
    (caption-side ,(mf "(top)|(bottom)|(inherit)") ("top") #t)
    (clear ,(mf "(none)|(left)|(right)|(both)|(inherit)") ("none") #f)
    (clip 
     ,(mf (string-append "(rect\\((" length-regex "|(auto))(,\\w(" length-regex
			 "|(auto))){3}\\))|(auto)|(inherit)"))
     ("auto") #f)
    (color ,(mf pcolor-regex) ("white") #t)
    (content
     ,(mf (string-append "(normal)|(" string-regex "|" uri-regex "|" 
			 counter-regex "|(attr\\(" ident-regex "\\))|"
			 "(open-quote)|(close-quote)|(no-open-quote)|"
			 "(no-close-quote))+|(inherit)"))
     ("normal") #f)
    ((counter-increment counter-reset)
     ,(mf (s+ "(" ident-regex "(\\w+" integer-regex ")?)+|(none)|(inherit)"))
     ("none") #f)
    ((cue-after cue-before) 
     ,(mf (string-append uri-regex "|(none)|(inherit)")) ("none") #f)
    (cue ,(mf (string-append "(" uri-regex "|(none)|(inherit)(\\w+" uri-regex
			     "|(none)|(inherit))?)|(inherit)"))
	 ("none" "none") #f)
    (cursor
     ,(mf (string-append "((" uri-regex ",)*((auto)|(crosshair)|(default)|"
			     "(pointer)|(move)|(e-resize)|(ne-resize)|"
			     "(nw-resize)|(n-resize)|(se-resize)|(sw-resize)|"
			     "(s-resize)|(w-resize)|(text)|(wait)|(help)|"
			     "(progress)))|(inherit)"))
     ("auto") #t)
    (direction ,(mf "(ltr)|(rtl)|(inherit)") ("ltr") #t)
    (display
     ,(mf (string-append "(inline)|(block)|(list-item)|(run-in)|"
			     "(inline-block)|(table)|(inline-table)|"
			     "(table-row-group)|(table-header-group)|"
			     "(table-footer-group)|(table-row)|"
			     "(table-column-group)|(table-column)|"
			     "(table-cell)|(table-caption)|(none)|(inherit)"))
     ("inline") #f)
    (elevation
     ,(mf (string-append angle-regex "|(below)|(level)|(above)|(higher)|"
			 "(lower)|(inherit)"))
     ("level") #t)
    (empty-cells ,(mf "(show)|(hide)|(inherit)") ("show") #t)
    (float ,(mf "(left)|(right)|(none)|(inherit)") ("none") #f)
    (font-family ,(mf ffamily-regex) ("monospace") #t)
    (font-size ,(mf fsize-regex) ("medium") #t)
    (font-style ,(mf fstyle-regex) ("normal") #t)
    (font-variant ,(mf fvariant-regex) ("normal") #t)
    (font-weight ,(mf fweight-regex) ("normal") #t)
    (font
     ,(lambda (x)
	(let ((y (s+ fsize-regex "(\\w+\\/" lheight-regex ")?\\w+"
		     ffamily-regex)))
	  (or (and (apply (any-order-or-match fstyle-regex fvariant-regex 
					      fweight-regex y)
			  (list x))
		   (string-match (string-append y "$") x))
	      (exact-match y x)
	      (exact-match (string-append "(caption)|(icon)|(menu)|"
					  "(message-box)|(small-caption)|"
					  "(status-bar)|(inherit)") x))))
     ("normal" "normal" "normal" "medium" "monospace") #t)
    ((height left right width bottom top)
     ,(mf (s+ length-regex "|" percentage-regex "|(auto)|(inherit)")) 
     ("auto") #f)
    (letter-spacing ,(mf (s+ "(normal)|" length-regex "|(inherit)"))
		    ("normal") #t)
    (line-height
     ,(mf (string-append "(normal)|" number-regex "|" length-regex "|"
			 percentage-regex "|(inherit)"))
     ("normal") #t)
    (list-style-image ,(mf (s+ lsimage-regex "|(inherit)")) ("none") #t)
    (list-style-position ,(mf (s+ lsposition-regex "|(inherit)")) 
			 ("outside") #t)
    (list-style-type ,(mf (s+ lstype-regex "|(inherit)")) ("disc") #t)
    (list-style
     ,(lambda (x)
	(or (apply (any-order-or-match lstype-regex lsposition-regex 
				       lsimage-regex)
		   (list x))
	    (exact-match "inherit" x)))
     ("disc" "outside" "none") #t)
    ((margin-right margin-left margin-top margin-bottom)
     ,(mf (s+ length-regex "|" percentage-regex "|(auto)|(inherit)"))
     ("0") #f)
    (margin ,(mf (string-append "(" margin-regex "\\s*){1,4}|(inherit)"))
     ("0" "0" "0" "0") #f)
    ((max-height max-width)
     ,(mf (s+ length-regex "|" percentage-regex "|(none)|(inherit)"))
     ("none") #f)
    ((min-height min-width)
     ,(mf (s+ length-regex "|" percentage-regex "|(inherit)")) ("0") #f)
    (orphans ,(mf (string-append integer-regex "|(inherit)")) ("2") #t)
    (outline-color ,(mf (s+ ocolor-regex "|(inherit)")) ("invert") #f)
    (outline-style ,(mf (s+ ostyle-regex "|(inherit)")) ("none") #f)
    (outline-width ,(mf (s+ owidth-regex "|(inherit)")) ("medium") #f)
    (outline
     ,(lambda (x) 
	(or (apply (any-order-or-match ocolor-regex ostyle-regex owidth-regex)
		   (list x))
	    (exact-match "inherit" x)))
     ("invert" "none" "medium") #f)
    (overflow
     ,(mf "(visible)|(hidden)|(scroll)|(auto)|(inherit)") ("visible") #f)
    ((padding-top padding-right padding-bottom padding-left)
     ,(mf (s+ length-regex "|" percentage-regex "|(inherit)")) ("0") #f)
    (padding ,(mf (s+ "(" padding-regex "\\s*){1,4}|(inherit)"))
     ("0" "0" "0" "0") #f)
    ((page-break-after page-break-before)
     ,(mf "(auto)|(always)|(avoid)|(left)|(right)|(inherit)") ("auto") #f)
    (page-break-inside ,(mf "(avoid)|(auto)|(inherit)") ("auto") #t)
    ((pause-after pause-before)
     ,(mf (s+ time-regex "|" percentage-regex "|(inherit)")) ("0") #f)
    (pause
     ,(mf (s+ "((" time-regex "|" percentage-regex ")\\s*){1,2}|(inherit)"))
     ("0" "0") #f)
    (pitch-range ,(mf (s+ number-regex "|(inherit)")) ("50") #t)
    (pitch ,(mf (string-append "(" number-regex "k?Hz)|(x-low)|(low)|"
			       "(medium)|(high)|(x-high)|(inherit)"))
     ("medium") #t)
    (play-during 
     ,(mf (string-append uri-regex "|(" uri-regex "\\w+mix)|(" uri-regex
			 "\\w+repeat)|(" uri-regex "\\w+mix\\w+repeat)|("
			 uri-regex "\\w+repeat\\w+mix)|(auto)|(none)|"
			 "(inherit)"))
     ("auto") #f)
    (position ,(mf "(static)|(relative)|(absolute)|(fixed)|(inherit)") 
	      ("static") #f)
    (quotes 
     ,(mf (string-append "(" string-regex "\\w+" string-regex ")+|(none)|"
			 "(inherit)"))
     ("none") #t)
    (richness ,(mf (string-append number-regex "|(inherit)")) ("50") #t)
    (speak-header ,(mf "(once)|(always)|(inherit)") ("once") #t)
    (speak-numeral ,(mf "(digits)|(continuous)|(inherit)") ("continuous") #t)
    (speak-punctuation ,(mf "(code)|(none)|(inherit)") ("none") #t)
    (speak ,(mf "(normal)|(none)|(spell-out)|(inherit)") ("normal") #t)
    (speech-rate
     ,(mf (string-append number-regex "|(x-slow)|(slow)|(medium)|(fast)|"
			     "(x-fast)|(faster)|(slower)|(inherit)"))
     ("medium") #t)
    (stress ,(mf (string-append number-regex "|(inherit)")) ("50") #t)
    (table-layout ,(mf "(auto)|(fixed)|(inherit)") ("auto") #f)
    (text-align ,(mf "(left)|(right)|(center)|(justify)|(inherit)") 
		("left") #t)
    (text-decoration
     ,(lambda (x) 
	(or (exact-match "none" x)
	    (apply (any-order-or-match "underline" "overline" "line-through" 
				       "blink")
		   (list x))
	    (exact-match "inherit" x)))
     ("none") #f)
    (text-indent ,(mf (s+ length-regex "|" percentage-regex "|(inherit)"))
     ("0") #t)
    (text-transform 
     ,(mf "(capitalize)|(uppercase)|(lowercase)|(none)|(inherit)") 
     ("none") #t)
    (unicode-bidi ,(mf "(normal)|(embed)|(bidi-override)|(inherit)")
     ("normal") #f)
    (vertical-align
     ,(mf (string-append "(baseline)|(sub)|(super)|(top)|(text-top)|"
			     "(middle)|(bottom)|(text-bottom)|" 
			     percentage-regex "|" length-regex "|(inherit)"))
     ("baseline") #f)
    (visibility ,(mf "(visible)|(hidden)|(collapse)|(inherit)") ("visible") #t)
    (voice-family 
     ,(mf (string-append "((" svoice-regex "|" gvoice-regex ",)*(" 
			 svoice-regex "|" gvoice-regex "))|(inherit)"))
     ("female") #t)
    (volume ,(mf (s+ number-regex "|" percentage-regex 
		     "|(silent)|(x-soft)|(soft)|(medium)|(loud)|"
		     "(xloud)|(inherit)"))
	    ("medium") #t)
    (white-space 
     ,(mf "(normal)|(pre)|(nowrap)|(pre-wrap)|(pre-line)|(inherit)")
     ("normal") #t)
    (widows ,(mf (string-append integer-regex "|(inherit)")) ("2") #t)
    (word-spacing 
     ,(mf (s+ "(normal)|" length-regex "|(inherit)")) ("normal") #t)
    (z-index ,(mf (s+ "(auto)|" integer-regex "|(inherit)")) ("auto") #f)))

(define num-css-props (length property-table))

(define property-hash-table
  (let ((pht (make-hash-table num-css-props)))
    (for-each (lambda (x) 
		(if (list? (car x))
		    (for-each (lambda (y) (hashq-set! pht y (cdr x))) (car x))
		    (hashq-set! pht (car x) (cdr x))))
	      property-table)
    pht))

(define document-hash-table (make-weak-key-hash-table 16))
(define cascade-hash-table (make-weak-key-hash-table 16))

(define cascade-hash
  (lambda (cascade n) (modulo (+ (hashq (car cascade) n) 
				 (hashq (cadr cascade) n)
				 (hashq (caddr cascade) n))
			      n)))

(define cascade-assoc
  (lambda (x alist) (find (lambda (y) (and (eq? (car x) (caar y))
					   (eq? (cadr x) (cadar y))
					   (eq? (caddr x) (caddar y))))
			  alist)))

(define (node? x)
  (and (list? x) (let ((y (car x))) (or (symbol? y) (string? y)))))

(define get-sxml-parent
  (lambda (doc node)
    (if (memq node doc) doc (let ((c (filter list? (cdr doc))))
			      (if c (find (lambda (x) 
					    (get-sxml-parent x node))
					  c))
			      #f))))

(define sxml-node-name
  (lambda (node)
    (let* ((str (false-if-exception (symbol->string (car node))))
	   (ri (if str (string-rindex str #\:) #f)))
      (if ri (substring str (+ ri 1)) str))))

(define sxml-attr-val
  (lambda (node name)
    (and (symbol? (car node))
	 (let ((attrs (find (lambda (x) (and (list? x) (eq? (car x) '@)))
			    (cdr node))))
	   (and attrs 
		(and=> (find (lambda (x) 
			       (and (list? x) 
				    (equal? (symbol->string (car x)) name)))
			     (cdr attrs))
		       cadr))))))

(define scss:set-sxml-parent-function!
  (lambda (proc) 
    (verify-arg-types "scss:set-sxml-parent-function!" 
		      (list procedure?) 
		      (list proc)
		      1)
    (set! get-sxml-parent proc)))

(define internal-dot-handler (lambda (sel doc node) #f))
(define scss:set-dot-handler! 
  (lambda (p) 
    (verify-arg-types "scss:set-dot-handler!" (list procedure?) (list p) 1)
    (set! internal-dot-handler p)))

(define internal-id-handler (lambda (str doc node) #f))
(define scss:set-id-handler! 
  (lambda (p) 
    (verify-arg-types "scss:set-id-handler!" (list procedure?) (list p) 1)
    (set! internal-id-handler p)))

(define internal-pseudo-class-handler (lambda (str doc node) #f))
(define scss:set-pseudo-class-handler!
  (lambda (p)
    (verify-arg-types "scss:set-pseudo-class-handler!" 
		      (list procedure?) 
		      (list p)
		      1)
    (set! internal-pseudo-class-handler p)))

(define internal-pseudo-element-handler (lambda (str doc node) #f))
(define scss:set-pseudo-element-handler!
  (lambda (p)
    (verify-arg-types "scss:set-pseudo-element-handler!"
		      (list procedure?) 
		      (list p)
		      1)
    (set! internal-pseudo-element-handler p)))

(define internal-uri-import-handler (lambda (uri) (open-input-string "")))
(define scss:set-uri-import-handler!
  (lambda (p)
    (verify-arg-types "scss:set-uri-import-handler!"
		      (list procedure?)
		      (list p)
		      1)
    (set! internal-uri-import-handler p)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Parsing functions
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define combine
  (lambda (sel combinator sels)
    (let ((csels (car sels)))
      (cons (list (string->symbol combinator) sel csels) (cdr sels)))))

(define parse-attrib-str
  (lambda (str)
    (let* ((chrs (string->list str))
	   (quot (list-index (lambda (x) (or (eqv? #\" x) (eqv? #\' x))) chrs))
	   (p (list-index (lambda (x) (eqv? #\~ x)) chrs))
	   (p (or (and p (or (not quot) (< p quot)) p)
		  (list-index (lambda (x) (eqv? #\| x)) chrs)))
	   (p (or (and p (or (not quot) (< p quot)) p)
		  (list-index (lambda (x) (eqv? #\= x)) chrs))))
      (if p
	  (list (case (list-ref chrs p) ((#\~) '~=) ((#\|) '|=) ((#\=) '=))
		(string->symbol (list->string (take (cdr chrs) (- p 1)))) 
		(let* ((ccs (cdr chrs))
		       (val (list-tail ccs (if (eqv? (list-ref chrs p) #\=) 
					       p 
					       (+ p 1)))))
		  (list->string (take (if quot (cdr val) val) 
				      (- (length val) (if quot 3 1))))))
	  (string->symbol 
	   (list->string (take (cdr chrs) (- (length chrs) 2))))))))

(define add-modifiers
  (let ((contains-special-chars? 
	 (lambda (str)
	   (let* ((chars (string->list str))
		  (cchars (if (null? chars) (list) (cdr chars))))
	     (or (memv #\. cchars)
		 (memv #\: cchars)
		 (memv #\" cchars)
		 (memv #\' cchars)
		 (and (not (null? cchars))
		      (not (eqv? (car chars) #\|))
		      (or (memv #\| cchars) (memv #\# cchars)))))))
	(add-modifier 
	 (lambda (modifier s)
	   (let ((sm (substring modifier 1)))
	     (case (string-ref modifier 0)
	       ((#\.) (list 'class s (string->symbol sm)))
	       ((#\:) (let ((x (string->symbol sm)))
			(cond ((member x pseudo-classes) (list 'pclass s x))
			      ((member x pseudo-elements) (list 'pelement s x))
			      (else s))))
	       ((#\|) `(id ,s ,(string->symbol 
				(substring sm 1 (string-index sm #\|)))))
	       ((#\[) `(attrib ,s ,(parse-attrib-str modifier)))
	       (else s)))))
	(valid-modifier? (lambda (m) (if (eqv? (string-ref m 0) #\:)
					 (let ((n (substring m 1)))
					   (or (member n pseudo-classes)
					       (member n pseudo-elements)))
					 #t))))
    (lambda (sel modifiers)
      (let ((mods (if (list? modifiers) 
		      (map replace-escapes modifiers)
		      (map replace-escapes (list modifiers)))))
	(if (every valid-modifier? mods)
	    (if (and (not (contains-special-chars? sel)) 
		     (not (find contains-special-chars? mods)))
		(string->symbol (string-append sel (apply string-append mods)))
		(fold add-modifier (string->symbol sel) mods))
	    (list))))))

(define null-merge 
  (lambda (x y) 
    (if (not (null? x)) 
	(if (null? y) 
	    (list x)
	    (if (list? y) 
		(cons x y) 
		(list x y))) 
	y)))

(define guile-unicode-support 
  (let ((v (string-split (version) #\.)))
    (or (> 6 (string->number (cadr v)))
	(> 1 (string->number (car v))))))

(define can-parse-unicode?
  (lambda (num) (or (< num 256) guile-unicode-support)))

(define replace-escapes
  (lambda (s)
    (let* ((str (string-downcase (if (symbol? s) (symbol->string s) s)))
	   (f (lambda (m)
		(let ((esc (substring (match:substring m) 1)))
		  (cond ((eqv? (string-ref esc 0) #\\) "\\")
			((char-whitespace? (string-ref esc 0)) " ")
			(else (let* ((ms (match:substring m 3))
				     (n (and ms (string->number ms 16))))
				(if (and n (can-parse-unicode? n))
				    (make-string 1 (integer->char n)) 
				    esc)))))))
	   (r (regexp-substitute/global #f escape-regexc str 'pre f 'post)))
      (if (symbol? s) (string->symbol r) r))))

(define media-types
  (list "all" 
	"braille" 
	"embossed" 
	"handheld" 
	"print" 
	"projection" 
	"screen" 
	"speech" 
	"tty" 
	"tv"))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Selector detection
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (end-index str start-char from)
  (let* ((chrs (delete start-char (list #\. #\: #\| #\[)))
	 (indices (filter-map (lambda (x) (string-index str x from)) chrs)))
    (if (null? indices)
	(string-length str)
	(car (sort indices <)))))

(define pseudo-classes
  '("first-child" "link" "visited" "hover" "active" "focus" "lang"))

(define pseudo-elements '("first-line" "first-letter" "before" "after"))

(define (class? x recurse) 
  (if (list? x)
      (and (eq? (car x) 'class)
	   (case (length x)
	     ((2) (cadr x))
	     ((3) (and (if recurse (selector? (cadr x)) #t)
		       (symbol? (caddr x)) 
		       (caddr x)))
	     (else #f)))
      (let ((y (symbol->string x)))
	(and=> (let ((z (string-index y #\.)))
		 (and z (not (eqv? z (string-rindex y #\. (+ z 1)))) z))
	       (lambda (z) (or (and=> (end-index y #\: (+ z 1))
				      (lambda (a) (substring y (+ z 1) a)))
			       (substring y (+ z 1))))))))

(define (xor x y) (if x (and (not y) x) y))

(define (colon-match? x sym lst recurse)
  (if (list? x)
      (and (eq? (car x) sym)
	   (case (length x)
	     ((2) (and=> (member (cadr x) lst) car))
	     ((3) (and (if recurse (selector? (cadr x) recurse) #t) 
		       (and=> (member (caddr x) lst) car)))
	     (else #f)))
      (let ((y (symbol->string x)))
	(let* ((z1 (string-index y #\:))
	       (z2 (if z1 (string-index y #\: (+ z1 1)) #f))
	       (s1 (if z1 
		       (if z2 
			   (substring y (+ z1 1) z2)
			   (substring y (+ z1 1)))
		       #f))
	       (s2 (if z2 (substring y (+ z2 1)) #f)))
	  (xor (and=> (member s1 lst) car) (and=> (member s2 lst) car))))))

(define (pseudo-class? x recurse) 
  (colon-match? x 'pclass pseudo-classes recurse))
(define (pseudo-element? x recurse) 
  (colon-match? x 'pelement pseudo-elements recurse))

(define (id? x recurse) 
  (if (list? x)
      (and (eq? (car x) 'id)
	   (case (length x)
	     ((2) (cadr x))
	     ((3) (and (if recurse (selector? (cadr x) #t) #t)
		       (symbol? (caddr x)) 
		       (caddr x)))
	     (else #f)))
      (let* ((y (symbol->string x))
	     (ididx (string-index y #\|))
	     (endidx (and ididx (string-index y #\| (+ ididx 1)))))
	(and ididx
	     endidx
	     (eqv? (string-ref y (+ ididx 1)) #\#)
	     (substring y (+ ididx 2) endidx)))))

(define (attrib? x recurse)
  (if (list? x)
      (and (= (length x) 3) 
	   (eq? (car x) 'attrib) 
	   (if recurse (selector? (cadr x)) #t) 
	   (caddr x))
      (let* ((str (symbol->string x))
	     (start (string-index str #\[))
	     (end (string-index str #\] (if start start 0))))
	(and start end (parse-attrib-str (substring str start (+ end 1)))))))

(define (and-wrapper x y) (and x y))
(define (selector-recurse? x) (selector? x #t))
(define (contextual? x recurse)
  (and (list? x) 
       (eq? (car x) '//)
       (if recurse (fold and-wrapper #t (map selector-recurse? (cdr x))) #t)))
(define (simple? x recurse)
  (and (symbol? x) 
       (let* ((chars (string->list (symbol->string x)))
	      (head (take-while (lambda (x) 
				  (not (memv x (list #\. #\: #\| #\[))))
				chars)))
	 (if (null? head) "*" (list->string head)))))
	 
(define (grouping? x recurse)
  (and (list? x) 
       (not (memq (car x) '(// + > class pclass pelement attrib id @import)))
       (if recurse (fold and-wrapper #t (map selector-recurse? x)) #t)
       x))

(define (combinator? x recurse)
  (and (list? x) (let ((y (car x)))
		   (and (memq y '(+ >))
			(= (length x) 3)
			(or (not recurse)
			    (and (selector? (cadr x) #t) 
				 (selector? (caddr x) #t)))
			y))))

(define (path? x recurse)
  (or (combinator? x recurse) (contextual? x recurse)))

(define (selector? x recurse)
  (or (and (list? x) (or (contextual? x recurse) (grouping? x recurse)))
      (class? x recurse)
      (pseudo-class? x recurse)
      (pseudo-element? x recurse)
      (id? x recurse)
      (attrib? x recurse)
      (combinator? x recurse)
      (simple? x recurse)))

(define (simple-selector-match? sel d nodes)
  (let ((cn (car nodes))
        (imp? (lambda (x y) (and (list? x) (eq? (car x) '@import)))))
    (letrec ((f (lambda (preds tests)
		  (or (null? preds)
		      (and (let ((x ((car preds) sel #f)))
			     (if x ((car tests) x) #t))
			   (f (cdr preds) (cdr tests)))))))
      (f (list imp? class? pseudo-class? pseudo-element? id? attrib? simple?)
	 (list (lambda (x) #f)
	       (lambda (x) (equal? (sxml-attr-val cn "class") x))
	       (lambda (x) (internal-pseudo-class-handler x d cn))
	       (lambda (x) (internal-pseudo-element-handler x d cn))
	       (lambda (x) (internal-id-handler x d cn))
	       (lambda (x) 
		 (if (list? x)
		     (let ((y (sxml-attr-val cn (symbol->string (cadr x)))))
		       (and y (case (car x)
				(('~=) (member (caddr x)
					       (string-split y #\sp)))
				(('|=) (member (caddr x) (string-split y #\-)))
				(else (equal? y (caddr x))))))
		     (sxml-attr-val cn (symbol->string x))))
	       (lambda (x) (or (equal? x "*")
			       (equal? (sxml-node-name cn) x))))))))

(define (sxml-get-priv-sibling node doc)
  (let ((p (get-sxml-parent doc node)))
    (letrec ((f (lambda (t) 
		  (and (not (null? t))
		       (not (null? (cdr t)))
		       (or (let ((ct (car t)))
			     (and (list? ct) 
				  (not (eq? (car ct) '@)) (eq? (cadr t) node) 
				  (car t)))
			   (f (cdr t)))))))
      (f p))))

(define (combinator-selector-match? sel d nodes combinator)
  (if (eq? combinator '+)
      (let ((sib (sxml-get-priv-sibling (car nodes) d)))
	(and sib
	     (simple-selector-match? (cadr sel) d (list sib))
	     (simple-selector-match? (caddr sel) d nodes)))
      (and (simple-selector-match? (cadr sel) d nodes)
	   (simple-selector-match? (caddr sel) d nodes))))

(define (path-selector-match? sel d nodes slen nlen)
  (and (<= slen nlen)
       (let ((csel (car sel)))
	 (and (if (combinator? csel #f)
		  (combinator-selector-match? csel d nodes)
		  (simple-selector-match? csel d nodes))
	      (or (null? (cdr sel))
		  (let* ((s (simple? (cadr sel) #f))
			 (t (or (and (equal? s "*") (cdr nodes))
				(find-tail (lambda (x) 
					     (equal? (sxml-node-name x) s))
					   (cdr nodes)))))
		    (and t (path-selector-match? (cdr sel) 
						 d 
						 t 
						 (- slen 1) 
						 (length t)))))))))

(define	(path-length sel)
  (fold (lambda (x y) (+ y (if (combinator? x #f) 2 1))) 0 sel))

(define selector-match?
  (lambda (sel d n)
    (let ((x (combinator? sel #f)))
      (if x 
	  (combinator-selector-match? sel d n x)
	  (if (contextual? sel #f)
	      (let* ((rsel (reverse (cdr sel)))
		     (psel (path-length rsel)))
		(path-selector-match? rsel d n psel (length n)))
	      (simple-selector-match? sel d n))))))

(define calc-precedence
  (lambda (item)
    (case (car item)
      ((agent) 1)
      ((user) (if (and (= (length item) 5) (eq? (list-ref item 2) '!)) 5 2))
      (else (if (and (= (length item) 5) (eq? (list-ref item 2) '!)) 4 3)))))

(define calc-specificity
  (lambda (sel)
    (let ((count (lambda (pred lst) (length (filter pred lst))))
	  (lsel (if (contextual? sel #f) (cdr sel) (list sel))))
      (+ (* (count (lambda (x) (id? x #f)) lsel) 100)
	 (* (count (lambda (x) (or (pseudo-class? x #f) 
				   (attrib? x #f)
				   (class? x #f)))
		   lsel)
	    10)
	 (count (lambda (x) (or (pseudo-element? x #f) (simple? x #f)))
		lsel)))))

(define validate-property 
  (lambda (property value)
    (let ((pe (hashq-ref property-hash-table (symbol-downcase property))))
      (and pe (apply (car pe) (list (string-downcase value)))))))

(define verify-arg-types
  (lambda (name predicates args startnum)
    (if (not (= (length predicates) (length args)))
	(error #t "predicate argument mismatch"))
    (letrec ((f (lambda (l1 l2 i)
		  (if (null? l1) 
		      #t
		      (if (apply (car l1) (list (car l2)))
			  (f (cdr l1) (cdr l2) (+ i 1))
			  (error #t (string-append 
				     name ": wrong argument type in position "
				     (number->string (+ startnum i)))))))))
      (f predicates args 0))))

(define scss:parser-debug-messages #f)
(define display-list 
  (lambda lst (if scss:parser-debug-messages (display lst))))

(define make-parser
  (lambda (port)
    (let* 
	((error-state #f)
	 (parse-error-handler (lambda args 
				(display-list args) 
				(set! error-state #t)))
	 (lexer (lexer-make-lexer lexer-default-table 
				  (lexer-make-IS 'port port 'line)))
	 (pre-token #f)
	 (use-pre-token #f)
	 (post-tokens (list))
	 (push (lambda (sym) (set! post-tokens (cons sym post-tokens))))
	 (pop (lambda (sym) (if (eq? (car post-tokens) sym)
				(set! post-tokens (cdr post-tokens)))))
	 (lexer-wrapper
	  (lambda ()
	    (if use-pre-token
		(begin (set! use-pre-token #f) pre-token)
		(let* ((tok (lexer))
		       (tok
		  (case (car tok)
		    ((LBRACE) (push 'RBRACE) tok)
		    ((LPAREN) (push 'RPAREN) tok)
		    ((FUNCTION) (push 'RPAREN) tok)
		    ((LBRACK) (push 'RBRACK) tok)		    
		    ((RBRACE) (pop 'RBRACE) tok)
		    ((RPAREN) (pop 'RPAREN) tok)
		    ((RBRACK) (pop 'RBRACK) tok)
		    ((BAD_AT_KEYWORD)
		     (letrec 
			 ((f (lambda (wfb)
			       (let ((t (lexer)))
				 (cond ((eq? (car t) '*eoi*) t)
				       ((and (eq? (car t) 'RBRACE))
					(if (<= wfb 1) (lexer) (f (- wfb 1))))
				       ((and (eqv? wfb 0)
					     (eq? (car t) 'SEMICOLON))
					(lexer))
				       ((eq? (car t) 'LBRACE)
					(f (+ wfb 1)))
				       (else (f wfb)))))))
		       (f 0)))
		    (else tok))))
		  (let ((ctok (car tok)))
		    (if (and ctok (not (eqv? ctok 0)) (not (eq? ctok '*eoi*)))
			(begin (set! pre-token tok) tok)
			(if (null? post-tokens)
			    (begin (set! pre-token '(*eoi*)) '(*eoi*))
			    (let ((t (list (car post-tokens)))) 
			      (set! post-tokens (cdr post-tokens))
			      (set! pre-token t) 
			      t)))))))))
      (lambda ()
	(catch 'scss:parsed-statement
	       (lambda () (scss-parser lexer-wrapper parse-error-handler))
	       (lambda (key . args) 
		 (if error-state 
		     (begin (set! error-state #f) '())
		     (car args))))))))
 
(define parse-fully
  (lambda (port) 
    (let ((s (list 'css))
	  (parser (make-parser port)))
      (letrec ((f (lambda ()
		    (let ((st (parser)))
		      (if (not (eq? st '*eoi*))
			  (begin (if (and st (not (null? st)))
				     (if (not (null? s))
					 (append! s `(,st))))
				 (f)))))))
	(f)
	s))))

(define scss:css->scss 
  (lambda (port . baseurl)
    (verify-arg-types "scss:css->scss" (list port?) (list port) 1)
    (if (not (null? baseurl)) 
	(verify-arg-types "scss:css->scss" (list string?) baseurl 1))
    (let* ((dirstr (lambda (str)
		     (let ((s (string-rindex str #\/)))
		       (if s (substring str 0 (+ s 1)) ""))))
	   (uh (make-regexp "^\\w+\\:\\/\\/"))
	   (bu (if (null? baseurl)
		   (if (file-port? port) 
		       (dirstr (port-filename port))
		       (getcwd))
		   (car baseurl))))
      (lexer-init 'port port)
      (let* ((parsed-sheet (parse-fully port))
	     (imports (letrec
			  ((f (lambda (s i)
				(if (not (null? s))
				    (if (eq? (caar s) '@import)
					(f (cdr s) (cons (cadar s) i))
					i)
				    i))))
			(f (cdr parsed-sheet) (list))))
	     (clean-sheet (list-tail (cdr parsed-sheet) (length imports)))
	     (final (fold-right 
		     (lambda (s1 s2)
		       (let* ((s1 (if (and (> (string-length s1) 7)
					   (equal? (substring s1 0 7) 
						   "file://"))
				      (substring s1 7)
				      s1))
			      (bu (if (and (> (string-length bu) 7)
					   (equal? (substring bu 0 7) 
						   "file://"))
				      (substring bu 7)
				      bu))
			      (nbu (dirstr (if (and (> (string-length s1) 0)
						    (eqv? (string-ref s1 0) 
							  #\/))
					       s1
					       (string-append bu "/" s1))))
			      (p (false-if-exception
				  (cond ((and (> (string-length s1) 0)
					      (equal? (string-ref s1 0) #\/))
					 (open-input-file s1))
					((regexp-exec uh s1))
					(else (open-input-file 
					       (string-append bu "/" s1))))))
			      (new-sheet (false-if-exception (scss:css->scss 
							      p nbu))))
			 (if new-sheet (append (cdr new-sheet) s2) `(,s2))))
		     clean-sheet
		     imports)))
	(cons 'css final)))))

(define scss:scss->css
  (lambda (stylesheet port)
    (let* 
	((ser-selector 
	  (lambda (selector)
	    (display 
	     (fold (lambda (x y) 
		     (string-append 
		      (fold (lambda (q r)
			      (string-append 
			       q (if (or (exact-exec ident-regexc r)
					 (equal? r ">")
					 (equal? r "+")
					 (equal? r "*"))
				     " " "") r))
			    ""
			    (reverse x))
		      (if (null? y) "" (string-append ", " y))))
		   '()
		   (reverse selector))
	     port)))
	 (ser-property (lambda (pair) 
			 (display "\t" port)
			 (display (car pair) port)
			 (display ": " port)
			 (display (cadr pair) port)
			 (display ";" port)
			 (newline port)))
	 (ser-block (lambda (block)
		      (ser-selector (car block))
		      (display " {" port)
		      (newline port)
		      (for-each (lambda (x) (ser-property x)) (cadr block))
		      (display "}" port)
		      (newline port)
		      (newline port))))			  
      (verify-arg-types "scss:scss->css"
			(list scss:stylesheet? port?) 
			(list stylesheet port)
			1)
      (for-each (lambda (block) (ser-block block)) stylesheet))))

(define scss:create-cascade 
  (lambda arglist
    (if (null? arglist) 
	(list (list) (list) (list))
	(if (= (length arglist) 3)
	    (begin (verify-arg-types "scss:create-cascade"
				     (make-list 3 scss:stylesheet?) 
				     arglist
				     1)
		   arglist)
	    (error #t "wrong number of arguments to scss:create-cascade")))))
    
(define scss:set-author-stylesheet!
  (lambda (cascade authorsheet) 
    (set-car! (list-cdr-ref cascade 2) authorsheet)))

(define scss:set-user-stylesheet!
  (lambda (cascade usersheet) 
    (set-car! cascade usersheet)))

(define scss:set-agent-stylesheet!
  (lambda (cascade agentsheet) 
    (set-car! (list-cdr-ref cascade 1) agentsheet)))

(define scss:cascade? 
  (lambda (cascade)
    (and (list? cascade) 
	 (= (length cascade) 3) 
	 (every (lambda (x) (or (null? x) (scss:stylesheet? x))) cascade))))

(define scss:stylesheet? 
  (lambda (stylesheet)
    (and (list? stylesheet)
	 (every (lambda (x) 
		  (and (list? x)
		       (>= (length x) 2)
		       (list? (car x))
		       (false-if-exception (validate-selector (list (car x))))
		       (list? (cdr x))
		       (every (lambda (y)
				(and (list? y)
				     (or (= (length y) 2)
					 (and (= (length y) 3)
					      (eq? (list-ref y 2) '!)))
				     (string? (car y))
				     (string? (cadr y))))
			      (cdr x))))
		stylesheet))))

(define scss:color->hex 
  (lambda (color)
    (verify-arg-types "scss:color->hex" (list string?) (list color) 1)
    (let ((c (find (lambda (x) (equal? (car x) (string-downcase color))) 
		   color-table)))
      (if c (cadr c) (list)))))

(define get-prop-entry (lambda (p) (hashq-ref property-hash-table p)))

(define get-ancestors 
  (lambda (doc node)
    (if (null? node)
	(list)
	(let ((p (get-sxml-parent doc node)))
	  (if (and p (not (eq? p doc))) 
	      (cons p (get-ancestors doc p)) 
	      (list))))))

(define get-more-general-properties
  (lambda (prop)
    (let ((prop-bits (string-split (symbol->string prop) #\-)))
      (cond ((<= (length prop-bits) 1) (list))
	    ((member (car prop-bits)
		     '("background" "margin" "outline" "padding"))
	     (list (string->symbol (car prop-bits))))
	    ((and (equal? (car prop-bits) "list")
		  (equal? (cadr prop-bits) "style"))
	     (list 'list-style))
	    ((equal? (car prop-bits) "border")
	     (if (eqv? (length prop-bits) 2) 
		 (list 'border)
		 (list (string->symbol (string-append "border-" 
						      (cadr prop-bits)))
		       (string->symbol (string-append "border-" 
						      (caddr prop-bits)))
		       'border)))
	    (else (list))))))

(define (symbol-downcase x)
  (string->symbol (string-downcase (symbol->string x))))

;; This function is a bit complicated.  The general idea is that for certain
;; properties, if they're not explicitly defined in the matched selector 
;; block, you can derive their value by looking at a more general property 
;; that is defined in that block.

(define get-general-property
  (lambda (sprop val oa)
    (let* ((split-matches 
	    (lambda (pattern str)
	      (let* ((lst (list))
		     (f (lambda (x) 
			  (set! lst (append 
				     lst (list (match:substring x)))))))
		(regexp-substitute/global #f pattern str f 'post)
		lst)))

	   (prop-bits (string-split (symbol->string sprop) #\-))

	   ;; The way values are mapped to specific properties depends on the 
	   ;; number of values as per 
	   ;; http://www.w3.org/TR/CSS21/box.html#propdef-border-top-color

	   (g (lambda (pat d x)
		(let ((ml (split-matches pat x)))
		  (case (length ml)
		    ((1) (car ml)) 
		    ((2) (if (member d '("top" "bottom")) (car ml) (cadr ml)))
		    ((3) (cond ((equal? d "top") (car ml))
			       ((member d '("left" "right")) (cadr ml))
			       (else (caddr ml))))
		    ((4) (list-ref 
			  ml (list-index (lambda (y) (equal? y d))
					 '("top" "right" "bottom" "left"))))
		    (else #f)))))
 	   (h (lambda (str pattern)
		(let ((match (if (string? pattern) 
				 (string-match pattern str)
				 (regexp-exec pattern str))))
		  (and match (match:substring match)))))
	   (cl (lambda () (apply scss:select-value (append oa '(color))))))
      (cond ((= (length prop-bits) 1) #f)
	    ((equal? (car prop-bits) "border")
	     (if (= (length prop-bits) 2)
		 (cond ((equal? (cadr prop-bits) "color") 
			(let ((res (h val color-regex)))
			  (if res res (cl))))
		       ((equal? (cadr prop-bits) "width")
			(h val border-width-regex))
		       ((equal? (cadr prop-bits) "style")
			(h val border-style-regex))
		       
		       ;; Else it's one of top, left, bottom, right
		       
		       (else (car b)))
		 (let* ((c (caddr prop-bits))
			(d (string-append (car prop-bits) 
					  "-" (cadr prop-bits))))
		   (cond ((equal? (caddr prop-bits) "color")
			  (let ((res (g color-regex (cadr prop-bits) val)))
			    (if res res (cl))))
			 ((equal? (caddr prop-bits) "width")
			  (g border-width-regex (cadr prop-bits) val))
			 ((equal? (caddr prop-bits) "style")
			  (g border-style-regex (cadr prop-bits) val))))))
	    ((equal? (car prop-bits) "padding")
	     (g padding-regex (cadr prop-bits) val))
	    ((equal? (car prop-bits) "margin")
	     (g margin-regex (cadr prop-bits) val))
	    ((equal? (car prop-bits) "background")
	     (cond ((equal? (cadr prop-bits) "color") (h val pcolor-regex))
		   ((equal? (cadr prop-bits) "attach") (h val pattach-regex))
		   ((equal? (cadr prop-bits) "image") (h val pimage-regex))
		   ((equal? (cadr prop-bits) "repeat") (h val prepeat-regex))
		   ;; FIX THIS!!!
		   ((equal? (cadr prop-bits) "position"))
		   (else #f)))
	    ((and (equal? (car prop-bits) "list")
		  (equal? (cadr prop-bits) "style"))
	     (cond ((equal? (caddr prop-bits) "position")
		    (h val (string-append lsposition-regex "|(inherit)")))
		   ((equal? (caddr prop-bits) "image")
		    (h val (string-append lsimage-regex "|(inherit)")))
		   ((equal? (caddr prop-bits) "type")
		    (h val (string-append lstype-regex "|(inherit)")))
		   (else #f)))
	    ((equal? (car prop-bits) "outline")
	     (cond ((equal? (cadr prop-bits) "color")
		    (h val (string-append ocolor-regex "|(inherit)")))
		   ((equal? (cadr prop-bits) "style")
		    (h val (string-append ostyle-regex "|(inherit)")))
		   ((equal? (cadr prop-bits) "width")
		    (h val (string-append owidth-regex "|(inherit)")))
		   (else #f)))
	    ((equal? (car prop-bits) "font")
	     (cond ((equal? (cadr prop-bits) "family") (h val ffamily-regex))
		   ((equal? (cadr prop-bits) "size") (h val fsize-regex))
		   ((equal? (cadr prop-bits) "style") (h val fstyle-regex))
		   ((equal? (cadr prop-bits) "variant") (h val fvariant-regex))
		   ((equal? (cadr prop-bits) "weight") (h val fweight-regex))
		   (else #f)))
	    (else #f)))))

(define (filter-media medium cascade)
  (map (lambda (x)
	 (let ((res (fold-right append
				'()
				(filter-map (lambda (y)
					      (if (eq? (car y) '@media)
						  (let ((z (cadr y)))
						    (and (or (memq medium z)
							     (memq 'all z))
							 (cddr y)))
						  (list y)))
					    (if (null? x) x (cdr x))))))
	   (if (null? res) res (cons 'css res))))
       cascade))

(define lookup-values
  (lambda (cascade selector medium table)
    (let* 
	((cascade (filter-media medium cascade))
	 (ss (string->symbol selector))
	 (match-pred (lambda (x) (or (eq? x '*) (eq? x ss))))
	 (f (lambda (sym sheet)
	      (fold append
		    '()
		    (map (lambda (x)
			   (filter-map 
			    (lambda (y) 
			      (and (match-pred y)
				   (map (lambda (z) (cons* sym y z)) (cdr x))))
			    (let ((cx (car x)))
			      (or (grouping? cx #f) (list cx)))))
			 (if (null? sheet) sheet (cdr sheet))))))
	 (agent-matches (apply append (f 'agent(car cascade))))
	 (user-matches (apply append (f 'user (cadr cascade))))
	 (author-matches (apply append (f 'author (caddr cascade))))
	 (sr (sort (append '() agent-matches user-matches author-matches)
		   (lambda (x y)
		     (and (<= (calc-precedence x) (calc-precedence y))
			  (<= (calc-specificity (cadr x))
			      (calc-specificity (cadr y)))))))
	 (order 0))
      (for-each (lambda (x)
		  (let* ((imp (eq? (caddr x) '!))
			 (sdcy (symbol-downcase (list-ref x (if imp 3 2))))
			 (sdcv (string-downcase (list-ref x (if imp 4 3)))))
		    (if (hashq-ref property-hash-table sdcy)
			(begin
			  (hashq-set! table sdcy (cons sdcy (cons sdcv order)))
			  (set! order (+ order 1))))))
		sr))))
  
(define select-values
  (lambda (cascade node doc medium table)
    (let* 
	((cascade (filter-media medium cascade))
	 (a (cons node (get-ancestors doc node)))
	 (f (lambda (sym sheet)
	      (fold append
		    '()
		    (map (lambda (x)
			   (filter-map (lambda (y)
					 (and (selector-match? y doc a)
					      (map (lambda (z) (cons* sym y z))
						   (cdr x))))
				       (let ((cx (car x)))
					 (or (grouping? cx #f) (list cx)))))
			 (if (null? sheet) sheet (cdr sheet))))))
	 (agent-matches (apply append (f 'agent (car cascade))))
	 (user-matches (apply append (f 'user (cadr cascade))))
	 (author-matches (apply append (f 'author (caddr cascade))))
	 (sr (sort (append '() author-matches user-matches agent-matches)
		   (lambda (x y)
		     (let ((cpx (calc-precedence x)) (cpy (calc-precedence y)))
		       (or (< cpx cpy)
			   (and (eqv? cpx cpy)
				(<= (calc-specificity (cadr x))
				    (calc-specificity (cadr y)))))))))
	 (order 0))
      (for-each (lambda (x)
		  (let* ((imp (eq? (caddr x) '!))
			 (sdcy (symbol-downcase (list-ref x (if imp 3 2))))
			 (sdcv (string-downcase (list-ref x (if imp 4 3)))))
		    (if (hashq-ref property-hash-table sdcy)
			(begin
			  (hashq-set! table sdcy (cons sdcy (cons sdcv order)))
			  (set! order (+ order 1))))))
		sr))))
 
(define get-default-prop-value
  (let ((foldfn (lambda (x y)
		  (let ((z (if (equal? y "") "" (string-append " " y))))
		    (if (symbol? x)
			(let ((r (get-default-prop-value (get-prop-entry x))))
			  (if (and r (not (null? r))) (string-append r z) z))
			(string-append x z))))))
    (lambda (pe) 
      (and pe (fold foldfn "" (list-ref pe 1))))))

(define scss:get-default-value
  (lambda (prop)
    (verify-arg-types "scss:get-default-value" (list symbol?) (list prop) 1)
    (get-default-prop-value (get-prop-entry prop))))

(define scss:inherited? 
  (lambda (prop) (let ((pe (get-prop-entry prop))) (and pe (list-ref pe 2)))))

(define gsds
  (lambda (d)
    (let* ((c (filter (lambda (x) (and (list? x) (not (eq? (car x) '@)))) d))
	   (lc (length c)))
      (for-each (lambda (x) (set! lc (+ lc (gsds x)))) c) lc)))

(define lookup-value
  (lambda (source selector recurse medium prop)
    (let* ((prop (string->symbol (string-downcase (symbol->string prop))))
	   (d (hashx-ref cascade-hash cascade-assoc cascade-hash-table source))
	   (d (if d d (let ((dh (make-hash-table 32)))
			(hashx-set! cascade-hash cascade-assoc 
				    cascade-hash-table source dh)
			dh)))
	   (pe (get-prop-entry prop))
	   (e (hashq-ref d selector))
	   (e (if e e (let ((eh (make-hash-table num-css-props)))
			(lookup-values source selector medium eh)
			(hash-set! d selector eh)
			eh)))
           (vs (sort (cons (hashq-ref e prop)
			   (map (lambda (z) (hashq-ref e z))
				(get-more-general-properties prop)))
		     (lambda (x y)
		       (or (not y) (and x (> (cddr x) (cddr y)))))))
	   (v (and (car vs)
		   (if (eq? (caar vs) prop)
		       (cadar vs)
		       (get-general-property prop 
					     (cadar vs) 
					     (list source selector medium))))))
      (or v (and recurse (get-default-prop-value pe))))))

(define select-value
  (lambda (source selector recurse doc medium prop)
    (let* ((d (hashq-ref document-hash-table doc))
	   (d (if d d (begin (let ((dh (make-weak-key-hash-table (gsds doc))))
			       (hashq-set! document-hash-table doc dh)
			       dh))))
	   (c (hashx-ref cascade-hash cascade-assoc d source))
	   (c (if c c (begin (let ((ch (make-weak-key-hash-table 16)))
			       (hashx-set! cascade-hash cascade-assoc d source 
					   ch)
			       ch))))
	   (prop (string->symbol (string-downcase (symbol->string prop))))
	   (create-hash (lambda (elt)
			  (let ((eh (make-hash-table 32)))
			    (select-values source elt doc medium eh)
			    (hashq-set! c elt eh)
			    eh)))
	   (pe (get-prop-entry prop)))
      (letrec
	  ((f (lambda (ht elt)
		(let* ((e (hashq-ref c elt))
		       (e (if e e (create-hash elt)))
		       
		       ;; The most specific property might not be the best
		       ;; match -- look at ALL the related properties and
		       ;; derive the requested value if it's not the most
		       ;; specific.
		       
		       (vs (sort (cons (hashq-ref e prop)
				       (map (lambda (z) (hashq-ref e z))
					    (get-more-general-properties 
					     prop)))
				 (lambda (x y)
				   (or (not y)
				       (and x (> (cddr x) (cddr y)))))))
		       (v (and (car vs)
			       (if (eq? (caar vs) prop)
				   (cadar vs)
				   (get-general-property prop 
							 (cadar vs)
							 (list source 
							       elt 
							       doc
							       medium)))))

		       (par (get-sxml-parent d elt)))
		  (if (and recurse
			   (and par (not (null? par)) (not (eq? par doc)))
			   (or (and (not v) pe (list-ref pe 2))
			       (equal? v "inherit")))
		      (f ht par)
		      v)))))
	(let ((val (f c selector)))
	  (if val
	      (string-downcase val)
	      (and recurse (get-default-prop-value pe))))))))

(define scss:select-value
  (lambda (source selector . r)
    (let ((r (if (string? selector)
		 (if (< (length r) 2) (cons 'all r) r)
		 (if (< (length r) 3) (cons* (car r) 'all (cdr r)) r))))
      (apply (if (string? selector) lookup-value select-value)
	     (append (list source selector #t) r)))))

(define scss:select-value-at-node
  (lambda (source selector . r)
    (let ((r (if (string? selector)
		 (if (< (length r) 2) (cons 'all r) r)
		 (if (< (length r) 3) (cons* (car r) 'all (cdr r)) r))))
      (apply (if (string? selector) lookup-value select-value)
	     (append (list source selector #f) r)))))

(define scss:clear-style-cache!
  (lambda (source selector . r)
    (if (string? selector)
	(let ((d (hashx-ref cascade-hash cascade-assoc cascade-hash-table 
			    source)))
	  (if d (hash-remove! d selector)))
	(let* ((d (hashq-ref document-hash-table (car r)))) 
	  (if d (let ((c (hashx-ref cascade-hash cascade-assoc d source)))
		  (if c (hashq-remove! c selector))))))))