/[climacs]/climacs/html-syntax.lisp
ViewVC logotype

Diff of /climacs/html-syntax.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.8 by rstrandh, Thu Mar 10 06:37:40 2005 UTC revision 1.9 by rstrandh, Fri Mar 11 07:03:31 2005 UTC
# Line 24  Line 24 
24    
25  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
26  ;;;  ;;;
27    ;;; this should really go in syntax.lisp
28    
29    (defclass parse-tree ()
30      ((start-mark :initarg :start-mark :reader start-mark)
31       (size :initarg :size)))
32    
33    (defgeneric start-offset (parse-tree))
34    
35    (defmethod start-offset ((tree parse-tree))
36      (offset (start-mark tree)))
37    
38    (defgeneric end-offset (parse-tree))
39    
40    (defmethod end-offset ((tree parse-tree))
41      (with-slots (start-mark size) tree
42         (+ (offset start-mark) size)))
43    
44    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
45    ;;;
46  ;;; grammar classes  ;;; grammar classes
47    
48  (defclass html-sym ()  (defclass html-sym (parse-tree)
49    ((badness :initform 0 :initarg :badness :reader badness)    ((badness :initform 0 :initarg :badness :reader badness)
50     (message :initform "" :initarg :message :reader message)))     (message :initform "" :initarg :message :reader message)))
51    
# Line 34  Line 53 
53    (and (eq (class-of t1) (class-of t2))    (and (eq (class-of t1) (class-of t2))
54         (< (badness t1) (badness t2))))         (< (badness t1) (badness t2))))
55    
56  (defclass html-nonterminal (html-sym)  (defclass html-nonterminal (html-sym) ())
   ((start-offset :initarg :start-offset :reader start-offset)  
    (end-offset :initarg :end-offset :reader end-offset)))  
57    
58  (defclass words (html-nonterminal) ())  (defclass words (html-nonterminal) ())
59    
# Line 68  Line 85 
85  (defclass para (html-words) ())  (defclass para (html-words) ())
86    
87  (defclass html-token (html-sym)  (defclass html-token (html-sym)
88    ((start-mark :initarg :start-mark :reader start-mark)    ((ink) (face)))
    (size :initarg :size)))  
   
 (defgeneric end-offset (html-token))  
   
 (defmethod end-offset ((token html-token))  
   (with-slots (start-mark size) token  
      (+ (offset start-mark) size)))  
   
 (defgeneric start-offset (html-token))  
89    
90  (defmethod start-offset ((token html-token))  (defclass html-tag (html-token) ())
   (offset (start-mark token)))  
