From f5cb35b87255ebbe2d322bcedde6bc7d5f6aebae Mon Sep 17 00:00:00 2001
From: Thomas Albers Raviola <thomas@thomaslabs.org>
Date: Mon, 13 May 2024 21:29:31 +0200
Subject: * Initial commit

---
 src/parser.lisp | 144 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 144 insertions(+)
 create mode 100644 src/parser.lisp

(limited to 'src/parser.lisp')

diff --git a/src/parser.lisp b/src/parser.lisp
new file mode 100644
index 0000000..60e7ac4
--- /dev/null
+++ b/src/parser.lisp
@@ -0,0 +1,144 @@
+(in-package #:chains)
+
+(defconstant +special-characters+
+  '(#\\ #\% #\# #\@ #\$ #\{ #\} #\[ #\] #\Newline)
+  "")
+
+(defconstant +whitespace+ '(#\Tab #\Newline #\Return #\Space)
+  "")
+
+;; TODO: (read-char stream nil)
+(defun read-if (predicate stream)
+  "Read characters from STREAM into a string as long as PREDICATE is true"
+  (let ((string (with-output-to-string (value)
+                  (loop :for c = (read-char stream nil)
+                        :while (and c (funcall predicate c))
+                        :do (write-char c value)
+                        :finally
+                           (when c (unread-char c stream))))))
+    (if (emptyp string) nil string)))
+
+(defun read-if-not (predicate stream)
+  "Read characters from STREAM into a string as long as PREDICATE is false"
+  (read-if (complement predicate) stream))
+
+(defun read-text (stream start-of-line)
+  "Read text from STREAM"
+  (let* ((text (read-if-not #'special-char-p stream))
+         (peek (peek-char nil stream nil)))
+    (when text (setf start-of-line nil))
+    (cond ((and (null text) (null peek))
+           nil)
+          ((and (not start-of-line) (newlinep peek))
+           (read-char stream nil)
+           (let ((rest (read-text stream t)))
+             (when (eq rest 'empty-line)
+               (setf rest nil)
+               (unread-char #\Newline stream))
+             (list* text (string #\Newline) rest)))
+          ((newlinep peek)
+           (read-char stream nil)
+           'empty-line)
+          (t
+           (ensure-list text)))))
+
+(defun atom-char-p (char)
+  (or (alphanumericp char) (eql char #\-)))
+
+(defun next-token (stream start-of-line &aux c)
+  "Read the next token inside STREAM"
+  (case (setf c (read-char stream nil))
+    ('nil nil)
+    (#\\
+     (concat-text (make-text (string (read-char stream nil)))
+                  (make-text (read-if-not #'special-char-p stream))))
+    (#\%
+     (peek-char #\Newline stream)
+     (read-char stream nil)
+     ;;(next-token stream nil)
+     'separator)
+    ((#\@ #\$)
+     (let* ((text (read-if #'atom-char-p stream))
+            (value (read-from-string text))
+            (type (cond ((symbolp value) 'symbol)
+                        ((integerp value) 'integer)
+                        (t (error "Unknown type of object @~A~%" text)))))
+       ;; (unless (or (symbolp value) (integerp value))
+       ;;   (error "Unknown type of object @~A~%" text))
+       (cons type value)))
+    (#\#
+     (case (read-char stream nil)
+       (#\@ (cons 'raw-function (read-if #'alphanumericp stream)))
+       (#\$ (cons 'inline-raw-function (read-if #'alphanumericp stream)))))
+    (#\{ 'link-start)
+    (#\} 'link-end)
+    (#\[ 'raw-link-start)
+    (#\] 'raw-link-end)
+    (t
+     (unread-char c stream)
+     (let ((text (read-text stream start-of-line)))
+       (cond ((null text) nil)
+             ((symbolp text) text)
+             (t (make-text (apply #'concatenate 'string text))))))))
+
+(defun build-tree (tokens)
+  "Groups a list of tokens into a tree. Returns a subtree and a list of unused
+tokens."
+  (flet ((build-chain (tokens)
+           (loop :with tokens = tokens
+                 :for (link rest) = (multiple-value-list (build-tree tokens))
+                 :collect link :into links
+                 :while (member (first rest) '(raw-link-start link-start))
+                 :do (setf tokens (rest rest))
+                 :finally
+                    (setf tokens rest)
+                    (return (values links tokens)))))
+    (destructuring-bind (&optional head &rest tail) tokens
+      (cond ((null head)
+             (values nil '()))
+            ((or (eq head 'link-end) (eq head 'raw-link-end))
+             (values '() (rest tokens)))
+            ((eq head 'separator)
+             (multiple-value-bind (tree rest) (build-tree tail)
+               (values tree rest)))
+            ((eq head 'link-start)
+             (multiple-value-bind (links rest) (build-chain tail)
+               (multiple-value-bind (tree rest) (build-tree rest)
+                 (values (cons (cons 'chain links) tree) rest))))
+            (t
+             (multiple-value-bind (tree rest) (build-tree tail)
+               (values (cons head tree) rest)))))))
+
+(defun read-raw-link (stream)
+  "Read argument of a raw function"
+  (flet ((squarep (x) (member x '(#\]))))
+    ;; Text omits closing ], may therefore be nil, for example when reading ]]
+    (loop :for text = (read-if-not #'squarep stream)
+          :for c = (peek-char nil stream nil)
+          :when text :collect text :into text-list
+          :while (and c text (eql (last-elt text) #\\))
+          :collect (string (read-char stream nil)) :into text-list
+          :finally
+             ;; Keep ] inside stream
+             (return (list (make-text (apply #'concat text-list)))))))
+
+(defun start-of-line-p (last-token)
+  ;; Keep track if new line starts a paragraph
+  (or (eq last-token 'empty-line)
+      (and (textp last-token)
+           (newlinep (last-elt (content last-token))))))
+
+(defun read-tree (stream)
+  "Build a syntax tree from the contents of STREAM"
+  (loop :with start-of-line = t
+        :for token = (next-token stream start-of-line)
+        :while token
+        :if (eq token 'raw-link-start)
+          :append (cons 'raw-link-start (read-raw-link stream)) :into tokens
+          :and :do
+            (setf start-of-line nil)
+        :else
+          :collect token :into tokens :and :do
+            (setf start-of-line (start-of-line-p token))
+        :finally ;; (build-tree)
+           (return tokens)))
-- 
cgit v1.2.3