ts2cl.ros

#!/bin/sh
#|-*- mode:lisp -*-|#
#| <Put a one-line description here>
exec ros -Q -- $0 "$@"
|#
(progn ;;init forms
  (ros:ensure-asdf)
  #+quicklisp (ql:quickload '(:alexandria
                              :trivial-types
                              :cl-ppcre)
                            :silent t)
  )

(defpackage :ros.script.ts2cl.3692253918
  (:use :cl))
(in-package :ros.script.ts2cl.3692253918)

(defvar *tokens*)
(defvar *debug* nil)

(declaim (ftype function
                parse
                lookahead
                next
                maybe
                match
                =top
                =namespace
                =namespace-body
                =interface
                =interface-extends
                =var-type-list
                =var-type
                =typespec
                =name
                =type
                =value
                ts-to-lisp-type
                scan-text
                scan-ahead))

(defun parse (text)
  (let ((*tokens* (scan-text text)))
    (catch 'fail
      (loop
        (let ((*print-case* :downcase))
          (pprint (=top)))
        (unless *tokens*
          (return))))))

(defun lookahead ()
  (first *tokens*))

(defun next ()
  (pop *tokens*)
  t)

(defun maybe (name)
  (when (equal name (lookahead))
    (next)
    t))

(defun match (name)
  (if (equal name (lookahead))
      (next)
      (throw 'fail
        (progn
          (setf *debug*
                (list *tokens*
                      (with-output-to-string (stream)
                        (uiop:print-backtrace :stream stream))))
          nil))))

(defun =top ()
  (flet ((f (fn)
           (let ((tokens *tokens*))
             (or (catch 'fail (funcall fn))
                 (progn
                   (setf *tokens* tokens)
                   nil)))))
    (or (f '=namespace)
        (f '=interface))))

(defun =namespace ()
  (maybe "export")
  (match "namespace")
  (let ((name (=name))
        (definitions (=namespace-body)))
    `(progn
       ,@(loop :for (var value) :in definitions
               :collect `(defparameter ,(alexandria:symbolicate name "." var) ,value)))))

(defun =namespace-body ()
  (match "{")
  (let ((definitions '()))
    (loop
      (match "export")
      (match "const")
      (let ((var (=name)))
        (when (maybe ":") (=name))
        (match "=")
        (let ((value (=value)))
          (match ";")
          (push (list (intern var) value) definitions)
          (when (maybe "}")
            (return)))))
    (nreverse definitions)))

(defun =interface ()
  (maybe "export")
  (match "interface")
  (let ((name (=name))
        (extends))
    (when (maybe "extends")
      (setf extends (=interface-extends)))
    (let ((definitions (=var-type-list)))
      `(define-interface ,(alexandria:symbolicate name) (,@extends)
         ,@definitions))))

(defun =interface-extends ()
  (let ((extends '()))
    (loop
      (let ((name (=name)))
        (push name extends)
        (unless (maybe ",")
          (return))))
    (mapcar #'alexandria:symbolicate (nreverse extends))))

(defun =var-type-list ()
  (and (maybe "{")
       (loop :until (maybe "}")
             :collect (=var-type))))

(defun =var-type ()
  (let ((var (=name)))
    (when var
      (let ((optionalp (maybe "?")))
        (match ":")
        (let ((type (=typespec)))
          (let ((rest-types
                 (loop :while (maybe "|")
                       :collect (=typespec))))
            (when rest-types
              (setf type `(or ,type ,@rest-types)))
            (maybe ";")
            `(,(alexandria:symbolicate var)
              ,@(if optionalp
                    `(:optional t))
              :type ,type)))))))

(defun =typespec ()
  (let ((type (=type)))
    (if (null type)
        (progn (=var-type-list)
               'hash-table)
        type)))

(defun =name ()
  (let ((str (lookahead)))
    (and (stringp str)
         (loop :for c :across str
               :do (unless (alphanumericp c)
                     (return nil))
               :finally (return t))
         (progn
           (next)
           str))))

(defun =type ()
  (let ((name (=name)))
    (when name
      (cond
        ((maybe "[")
         (match "]")
         `(trivial-types:proper-list
           ,(ts-to-lisp-type name)))
        (t
         (ts-to-lisp-type name))))))

(defun =value ()
  (prog1 (read-from-string (lookahead))
    (next)))

(defun ts-to-lisp-type (name)
  (cond
    ((equal name "boolean") 'boolean)
    ((equal name "number") 'number)
    ((equal name "string") 'string)
    ((equal name "any") 'T)
    (t (intern name))))

(defun scan-text (text)
  (let ((pos 0)
        (str)
        (tokens '()))
    (loop
      (setf (values str pos) (scan-ahead text pos))
      (unless str (return))
      (cond ((string= str "/*")
             (setf pos (search "*/" text :start2 (+ pos 2)))
             (unless pos
               (warn "comment end does not found.")
               (return))
             (incf pos 2))
            ((string= str "'")
             (let ((quote-start (1- pos)))
               (setf pos (search "'" text :start2 (+ pos 1)))
               (unless pos
                 (warn "string end does not found.")
                 (return))
               (incf pos 1)
               (push (subseq text quote-start pos) tokens)))
            (t
             (push str tokens))))
    (nreverse tokens)))

(defun scan-ahead (text &optional (start 0))
  (multiple-value-bind (start end start-groups end-groups)
      (ppcre:scan "^\\s*([a-zA-Z0-9_]+|[-+]?[0-9]+(:?\\.[0-9]+)|\\?|/\\*|.)" text :start start)
    (when start
      (let ((str (subseq text (aref start-groups 0) (aref end-groups 0))))
        (values str end)))))

(defun main (&rest argv)
  (declare (ignorable argv))
  (parse (with-output-to-string (output)
           (loop :for line := (read-line nil nil)
                 :while line
                 :do (princ line output))))
  (fresh-line))


;;; vim: set ft=lisp lisp: