#|
 This file is a part of LASS
 (c) 2014 Shirakumo http://tymoon.eu (shinmera@tymoon.eu)
 Author: Nicolas Hafner <shinmera@tymoon.eu>
|#

(in-package #:org.tymoonnext.lass)

;;; FUNCS
(macrolet ((define-properties (&rest rest)
             `(progn
                ,@(loop for (name args) on rest by #'cddr
                        collect `(define-simple-property-function ,name ,args)))))
  (define-properties
    rgb (red green blue)
    rgba (red green blue alpha)
    hsl (hue saturation lightness)
    hsla (hue saturation lightness alpha)))
(define-property-function hex (hex) (format NIL "#~6,'0d" hex))
(define-property-function url (url) (format NIL "url(~s)" url))
(define-property-function attr (attribute) (format NIL "attr(~a)" (resolve attribute)))

;;; https://www.w3.org/TR/css-variables-1/
(define-property-function var (name &rest fallback-vals)
  (format nil "var(~(~A~)~{~^, ~(~A~)~})" name fallback-vals))

(define-property-function calc (func)
  (with-output-to-string (out)
    (labels ((proc (func)
               (write-string "(" out)
               (if (or (not (listp func))
                       (property-function (first func)))
                   (write-string (resolve func) out)
                   (destructuring-bind (func first &rest rest) func
                     (proc first)
                     (loop :for arg :in rest
                           :do (format out " ~A " (resolve func))
                               (proc arg))))
               (write-string ")" out)))
      (write-string "calc" out)
      (proc func)))) 

(define-simple-property-function counter (var))

;;; BLOCKS

(define-special-block charset (charset)
  (list (list :property (format NIL "@charset ~a" (resolve charset)))))

