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)  (let ((s (strim s 2)))
48                                 (if (string-equal s "")
49                                     (make-instance 'paragraph :text "=>")
50                                     (parse-link s))))
51           ((prefix-p "* " s)  (make-instance 'item :text (strim s 1)))
52           ((prefix-p ">" s)   (make-instance 'blockquote :text (strim s 1)))
53           (t (make-instance 'paragraph :text (strim s 0))))))
54 
55 (defmacro markerp (line)
56   `(uiop:string-prefix-p "```" ,line))
57 
58 (defun parse (in)
59   "Parse gemtext from the stream IN."
60   (loop with doc = nil
61         for line = (read-line in nil)
62         unless line
63           return (nreverse doc)
64         do (push
65             (if (markerp line)
66                 (loop with label = (subseq line 3)
67                       with content = nil
68                       for line = (read-line in nil)
69                       unless line
70                         do (error "non-closed verbatim")
71                       when (markerp line)
72                         return (make-instance 'verbatim
73                                               :alt label
74                                               :text (format nil "~{~A~%~^~}"
75                                                             (nreverse content)))
76                       do (push line content))
77                 (parse-line line))
78             doc)))
79 
80 (defun parse-string (str)
81   "Parse the string STR as gemtext."
82   (with-input-from-string (s str)
83     (parse s)))
84 
85 (defgeneric unparse (obj stream)
86   (:documentation "Print a textual representation of OBJ onto STREAM."))
87 
88 (defmethod unparse ((l list) stream)
89   (dolist (item l)
90     (unparse item stream)))
91 
92 (defmethod unparse ((title title) stream)
93   (with-slots (text level) title
94     (dotimes (_ level)
95       (format stream "#"))
96     (format stream " ~a~%" text)))
97 
98 (defmethod unparse ((link link) stream)
99   (with-slots (url text) link
100     (format stream "=> ~a ~a~%" url text)))
101 
102 (defmethod unparse ((item item) stream)
103   (with-slots (text) item
104     (format stream "* ~a~%" text)))
105 
106 (defmethod unparse ((p paragraph) stream)
107   (with-slots (text) p
108     (format stream "~a~%" text)))
109 
110 (defmethod unparse ((v verbatim) stream)
111   (with-slots (alt text) v
112     (format stream "```~a~%~a```~%" alt text)))
113 
114 (defmethod unparse ((b blockquote) stream)
115   (with-slots (text) b
116     (format stream "> ~a~%" text)))
117 
118 (defgeneric line-eq (a b)
119   (:documentation "t if the lines A and B are equals.")
120   (:method-combination and))
121 
122 (defmethod line-eq and ((a element) (b element))
123   (and (eq (type-of a)
124            (type-of b))
125        (equal (slot-value a 'text)
126               (slot-value b 'text))))
127 
128 (defmethod line-eq and ((a title) (b title))
129   (eq (slot-value a 'level)
130       (slot-value b 'level)))
131 
132 (defmethod line-eq and ((a link) (b link))
133   (quri:uri-equal (slot-value a 'url)
134                   (slot-value b 'url)))
135 
136 (defmethod line-eq and ((a verbatim) (b verbatim))
137   (equal (slot-value a 'alt)
138          (slot-value b 'alt)))