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

---
 .gitignore       |   2 +
 README.md        |  98 +++++++++++++++++++++++++++++++++++++
 chains.asd       |  19 ++++++++
 src/core.lisp    |  76 +++++++++++++++++++++++++++++
 src/eval.lisp    |  44 +++++++++++++++++
 src/package.lisp |  10 ++++
 src/parser.lisp  | 144 +++++++++++++++++++++++++++++++++++++++++++++++++++++++
 src/types.lisp   |  85 ++++++++++++++++++++++++++++++++
 t/test1.chn      |  14 ++++++
 t/test2.chn      |  19 ++++++++
 t/test3.chn      |   3 ++
 11 files changed, 514 insertions(+)
 create mode 100644 .gitignore
 create mode 100644 README.md
 create mode 100644 chains.asd
 create mode 100644 src/core.lisp
 create mode 100644 src/eval.lisp
 create mode 100644 src/package.lisp
 create mode 100644 src/parser.lisp
 create mode 100644 src/types.lisp
 create mode 100644 t/test1.chn
 create mode 100644 t/test2.chn
 create mode 100644 t/test3.chn

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..e5aa101
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,2 @@
+sandbox.lisp
+archive/*
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..0f030a8
--- /dev/null
+++ b/README.md
@@ -0,0 +1,98 @@
+# About chains
+
+Chains is a Lisp inspired programming language designed to serve as a
+preprocessor replacement. Just as Lisp stands for List Processing, Chains is in
+a sense Tree Processing. It was originaly designed with the generation of HTML
+in mind, but it does not restrict itself to this task.
+
+The result of evaluating a program is a tree, which may then be used to generate
+other markup languages. However, chains is not a macro language like the
+C preprocessor or m4.
+
+One of the issues of generating markup text from within a conventional
+programming language is how cumbersome this is. Due to the syntax rules of the
+language, the markup must be in a way escaped e.g. by writing a string between
+quotes. Meanwhile unquoted items are syntactic elements of the language. This
+way writing code is "easy" while writing markup is "cumbersome".
+
+In Chains, text is a first class citizen and all other syntactic elements have
+to be escaped. Because of this, you probably won't want to write Chains code
+directly but instead define it inside of the interpreter. On the other hand,
+writing markup is as easy as writing markdown or TeX.
+
+The language also has a built-in notion of paragraph
+
+At the moment, chains is more a proof of concept rather than a complete
+language. Many features are still undecided.
+
+# Syntax
+
+| Character | Description                                                             |
+|-----------|-------------------------------------------------------------------------|
+| %         |                                                                         |
+| \\        |                                                                         |
+| { }       |                                                                         |
+| \[ \]     |                                                                         |
+| #         | Raw function. All special characters in the arguments are taken literal |
+| @         |                                                                         |
+| $         |                                                                         |
+
+## Primitives
+Chains is built on 3 type of objects: text, chains and atoms.
+
+## Evaluation rules
+
+Unless a chain is escaped, the following rules apply. The chain to be evaluated
+may only have a single object inside the first link. The function is value of
+evaluating this first element.
+
+Text evaluates to itself.
+
+Atoms consists of symbols or numbers. Symbols evaluate to the bound value in the
+environment. Numbers evaluate to themselves.
+
+# How to contribute
+
+If you would like to contibute to the development of chains please send a mail
+with your patch to the following address: thomas _at_ thomaslabs _dot_ org
+
+# Misc
+
+;; next-token : cache raw block for further reads. avoid creating list (1 pass)
+;; build link directly instead of returning block start tokens
+
+;; read link
+;; {} link := list of objects
+;; { }{ }{ } chain := list of links
+;;
+
+;; special form : does not get its arguments pre-evaluated
+
+;; after eval, unevaluated links are spliced into tree
+;; {@if}{{@=}{2}{2}}{1}{2} -> {1} ;; needs to return link, in case text is also inside
+;; @if{@={@2}{@2}}{1}{2} ;; alias syntax
+
+
+;; use chains as library for static website generator, define-syntax and define
+;; to define "callbacks" from library and read/eval file
+
+;; tree from file may be discarded ;; writing libraries
+
+;; a chain is evaluated by first evaluating the first link and applying the
+;; other links as arguments for the function
+
+;; a link with one element is evaluated to that element
+
+;; inside the evaluation of a lambda, the argument is spliced into the link of
+;; the body
+
+;; {{@lambda}{@x @y}{@x}}{Hello}{World} -> {{Hello}} -> {Hello} -> Hello
+
+;; Metaprogramming is hard :(
+
+;; make closure return links instead of plain lists? dont use flatten?
+
+;; type 1 - {{@lambda}{{@x}{@y}}{@x}}{Hello}{World}
+;; type 2 - {{@lambda}{@x @y}{@x}}{Hello}{World}
+
+;; semantically. What exactly is a chain?
diff --git a/chains.asd b/chains.asd
new file mode 100644
index 0000000..82df35a
--- /dev/null
+++ b/chains.asd
@@ -0,0 +1,19 @@
+;;;; chains.asd
+
+(asdf:defsystem #:chains
+  :description ""
+  :author ("")
+  :license  ""
+  :version "0.0.1"
+  :serial t
+  :depends-on (:split-sequence
+               :cl-ppcre
+               :alexandria
+               :trivia
+               :spinneret)
+  :pathname "src"
+  :components ((:file "package")
+               (:file "types")
+               (:file "parser")
+               (:file "eval")
+               (:file "core")))
diff --git a/src/core.lisp b/src/core.lisp
new file mode 100644
index 0000000..6c151ce
--- /dev/null
+++ b/src/core.lisp
@@ -0,0 +1,76 @@
+(in-package #:chains)
+
+(defun get-var (env key)
+  (if-let ((slot (assoc key env)))
+    (cdr slot)
+    (error "var ~A not found~% ~A~%" key env)))
+
+;; Built-in functions and variables used inside the interpreter use their own
+;; package. This allows the language to have keywords like lambda which
+;; otherwise would be reserved words from the cl package
+
+(defmacro define-function (name (&rest args) &body body)
+  (let ((siblings (gensym)))
+    `(make-closure #'(lambda (environment ,siblings ,@args)
+                       (declare (ignore ,siblings))
+                       ,@body)
+                   ',args
+                   nil
+                   (complement #'identity))))
+
+(defmacro define-function* (name (&rest args) (siblings group-predicate)
+                            &body body)
+  `(make-closure #'(lambda (environment ,siblings ,@args)
+                     ,@body)
+                 ',args
+                 nil
+                 ,group-predicate))
+
+(defmacro define-syntax (name (&rest args) &body body)
+  `(make-closure #'(lambda (environment siblings ,@args)
+                     ,@body)
+                 ',args
+                 t
+                 (complement #'identity)))
+
+(defmacro define-syntax* (name (&rest args) (siblings group-predicate)
+                          &body body)
+  `(make-closure #'(lambda (environment ,siblings ,@args)
+                     ,@body)
+                 ',args
+                 t
+                 ,group-predicate))
+
+(defparameter *lambda*
+  (define-syntax lambda (arglist body)
+    (setf arglist (remove-if #'whitespace-text-p arglist))
+    (assert (every #'object-symbolp arglist))
+    (setf arglist (mapcar #'cdr arglist))
+    (let ((env environment))
+      (make-closure  #'(lambda (environment siblings &rest args)
+                         (tree-eval (append (pairlis arglist args)
+                                            env
+                                            environment)
+                                    body))
+                     arglist nil (complement #'identity) env))))
+
+(defparameter *syntax*
+  (define-syntax syntax (arglist body)
+    (setf arglist (remove-if #'whitespace-text-p arglist))
+    (assert (every #'object-symbolp arglist))
+    (setf arglist (mapcar #'cdr arglist))
+    (let ((env environment))
+      (make-closure  #'(lambda (environment siblings &rest args)
+                         (tree-eval (append (pairlis arglist args)
+                                            env
+                                            environment)
+                                    body))
+                     arglist t (complement #'identity) env))))
+
+(defparameter *define*
+  (define-syntax* define (name value) (siblings #'identity)
+    (assert (object-symbolp (first name)))
+    (setf name (cdr (first name)))
+    (setf value (first (tree-eval environment value)))
+    (tree-eval (acons name value environment)
+               siblings)))
diff --git a/src/eval.lisp b/src/eval.lisp
new file mode 100644
index 0000000..4962ade
--- /dev/null
+++ b/src/eval.lisp
@@ -0,0 +1,44 @@
+(in-package #:chains)
+
+(defun chainp (object)
+  (and (consp object) (eq (first object) 'chain)))
+
+(defun chain-links (chain)
+  (rest chain))
+
+(defun object-symbolp (object)
+  (and (consp object) (eq (first object) 'symbol)))
+
+(defun tree-eval (environment node)
+  (cond ((null node)
+         nil)
+        ((object-symbolp node)
+         (get-var environment (cdr node)))
+        ((not (consp node))
+         node)
+        ((chainp (first node))
+         (destructuring-bind (flink &rest rlinks) (chain-links (first node))
+           (setf flink (tree-eval environment flink))
+           (assert (and (consp flink)
+                        (closurep (first flink))
+                        (null (rest flink)))
+                   (flink)
+                   "~A ~A" flink (content (second flink)))
+           (let* ((closure (first flink))
+                  (function (closure-function closure))
+                  (group-predicate (closure-group-p closure)))
+             (multiple-value-bind (siblings rest)
+                 (group-if group-predicate (rest node))
+               (append
+                ;; Evaluating a function returns a sublink, flatten all sublink
+                (flatten
+                 (let ((eval-with-environment (curry #'tree-eval environment)))
+                   (if (closure-special-p closure)
+                       (ensure-list (apply function environment siblings rlinks))
+                       (let ((args (mapcar eval-with-environment rlinks))
+                             (siblings (funcall eval-with-environment siblings)))
+                         (ensure-list (apply function environment siblings args))))))
+                (tree-eval environment rest))))))
+        (t
+         (cons (tree-eval environment (first node))
+               (tree-eval environment (rest node))))))
diff --git a/src/package.lisp b/src/package.lisp
new file mode 100644
index 0000000..962ce17
--- /dev/null
+++ b/src/package.lisp
@@ -0,0 +1,10 @@
+(defpackage #:chains
+  (:use #:cl
+        #:split-sequence
+        #:alexandria
+        #:trivia)
+  (:export))
+
+(in-package #:chains)
+
+(defvar *interpreter-package* (make-package 'interpreter))
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)))
diff --git a/src/types.lisp b/src/types.lisp
new file mode 100644
index 0000000..09ede2b
--- /dev/null
+++ b/src/types.lisp
@@ -0,0 +1,85 @@
+(in-package #:chains)
+
+(defclass text ()
+  ((content :reader content
+            :initarg :content
+            :type string
+            :documentation "")))
+
+(defun textp (object)
+  (typep object 'text))
+
+(defun make-text (content)
+  (make-instance 'text :content content))
+
+(defun concat-text (&rest text)
+  (let ((strings (mapcar #'content text)))
+    (make-text (apply #'concatenate 'string strings))))
+
+(defmethod content ((object (eql 'empty-line)))
+  (list (make-text "")))
+
+(defclass closure ()
+  ((function :reader closure-function
+             :initarg :function
+             :type function
+             :documentation "")
+   (arg-list :reader closure-arg-list
+             :initarg :arg-list
+             :type list
+             :documentation "")
+   (environment :reader closure-environment
+                :initarg :environment
+                :type list
+                :documentation "")
+   (specialp :reader closure-special-p
+             :initarg :specialp
+             :type boolean
+             :documentation "")
+   (groupp :reader closure-group-p
+           :initarg :groupp
+           :type function
+           :documentation "")))
+
+(defun make-closure (function arg-list specialp groupp &optional environment)
+  (make-instance 'closure :function function :arg-list arg-list
+                          :specialp specialp :groupp groupp
+                          :environment environment))
+
+(defun closurep (object)
+  (typep object 'closure))
+
+(defun group (item sequence &key (test #'eql))
+  (group-if #'(lambda (x) (funcall test item x)) sequence))
+
+(defun group-if (predicate sequence)
+  (loop :for (head . tail) :on sequence
+        :while (funcall predicate head)
+        :collect head :into group
+        :finally
+           (return (values group (if (not (funcall predicate head))
+                                     (cons head tail)
+                                     tail)))))
+
+(defun group-if-not (predicate sequence)
+  (group-if (complement predicate) sequence))
+
+(defun whitespacep (char-or-string)
+  (if (stringp char-or-string)
+      (every #'whitespacep char-or-string)
+      (member char-or-string +whitespace+)))
+
+(defun whitespace-text-p (object)
+  (and (textp object) (whitespacep (content object))))
+
+(defun special-char-p (x)
+  (member x +special-characters+))
+
+(defun empty-line-p (x)
+  (or (emptyp x) (every #'whitespacep x)))
+
+(defun newlinep (x)
+  (eql x #\Newline))
+
+(defun concat (&rest strings)
+  (apply #'concatenate 'string strings))
diff --git a/t/test1.chn b/t/test1.chn
new file mode 100644
index 0000000..f55fb70
--- /dev/null
+++ b/t/test1.chn
@@ -0,0 +1,14 @@
+{@define}{@author}{Thomas Albers Raviola}%
+{@define}{@today}{May 12, 2024}%
+{@define}{@printdate}{{@lambda}{@date}{the date is @date}}%
+{@section}{Introduction}
+
+Hello, this is a sample of a program written in chains
+
+Chains was created by @author to help him write articles of questionable
+usefulness.
+
+{@printdate}{@today}
+{@section}[Conclusion]
+
+idk man, guess it works, don't it?
diff --git a/t/test2.chn b/t/test2.chn
new file mode 100644
index 0000000..a637b61
--- /dev/null
+++ b/t/test2.chn
@@ -0,0 +1,19 @@
+{@define}{@html-element}{{@lambda}{@name}{{@lambda}{@attr @content}{<@name @attr>
+@content
+</@name>}}}%
+%
+%
+{@define}{@html-html}{{@html-element}{html}}%
+{@define}{@html-head}{{@html-element}{head}}%
+{@define}{@html-body}{{@html-element}{body}}%
+{@define}{@html-title}{{@html-element}{title}}%
+{@define}{@html-h1}{{@html-element}{h1}}%
+{@define}{@html-p}{{@html-element}{p}}%
+%
+%
+{@html-html}{}{%
+{@html-head}{}{{@html-title}{}{Website}}%
+
+{@html-body}{}{
+{@html-h1}{}{Chains test}
+{@html-p}{}{Hello World!}}}
diff --git a/t/test3.chn b/t/test3.chn
new file mode 100644
index 0000000..d989187
--- /dev/null
+++ b/t/test3.chn
@@ -0,0 +1,3 @@
+{@define}{@define-function}{{@syntax}{@name @args @body}{{@define}{@name}{{@lambda}{@args}{@body}}}}%
+{@define-function}{@foo}{@a}{hola @a}%
+%{@foo}{mundo}
-- 
cgit v1.2.3