(define-special-block document (selector &rest body)
  (list (make-superblock
         "document"
         (compile-media-query selector)
         (apply #'compile-sheet body))))

(define-special-block font-face (&rest body)
  (compile-block "@font-face" body))

(define-special-block import (url &rest media-queries)
  (list (make-property
         (format NIL "@import ~a~{ ~a~}"
                 (resolve url)
                 (mapcar #'resolve media-queries)))))

(define-special-block keyframes (identifier &rest body)
  (list (make-superblock
         "keyframes"
         (list (list :constraint :literal (resolve identifier)))
         (apply #'compile-sheet body))))

(define-special-block media (query &rest body)
  (list (make-superblock
         "media"
         (compile-media-query query)
         (apply #'compile-sheet body))))

(define-special-block namespace (prefix/namespace &optional namespace)
  (list (make-property
         (format NIL "@namespace ~a~@[ ~a~]"
                 (resolve prefix/namespace)
                 (when namespace (resolve namespace))))))

(define-special-block page (pseudo-class &rest body)
  (compile-block (format NIL "@page ~a"
                         (if (keywordp pseudo-class)
                             (format NIL ":~a" (string-downcase pseudo-class))
                             (resolve pseudo-class))) body))

(define-special-block supports (selector &rest body)
  (list (make-superblock
         "supports"
         (compile-selector selector)
         (apply #'compile-sheet body))))

(defmacro bind-vars (bindings &body body)
  `(let ((*vars* (let ((table (make-hash-table)))
                   (maphash #'(lambda (k v) (setf (gethash k table) v)) *vars*)
                   (loop for (k v) in ,bindings
                         do (setf (gethash k table)
                                  (resolve v)))
                   table)))
     ,@body))

(define-special-block let (bindings &rest body)
  (bind-vars bindings
             (apply #'compile-sheet body)))

;;; SELECTORS

(defmacro define-attr-comparator (comp &optional (outcomp comp))
  "Helper macro to define an attribute comparator selector."
  `(define-special-selector ,comp (attr value)
     (loop with out = ()
           with values = (compile-selector value)
           for attr in (compile-selector attr)
           do (loop for value in values
                    do (push (list :constraint :attribute attr ,(string outcomp) value) out))
           finally (return (nreverse out)))))

(define-attr-comparator =)
(define-attr-comparator ~=)
(define-attr-comparator *=)
(define-attr-comparator $=)
(define-attr-comparator ^=)
(define-attr-comparator /= \|=)

(defmacro define-single-arg-selector (name)
  "Helper macro to define a single-argument pseudo-selector like NOT or NTH-CHILD."
  `(define-special-selector ,name (arg)
     (loop for arg in (compile-selector arg)
           collect (list :constraint :selector ,(string-downcase name) arg))))

(define-single-arg-selector dir)
(define-single-arg-selector lang)
(define-single-arg-selector not)
(define-single-arg-selector nth-child)
(define-single-arg-selector nth-last-child)
(define-single-arg-selector nth-last-of-type)
(define-single-arg-selector nth-of-type)

;;; ATTRIBUTES

(define-special-property font-family (&rest faces)
  (list (make-property "font-family" (format NIL "~{~a~^, ~}" (mapcar #'resolve faces)))))

(define-special-property content (&rest content)
  (labels ((translate (content)
             (typecase content
               (string
                ;; Backwards compat with the usage of "'foo'" in LASS files
                (when (and (<= 2 (length content))
                           (char= #\' (char content 0))
                           (char= #\' (char content (1- (length content)))))
                  (setf content (subseq content 1 (1- (length content)))))
                (with-output-to-string (out)
                  (write-char #\" out)
                  (unwind-protect
                       (loop for char across content
                             do (when (char= char #\")
                                  (write-char #\\ out))
                                (write-char char out))
                    (write-char #\" out))))
               (T
                (resolve content)))))
    (list (make-property "content" (format NIL "~{~a~^ ~}" (mapcar #'translate content))))))

(defmacro define-browser-property (name args &body browser-options)
  "Helper macro to define properties that have browser-dependant versions.

NAME            --- The base name of the property name or value.
ARGS            --- Property arguments, see DEFINE-SPECIAL-PROPERTY.
BROWSER-OPTIONS ::= (OPTION (symbol) FORM*)
OPTION          ::= :MOZ | :O | :WEBKIT | :MS | :W3C | :DEFAULT

Each browser-option body should return a single property. The SYMBOL
in the option definition is bound to the computed property name
 (eg -moz-NAME for the :MOZ option).
You can define special handling of the browsers by defining options
specifically for them. If no handling is defined, the DEFAULT option
is used as a fallback."
  `(define-special-property ,name ,args
     (list ,@(loop for (browser prefix) in '((:moz "-moz-")
                                             (:o "-o-")
                                             (:webkit "-webkit-")
                                             (:ms "-ms-")
                                             (:w3c ""))
                   for body = (or (assoc browser browser-options)
                                  (assoc :default browser-options))
                   collect `(let ((,(caadr body) ,(format NIL "~a~a" prefix (string-downcase name))))
                              ,@(cddr body))))))

(indent:define-indentation define-browser-property (4 6 &rest (&whole 2 0 4 2)))

(define-browser-property text-stroke (width color)
  (:default (property)
    (make-property property (format NIL "~a ~a" (resolve width) (resolve color)))))

(define-browser-property linear-gradient (direction &rest colors)
  (:default (property)
    (make-property "background" (format NIL "~a(~a~{, ~a ~a~})"
                                        property (resolve direction) (mapcar #'resolve colors)))))

(define-browser-property radial-gradient (shape size position &rest colors)
  (:default (property)
    (make-property "background" (format NIL "~a(~a ~a at ~a~{, ~a ~a~})"
                                        property (resolve shape) (resolve size) (resolve position) (mapcar #'resolve colors)))))

(define-browser-property repeating-radial-gradient (shape size position &rest colors)
  (:default (property)
    (make-property "background" (format NIL "~a(~a ~a at ~a~{, ~a ~a~})"
                                        property (resolve shape) (resolve size) (resolve position) (resolve colors)))))

(define-browser-property transform (value/function &rest function-args)
  (:default (property)
    (make-property property (format NIL "~a~@[(~{~a~^, ~})~]"
                                    (resolve value/function) (mapcar #'resolve function-args)))))

(define-browser-property transform-origin (value/x &optional y z)
  (:default (property)
    (make-property property (format NIL "~a~@[ ~a~]~@[ ~a~]"
                                    (resolve value/x) (resolve y) (resolve z)))))

(define-browser-property transform-style (style)
  (:default (property)
    (make-property property (resolve style))))

(define-browser-property transition (value/property &optional duration timing-function &rest function-args)
  (:default (property)
    (make-property property (format NIL "~a~@[ ~a~]~:[~*~;~:* ~a~@[(~{~a~^, ~})~]~]"
                                    (resolve value/property) (resolve duration) (resolve timing-function) (mapcar #'resolve function-args)))))

(define-browser-property transition-delay (value)
  (:default (property)
    (make-property property (resolve value))))

(define-browser-property transition-duration (value)
  (:default (property)
    (make-property property (resolve value))))

(define-browser-property transition-property (value)
  (:default (property)
    (make-property property (resolve value))))

(define-browser-property transition-timing-function (value/function &rest function-args)
  (:default (property)
    (make-property property (format NIL "~a~@[(~{~a~^, ~})~]"
                                    (resolve value/function) (mapcar #'resolve function-args)))))

(define-browser-property user-select (value)
  (:default (property)
    (make-property property (resolve value))))

(define-browser-property appearance (value)
  (:default (property)
    (make-property property (resolve value))))

(define-simple-property-functions :filter
    (url (url))
  (blur (radius))
  (brightness (value))
  (contrast (value))
  (drop-shadow (x y &optional blur spread color))
  (grayscale (value))
  (hue-rotate (value))
  (invert (value))
  (opacity (value))
  (saturate (value))
  (sepia (value)))

(define-browser-property filter (&rest args)
  (:default (property)
    (make-property property (format NIL "~{~a~^ ~}" (mapcar #'resolve args)))))

(define-browser-property box-shadow (color &optional x y blur spread inset)
  (:default (property)
    (make-property property (format NIL "~a~@[ ~a~]~@[ ~a~]~@[ ~a~]~@[ ~a~]~@[ ~a~]"
                                    (resolve color) (resolve x) (resolve y) (resolve blur) (resolve spread) (resolve inset)))))