Support for label and caption embed options in the parser

Shirakumo · Feb 6, 2019 · 127f238 · 127f238
1 parent 0e74b52
commit 127f238
Show file tree

Hide file tree

Showing 5 changed files with 51 additions and 4 deletions.
diff --git a/component.lisp b/component.lisp
@@ -195,6 +195,12 @@
 (defclass float-option (embed-option)
   ((direction :initarg :direction :initform (cl:error "DIRECTION required") :accessor direction)))
 
+(defclass label-option (embed-option)
+  ((target :initarg :target :initform (cl:error "TARGET required") :accessor target)))
+
+(defclass caption-option (embed-option parent-component)
+  ())
+
 (defclass footnote (parent-component block-component)
   ((target :initarg :target :initform (cl:error "TARGET required") :accessor target)))
 

diff --git a/directive.lisp b/directive.lisp
@@ -369,13 +369,25 @@
         (cond (class
                (incf cursor)
                (let ((component (make-instance class :target target)))
-                 (commit _ component parser)
                  (setf (components:options component)
                        (loop for (string next continue) = (next-option line cursor #\])
                              for option = (when string (parse-embed-option cursor string component))
                              when option collect option
-                             do (setf cursor next)
+                             ;; KLUDGE: Since we can't invoke the parser inside PARSE-EMBED-OPTION
+                             ;;         we do things here.
+                             do (typecase option
+                                  (components:caption-option
+                                   (stack-push (directive 'paragraph parser) option (stack parser))
+                                   (loop for cursor = (length "caption ")
+                                         then (read-inline parser string cursor #\Nul)
+                                         while (< cursor (length string)))
+                                   (stack-pop (stack parser)))
+                                  (components:label-option
+                                   (setf (components:label (components:target option) (root parser))
+                                         component)))
+                                (setf cursor next)
                              while continue))
+                 (commit _ component parser)
                  (length line)))
               (T
                (warn 'unknown-embed-type
@@ -415,6 +427,12 @@
                                   ((string-equal "float right" option) :right)
                                   (T (error "FLOAT must be LEFT or RIGHT.")))))
 
+(defmethod parse-embed-option-type ((type components:label-option) option)
+  (make-instance (class-of type) :target (subseq option (length "label "))))
+
+(defmethod parse-embed-option-type ((type components:caption-option) option)
+  (make-instance (class-of type)))
+
 (defmethod parse-embed-option-type ((type components:width-option) option)
   (multiple-value-bind (size unit) (parse-unit option :start (length "width "))
     (when unit
@@ -429,6 +447,8 @@
 (defmethod embed-option-allowed-p ((option components:width-option) (embed components:embed)) T)
 (defmethod embed-option-allowed-p ((option components:height-option) (embed components:embed)) T)
 (defmethod embed-option-allowed-p ((option components:float-option) (embed components:embed)) T)
+(defmethod embed-option-allowed-p ((option components:label-option) (embed components:embed)) T)
+(defmethod embed-option-allowed-p ((option components:caption-option) (embed components:embed)) T)
 (defmethod embed-option-allowed-p ((option components:autoplay-option) (embed components:video)) T)
 (defmethod embed-option-allowed-p ((option components:autoplay-option) (embed components:audio)) T)
 (defmethod embed-option-allowed-p ((option components:loop-option) (embed components:video)) T)

diff --git a/package.lisp b/package.lisp
@@ -72,6 +72,8 @@
    #:width-option
    #:height-option
    #:float-option
+   #:label-option
+   #:caption-option
    #:direction
    #:footnote
    #:bold

diff --git a/tests.lisp b/tests.lisp
@@ -92,6 +92,13 @@
   (list 'float
         (reloc-symbol (components:direction _))))
 
+(defmethod to-ast ((_ components:label-option))
+  (list 'label (components:target _)))
+
+(defmethod to-ast ((_ components:caption-option))
+  (list* 'caption (loop for child across (cl-markless::condense-children (components:children _))
+                        collect (to-ast child))))
+
 (defmethod to-ast ((_ components:footnote))
   (list* (reloc-symbol (type-of _))
          (list (components:target _))

diff --git a/tests/embed.test b/tests/embed.test
@@ -14,9 +14,21 @@
 ~~
 (root (embed video "a" (loop) (float right)))
 
-[ video a, loop, autoplay, float left, width 10px, height 10% ]
+[ video a, caption a ]
 ~~
-(root (embed video "a" (loop) (autoplay) (float left) (width 10 px) (height 10 %)))
+(root (embed video "a" (caption "a")))
+
+[ video a, caption **a** ]
+~~
+(root (embed video "a" (caption (bold "a"))))
+
+[ video a, caption a**b** ]
+~~
+(root (embed video "a" (caption "a" (bold "b"))))
+
+[ video a, loop, autoplay, float left, width 10px, height 10%, label foo ]
+~~
+(root (embed video "a" (loop) (autoplay) (float left) (width 10 px) (height 10 %) (label "foo")))
 
 [ unknown a ]
 ~~