1 (in-package #:phos/gemtext)
2 
3 (defclass element ()
4   ((text :initarg :text
5          :initform "")))
6 
7 (defclass title (element)
8   ((level :initarg :level)))
9 
10 (defclass link (element)
11   ((url :initarg :url)))
12 
13 (defclass item (element)
14   ())
15 
16 (defclass paragraph (element)
17   ())
18 
19 (defclass blockquote (element)
20   ())
21 
22 (defclass verbatim (element)
23   ((alt :initarg :alt)))
24 
25 (defun make-link (url &optional text)
26   (make-instance 'link :url (quri:uri url)
27                        :text text))
28 
29 (defun parse-link (s)
30   "Parse a line into link."
31   (match (cl-ppcre:split "\\s+" s :limit 2)
32     ((list url)      (make-instance 'link :url (quri:uri url)))
33     ((list url text) (make-instance 'link :url (quri:uri url)
34                                           :text text))))
35 
36 (defun parse-line (s)
37   (flet ((strim (s n)
38            (string-trim '(#\Space #\Tab) (subseq s n)))
39          (prefix-p (prfx str)
40            (uiop:string-prefix-p prfx str)))
41     (cond ((prefix-p "###" s) (make-instance 'title :level 3
42                                                     :text (strim s 3)))
43           ((prefix-p "##" s)  (make-instance 'title :level 2
44                                                     :text (strim s 2)))
45           ((prefix-p "#" s)   (make-instance 'title :level 1
46                                                     :text (strim s 1)))
47           ((prefix-p "=>" s)  (parse-link (strim s 2)))
48           ((prefix-p "* " s)  (make-instance 'item :text (strim s 1)))
49           ((prefix-p ">" s)   (make-instance 'blockquote :text (strim s 1)))
50           (t (make-instance 'paragraph :text (strim s 0))))))
51 
52 (defmacro markerp (line)
53   `(uiop:string-prefix-p "```" ,line))
54 
55 (defun parse (in)
56   "Parse gemtext from the stream IN."
57   (loop with doc = nil
58         for line = (read-line in nil)
59         unless line
60           return (nreverse doc)
61         do (push
62             (if (markerp line)
63                 (loop with label = (subseq line 3)
64                       with content = nil
65                       for line = (read-line in nil)
66                       unless line
67                         do (error "non-closed verbatim")
68                       when (markerp line)
69                         return (make-instance 'verbatim
70                                               :alt label
71                                               :text (format nil "~{~A~%~^~}"
72                                                             (nreverse content)))
73                       do (push line content))
74                 (parse-line line))
75             doc)))
76 
77 (defun parse-string (str)
78   "Parse the string STR as gemtext."
79   (with-input-from-string (s str)
80     (parse s)))
81 
82 (defgeneric unparse (obj stream)
83   (:documentation "Print a textual representation of OBJ onto STREAM."))
84 
85 (defmethod unparse ((l list) stream)
86   (dolist (item l)
87     (unparse item stream)))
88 
89 (defmethod unparse ((title title) stream)
90   (with-slots (text level) title
91     (dotimes (_ level)
92       (format stream "#"))
93     (format stream " ~a~%" text)))
94 
95 (defmethod unparse ((link link) stream)
96   (with-slots (url text) link
97     (format stream "=> ~a ~a~%" url text)))
98 
99 (defmethod unparse ((item item) stream)
100   (with-slots (text) item
101     (format stream "* ~a~%" text)))
102 
103 (defmethod unparse ((p paragraph) stream)
104   (with-slots (text) p
105     (format stream "~a~%" text)))
106 
107 (defmethod unparse ((v verbatim) stream)
108   (with-slots (alt text) v
109     (format stream "```~a~%~a```~%" alt text)))
110 
111 (defmethod unparse ((b blockquote) stream)
112   (with-slots (text) b
113     (format stream "> ~a~%" text)))
114 
115 (defgeneric line-eq (a b)
116   (:documentation "t if the lines A and B are equals.")
117   (:method-combination and))
118 
119 (defmethod line-eq and ((a element) (b element))
120   (and (eq (type-of a)
121            (type-of b))
122        (equal (slot-value a 'text)
123               (slot-value b 'text))))
124 
125 (defmethod line-eq and ((a title) (b title))
126   (eq (slot-value a 'level)
127       (slot-value b 'level)))
128 
129 (defmethod line-eq and ((a link) (b link))
130   (quri:uri-equal (slot-value a 'url)
131                   (slot-value b 'url)))
132 
133 (defmethod line-eq and ((a verbatim) (b verbatim))
134   (equal (slot-value a 'alt)
135          (slot-value b 'alt)))