path: root/src/xml-abbrev.el

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; XML abbrev

(defun zencoding-expr (input)
  "Parse a zen coding expression with optional filters."
  (zencoding-pif (zencoding-parse "\\(.*?\\)|" 2 "expr|filter" it)
                 (let ((input (elt it 1))
                       (filters (elt it 2)))
                   (zencoding-pif (zencoding-extract-filters filters)
                                  (zencoding-filter input it)
                                  it))
                 (zencoding-filter input (zencoding-default-filter))))

(defun zencoding-subexpr (input)
  "Parse a zen coding expression with no filter. This pretty much defines precedence."
  (zencoding-run zencoding-siblings
                 it
                 (zencoding-run zencoding-parent-child
                                it
                                (zencoding-run zencoding-multiplier
                                               it
                                               (zencoding-run zencoding-pexpr
                                                              it
                                                              (zencoding-run zencoding-text
                                                                             it
                                                                             (zencoding-run zencoding-tag
                                                                                            it
                                                                                            '(error "no match, expecting ( or a-zA-Z0-9"))))))))

(defun zencoding-extract-filters (input)
  "Extract filters from expression."
  (zencoding-pif (zencoding-parse "\\([^\\|]+?\\)|" 2 "" it)
                 (let ((filter-name (elt it 1))
                       (more-filters (elt it 2)))
                   (zencoding-pif (zencoding-extract-filters more-filters)
                                  (cons filter-name it)
                                  it))
                 (zencoding-parse "\\([^\\|]+\\)" 1 "filter name" `(,(elt it 1)))))

(defun zencoding-filter (input filters)
  "Construct AST with specified filters."
  (zencoding-pif (zencoding-subexpr input)
                 (let ((result (car it))
                       (rest (cdr it)))
                   `((filter ,filters ,result) . ,rest))
                 it))

(defun zencoding-default-filter ()
  "Default filter(s) to be used if none is specified."
  (let* ((file-ext (car (zencoding-regex ".*\\(\\..*\\)" (or (buffer-file-name) "") 1)))
         (defaults '(".html" ("html")
                     ".htm"  ("html")
                     ".haml" ("haml")
                     ".clj"  ("hic")))
         (default-else      '("html"))
         (selected-default (member file-ext defaults)))
    (if selected-default
        (cadr selected-default)
      default-else)))

(defun zencoding-numbering (input)
  (zencoding-parse
   "\\(\\$+\\)" 2 "numbering, $"
   (let ((doller (elt it 1)))
     (zencoding-pif (zencoding-parse
                     "@\\([0-9-][0-9]*\\)" 2 "numbering args"
                     (let* ((args (read (elt it 1)))
                            (direction  (not (or (eq '- args) (minusp args))))
                            (base       (if (eq '- args) 1 (abs args))))
                       `((n ,(length doller) ,direction ,base) . ,input)))
                    it
                    `((n ,(length doller) t 1) . ,input)))))

(defun zencoding-split-numbering-expressions (input)
  (labels
      ((iter (input)
             (zencoding-aif (zencoding-regex "\\([^$]*\\)\\(\\$.*\\)" input '(1 2))
                (let ((prefix (car it))
                      (input (cadr it)))
                  (if (and (< 0 (length prefix)) ; check if ..\\$... or ...$...
                           (string-equal (substring prefix -1) "\\"))
                      `(,(store-substring prefix (- (length prefix) 1) ?$)
                        ,@(iter (substring input 1)))
                    (let ((res (zencoding-numbering input)))
                      `(,prefix ,(car res) ,@(iter (cdr res))))))
                (list input))))
    (let ((res (iter input)))
      (if (every #'stringp res)
          (apply #'concat res)
        `(numberings ,@res)))))

(defun zencoding-instantiate-numbering-expression (i lim exp)
  (labels ((instantiate
            (i lim exps)
            (apply #'concat
                   (mapcar
                    (lambda (exp)
                      (if (listp exp)
                          (let ((digits (second exp))
                                (direction (third exp))
                                (base (fourth exp)))
                            (let ((num (if direction (+ base i)
                                         (- (+ lim (- base 1)) i))))
                              (format (concat "%0" (format "%d" digits) "d") num)))
                        exp)) exps)))
           (search
            (i lim exp)
            (if (listp exp)
                (if (eql (car exp) 'numberings)
                    (instantiate i lim (cdr exp))
                  ;; Should do like this for real searching.
                  ;; But stack overflow occurs.
                  ;; (cons (search-numberings i lim (car exp))
                  ;;       (search-numberings i lim (cdr exp)))
                  (mapcar (lambda (exp) (search i lim exp)) exp))
              exp)))
    (search i lim exp)))

(defun zencoding-multiply-expression (multiplicand exp)
  (loop for i to (- multiplicand 1) collect
        (zencoding-instantiate-numbering-expression i multiplicand exp)))

(defun zencoding-multiplier (input)
  (zencoding-pif (zencoding-run zencoding-pexpr
                                it
                                (zencoding-run zencoding-tag
                                               it
                                               (zencoding-run zencoding-text
                                                              it
                                                              '(error "expected *n multiplier"))))
                 (let* ((expr (car it)) (input (cdr it))
                        (multiplier expr))
                   (zencoding-parse "\\*\\([0-9]+\\)" 2 "*n where n is a number"
                                    (let ((multiplicand (read (elt it 1))))
                                      `((list ,(zencoding-multiply-expression
                                                multiplicand
                                                multiplier)) . ,input))))))

(defun zencoding-tag (input)
  "Parse a tag."
  (zencoding-run zencoding-tagname
                 (let ((tagname (cadr expr))
                       (has-body? (cddr expr)))
                   (zencoding-pif (zencoding-run zencoding-identifier
                                                 (zencoding-tag-classes
                                                  `(tag (,tagname ,has-body? ,(cddr expr))) input)
                                                 (zencoding-tag-classes
                                                  `(tag (,tagname ,has-body? nil)) input))
                                  (let ((tag-data (cadar it)) (input (cdr it)))
                                    (zencoding-pif (zencoding-run zencoding-props
                                                                  (let ((props (cdr expr)))
                                                                    `((tag ,(append tag-data (list props))) . ,input))
                                                                  `((tag ,(append tag-data '(nil))) . ,input))
                                                   (let ((expr (car it)) (input (cdr it)))
                                                     (zencoding-tag-text expr input))))))
                 (zencoding-default-tag input)))

(defun zencoding-default-tag (input)
  "Parse a #id or .class"
  (zencoding-parse "\\([#|\\.]\\)" 1 "tagname"
                   (zencoding-tag (concat "div" (elt it 0)))))

(defun zencoding-tag-text (tag input)
  (let ((tag-data (cadr tag)))
    (zencoding-run zencoding-text
                   (let ((txt (cadr expr)))
                     `((tag ,(append tag-data (list txt))) . ,input))
                   `((tag ,(append tag-data '(nil))) . ,input))))

(defun zencoding-tag-props (tag input)
  (let ((tag-data (cadr tag)))
    (zencoding-run zencoding-props
                   (let ((props (cdr expr)))
                     `((tag ,(append tag-data (list props))) . ,input))
                   `((tag ,(append tag-data '(nil))) . ,input))))

(defun zencoding-props (input)
  "Parse many props."
    (zencoding-run zencoding-prop
                   (zencoding-pif (zencoding-props input)
                                  `((props . ,(cons expr (cdar it))) . ,(cdr it))
                                  `((props . ,(list expr)) . ,input))))

(defun zencoding-prop (input)
  (zencoding-parse
   " " 1 "space"
   (zencoding-run
    zencoding-name
    (let ((name (cdr expr)))
      (zencoding-pif (zencoding-prop-value name input)
                     it
                     `((,(read name) "") . ,input))))))

(defun zencoding-prop-value (name input)
  (zencoding-pif (zencoding-parse "=\"\\(.*?\\)\"" 2
                                  "=\"property value\""
                                  (let ((value (elt it 1))
                                        (input (elt it 2)))
                                    `((,(read name) ,value) . ,input)))
                 it
                 (zencoding-parse "=\\([^\\,\\+\\>\\ )]*\\)" 2
                                  "=property value"
                                  (let ((value (elt it 1))
                                        (input (elt it 2)))
                                    `((,(read name) ,value) . ,input)))))

(defun zencoding-tag-classes (tag input)
  (let ((tag-data (cadr tag)))
    (zencoding-run zencoding-classes
                   (let ((classes (mapcar (lambda (cls) (cdadr cls))
                                          (cdr expr))))
                     `((tag ,(append tag-data (list classes))) . ,input))
                   `((tag ,(append tag-data '(nil))) . ,input))))

(defun zencoding-tagname (input)
  "Parse a tagname a-zA-Z0-9 tagname (e.g. html/head/xsl:if/br)."
  (zencoding-parse "\\([a-zA-Z][a-zA-Z0-9:$@-]*\/?\\)" 2 "tagname, a-zA-Z0-9"
                   (let* ((tag-spec (elt it 1))
                          (empty-tag (zencoding-regex "\\([^\/]*\\)\/" tag-spec 1))
                          (tag (zencoding-split-numbering-expressions
                                (if empty-tag (car empty-tag) tag-spec))))
                     `((tagname . (,tag . ,(not empty-tag))) . ,input))))

(defun zencoding-text (input)
  "A zen coding expression innertext."
  (zencoding-parse "{\\(.*?\\)}" 2 "inner text"
                   (let ((txt (zencoding-split-numbering-expressions (elt it 1))))
                     `((text ,txt) . ,input))))

(defun zencoding-pexpr (input)
  "A zen coding expression with parentheses around it."
  (zencoding-parse "(" 1 "("
                   (zencoding-run zencoding-subexpr
                                  (zencoding-aif (zencoding-regex ")" input '(0 1))
                                                 `(,expr . ,(elt it 1))
                                                 '(error "expecting `)'")))))

(defun zencoding-parent-child (input)
  "Parse an tag>e expression, where `n' is an tag and `e' is any
   expression."
  (defun listing (parents child input)
    (let ((len (length parents)))
      `((list ,(map 'list
                    (lambda (parent i)
                      `(parent-child ,parent
                                     ,(zencoding-instantiate-numbering-expression i len child)))
                    parents
                    (loop for i to (- len 1) collect i))) . ,input)))
  (zencoding-run zencoding-multiplier
                 (let* ((items (cadr expr))
                        (rest (zencoding-child-sans expr input)))
                   (if (not (eq (car rest) 'error))
                       (let ((child (car rest))
                             (input (cdr rest)))

                         (zencoding-aif (zencoding-regex "^" input '(0 1))
                                                   (let ((input (elt it 1)))
                                                     (zencoding-run zencoding-subexpr
                                                                    `((sibling ,(car (listing items child "")) ,expr) . ,input)
                                                                    (listing items child input)))
                                                   (listing items child input)))
                     '(error "expected child")))
                 (zencoding-run zencoding-tag
                                (zencoding-child expr input)
                                '(error "expected parent"))))

(defun zencoding-child-sans (parent input)
  (zencoding-parse ">" 1 ">"
                   (zencoding-run zencoding-subexpr
                                  it
                                  '(error "expected child"))))

(defun zencoding-child (parent input)
  (zencoding-parse ">" 1 ">"
                   (zencoding-run zencoding-subexpr
                                  (let ((child expr))
                                    (zencoding-aif (zencoding-regex "^" input '(0 1))
                                                   (let ((input (elt it 1)))
                                                     (zencoding-run zencoding-subexpr
                                                                    `((sibling (parent-child ,parent ,child) ,expr) . ,input)
                                                                    `((parent-child ,parent ,child) . ,input)))
                                                   `((parent-child ,parent ,child) . ,input)))
                                  '(error "expected child"))))

(defun zencoding-sibling (input)
  (zencoding-por zencoding-pexpr zencoding-multiplier
                 it
                 (zencoding-run zencoding-tag
                                it
                                (zencoding-run zencoding-text
                                               it
                                               '(error "expected sibling")))))

(defun zencoding-siblings (input)
  "Parse an e+e expression, where e is an tag or a pexpr."
  (zencoding-run zencoding-sibling
                 (let ((parent expr))
                   (zencoding-parse "\\+" 1 "+"
                                    (zencoding-run zencoding-subexpr
                                                   (let ((child expr))
                                                     `((sibling ,parent ,child) . ,input))
                                                   (zencoding-expand parent input))))
                 '(error "expected first sibling")))

(defvar zencoding-expandable-tags
  '("dl"    ">(dt+dd)"
    "ol"    ">li"
    "ul"    ">li"
    "table" ">tr>td"))

(defun zencoding-expand (parent input)
  "Parse an e+ expression, where e is an expandable tag"
  (let* ((parent-tag (car (elt parent 1)))
         (expandable (member parent-tag zencoding-expandable-tags)))
    (if expandable
        (let ((expansion (zencoding-child parent (concat (cadr expandable)))))
          (zencoding-pif (zencoding-parse "+\\(.*\\)" 1 "+expr"
                                          (zencoding-subexpr (elt it 1)))
                         `((sibling ,(car expansion) ,(car it)))
                         expansion))
      '(error "expected second sibling"))))

(defun zencoding-name (input)
  "Parse a class or identifier name, e.g. news, footer, mainimage"
  (zencoding-parse "\\([a-zA-Z$@][a-zA-Z0-9$@_:-]*\\)" 2 "class or identifer name"
                   `((name . ,(zencoding-split-numbering-expressions
                               (elt it 1))) . ,input)))

(defun zencoding-class (input)
  "Parse a classname expression, e.g. .foo"
  (zencoding-parse "\\." 1 "."
                   (zencoding-run zencoding-name
                                  `((class ,expr) . ,input)
                                  '(error "expected class name"))))
(defun zencoding-identifier (input)
  "Parse an identifier expression, e.g. #foo"
  (zencoding-parse "#" 1 "#"
                   (zencoding-run zencoding-name
                                  `((identifier . ,expr) . ,input))))

(defun zencoding-classes (input)
  "Parse many classes."
  (zencoding-run zencoding-class
                 (zencoding-pif (zencoding-classes input)
                                `((classes . ,(cons expr (cdar it))) . ,(cdr it))
                                `((classes . ,(list expr)) . ,input))
                 '(error "expected class")))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Zen coding transformer from AST to string

(defvar zencoding-inline-tags
  '("a"
    "abbr"
    "acronym"
    "cite"
    "code"
    "dd"
    "dfn"
    "dt"
    "em"
    "h1" "h2" "h3" "h4" "h5" "h6"
    "kbd"
    "li"
    "q"
    "span"
    "strong"
    "var"
    "textarea"
    "small"
    "time" "del" "ins"
    "sub"
    "sup"
    "i" "s" "b"
    "ruby" "rt" "rp"
    "bdo"
    "iframe" "canvas"
    "audio" "video"
    "ovject" "embed"
    "map"))

(defvar zencoding-block-tags
  '("p"
    "article"
    "section"
    "aside"
    "nav"
    "figure"
    "address"
    "header"
    "footer"))

(defvar zencoding-self-closing-tags
  '("br"
    "img"
    "input"
    "wbr"
    "object"
    "source"
    "area"
    "param"
    "option"))

(defvar zencoding-leaf-function nil
  "Function to execute when expanding a leaf node in the
  Zencoding AST.")

(defvar zencoding-filters
  '("html" (zencoding-primary-filter zencoding-make-html-tag)
    "c"    (zencoding-primary-filter zencoding-make-commented-html-tag)
    "haml" (zencoding-primary-filter zencoding-make-haml-tag)
    "hic"  (zencoding-primary-filter zencoding-make-hiccup-tag)
    "e"    (zencoding-escape-xml)))

(defun zencoding-primary-filter (input proc)
  "Process filter that needs to be executed first, ie. not given output from other filter."
  (if (listp input)
      (let ((tag-maker (cadr proc)))
        (zencoding-transform-ast input tag-maker))
    nil))

(defun zencoding-process-filter (filters input)
  "Process filters, chain one filter output as the input of the next filter."
  (let ((filter-data (member (car filters) zencoding-filters))
        (more-filters (cdr filters)))
    (if filter-data
        (let* ((proc   (cadr filter-data))
               (fun    (car proc))
               (filter-output (funcall fun input proc)))
          (if more-filters
              (zencoding-process-filter more-filters filter-output)
            filter-output))
      nil)))

(defun zencoding-make-tag (tag-maker tag-info &optional content)
  "Extract tag info and pass them to tag-maker."
  (let* ((name      (pop tag-info))
         (has-body? (pop tag-info))
         (id        (pop tag-info))
         (classes   (pop tag-info))
         (props     (pop tag-info))
         (txt       (pop tag-info))
         (self-closing? (not (or txt content
                                 (and has-body?
                                      (not (member name zencoding-self-closing-tags)))))))
    (funcall tag-maker name id classes props txt self-closing?
             (if content content
               (if zencoding-leaf-function (funcall zencoding-leaf-function))))))

(defun zencoding-make-html-tag (tag-name tag-id tag-classes tag-props tag-txt self-closing? content)
  "Create HTML markup string"
  (let* ((id      (zencoding-concat-or-empty " id=\"" tag-id "\""))
         (classes (zencoding-mapconcat-or-empty " class=\"" tag-classes " " "\""))
         (props   (zencoding-mapconcat-or-empty " " tag-props " " nil
                                                (lambda (prop)
                                                  (concat (symbol-name (car prop)) "=\"" (cadr prop) "\""))))
         (content-multiline? (and content (string-match "\n" content)))
         (block-tag? (or (member tag-name zencoding-block-tags)
                         (and (> (length tag-name) 1)
                              (not (member tag-name zencoding-inline-tags)))))
         (lf (if (or content-multiline? block-tag?)
                 "\n")))
    (concat "<" tag-name id classes props (if self-closing?
                                              "/>"
                                            (concat ">"
                                                    (if tag-txt
                                                        (if (or content-multiline? block-tag?)
                                                            (zencoding-indent tag-txt)
                                                          tag-txt))
                                                    (if content
                                                        (if (or content-multiline? block-tag?)
                                                            (zencoding-indent content)
                                                          content))
                                                    lf
                                                    "</" tag-name ">")))))

(defun zencoding-make-commented-html-tag (tag-name tag-id tag-classes tag-props tag-txt self-closing? content)
  "Create HTML markup string with extra comments for elements with #id or .classes"
  (let ((body (zencoding-make-html-tag tag-name tag-id tag-classes tag-props tag-txt self-closing? content)))
    (if (or tag-id tag-classes)
        (let ((id      (zencoding-concat-or-empty "#" tag-id))
              (classes (zencoding-mapconcat-or-empty "." tag-classes ".")))
          (concat "<!-- " id classes " -->\n"
                  body
                  "\n<!-- /" id classes " -->"))
      body)))

(defun zencoding-make-haml-tag (tag-name tag-id tag-classes tag-props tag-txt self-closing? content)
  "Create HAML string"
  (let ((name    (if (and (equal tag-name "div")
                          (or tag-id tag-classes))
                     ""
                   (concat "%" tag-name)))
        (id      (zencoding-concat-or-empty "#" tag-id))
        (classes (zencoding-mapconcat-or-empty "." tag-classes "."))
        (props   (zencoding-mapconcat-or-empty "{" tag-props ", " "}"
                                               (lambda (prop)
                                                 (concat ":" (symbol-name (car prop)) " => \"" (cadr prop) "\"")))))
    (concat name id classes props
            (if tag-txt
                (zencoding-indent tag-txt))
            (if content
                (zencoding-indent content)))))

(defun zencoding-make-hiccup-tag (tag-name tag-id tag-classes tag-props tag-txt self-closing? content)
  "Create Hiccup string"
  (let* ((id      (zencoding-concat-or-empty "#" tag-id))
         (classes (zencoding-mapconcat-or-empty "." tag-classes "."))
         (props   (zencoding-mapconcat-or-empty " {" tag-props ", " "}"
                                                (lambda (prop)
                                                  (concat ":" (symbol-name (car prop)) " \"" (cadr prop) "\""))))
         (content-multiline? (and content (string-match "\n" content)))
         (block-tag? (or (member tag-name zencoding-block-tags)
                         (and (> (length tag-name) 1)
                              (not (member tag-name zencoding-inline-tags))))))
    (concat "[:" tag-name id classes props
            (if tag-txt
                (let ((tag-txt-quoted (concat "\"" tag-txt "\"")))
                  (if (or content-multiline? block-tag?)
                      (zencoding-indent tag-txt-quoted)
                    (concat " " tag-txt-quoted))))
            (if content
                (if (or content-multiline? block-tag?)
                    (zencoding-indent content)
                  (concat " " content)))
            "]")))

(defun zencoding-make-text (tag-maker text)
  (cond
   ((eq tag-maker 'zencoding-make-hiccup-tag)
    (concat "\"" text "\""))
   (t text)))

(defun zencoding-concat-or-empty (prefix body &optional suffix)
  "Return prefixed suffixed text or empty string."
  (if body
      (concat prefix body suffix)
    ""))

(defun zencoding-mapconcat-or-empty (prefix list-body delimiter &optional suffix map-fun)
  "Return prefixed suffixed mapconcated text or empty string."
  (if list-body
      (let* ((mapper (if map-fun map-fun 'identity))
             (body (mapconcat mapper list-body delimiter)))
        (concat prefix body suffix))
    ""))

(defun zencoding-escape-xml (input proc)
  "Escapes XML-unsafe characters: <, > and &."
  (replace-regexp-in-string
   "<" "&lt;"
   (replace-regexp-in-string
    ">" "&gt;"
    (replace-regexp-in-string
     "&" "&amp;"
     (if (stringp input)
         input
       (zencoding-process-filter (zencoding-default-filter) input))))))

(defun zencoding-transform (ast-with-filters)
  "Transform AST (containing filter data) into string."
  (let ((filters (cadr ast-with-filters))
        (ast (caddr ast-with-filters)))
    (zencoding-process-filter filters ast)))

(defun zencoding-transform-ast (ast tag-maker)
  "Transform AST (without filter data) into string."
  (let ((type (car ast)))
    (cond
     ((eq type 'list)
      (mapconcat (lexical-let ((make-tag-fun tag-maker))
                   #'(lambda (sub-ast)
                       (zencoding-transform-ast sub-ast make-tag-fun)))
                 (cadr ast)
                 "\n"))
     ((eq type 'tag)
      (zencoding-make-tag tag-maker (cadr ast)))
     ((eq type 'text)
      (zencoding-make-text tag-maker (cadr ast)))
     ((eq type 'parent-child)
      (let ((parent (cadadr ast))
            (children (zencoding-transform-ast (caddr ast) tag-maker)))
        (zencoding-make-tag tag-maker parent children)))
     ((eq type 'sibling)
      (let ((sib1 (zencoding-transform-ast (cadr ast) tag-maker))
            (sib2 (zencoding-transform-ast (caddr ast) tag-maker)))
        (concat sib1 "\n" sib2))))))

(defun zencoding-indent (text)
  "Indent the text"
  (if text
      (replace-regexp-in-string "\n" "\n    " (concat "\n" text))
    nil))