Optimize grammar

extensions.lisp

@@ -56,11 +56,12 @@
             `((defrule ,(first characters)
                   (or ,@(rest characters))
                 (:when ,extension-flag))
-              (setf %extended-special-char-rules%
-                    (add-expression-to-list ',(first characters)
-                                            %extended-special-char-rules%))
-              (esrap:change-rule 'extended-special-char
-                                            (cons 'or %extended-special-char-rules%))))
+              (if (assoc ',extension-flag %flag-to-extended-chars-alist%)
+                  (setf (cdr (assoc ',extension-flag
+                                    %flag-to-extended-chars-alist%))
+                        ',(rest characters))
+                  (push '(,extension-flag ,@ (rest characters))
+                        %flag-to-extended-chars-alist%))))
           ;; define a rule for escaped chars if any
        ,@ (when escapes
             `((defrule ,(first escapes)

markdown-printer.lisp

@@ -223,11 +223,27 @@
       (foo parse-tree))
     n))
 
+(defun starts-with-backtick-p (parse-tree)
+  (let ((a (first parse-tree)))
+    (and (stringp a)
+         (plusp (length a))
+         (char= (aref a 0) #\`))))
+
+(defun ends-with-backtick-p (parse-tree)
+  (let ((a (first (last parse-tree))))
+    (and (stringp a)
+         (plusp (length a))
+         (char= (aref a (1- (length a))) #\`))))
+
 (defmethod print-md-tagged-element ((tag (eql :code)) stream rest)
   (let ((n (max-n-consecutive-backticks rest)))
     (loop repeat (1+ n) do (write-char #\` stream))
     (let ((*in-code* t))
-      (dolist (a rest) (print-md-element a stream)))
+      (when (starts-with-backtick-p rest)
+        (write-char #\Space stream))
+      (dolist (a rest) (print-md-element a stream))
+      (when (ends-with-backtick-p rest)
+        (write-char #\Space stream)))
     (loop repeat (1+ n) do (write-char #\` stream))))
 
 (defmacro define-smart-quote-md-translation (name replacement)

parser.lisp

@@ -33,32 +33,51 @@
 (defrule line-break (and "  " normal-endline)
   (:constant '(:line-break)))
 (defrule endline (or line-break terminal-endline normal-endline))
-(defrule normal-char (and (! (or special-char space-char newline)) character)
-  (:text t))
-(defrule special-char (or #\* #\_ #\` #\& #\[ #\] #\< #\! #\# #\\
-                          extended-special-char)
-  (:text t))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (defparameter %extended-special-char-rules% nil))
-(defrule extended-special-char #.(cons 'or %extended-special-char-rules%)
+  (defparameter %standard-special-chars%
+    '(#\* #\_ #\` #\& #\[ #\] #\< #\! #\# #\\))
+  ;; Elements like (*SMART-QUOTES* . <EXTENDED-CHARS>) where
+  ;; <EXTENDED-CHARS> are from the corresponding :CHARACTER-RULE.
+  (defvar %flag-to-extended-chars-alist% ()))
+
+(declaim (inline extended-special-char-p))
+(defun extended-special-char-p (char)
+  (dolist (entry %flag-to-extended-chars-alist%)
+    (when (and (symbol-value (car entry))
+               (member char (cdr entry)))
+      (return t))))
+
+(declaim (inline newlinep))
+(defun newlinep (char next-char)
+  (or (char= char #\linefeed)
+      (and (char= char #\return)
+           (eql next-char #\linefeed))))
+
+;;; A predicate equivalent to (AND (! (OR SPECIAL-CHAR SPACE-CHAR NEWLINE)).
+(defun normal-char-p (char next-char)
+  (and (not (or (char= char #\space)
+                (char= char #\tab)
+                (special-char-p char)
+                (newlinep char next-char)))))
+
+(defun special-char-p (char)
+  (declare (type character char))
+  (or (find char #.(coerce %standard-special-chars% 'string))
+      (extended-special-char-p char)))
+
+(defrule special-char (special-char-p character)
   (:text t))
-
 (defrule non-space-char (and (! space-char) (! newline) character)
   (:text t))
-(defrule alphanumeric (alphanumericp character))
-(defrule dec-digit (or #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
+(defrule alphanumeric (alphanumericp character)
+  (:use-cache nil))
+(defrule dec-digit (character-ranges (#\0 #\9)))
 (defrule hex-digit (or dec-digit
                        #\a #\A #\b #\B #\c #\C #\d #\D #\e #\E #\f #\F))
-(defun ascii-char-p (c)
-  (let ((c (char-code c)))
-    (or (<= (char-code #\a) c (char-code #\z))
-        (<= (char-code #\A) c (char-code #\Z))
-        (<= (char-code #\0) c (char-code #\9)))))
-(defrule |A-Za-z| #.`(or ,@(coerce "ABCDEFGHIJKLMNOPQRSTUVWXYZ" 'list)
-                         ,@(coerce "abcdefghijklmnopqrstuvwxyz" 'list)))
-(defrule ascii-character (ascii-char-p character))
-(defrule alphanumeric-ascii (ascii-char-p character))
+(defrule |A-Za-z| (character-ranges (#\a #\z) (#\A #\Z)))
+(defrule ascii-character (character-ranges (#\a #\z) (#\A #\Z) (#\0 #\9)))
+(defrule alphanumeric-ascii ascii-character)
 
 (defrule doc (and (* %block) (* blank-line))
   (:destructure (content blanks)
@@ -103,9 +122,31 @@
 
 (defrule line raw-line
   (:text t))
-(defrule raw-line (or (and (* (and (! newline) character))
-                           newline)
-                      (and (+ character) eof)))
+
+;;; This function is an optimized version of the rule
+;;;
+;;;     (or (and (* (and (! newline) character)) newline)
+;;;         (and (+ character) eof))
+(defun parse-raw-line (text position end)
+  (declare (type string text)
+           (type fixnum position end))
+  (if (>= position end)
+      (values nil position)
+      (let ((p position))
+        (declare (type fixnum p))
+        (let ((pos (loop while (< p end)
+                         for char = (aref text p)
+                         do (when (char= char #\linefeed)
+                              (return (1+ p)))
+                            (when (and (char= char #\return)
+                                       (< (1+ p) end)
+                                       (char= (aref text (1+ p)) #\linefeed))
+                              (return (+ p 2)))
+                            (incf p)
+                         finally (return p))))
+          (values (subseq text position pos) pos)))))
+(defrule raw-line (function parse-raw-line))
+
 (defrule optionally-indented-line (and (? indent) line)
   (:destructure (i l)
                 (declare (ignore i))
@@ -446,7 +487,7 @@
     (cons :plain a)))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (defparameter %inline-rules% '(string
+  (defparameter %inline-rules% '(%string
                                  endline
                                  ul-or-star-line
                                  %space
@@ -469,11 +510,56 @@
 
 (defrule maybe-alphanumeric (& alphanumeric)
   (:constant ""))
-(defrule string (or (and alphanumeric (* (or normal-char
-                                             (and (+ #\_) maybe-alphanumeric))))
-                    ;; This could be (+ NORMAL-CHAR), but that's a bit slower.
-                    normal-char)
-  (:text t))
+
+;;; This function is an optimized version of the rule
+;;;
+;;;     (or (and alphanumeric (* (or normal-char
+;;;                                  (and (+ #\_) maybe-alphanumeric))))
+;;;         (+ normal-char))
+(defun parse-string (text position end)
+  (declare (type string text)
+           (type fixnum position end))
+  (if (<= end position)
+      (values nil position)
+      (let ((c (aref text position)))
+        (cond ((alphanumericp c)
+               (let ((p (1+ position)))
+                 (declare (type fixnum p))
+                 (loop while (< p end)
+                       for char = (aref text p)
+                       for next-char = (when (< (1+ p) end)
+                                         (aref text (1+ p)))
+                       do (cond
+                            ((normal-char-p char next-char)
+                             (incf p))
+                            ((char= char #\_)
+                             (let ((i p))
+                               (declare (type fixnum i))
+                               (loop while (and (< i end)
+                                                (char= (aref text i) #\_))
+                                     do (incf i))
+                               (if (and (< i end)
+                                        (alphanumericp (aref text i)))
+                                   (setq p i)
+                                   (return))))
+                            (t
+                             (return))))
+                 (values (subseq text position p) p)))
+              ((normal-char-p c (when (< (1+ position) end)
+                                  (aref text (1+ position))))
+               (let ((p (1+ position)))
+                 (declare (type fixnum p))
+                 (loop while (< p end)
+                       for char = (aref text p)
+                       for next-char = (when (< (1+ p) end)
+                                         (aref text (1+ p)))
+                       do (if (normal-char-p char next-char)
+                              (incf p)
+                              (return)))
+                 (values (subseq text position p) p)))
+              (t
+               (values nil position))))))
+(defrule %string (function parse-string))
 
 (defrule maybe-space-char (& space-char)
   (:constant ""))
@@ -623,15 +709,17 @@
   (ticks-code ticks3 code3 "```")
   (ticks-code ticks4 code4 "````")
   (ticks-code ticks5 code5 "`````"))
-(defrule code (or code1 code2 code3 code4 code5)
-  (:lambda (a)
+(defrule code (and (& #\`) (or code1 code2 code3 code4 code5))
+  (:destructure (guard a)
+    (declare (ignore guard))
     (list :code a)))
 
 
-(defrule raw-html (or html-comment
-                      html-processing-instruction
-                      html-tag)
-  (:lambda (a)
+(defrule raw-html (and (& #\<) (or html-comment
+                                   html-processing-instruction
+                                   html-tag))
+  (:destructure (guard a)
+    (declare (ignore guard))
     (list :raw-html a)))
 (defrule html-comment (and "<!--" (* (and (! "-->") character)) "-->")
   (:text t))

tables.lisp

@@ -159,13 +159,13 @@
                          :body
                          (((td (:plain "col" " " (:code "3") " " "is") left)
                            (td (:plain "some" " " "wordy" " " "text") center)
-                           (td (:plain "$1600") right))
+                           (td (:plain "$" "1600") right))
                           ((td (:plain "col" " " "2" " " "is") left)
                            (td (:plain "centered") center)
-                           (td (:plain "$12") right))
+                           (td (:plain "$" "12") right))
                           ((td (:plain "zebra" " " "stripes") left)
                            (td (:plain "are" " " "neat") center)
-                           (td (:plain "$1") right)))))
+                           (td (:plain "$" "1") right)))))
           (parse-doc "
 | Left-Aligned  | Center Aligned  | Right Aligned |
 | :------------ |:---------------:| -----:|

tests/grammar/blocks/heading.lisp

@@ -71,7 +71,7 @@ World!
                (:LIST-ITEM (:PLAIN "First" " " "line")))
               (:PLAIN "  " "The" " " "header" "
 "
-               "  " "=" "=" "=" "=" "=" "=" "=" "=" "=" "=")))
+               "  " "==========")))
 
 (def-grammar-test atx-heading-in-a-list ;; bug 35
   ;;; marked bug as invalid, since original markdown is inconsistent

tests/grammar/inlines/link.lisp

@@ -140,5 +140,5 @@ x"
   :expected '((:PARAGRAPH
                (:REFERENCE-LINK :LABEL ("link") :TAIL NIL))
               (:PLAIN (:REFERENCE-LINK :LABEL ("link") :TAIL NIL)
-               ":" " " "http://example.com/" " " "\"" "title\"" " "
+               ":" " " "http://example.com/" " " "\"title\"" " "
                "junk")))

tests/grammar/inlines/string.lisp

@@ -2,25 +2,25 @@
 
 
 (def-grammar-test string-test-1
-  :rule 3bmd-grammar::string
+  :rule 3bmd-grammar::%string
   :text "Some string with spaces."
   :expected "Some"
   :remaining-text " string with spaces.")
 
 (def-grammar-test string-test-2
-  :rule 3bmd-grammar::string
+  :rule 3bmd-grammar::%string
   :text "100500 string with spaces."
   :expected "100500"
   :remaining-text " string with spaces.")
 
 (def-grammar-test string-test-3
-  :rule 3bmd-grammar::string
+  :rule 3bmd-grammar::%string
   :text "@a_symbol@ string with spaces."
-  :expected "@"
-  :remaining-text "a_symbol@ string with spaces.")
+  :expected "@a"
+  :remaining-text "_symbol@ string with spaces.")
 
 (def-grammar-test string-test-4
-  :rule 3bmd-grammar::string
+  :rule 3bmd-grammar::%string
   :text "*a_symbol* string with spaces."
   ;; TODO: Probably this is not an error, because * surrounds
   ;; emphasised text.

tests/printing/inline.lisp

@@ -163,3 +163,18 @@
   :format :markdown
   :text "<http://a/?forum_id=*_`&[]>"
   :expected "<http://a/?forum_id=*_`&[]>")
+
+(def-print-test print-code-with-backticks-1
+  :format :markdown
+  :text "``a`b``"
+  :expected "``a`b``")
+
+(def-print-test print-code-with-backticks-2
+  :format :markdown
+  :text "``a` ``"
+  :expected "``a` ``")
+
+(def-print-test print-code-with-backticks-3
+  :format :markdown
+  :text "`` `b``"
+  :expected "`` `b``")