91    
92  (defclass <html> (html-token) () (:default-initargs :size 6))  (defclass <html> (html-tag) () (:default-initargs :size 6))
93  (defclass </html> (html-token) ()(:default-initargs :size 7))  (defclass </html> (html-tag) ()(:default-initargs :size 7))
94  (defclass <head> (html-token) () (:default-initargs :size 6))  (defclass <head> (html-tag) () (:default-initargs :size 6))
95  (defclass </head> (html-token) () (:default-initargs :size 7))  (defclass </head> (html-tag) () (:default-initargs :size 7))
96  (defclass <title> (html-token) () (:default-initargs :size 7))  (defclass <title> (html-tag) () (:default-initargs :size 7))
97  (defclass </title> (html-token) () (:default-initargs :size 8))  (defclass </title> (html-tag) () (:default-initargs :size 8))
98  (defclass <body> (html-token) () (:default-initargs :size 6))  (defclass <body> (html-tag) () (:default-initargs :size 6))
99  (defclass </body> (html-token) () (:default-initargs :size 7))  (defclass </body> (html-tag) () (:default-initargs :size 7))
100  (defclass <h1> (html-token) () (:default-initargs :size 4))  (defclass <h1> (html-tag) () (:default-initargs :size 4))
101  (defclass </h1> (html-token) () (:default-initargs :size 5))  (defclass </h1> (html-tag) () (:default-initargs :size 5))
102  (defclass <h2> (html-token) () (:default-initargs :size 4))  (defclass <h2> (html-tag) () (:default-initargs :size 4))
103  (defclass </h2> (html-token) () (:default-initargs :size 5))  (defclass </h2> (html-tag) () (:default-initargs :size 5))
104  (defclass <h3> (html-token) () (:default-initargs :size 4))  (defclass <h3> (html-tag) () (:default-initargs :size 4))
105  (defclass </h3> (html-token) () (:default-initargs :size 5))  (defclass </h3> (html-tag) () (:default-initargs :size 5))
106  (defclass <p> (html-token) () (:default-initargs :size 3))  (defclass <p> (html-tag) () (:default-initargs :size 3))
107  (defclass </p> (html-token) () (:default-initargs :size 4))  (defclass </p> (html-tag) () (:default-initargs :size 4))
108  (defclass <ul> (html-token) () (:default-initargs :size 4))  (defclass <ul> (html-tag) () (:default-initargs :size 4))
109  (defclass </ul> (html-token) () (:default-initargs :size 5))  (defclass </ul> (html-tag) () (:default-initargs :size 5))
110  (defclass <li> (html-token) () (:default-initargs :size 4))  (defclass <li> (html-tag) () (:default-initargs :size 4))
111  (defclass </li> (html-token) () (:default-initargs :size 5))  (defclass </li> (html-tag) () (:default-initargs :size 5))
112    
113  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
114  ;;;  ;;;
# Line 199  Line 206 
206                   (tag-end (= (end-offset word) (start-offset tag-end))))                   (tag-end (= (end-offset word) (start-offset tag-end))))
207               :start-mark (start-mark tag-start))               :start-mark (start-mark tag-start))
208      (html -> (<html> head body </html>)      (html -> (<html> head body </html>)
209            :start-offset (start-offset <html>) :end-offset (end-offset </html>)            :start-mark (start-mark <html>)
210              :size (- (end-offset </html>) (start-offset <html>))
211            :start <html> :head head :body body :end </html>)            :start <html> :head head :body body :end </html>)
212      (head -> (<head> title </head>)      (head -> (<head> title </head>)
213            :start-offset (start-offset <head>) :end-offset (end-offset </head>)            :start-mark (start-mark <head>)
214              :size (- (end-offset </head>) (start-offset <head>))
215            :start <head> :title title :end </head>)            :start <head> :title title :end </head>)
216      (title -> (<title> words </title>)      (title -> (<title> words </title>)
217             :start-offset (start-offset <title>) :end-offset (end-offset </title>)             :start-mark (start-mark <title>)
218               :size (- (end-offset </title>) (start-offset <title>))
219             :start <title> :words words :end </title>)             :start <title> :words words :end </title>)
220      (body -> (<body> words </body>)      (body -> (<body> words </body>)
221            :start-offset (start-offset <body>) :end-offset (end-offset </body>)            :start-mark (start-mark <body>)
222              :size (- (end-offset </body>) (start-offset <body>))
223            :start <body> :words words :end </body>)            :start <body> :words words :end </body>)
224      (words -> ()      (words -> ()
225             (make-instance 'empty-words :start-offset nil))             (make-instance 'empty-words :start-mark nil))
226      (words -> (words word)      (words -> (words word)
227             (make-instance 'nonempty-words             (make-instance 'nonempty-words
228                :start-offset (or (start-offset words) (start-offset word))                :start-mark (or (start-mark words) (start-mark word))
229                :end-offset (end-offset word)                :size (- (end-offset word) (offset (or (start-mark words) (start-mark word))))
230                :words words :word word))))                :words words :word word))))
231    
232  (defmethod initialize-instance :after ((syntax html-syntax) &rest args)  (defmethod initialize-instance :after ((syntax html-syntax) &rest args)
# Line 287  Line 298 
298  ;;;  ;;;
299  ;;; display  ;;; display
300    
301    (defvar *white-space-start* nil)
302    
303    (defvar *cursor-positions* nil)
304    (defvar *current-line* 0)
305    
306  (defun handle-whitespace (pane buffer start end)  (defun handle-whitespace (pane buffer start end)
307    (let ((space-width (space-width pane))    (let ((space-width (space-width pane))
308          (tab-width (tab-width pane)))          (tab-width (tab-width pane)))
309      (loop while (< start end)      (loop while (< start end)
310            do (ecase (buffer-object buffer start)            do (ecase (buffer-object buffer start)
311                 (#\Newline (terpri pane))                 (#\Newline (terpri pane)
312                              (setf (aref *cursor-positions* (incf *current-line*))
313                                    (multiple-value-bind (x y) (stream-cursor-position pane)
314                                      y)))
315                 (#\Space (stream-increment-cursor-position                 (#\Space (stream-increment-cursor-position
316                           pane space-width 0))                           pane space-width 0))
317                 (#\Tab (let ((x (stream-cursor-position pane)))                 (#\Tab (let ((x (stream-cursor-position pane)))
# Line 310  Line 329 
329    nil)    nil)
330    
331  (defmethod display-parse-tree ((entity html-token) (syntax html-syntax) pane)  (defmethod display-parse-tree ((entity html-token) (syntax html-syntax) pane)
332    (updating-output (pane :unique-id entity    (flet ((cache-test (t1 t2)
333                           :id-test #'eq             (and (eq t1 t2)
334                           :cache-value entity                  (eq (slot-value t1 'ink)
335                           :cache-test #'eq)                      (medium-ink (sheet-medium pane)))
336      (present (coerce (region-to-sequence (start-mark entity)                  (eq (slot-value t1 'face)
337                                           (end-offset entity))                      (text-style-face (medium-text-style (sheet-medium pane)))))))
338                       'string)      (updating-output (pane :unique-id entity
339               'string                             :id-test #'eq
340               :stream pane)))                             :cache-value entity
341                               :cache-test #'cache-test)
342          (with-slots (ink face) entity
343             (setf ink (medium-ink (sheet-medium pane))
344                   face (text-style-face (medium-text-style (sheet-medium pane))))
345             (present (coerce (region-to-sequence (start-mark entity)
346                                                  (end-offset entity))
347                              'string)
348                      'string
349                      :stream pane)))))
350    
351    (defmethod display-parse-tree :around ((entity html-tag) (syntax html-syntax) pane)
352      (with-drawing-options (pane :ink +green+)
353        (call-next-method)))
354    
355    (defmethod display-parse-tree :before ((entity html-token) (syntax html-syntax) pane)
356      (handle-whitespace pane (buffer pane) *white-space-start* (start-offset entity))
357      (setf *white-space-start* (end-offset entity)))
358    
359  (defmethod display-parse-tree :before ((entity html-balanced) (syntax html-syntax) pane)  (defmethod display-parse-tree :before ((entity html-balanced) (syntax html-syntax) pane)
360    (with-slots (start) entity    (with-slots (start) entity
# Line 328  Line 364 
364    (with-slots (end) entity    (with-slots (end) entity
365       (display-parse-tree end syntax pane)))       (display-parse-tree end syntax pane)))
366    
367    (defmethod display-parse-tree :around ((entity title) (syntax html-syntax) pane)
368      (with-text-face (pane :bold)
369        (call-next-method)))
370    
371  (defmethod display-parse-tree ((entity html-words) (syntax html-syntax) pane)  (defmethod display-parse-tree ((entity html-words) (syntax html-syntax) pane)
372    (with-slots (words) entity    (with-slots (words) entity
373       (display-parse-tree words syntax pane)))       (display-parse-tree words syntax pane)))
# Line 367  Line 407 
407    
408  (defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax html-syntax) current-p)  (defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax html-syntax) current-p)
409    (with-slots (top bot) pane    (with-slots (top bot) pane
410         (setf *cursor-positions* (make-array (1+ (number-of-lines-in-region top bot)))
411               *current-line* 0
412               (aref *cursor-positions* 0) (stream-cursor-position pane))
413       (with-slots (tokens) syntax       (with-slots (tokens) syntax
414          (let ((average-token-size (max (float (/ (size (buffer pane)) (nb-elements tokens)))          (let ((average-token-size (max (float (/ (size (buffer pane)) (nb-elements tokens)))
415                                         1.0)))                                         1.0)))
# Line 383  Line 426 
426                ;; go back to the first token after top, or until the previous token                ;; go back to the first token after top, or until the previous token
427                ;; contains a valid parser state                ;; contains a valid parser state
428                (loop until (or (mark<= (end-offset (element* tokens (1- start-token-index))) top)                (loop until (or (mark<= (end-offset (element* tokens (1- start-token-index))) top)
429                                (not (null (parse-stack-top                                (not (parse-state-empty-p
430                                            (slot-value (element* tokens (1- start-token-index)) 'state)))))                                      (slot-value (element* tokens (1- start-token-index)) 'state))))
431                      do (decf start-token-index))                      do (decf start-token-index))
432                ;; display the parse tree if any                (let ((*white-space-start* (offset top)))
433                (unless (parse-state-empty-p (slot-value (element* tokens (1- start-token-index)) 'state))                  ;; display the parse tree if any
434                  (display-parse-state (slot-value (element* tokens (1- start-token-index)) 'state)                  (unless (parse-state-empty-p (slot-value (element* tokens (1- start-token-index)) 'state))
435                                       syntax                    (display-parse-state (slot-value (element* tokens (1- start-token-index)) 'state)
436                                       pane))                                         syntax
437                ;; display the tokens                                         pane))
438                (loop with prev-offset = (end-offset (element* tokens (1- start-token-index)))                  ;; display the tokens
439                      while (< start-token-index end-token-index)                  (with-drawing-options (pane :ink +red+)
440                      do (let ((token (element* tokens start-token-index)))                    (loop while (< start-token-index end-token-index)
441                           (handle-whitespace pane (buffer pane) prev-offset (start-offset token))                          do (let ((token (element* tokens start-token-index)))
442                           (updating-output (pane :unique-id token                               (display-parse-tree token syntax pane))
443                                                  :id-test #'eq                             (incf start-token-index))))))))
444                                                  :cache-value token       (let* ((cursor-line (number-of-lines-in-region top (point pane)))
445                                                  :cache-test #'eq)              (height (text-style-height (medium-text-style pane) pane))
446                             (present (coerce (region-to-sequence (start-mark token)              (cursor-y (+ (* cursor-line (+ height (stream-vertical-spacing pane)))))
447                                                                  (end-offset token))              (cursor-column (column-number (point pane)))
448                                              'string)              (cursor-x (* cursor-column (text-style-width (medium-text-style pane) pane))))
449                                      'string         (updating-output (pane :unique-id -1)
450                                      :stream pane))           (draw-rectangle* pane
451                           (setf prev-offset (end-offset token)))                            (1- cursor-x) (- cursor-y (* 0.2 height))
452                         (incf start-token-index))))))))                            (+ cursor-x 2) (+ cursor-y (* 0.8 height))
453                              :ink (if current-p +red+ +blue+))))))
454    
455    

Legend:
Removed from v.1.8  
changed lines
  Added in v.1.9

  ViewVC Help
Powered by ViewVC 1.1.5