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