1 (in-package #:phos/gemtext)
2 
3 (defclass element ()
4   ((text :initform ""
5          :initarg :text
6          :accessor text
7          :type string)))
8 
9 (defclass title (element)
10   ((level :initarg :level
11           :accessor level
12           :type integer
13           :documentation "The nesting level of the title.
14 
15 Synonymous to the HTML heading levels, i.e. level 1 is <h1> tag, level 2 is <h2> tag etc.")))
16 
17 (defclass link (element)
18   ((url :initform nil
19         :initarg :url
20         :accessor url
21         :type (or null string))))
22 
23 (defclass item (element)
24   ())
25 
26 (defclass paragraph (element)
27   ())
28 
29 (defclass blockquote (element)
30   ())
31 
32 (defclass verbatim (element)
33   ((alt :initform nil
34         :initarg :alt
35         :accessor alt
36         :type (or null string)
37         :documentation "The alternative text for the verbatim block.
38 
39 Is usually put at the same line as the opening backquotes.
40 
41 Can be a programming language name or alternative text for, e.g., ASCII art.")))
42 
43 (defun element-p (element) (typep element 'element))
44 (defun title-p (title) (typep title 'title))
45 (defun link-p (link) (typep link 'link))
46 (defun item-p (item) (typep item 'item))
47 (defun paragraph-p (paragraph) (typep paragraph 'paragraph))
48 (defun blockquote-p (blockquote) (typep blockquote 'blockquote))
49 (defun verbatim-p (verbatim) (typep verbatim 'verbatim))
50 
51 
52 (defun make-link (url &optional text)
53   (make-instance 'link :url (quri:uri url)
54                        :text text))
55 
56 (defun parse-link (s)
57   "Parse a line into link."
58   (match (cl-ppcre:split "\\s+" s :limit 2)
59     ((list url)      (make-instance 'link :url (quri:uri url)))
60     ((list url text) (make-instance 'link :url (quri:uri url)
61                                           :text text))))
62 
63 (defun parse-line (s)
64   (flet ((strim (s n)
65            (string-trim '(#\Space #\Tab) (subseq s n)))
66          (prefix-p (prfx str)
67            (uiop:string-prefix-p prfx str)))
68     (cond ((prefix-p "###" s) (make-instance 'title :level 3
69                                                     :text (strim s 3)))
70           ((prefix-p "##" s)  (make-instance 'title :level 2
71                                                     :text (strim s 2)))
72           ((prefix-p "#" s)   (make-instance 'title :level 1
73                                                     :text (strim s 1)))
74           ((prefix-p "=>" s)  (let ((s (strim s 2)))
75                                 (if (string-equal s "")
76                                     (make-instance 'paragraph :text "=>")
77                                     (parse-link s))))
78           ((prefix-p "* " s)  (make-instance 'item :text (strim s 1)))
79           ((prefix-p ">" s)   (make-instance 'blockquote :text (strim s 1)))
80           (t (make-instance 'paragraph :text (strim s 0))))))
81 
82 (defmacro markerp (line)
83   `(uiop:string-prefix-p "```" ,line))
84 
85 (defun parse (in)
86   "Parse gemtext from the stream IN."
87   (loop with doc = nil
88         for line = (read-line in nil)
89         unless line
90           return (nreverse doc)
91         do (push
92             (if (markerp line)
93                 (loop with label = (subseq line 3)
94                       with content = nil
95                       for line = (read-line in nil)
96                       unless line
97                         do (error "non-closed verbatim")
98                       when (markerp line)
99                         return (make-instance 'verbatim
100                                               :alt label
101                                               :text (format nil "~{~A~%~^~}"
102                                                             (nreverse content)))
103                       do (push line content))
104                 (parse-line line))
105             doc)))
106 
107 (defun parse-string (str)
108   "Parse the string STR as gemtext."
109   (with-input-from-string (s str)
110     (parse s)))
111 
112 (defgeneric unparse (obj stream)
113   (:documentation "Print a textual representation of OBJ onto STREAM."))
114 
115 (defmethod unparse ((l list) stream)
116   (dolist (item l)
117     (unparse item stream)))
118 
119 (defmethod unparse ((title title) stream)
120   (with-slots (text level) title
121     (dotimes (_ level)
122       (format stream "#"))
123     (format stream " ~a~%" text)))
124 
125 (defmethod unparse ((link link) stream)
126   (with-slots (url text) link
127     (format stream "=> ~a ~a~%" url text)))
128 
129 (defmethod unparse ((item item) stream)
130   (with-slots (text) item
131     (format stream "* ~a~%" text)))
132 
133 (defmethod unparse ((p paragraph) stream)
134   (with-slots (text) p
135     (format stream "~a~%" text)))
136 
137 (defmethod unparse ((v verbatim) stream)
138   (with-slots (alt text) v
139     (format stream "```~a~%~a```~%" alt text)))
140 
141 (defmethod unparse ((b blockquote) stream)
142   (with-slots (text) b
143     (format stream "> ~a~%" text)))
144 
145 (defgeneric line-eq (a b)
146   (:documentation "t if the lines A and B are equals.")
147   (:method-combination and))
148 
149 (defmethod line-eq and ((a element) (b element))
150   (and (eq (type-of a)
151            (type-of b))
152        (equal (slot-value a 'text)
153               (slot-value b 'text))))
154 
155 (defmethod line-eq and ((a title) (b title))
156   (eq (slot-value a 'level)
157       (slot-value b 'level)))
158 
159 (defmethod line-eq and ((a link) (b link))
160   (quri:uri-equal (slot-value a 'url)
161                   (slot-value b 'url)))
162 
163 (defmethod line-eq and ((a verbatim) (b verbatim))
164   (equal (slot-value a 'alt)
165          (slot-value b 'alt)))