play-with-parenscript-dot.ros

#!/bin/sh
#|-*- mode:lisp -*-|#
#|
exec ros -Q -- $0 "$@"
|#
(ql:quickload :parenscript)
(ql:quickload :cl-ppcre)

(defun replace-dot-sep (elem)
  (if (symbolp elem)
      (let ((name (symbol-name elem))
            (pack-name (package-name (symbol-package elem))))
        (cond ((and (> (length name) 1)
                    (string= name "!!" :start1 0 :end1 2))
               (intern (subseq name 2) pack-name))
              ((ppcre:scan "\\." name)
               `(ps:@ ,@(mapcar (lambda (x) (intern x pack-name))
                                (ppcre:split "\\." name))))
              (t elem)))
      elem))

(defun replace-dot-in-tree (tree)
  (labels ((rec (rest)
             (let (result)
               (when rest
                 (dolist (elem rest)
                   (push (if (listp elem)
                             (rec elem)
                             (replace-dot-sep elem))
                         result)))
               (nreverse result))))
    (rec tree)))

(defmacro ps. (&body body)
  `(ps:ps ,@(replace-dot-in-tree body)))

(defmacro defmacro.ps (name args &body body)
  `(ps:defmacro+ps ,name ,args
     ,@(replace-dot-in-tree body)))

(defmacro.ps test-mac (a)
  `(ps:with-slots (abc) ,a
     (ps:setf abc.value 100)))

(defun test-ps ()
  (ps.
    (setf $scope.abc.def 123)
    (with-slots (abc) $scope
      (setf abc.def 123)
      (setf !!abc.def 123))
    (test-mac $scope)))
    
(defun main (&rest argv)
  (declare (ignorable argv))
  (print (test-ps)))