Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 43b248a28e
Fetching contributors…

Cannot retrieve contributors at this time

601 lines (551 sloc) 25.008 kb
;;; kite-dom-css.el --- CSS helpers for DOM module implementation
;; Copyright (C) 2012 Julian Scheid
;; Author: Julian Scheid <julians37@gmail.com>
;; Keywords: tools
;; Package: kite
;; Compatibility: GNU Emacs 24
;; This file is not part of GNU Emacs.
;; Kite 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.
;; Kite 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 Kite. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; This package provides CSS helper functions used by the DOM module.
;;
;; It is part of Kite, a WebKit inspector front-end.
;;; Code:
(require 'kite-color)
(require 'kite-global)
(require 'kite-util)
(require 'widget)
(require 'wid-edit)
;; Try loading css-mode so we can steal their faces
(require 'css-mode nil t)
(defface kite-css-selector
(if (facep 'css-selector)
'((t (:inherit css-selector)))
'((t :inherit font-lock-function-name-face)))
"Face to use for selectors."
:group 'kite)
(defface kite-css-property
(if (facep 'css-property)
'((t (:inherit css-property)))
'((t :inherit font-lock-variable-name-face)))
"Face to use for properties."
:group 'kite)
(defface kite-css-computed-unused-property
`((t :inherit kite-css-property
:foreground ,(kite--dimmed-face-foreground 'kite-css-property 0.5)))
"Face to use for computed properties that are unused."
:group 'kite)
(defface kite-css-proprietary-property
(if (facep 'css-proprietary-property)
'((t (:inherit css-proprietary-property)))
'((t :inherit (css-property italic))))
"Face to use for vendor-specific properties."
:group 'kite)
(defface kite-css-computed-proprietary-unused-property
`((t :inherit kite-css-proprietary-property
:foreground ,(kite--dimmed-face-foreground 'kite-css-property 0.5)))
"Face to use for computed vendor-specific properties that are unused."
:group 'kite)
(defface kite-css-value-widget-modified
`((t :foreground ,(face-foreground 'warning nil t)
:background ,(face-background 'widget-field nil t)))
"Face to use for CSS value widget with unparseable input."
:group 'kite)
(defface kite-css-value-widget-error
`((t :foreground ,(face-foreground 'error nil t)
:background ,(face-background 'widget-field nil t)))
"Face to use for CSS value widget with unparseable input."
:group 'kite)
(defface kite-css-selected-overlay
`((t :inherit secondary-selection))
"Face to use for highlighting selected CSS property."
:group 'kite)
(defconst kite-css-completions
'((azimuth . [far-left left center-left center center-right right
far-right leftwards rightwards inherit])
(background . [inherit])
(background-attachment . [scroll fixed inherit])
(background-color . [transparent inherit])
(background-image . [none inherit])
(background-position . [left center top center center center
inherit])
(background-repeat . [repeat repeat-x repeat-y no-repeat inherit])
(border . [inherit])
(border-collapse . [collapse separate inherit])
(border-color . [inherit])
(border-left . [inherit])
(border-left-color . [transparent inherit])
(border-left-style . [inherit])
(border-left-width . [inherit])
(border-spacing . [inherit])
(border-style . [inherit])
(border-width . [inherit])
(bottom . [auto inherit])
(caption-side . [top bottom inherit])
(clear . [none left right both inherit])
(clip . [auto inherit])
(color . [inherit])
(content . [normal none open-quote close-quote no-open-quote
inherit])
(counter-increment . [none inherit])
(counter-reset . [none inherit])
(cue . [inherit])
(cue-after . [none inherit])
(cue-before . [none inherit])
(cursor . [crosshair default pointer move e-resize ne-resize
nw-resize n-resize se-resize sw-resize s-resize
w-resize text wait help inherit])
(direction . [ltr rtl inherit])
(display . [inline block list-item 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])
(elevation . [below level above higher lower inherit])
(empty-cells . [show hide inherit])
(float . [left right none inherit])
(font . [caption icon menu message-box small-caption status-bar
inherit])
(font-family . [inherit])
(font-size . [inherit])
(font-style . [normal italic oblique inherit])
(font-variant . [normal small-caps inherit])
(font-weight . [normal bold bolder lighter 100 200 300 400 500 600
700 800 900 inherit])
(height . [auto inherit])
(left . [auto inherit])
(letter-spacing . [normal inherit])
(line-height . [normal inherit])
(list-style . [inherit])
(list-style-image . [none inherit])
(list-style-position . [inside outside inherit])
(list-style-type . [disc circle square decimal decimal-leading-zero
lower-roman upper-roman lower-greek
lower-latin upper-latin armenian georgian
lower-alpha upper-alpha none inherit])
(margin . [inherit])
(margin-bottom . [inherit])
(margin-left . [inherit])
(max-height . [none inherit])
(max-width . [none inherit])
(min-height . [inherit])
(min-width . [inherit])
(orphans . [inherit])
(outline . [inherit])
(outline-color . [invert inherit])
(outline-style . [inherit])
(outline-width . [inherit])
(overflow . [visible hidden scroll auto inherit])
(padding . [inherit])
(padding-left . [inherit])
(page-break-after . [auto always avoid left right inherit])
(page-break-before . [auto always avoid left right inherit])
(page-break-inside . [avoid auto inherit])
(pause . [inherit])
(pause-after . [inherit])
(pause-before . [inherit])
(pitch . [x-low low medium high x-high inherit])
(pitch-range . [inherit])
(play-during . [auto none inherit])
(position . [static relative absolute fixed inherit])
(quotes . [none inherit])
(richness . [inherit])
(right . [auto inherit])
(speak . [normal none spell-out inherit])
(speak-header . [once always inherit])
(speak-numeral . [digits continuous inherit])
(speak-punctuation . [code none inherit])
(speech-rate . [x-slow slow medium fast x-fast faster slower
inherit])
(stress . [inherit])
(table-layout . [auto fixed inherit])
(text-align . [left right center justify inherit])
(text-decoration . [none overline line-through inherit])
(text-indent . [inherit])
(text-transform . [capitalize uppercase lowercase none inherit])
(top . [auto inherit])
(unicode-bidi . [normal embed bidi-override inherit])
(vertical-align . [baseline sub super top text-top middle bottom
text-bottom inherit])
(visibility . [visible hidden collapse inherit])
(voice-family . [inherit])
(volume . [silent x-soft soft medium loud x-loud inherit])
(white-space . [normal pre nowrap pre-wrap pre-line inherit])
(widows . [inherit])
(width . [auto inherit])
(word-spacing . [normal inherit])
(z-index . [auto inherit]))
"CSS 2.1 property completions. Automatically extracted by
extract-css2.py")
(defvar kite-css-widget-field-keymap
(let ((map (copy-keymap widget-field-keymap)))
(define-key map "\C-m" 'kite--widget-field-activate)
map)
"Custom keymap for editing CSS property values. Overrides RET
so that it works also at the very end of the field.")
(defun kite-dom--render-property (css-rule property-index property indent)
(widget-insert
(make-string (* 2 indent) 32))
(when (not (null (plist-get property :text)))
(widget-create 'checkbox
:notify (lambda (widget &rest ignore)
(kite-send "CSS.toggleProperty"
:params
(list :styleId (widget-get widget :kite-css-style-id)
:propertyIndex (widget-get widget :kite-css-property-index)
:disable (if (widget-value widget) :json-false t))))
:help-echo "Enable/disable this CSS property"
:kite-css-style-id (kite--get css-rule :style :styleId)
:kite-css-property-index property-index
t))
(widget-insert
(concat
" "
(propertize
(plist-get property :name)
'face 'kite-css-property
'font-lock-face 'kite-css-property)
":"))
(let ((color (kite-parse-color
(plist-get property :value))))
(when color
(let ((inhibit-read-only t))
(widget-insert " ")
(insert-image (kite--make-color-image (kite--rgba-value color))))))
(widget-create 'editable-field
:format " %v;"
:size 1
:action (lambda (widget changed-widget &optional event)
(kite-send
"CSS.setPropertyText"
:params
(list :styleId (widget-get widget :kite-css-style-id)
:propertyIndex (widget-get widget :kite-css-property-index)
:text (concat (widget-get widget :kite-css-property-name)
": "
(widget-value widget)
";")
:overwrite t)
:success-function
(lexical-let ((lex-property-name (widget-get widget :kite-css-property-name))
(lex-widget widget))
(lambda (result)
(mapcar (lambda (property)
(when (string= (plist-get property :name)
lex-property-name)
(overlay-put (widget-get lex-widget :field-overlay)
'face
(if (eq (plist-get property :parsedOk) :json-false)
'kite-css-value-widget-error
'widget-field))))
(kite--get result :style :cssProperties))))))
:notify (lambda (widget &rest ignore)
(overlay-put (widget-get widget :field-overlay)
'face
'kite-css-value-widget-modified))
:kite-css-style-id (kite--get css-rule :style :styleId)
:kite-css-property-index property-index
:kite-css-property-name (plist-get property :name)
:completions (cdr (assoc (intern (plist-get property :name))
kite-css-completions))
:keymap kite-css-widget-field-keymap
(plist-get property :value))
(put-text-property (save-excursion (beginning-of-line) (point))
(point)
'kite-css-property-index property-index)
(widget-insert "\n"))
(defun kite-dom--render-css-rule (css-rule)
(let ((begin (point)))
(widget-insert (concat
(propertize
(plist-get css-rule :selectorText)
'face 'kite-css-selector
'font-lock-face 'kite-css-selector)
" {\n" ))
(let* ((style (plist-get css-rule :style))
(shorthand-entries
(let* ((hashtable (make-hash-table :test 'equal))
(entries (plist-get style :shorthandEntries))
(index 0)
(count (length entries)))
(while (< index count)
(let ((element (elt entries index)))
(puthash (plist-get element :name)
element
hashtable))
(setq index (1+ index)))
hashtable))
(properties (plist-get style :cssProperties))
(property-index 0)
(property-count (length properties)))
(kite--log "shorthand-entries %s" shorthand-entries)
(while (< property-index property-count)
(let* ((property (elt properties property-index))
(shorthand-name (plist-get property :shorthandName))
(shorthand-property
(and shorthand-name
(gethash shorthand-name
shorthand-entries))))
(when shorthand-property
(kite-dom--render-property css-rule
property-index
shorthand-property
1)
(remhash shorthand-name shorthand-entries))
(kite-dom--render-property css-rule
property-index
property
(if shorthand-name 2 1)))
(setq property-index (1+ property-index))))
(widget-insert "}\n\n")
(put-text-property begin (point)
'kite-css-rule css-rule)))
(defvar kite-css-mode-map
(let ((map (make-composed-keymap
(copy-keymap widget-keymap)
(copy-keymap special-mode-map)))
(menu-map (make-sparse-keymap)))
(suppress-keymap map t)
(kite--define-global-mode-keys map)
(define-key map "\C-cg" 'kite--css-goto-source)
map)
"Local keymap for `kite-css-mode' buffers.")
(define-derived-mode kite-css-mode special-mode "kite-css"
"Toggle Kite CSS mode."
:group 'kite
(setq kite-buffer-type 'css)
(setq buffer-read-only nil))
(defun kite--dom-create-css-buffer (matched-css-rules)
(kite--log
(concat "kite--dom-create-css-buffer called with rules:\n"
(pp-to-string matched-css-rules)))
(let* ((-kite-session kite-session)
(node-region-buffer (get-buffer-create "*kite css*"))
(max-width 0)
(window (display-buffer
node-region-buffer
'((display-buffer-pop-up-window . nil)))))
(with-current-buffer node-region-buffer
(kite-css-mode)
(set (make-local-variable 'kite-session) -kite-session)
(let ((inhibit-read-only t))
(erase-buffer)
(remove-overlays)
(save-excursion
(widget-insert
(concat
(propertize "element.style"
'face 'kite-css-selector
'font-lock-face 'kite-css-selector)
" {\n"
"}\n"
"\n"))
(let ((rule-index (- (length matched-css-rules) 1)))
(while (>= rule-index 0)
(kite-dom--render-css-rule
(elt matched-css-rules rule-index))
(setq rule-index (- rule-index 1)))))
(widget-setup)))))
(defun kite-dom-show-matched-css ()
(interactive)
(kite-send
"CSS.getMatchedStylesForNode"
:params
(list :nodeId (get-char-property (point) 'kite-node-id))
:success-function
(lambda (result)
(kite--log (pp-to-string result))
(kite--dom-create-css-buffer
(plist-get result :matchedCSSRules)))))
(defun kite--dom-make-style-to-rule-map (matched-styles-result)
(let ((style-to-rule-map (make-hash-table)))
(let* ((matched-css-rules (plist-get matched-styles-result :matchedCSSRules))
(num-matched-rules (length matched-css-rules))
(matched-rule-index 0))
(while (< matched-rule-index num-matched-rules)
(let* ((matched-rule (elt matched-css-rules matched-rule-index))
(rule-info (list (plist-get matched-rule :selectorText)
(plist-get matched-rule :origin)
(plist-get matched-rule :sourceLine)))
(style-arr (plist-get (plist-get matched-rule :style) :cssProperties))
(num-styles (length style-arr))
(style-index 0))
(while (< style-index num-styles)
(let ((style-name (plist-get (elt style-arr style-index) :name))
(style-value (plist-get (elt style-arr style-index) :value)))
(puthash (intern style-name)
(cons (cons rule-info
style-value)
(gethash (intern style-name)
style-to-rule-map)) style-to-rule-map))
(setq style-index (1+ style-index))))
(setq matched-rule-index (1+ matched-rule-index))))
style-to-rule-map))
(defun kite--dom-insert-computed-style-value (value)
(let ((color (kite-parse-color value)))
(if color
(let ((inhibit-read-only t))
(insert-image (kite--make-color-image (kite--rgba-value color)))
(insert " ")
(insert value))
(insert value))))
(defun kite--dom-render-computed-css (computed-styles-result matched-styles-result)
(let* ((style-to-rule-map (kite--dom-make-style-to-rule-map matched-styles-result))
(arr (plist-get computed-styles-result :computedStyle))
(index 0)
(arr-len (length arr))
as-list)
(while (< index arr-len)
(let ((item (elt arr index)))
(setq as-list (cons (cons (plist-get item :name)
(plist-get item :value))
as-list)))
(setq index (1+ index)))
(let ((sorted-styles
(sort as-list
(lambda (x y) (string< (car x) (car y))))))
(let* ((node-region-buffer (get-buffer-create "*kite dom node details*"))
(max-width 0)
(window (display-buffer node-region-buffer (list (cons 'display-buffer-pop-up-window nil)))))
(with-current-buffer node-region-buffer
(special-mode)
(let ((inhibit-read-only t))
(erase-buffer)
(save-excursion
(while sorted-styles
(let* ((style (car sorted-styles))
(matched-styles (gethash (intern (car style)) style-to-rule-map)))
(insert (propertize (car style)
'face
(if (null (string-match "^-" (car style)))
(if matched-styles
'kite-css-property
'kite-css-computed-unused-property)
(if matched-styles
'kite-css-proprietary-property
'kite-css-computed-proprietary-unused-property))))
(insert ": ")
(kite--dom-insert-computed-style-value (cdr style))
(setq max-width (max max-width (current-column)))
(insert "\n")
(while matched-styles
(let ((match-info (car matched-styles)))
(insert (concat " "
(propertize
(caar match-info)
'face 'kite-css-selector)
" - "
(cdr match-info)
"\n"))
(when (string= "user-agent" (nth 1 (car match-info)))
(insert " user agent stylesheet\n")))
(setq matched-styles (cdr matched-styles))))
(setq sorted-styles (cdr sorted-styles))))))
(when (< max-width (window-width window))
(with-selected-window window
(shrink-window-horizontally (- (window-width window) max-width))))))))
(defun kite-dom-show-computed-css ()
(interactive)
(lexical-let ((barrier (cons nil nil))
(node-id (get-char-property (point) 'kite-node-id)))
(kite-send "CSS.getComputedStyleForNode"
:params
(list :nodeId node-id)
:success-function
(lambda (result)
(setcar barrier result)
(when (and (not (null (car barrier)))
(not (null (cdr barrier))))
(kite--dom-render-computed-css
(car barrier) (cdr barrier)))))
(kite-send "CSS.getMatchedStylesForNode"
:params
(list :nodeId node-id)
:success-function
(lambda (result)
(setcdr barrier result)
(when (and (not (null (car barrier)))
(not (null (cdr barrier))))
(kite--dom-render-computed-css
(car barrier) (cdr barrier)))))))
(defun kite--dom-timing-function-image (width height args)
"Create an image that visualizes the timing function as a cubic
bezier curve. WIDTH and HEIGHT are the image dimensions in
pixels. ARGS are four floating point numbers as per CSS
Transitions Module Level 3 section 2.3"
(create-image
(format
(concat
"<?xml version='1.0'?>\n"
"<!DOCTYPE svg PUBLIC '-//W3C//DTD SVG 1.1//EN'\n"
" 'http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd'>\n"
"<svg xmlns='http://www.w3.org/2000/svg'\n"
" width='%spx'\n"
" height='%spx'>\n"
" <g transform='translate(0, %s)'>\n"
" <g transform='scale(1, -1)'>\n"
" <path d='M0,0 C%s,%s %s,%s %s,%s' style='fill: none; stroke: red; stroke-width: 1px'/>\n"
" </g>"
" </g>"
"</svg>")
width height height
(* width (nth 0 args))
(* height (nth 1 args))
(* width (nth 2 args))
(* height (nth 3 args))
width height
)
'svg
t))
(defun kite--css-goto-source ()
"Open the CSS source stylesheet in a buffer, highlight the
region corresponding to the rule or property under point, and
place point at region end.
FIXME: the range information seems to change when updating
property values, causing a mismatch with the source CSS text if
that wasn't updated as well. Need to investigate whether we need
to store original range information before any property updates."
(interactive)
(let* ((css-rule (get-text-property (point) 'kite-css-rule))
(url (kite--get css-rule :sourceURL))
(rule-range (kite--get css-rule
:style
:range))
(property-index (get-text-property
(point)
'kite-css-property-index)))
(if url
(progn
(kite--visit-remote-file url)
(remove-overlays)
(when rule-range
(let* ((property-range (when property-index
(kite--get css-rule
:style
:cssProperties
property-index
:range)))
(start (+ (plist-get rule-range :start)
(or (plist-get property-range :start) 0)
1))
(end (+ (if property-range
(+ (plist-get rule-range :start)
(plist-get property-range :end))
(plist-get rule-range :end))
1)))
(when (and start end)
(overlay-put (make-overlay start end)
'face 'kite-css-selected-overlay))
(when end (goto-char end)))))
(error "Source location not available"))))
(provide 'kite-dom-css)
;;; kite-dom-css.el ends here
Jump to Line
Something went wrong with that request. Please try again.